Commit 1a669593 authored by Nicolas Lambert's avatar Nicolas Lambert
Browse files

first commit

parent e3e3273a
i,j,fij
5500,5500,483
5500,5501,12
5500,906,28
5500,912,4
5500,913,0
5500,914,2
5500,915,0
5500,916,0
5500,918,137
5500,922,95
5500,923,5603
5500,924,42
5500,925,50
5500,926,1107
5500,927,5
5500,931,0
5501,5500,16
5501,5501,11177
5501,906,210
5501,910,53
5501,912,15
5501,913,76
5501,914,3
5501,915,7
5501,916,9
5501,918,5334
5501,920,1666
5501,922,18402
5501,923,46
5501,924,2551
5501,925,694
5501,926,1104
5501,927,1152
5501,928,5
5501,931,10
5501,954,1
5501,957,0
906,5500,102
906,5501,313
906,906,5202
906,910,8
906,911,2
906,912,9
906,913,58
906,914,10
906,915,11
906,916,49
906,918,5700
906,920,830
906,922,33
906,923,148
906,924,580
906,925,439
906,926,543
906,927,1071
906,928,2
906,931,216
906,954,13
906,957,2
910,5500,0
910,5501,4
910,910,5330
910,911,440
910,912,1218
910,913,1538
910,914,7
910,915,1
910,916,0
910,918,912
910,920,2
910,922,630
910,923,57
910,924,1079
910,925,175
910,926,566
910,927,184
910,928,0
910,931,4
910,957,0
911,910,1135
911,911,1537
911,912,123
911,913,210
911,914,119
911,915,0
911,916,0
911,918,153
911,920,1
911,922,9
911,923,3
911,924,79
911,925,246
911,926,519
911,927,9
911,931,10
912,5500,0
912,5501,0
912,906,2
912,910,702
912,911,384
912,912,351
912,913,17
912,914,60
912,915,0
912,916,1
912,918,743
912,920,4
912,922,3878
912,923,20
912,924,215
912,925,1567
912,926,3841
912,927,78
912,928,2
912,931,9
912,957,1
913,5501,0
913,906,2
913,910,68
913,911,7
913,912,1
913,913,715
913,914,2
913,915,0
913,916,0
913,918,159
913,920,1
913,922,17
913,923,2
913,924,262
913,925,28
913,926,57
913,927,258
913,931,4
914,5500,0
914,5501,1
914,906,7
914,910,17
914,911,506
914,912,42
914,913,54
914,914,6625
914,915,1
914,916,1
914,918,904
914,920,0
914,922,29
914,923,8
914,924,483
914,925,606
914,926,770
914,927,31
914,931,8
915,5500,0
915,5501,0
915,910,0
915,911,1
915,912,0
915,913,4
915,914,10
915,915,864
915,916,43
915,918,6825
915,920,0
915,922,0
915,923,5
915,924,311
915,925,400
915,926,286
915,927,6
915,931,154
915,954,5
916,906,2
916,912,1
916,913,1
916,914,0
916,915,15
916,916,641
916,918,15415
916,920,0
916,922,3
916,923,3
916,924,35
916,925,197
916,926,77
916,927,22
916,931,66
918,5500,0
918,5501,52
918,906,228
918,910,4
918,911,3
918,912,24
918,913,31
918,914,6
918,915,242
918,916,836
918,918,1114
918,920,86
918,922,148
918,923,57
918,924,470
918,925,200
918,926,371
918,927,206
918,928,1
918,931,165
918,954,23
918,957,3
920,5500,0
920,5501,1555
920,906,1430
920,910,1
920,912,41
920,913,11
920,914,2
920,915,6
920,916,4
920,918,5437
920,920,6856
920,922,4186
920,923,92
920,924,671
920,925,247
920,926,880
920,927,1147
920,928,18
920,931,7
920,954,46
920,957,1
922,5500,166
922,5501,162
922,906,0
922,910,7
922,911,4
922,912,888
922,913,23
922,914,14
922,915,2
922,916,7
922,918,1885
922,920,23
922,922,13809
922,923,2097
922,924,1135
922,925,333
922,926,3841
922,927,353
922,931,82
923,5500,4396
923,5501,1
923,906,21
923,910,0
923,911,3
923,912,21
923,913,45
923,914,1
923,915,2
923,916,8
923,918,2345
923,920,0
923,922,1327
923,923,10462
923,924,2538
923,925,3246
923,926,6069
923,927,186
923,928,0
923,931,55
924,5500,12
924,5501,55
924,906,61
924,910,19
924,911,0
924,912,17
924,913,167
924,914,3
924,915,22
924,916,10
924,918,1693
924,920,59
924,922,180
924,923,489
924,924,2051
924,925,583
924,926,742
924,927,1691
924,928,2
924,931,46
924,954,0
924,957,0
925,5501,6
925,906,11
925,910,6
925,911,10
925,912,27
925,913,120
925,914,8
925,915,22
925,916,45
925,918,1821
925,920,5
925,922,331
925,923,268
925,924,894
925,925,3127
925,926,5443
925,927,612
925,928,0
925,931,844
925,957,0
926,5500,12
926,5501,5
926,906,35
926,910,111
926,911,50
926,912,84
926,913,187
926,914,26
926,915,136
926,916,33
926,918,1419
926,920,21
926,922,596
926,923,426
926,924,957
926,925,1594
926,926,2974
926,927,331
926,928,47
926,931,194
926,957,23
927,5500,0
927,5501,1
927,906,42
927,910,0
927,911,0
927,912,1
927,913,19
927,914,0
927,915,1
927,916,1
927,918,166
927,920,41
927,922,11
927,923,5
927,924,258
927,925,63
927,926,58
927,927,667
927,928,15
927,931,8
927,954,0
927,957,5
928,5501,0
928,913,0
928,914,0
928,916,0
928,918,77
928,920,0
928,922,0
928,923,0
928,924,10
928,925,0
928,926,2
928,927,143
928,928,7
928,931,0
928,954,1
928,957,4
931,5501,15
931,906,339
931,911,0
931,912,1
931,913,14
931,914,6
931,915,103
931,916,196
931,918,3747
931,920,1
931,922,63
931,923,9
931,924,294
931,925,2593
931,926,767
931,927,168
931,931,6160
954,913,0
954,914,0
954,916,0
954,918,16
954,920,1
954,922,0
954,923,0
954,924,0
954,925,0
954,926,0
954,927,3
954,928,1
954,931,0
954,954,21
954,957,0
957,913,0
957,914,2
957,915,0
957,918,42
957,922,0
957,923,1
957,924,1
957,925,1
957,926,0
957,927,156
957,928,14
957,931,1
957,954,0
957,957,19
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 <- 500
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")
links <- merge(links,r, by.x = "i", by.y = "id")
colnames(links) <- c("i", "j", "fij", "ang", "dist", "ctrx", "ctry", "delta_i", "delta_j", "geometry")
# View(links)
rect <- linktorect(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)
# polygons to links
x = subregions
df = migr
xid = "id"
dfid = c("i","j")
dfvar = "fij"
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),
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")
link <- link[link$i != link$j,]
link$ang <- atan2(link$yj - link$yi, link$xj - link$xi) * 180 / pi
link$dist <- sqrt ((link$xj - link$xi) ^ 2 + (link$yj - link$yi) ^ 2)
stringo <- paste0("LINESTRING(", link$xi, " ", link$yi, ", ",link$xj, " ", link$yj, ")")
link <- sf::st_sf(link, geometry = sf::st_as_sfc(stringo, crs = sf::st_crs(x)))
link <- link[,c(1:3,8:10)]
ctr <- st_coordinates(st_centroid(st_geometry(link)))
link$ctrx <- ctr[,1]
link$ctry <- ctr[,2]
link <- link[,c("i","j","fij","ang","dist","ctrx","ctry","geometry")]
return(link)
}
# Rotate
rotate <- function(x){
ctr = st_as_sf(x[,c("ctrx","ctry")] %>% st_drop_geometry(), coords = c("ctrx", "ctry"), crs = st_crs(links))
rot <- function(a) matrix(c(cos(a), sin(a), -sin(a), cos(a)), 2, 2)
n <- nrow(x)
for (i in 1:n){
st_geometry(x[i,]) <- ( st_geometry(x)[i] - st_geometry(ctr)[i]) * rot(x$ang[i] * pi/180) + st_geometry(ctr)[i]
}
return (x)
}
# 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 (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),]
#link <- link[order(link[[dfvar]], decreasing = FALSE),]
return(link)
}
# 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