Commit 2fd2512a authored by Nicolas Lambert's avatar Nicolas Lambert
Browse files

function -> R package

parent 02118115
Package: flowmapper
Title: flows maps
Version: 0.0.0.9000
Authors@R: person(given = "Nicolas",
family = "Lambert",
role = c("aut", "cre"),
email = "nicolas.lambert@cnrs.fr",
comment = c(ORCID = "0000-0003-4976-6560"))
Description: This package allows to create flow maps from spatial features (sf).
License: GPL-3
URL: https://gitlab.huma-num.fr/nlambert/flowmapper
Encoding: UTF-8
LazyData: true
Suggests:
knitr,
rmarkdown,
smoothr
VignetteBuilder: knitr
RoxygenNote: 7.1.0
Imports:
sf
# Generated by roxygen2: do not edit by hand
export(plotflows)
# polygons to links
x = subregions
df = migr
xid = "id"
dfid = c("i","j")
dfvar = "fij"
# Links
getlinks <- function(x, df, xid, dfid, dfvar){
dots <- sf::st_centroid(x = sf::st_geometry(x),of_largest_polygon = max(sf::st_is(sf::st_as_sf(x), "MULTIPOLYGON")))
x2 <- data.frame(id = x[[xid]],
sf::st_coordinates(sf::st_centroid(x = sf::st_geometry(x),
sf::st_coordinates(sf::st_centroid(x = sf::st_geometry(x),
of_largest_polygon = max(sf::st_is(sf::st_as_sf(x), "MULTIPOLYGON")))))
df <- df[, c(dfid,dfvar)]
colnames(df) <- c("i","j","fij")
df <- df[!df$i == df$j,]
link <- merge(df, x2, by.x = dfid[2], by.y = "id", all.x = TRUE)
link <- merge(link, x2, by.x = dfid[1], by.y = "id", all.x = TRUE)
names(link)[4:7] <- c("xj", "yj", "xi", "yi")
......@@ -34,7 +28,7 @@ getlinks <- function(x, df, xid, dfid, dfvar){
# Rotate
rotate <- function(x){
ctr = st_as_sf(x[,c("ctrx","ctry")] %>% st_drop_geometry(), coords = c("ctrx", "ctry"), crs = st_crs(links))
ctr = st_as_sf(x[,c("ctrx","ctry")] %>% st_drop_geometry(), coords = c("ctrx", "ctry"), crs = st_crs(x))
rot <- function(a) matrix(c(cos(a), sin(a), -sin(a), cos(a)), 2, 2)
n <- nrow(x)
for (i in 1:n){
......@@ -42,129 +36,43 @@ rotate <- function(x){
}
return (x)
}
# Circles
getcircles <- function(x, xid, df, dfid, dfvar, k){
# Link to Rect
linktorect <- function(link, size, k, dfvar, decreasing){
bb <- st_bbox(link)
hmax <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin)/25
delta <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin) / 300
if(!"delta_i" %in% names(link)){
link$delta_i <- 0
link$delta_j <- 0
delta <- 0
link$dist <- link$dist - link$delta_i - link$delta_j - delta - delta
if (is.null(k)){
m <- max(df[,dfvar])
bb <- st_bbox(x)
k <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin)/ (m * 50)
}
if (size == "area"){
if(is.null(k)){ k <- hmax / max(link[[dfvar]] / link$dist)}
link$height <- link[[dfvar]] / link$dist * k
} else {
if(is.null(k)){ k <- hmax / max(link[[dfvar]])}
link$height <- link[[dfvar]] * k
}
link <- rotate(link)
l <- st_geometry(link)
d <- st_coordinates(l)
n <- nrow(d)
r <- data.frame(d[seq(1, n, 2),] ,d[seq(2, n, 2),] )
rownames(r) <- r$L1
r <- r[,c("X","Y","X.1","Y.1")]
colnames(r) <- c("p1x","p1y","p2x","p2y")
r$height <- link$height
r$height2 <- link$height2
r$p1x <- r$p1x + link$delta_j + delta
r$p2x <- r$p2x - link$delta_i - delta
r$p3x <- r$p2x
r$p3y <- r$p2y + r[["height"]]/2
r$p4x <- r$p1x
r$p4y <- r$p1y + r[["height"]]/2
r$p1y <- r$p1y - r[["height"]]/2
r$p2y <- r$p2y - r[["height"]]/2
st_geometry(link) <- st_as_sfc(paste0("POLYGON((",r$p1x," ",r$p1y,", ",r$p2x," ",r$p2y,", ",r$p3x," ",r$p3y,", ",r$p4x," ",r$p4y,", ",r$p1x," ",r$p1y,"))"))
link$ang <- - link$ang
link <- rotate(link)
link <- link[order(link$height, decreasing = decreasing),]
return(link)
dots <- sf::st_centroid(x = sf::st_geometry(x),of_largest_polygon = max(sf::st_is(sf::st_as_sf(x), "MULTIPOLYGON")))
dots <- st_sf(x[,xid] %>% st_drop_geometry(), dots)
dots <- merge(dots, df, by.x = xid, by.y = dfid)
dots[,"r"] <- dots[,dfvar] %>% st_drop_geometry() * k
circles <- st_buffer(dots, dots$nb * k)
return(circles)
}
# Dots
# Link to Arrows
linktoarrows <- function(link, size, k, dfvar, decreasing){
bb <- st_bbox(link)
hmax <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin)/25
delta <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin) / 300
if(!"delta_i" %in% names(link)){
link$delta_i <- 0
link$delta_j <- 0
delta <- 0
}
if (size == "area"){
if(is.null(k)){ k <- hmax / max(link[[dfvar]] / link$dist)}
link$height <- link[[dfvar]] / link$dist * k
} else {
if(is.null(k)){ k <- hmax / max(link[[dfvar]])}
link$height <- link[[dfvar]] * k
getdots <- function(x, xid, k = NULL){
if (is.null(k)){
bb <- st_bbox(x)
k <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin)/300
}
link <- rotate(link)
l <- st_geometry(link)
d <- st_coordinates(l)
n <- nrow(d)
r <- data.frame(d[seq(1, n, 2),] ,d[seq(2, n, 2),] )
rownames(r) <- r$L1
r <- r[,c("X","Y","X.1","Y.1")]
colnames(r) <- c("x1","y1","x2","y2")
r$height <- link$height
r$x1 <- r$x1 + link$delta_j + delta
r$x2 <- r$x2 - link$delta_i - delta
r$p1x <- r$x1
r$p1y <- r$y1 - r[["height"]]/2
r$p2x <- r$x2 - r[["height"]]/2
r$p2y <- r$y2 - r[["height"]]/2
r$p3x <- r$x2
r$p3y <- r$y2
r$p4x <- r$x2 - r[["height"]]/2
r$p4y <- r$y2 + r[["height"]]/2
r$p5x <- r$x1
r$p5y <- r$y1 + r[["height"]]/2
st_geometry(link) <- st_as_sfc(paste0("POLYGON((",r$p1x," ",r$p1y,", ",r$p2x," ",r$p2y,", ",r$p3x," ",r$p3y,", ",r$p4x," ",r$p4y,", ",r$p5x," ",r$p5y,", ",r$p1x," ",r$p1y,"))"))
link$ang <- - link$ang
link <- rotate(link)
link <- link[order(link$height, decreasing = decreasing),]
return(link)
}
getcircles <- function(x, xid, df, dfid, dfvar,k){
dots <- sf::st_centroid(x = sf::st_geometry(x),of_largest_polygon = max(sf::st_is(sf::st_as_sf(x), "MULTIPOLYGON")))
dots <- st_sf(x[,xid] %>% st_drop_geometry(), dots)
dots <- merge(dots, df2, by.x = xid, by.y = df2id)
dots[,"r"] <- dots[,dfvar] %>% st_drop_geometry() * k
circles <- st_buffer(dots, dots$nb * k2)
dots[,"r"] <- k
circles <- st_buffer(dots, k)
return(circles)
}
# Link to Flows
# Link to Arrows
linktoarrows2 <- function(link, size, k, dfvar, decreasing){
linktoflows <- function(link, size, k, dfvar, type, decreasing){
crs <- st_crs(link)
link$shift <- 0
link$ij <- paste0(link$i,"_",link$j)
link$ji <- paste0(link$j,"_",link$i)
......@@ -172,28 +80,28 @@ linktoarrows2 <- function(link, size, k, dfvar, decreasing){
for(i in 1:nb) {
if(link$ij[i] %in% link$ji) {link$shift[i] <- 1}
}
bb <- st_bbox(link)
hmax <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin)/25
delta <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin) / 300
delta2 <- max(bb$xmax - bb$xmin, bb$ymax - bb$ymin) / 750
if(!"delta_i" %in% names(link)){
link$delta_i <- 0
link$delta_j <- 0
delta <- 0
}
if (size == "area"){
if(is.null(k)){ k <- hmax / max(link[[dfvar]] / link$dist)}
link$height <- link[[dfvar]] / link$dist * k
} else {
if(is.null(k)){ k <- hmax / max(link[[dfvar]])}
link$height <- link[[dfvar]] * k
link$height <- link[[dfvar]] * k
}
link <- rotate(link)
l <- st_geometry(link)
d <- st_coordinates(l)
......@@ -203,14 +111,12 @@ linktoarrows2 <- function(link, size, k, dfvar, decreasing){
r <- r[,c("X","Y","X.1","Y.1")]
colnames(r) <- c("x1","y1","x2","y2")
r$height <- link$height
if (type == "arrows"){
r$x1 <- r$x1 + link$delta_j + delta
r$x2 <- r$x2 - link$delta_i - delta
r$y1 <- r$y1 - (r[["height"]]/2 + delta2) * link$shift
r$y2 <- r$y2 - (r[["height"]]/2 + delta2) * link$shift
r$p1x <- r$x1
r$p1y <- r$y1 - r[["height"]]/2
r$p2x <- r$x2 - r[["height"]]/2
......@@ -219,12 +125,29 @@ linktoarrows2 <- function(link, size, k, dfvar, decreasing){
r$p3y <- r$y2
r$p4x <- r$x2 - r[["height"]]/2
r$p4y <- r$y2 + r[["height"]]/2
r$p5x <- r$x1
r$p5x <- r$x1
r$p5y <- r$y1 + r[["height"]]/2
st_geometry(link) <- st_as_sfc(paste0("POLYGON((",r$p1x," ",r$p1y,", ",r$p2x," ",r$p2y,", ",r$p3x," ",r$p3y,", ",r$p4x," ",r$p4y,", ",r$p5x," ",r$p5y,", ",r$p1x," ",r$p1y,"))"))
}
if (type == "rect"){
r$p1x <- r$x1 + link$delta_j + delta
r$p2x <- r$x2 - link$delta_i - delta
r$p1y <- r$y1 - (r[["height"]]/2 + delta2) * link$shift
r$p2y <- r$y2 - (r[["height"]]/2 + delta2) * link$shift
r$p3x <- r$p2x
r$p3y <- r$p2y + r[["height"]]/2
r$p4x <- r$p1x
r$p4y <- r$p1y + r[["height"]]/2
r$p1y <- r$p1y - r[["height"]]/2
r$p2y <- r$p2y - r[["height"]]/2
st_geometry(link) <- st_as_sfc(paste0("POLYGON((",r$p1x," ",r$p1y,", ",r$p2x," ",r$p2y,", ",r$p3x," ",r$p3y,", ",r$p4x," ",r$p4y,", ",r$p1x," ",r$p1y,"))"))
}
link$ang <- - link$ang
link <- rotate(link)
link <- link[order(link$height, decreasing = decreasing),]
st_crs(link) <- crs
return(link)
}
\ No newline at end of file
}
#' Title
#'
#' @param x
#' @param xid
#' @param df
#' @param dfid
#' @param dfvar
#' @param size
#' @param type
#' @param decreasing
#' @param add
#' @param lwd
#' @param col
#' @param border
#' @param k
#' @param df2
#' @param df2id
#' @param df2var
#' @param k2
#'
#' @return
#' @export
#'
#' @examples
#' library(sf)
#'
#' # Import
#'crs <- "+proj=robin +lon_0=0 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs"
#'
#'subregions <- st_read(system.file("subregions.gpkg", package="flowmapper")) %>% st_transform(crs)
#'migr <- read.csv(system.file("migrantstocks2019.csv", package="flowmapper"))
#'
#'# Selection, filtrage, traitement en amont
#'
#'threshold <- 1500
#'migr <- migr[migr$fij >= threshold,]
#'
#'# Example 1
#'
#'c <- plotflows(
#' x = subregions,
#' xid = "id",
#' df = migr,
#' dfid = c("i","j"),
#' dfvar = "fij"
#')
#'
#'# Example 2
#'
#'intra <- migr[migr$i == migr$j,c("i","fij")]
#'colnames(intra) <- c("id","nb")
#'
#'plot(st_geometry(subregions), col = "#CCCCCC", border = "white", lwd = 0.5)
#'c <- plotflows(
#' x = subregions,
#' xid = "id",
#' df = migr,
#' dfid = c("i","j"),
#' dfvar = "fij",
#' size = "thickness",
#' type = "rect",
#' decreasing = FALSE,
#' add = TRUE,
#' lwd = 1,
#' col = "#00FF0090",
#' border = "#4a0c25",
#' k = NULL,
#' df2 = intra,
#' df2id = "id",
#' df2var = "nb"
#')
#'
#'# Example 3
#'
#'crs <- "+proj=aeqd +lat_0=90 +lon_0=50 +x_0=0 +y_0=0 +datum=WGS84 +units=m +no_defs "
#'subregions2 <- st_transform(subregions, crs)
#'
#'plot(st_geometry(subregions2), col = "#CCCCCC", border = "white", lwd = 0.5)
#'c <- plotflows(
#' x = subregions2,
#' xid = "id",
#' df = migr,
#' dfid = c("i","j"),
#' dfvar = "fij",
#' add = TRUE
#')
#'
#'# Example 4
#'
#'crs <- "+proj=ortho +lat_0=42.5333333333 +lon_0=-72.53333333339999 +x_0=0 +y_0=0 +a=6370997 +b=6370997 +units=m +no_defs"
#'flows <- smoothr::densify(c[[3]], n = 30) %>% st_transform(crs)
#'plot(st_geometry(subregions) %>% st_transform(crs), col ="#CCCCCC", border = "white")
#'plot(st_geometry(flows), col ="#FF000099", add = TRUE)
#'plot(st_centroid(st_geometry(c[[2]])) %>% st_transform(crs), add = TRUE, pch = 20, cex = 1.3, col ="black")
plotflows <- function(
x,
xid = "id",
df,
dfid = c("i","j"),
dfvar = "fij",
size = "thickness",
type = "arrows",
decreasing = FALSE,
add = FALSE,
lwd = 1,
col = "#FF000099",
border = "#4a0c25",
k = NULL,
df2 = NULL,
df2id,
df2var,
k2 = NULL
){
links <- getlinks(x, df, xid, dfid, dfvar)
if(!is.null(df2)){
c <- getcircles(x = x, xid = xid, df = df2, dfid = df2id, dfvar = df2var, k = k2)
r <- c[,c(df2id,"r")] %>% st_drop_geometry()
} else {
c <- getdots(x = x, xid = xid, k = k2)
r <- c[,c(xid,"r")] %>% st_drop_geometry()
}
links <- merge(links,r, by.x = "j", by.y = "id", all.x = TRUE)
links <- merge(links,r, by.x = "i", by.y = "id", all.x = TRUE)
colnames(links) <- c("i", "j", "fij", "ang", "dist", "ctrx", "ctry", "delta_i", "delta_j", "geometry")
links$delta_i[is.na(links$delta_i)] <- 0
links$delta_j[is.na(links$delta_j)] <- 0
flows <- linktoflows(links, size, k = k, dfvar, type, decreasing)
plot(st_geometry(flows), col =col, add = add)
plot(st_geometry(c), col = NA, border = "black", lwd = 2, add = TRUE)
output <- list("links" = links, "circles" = c, "flows" = flows)
return(output)
}
Version: 1.0
RestoreWorkspace: No
SaveWorkspace: No
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX
AutoAppendNewline: Yes
StripTrailingWhitespace: Yes
LineEndingConversion: Posix
BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageRoxygenize: rd,collate,namespace,vignette
library(sf)
# Import
crs <- "+proj=robin +lon_0=0 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs"
subregions <- st_read("data/subregions.gpkg") %>% st_transform(crs)
migr <- read.csv("data/migrantstocks2019.csv")
source("helpers.R")
# Selection, filtrage, traitement en amont
threshold <- 1500
migr <- migr[migr$fij >= threshold,]
intra <- migr[migr$i == migr$j,c("i","fij")]
colnames(intra) <- c("id","nb")
# 1 - RECTANGLES
flowRect <- function(x, df, xid, dfid, dfvar, size = "thickness", k = NULL, decreasing = TRUE, add = TRUE, col = "red", border = "black", lwd = 1)
{
links <- getlinks(x, df, xid, dfid, dfvar)
rect <- linktorect(links, size, k, dfvar, decreasing)
plot(st_geometry(rect), col = col, border = border, lwd = lwd, add = add)
}
plot(st_geometry(subregions), col = "#CCCCCC", border = "white", lwd = 0.5)
flowRect(x = subregions, df = migr, xid = "id", dfid = c("i","j"), dfvar = "fij", size = "area", decreasing = FALSE, lwd = 0.1, col = "#c4518a", border = "#CCCCCC")
# 2 - ARROWS
flowArrows <- function(x, df, xid, dfid, dfvar, size = "thickness", k = NULL, decreasing = TRUE, add = TRUE, col = "red", border = "black", lwd = 1)
{
links <- getlinks(x, df, xid, dfid, dfvar)
rect <- linktoarrows(links, size, k, dfvar, decreasing)
plot(st_geometry(rect), col = col, border = border, lwd = lwd, add = add)
}
plot(st_geometry(subregions), col = "#CCCCCC", border = "white", lwd = 0.5)
flowArrows(x = subregions, df = migr, xid = "id", dfid = c("i","j"), dfvar = "fij", decreasing = FALSE, lwd = 0.3, col = "#FFFF0090", border = "black", size = "area")
# 3 - ARROWS + CIRCLES
x = subregions
xid = "id"
df = migr
dfid = c("i","j")
dfvar = "fij"
size = "thickness"
decreasing = TRUE
add = TRUE
lwd = 1
col = "red"
border = "#4a0c25"
k = NULL
df2 = intra
df2id = "id"
df2var = "nb"
k2 = 50
links <- getlinks(x, df, xid, dfid, dfvar)
c <- getcircles(x = x, xid = xid, df = df2, dfid = df2id, dfvar = df2var, k = k2)
r <- c[,c(df2id,"r")] %>% st_drop_geometry()
links <- merge(links,r, by.x = "j", by.y = "id", all.x = TRUE)
links <- merge(links,r, by.x = "i", by.y = "id", all.x = TRUE)
colnames(links) <- c("i", "j", "fij", "ang", "dist", "ctrx", "ctry", "delta_i", "delta_j", "geometry")
links$delta_i[is.na(links$delta_i)] <- 0
links$delta_j[is.na(links$delta_j)] <- 0
# View(links)
rect <- linktoarrows(links, size, k, dfvar, decreasing)
par(mar=c(0,0,0,0))
plot(st_geometry(links))
plot(st_geometry(subregions), col = "#CCCCCC", border = "white", lwd = 0.5, add=T)
plot(st_geometry(rect), col = col, border = border, lwd = lwd, add = add)
plot(st_geometry(c), col = NA, border = "black", lwd = 2, add = add)
# 4 - TWO ARROWS
x = subregions
xid = "id"
df = migr
dfid = c("i","j")
dfvar = "fij"
size = "area"
decreasing = FALSE
add = TRUE
lwd = 1
col = "red"
border = "#4a0c25"
k = NULL
df2 = intra
df2id = "id"
df2var = "nb"
k2 = 50
links <- getlinks(x, df, xid, dfid, dfvar)
c <- getcircles(x = x, xid = xid, df = df2, dfid = df2id, dfvar = df2var, k = k2)
r <- c[,c(df2id,"r")] %>% st_drop_geometry()
links <- merge(links,r, by.x = "j", by.y = "id", all.x = TRUE)
links <- merge(links,r, by.x = "i", by.y = "id", all.x = TRUE)
colnames(links) <- c("i", "j", "fij", "ang", "dist", "ctrx", "ctry", "delta_i", "delta_j", "geometry")
links$delta_i[is.na(links$delta_i)] <- 0