Commit 02118115 authored by Nicolas Lambert's avatar Nicolas Lambert
Browse files

double arrows

parent 1a669593
No preview for this file type
......@@ -12,7 +12,7 @@ source("helpers.R")
# Selection, filtrage, traitement en amont
threshold <- 500
threshold <- 1500
migr <- migr[migr$fij >= threshold,]
intra <- migr[migr$i == migr$j,c("i","fij")]
colnames(intra) <- c("id","nb")
......@@ -47,7 +47,6 @@ flowArrows(x = subregions, df = migr, xid = "id", dfid = c("i","j"), dfvar = "fi
# 3 - ARROWS + CIRCLES
x = subregions
xid = "id"
df = migr
......@@ -66,19 +65,58 @@ 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")
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 <- linktorect(links, size, k, dfvar, decreasing)
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(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
links$delta_j[is.na(links$delta_j)] <- 0
plot(st_geometry(links), col = "white")
plot(st_geometry(subregions), col = "#CCCCCC", border = "white", lwd = 0.5, add=T)
rect <- linktoarrows2(links, size, k = k, dfvar, decreasing)
plot(st_geometry(rect), col ="#FF000099", add=T)
plot(st_geometry(c), col = NA, border = "black", lwd = 2, add = add)
......@@ -91,7 +91,6 @@ linktorect <- function(link, size, k, dfvar, decreasing){
link$ang <- - link$ang
link <- rotate(link)
link <- link[order(link$height, decreasing = decreasing),]
#link <- link[order(link[[dfvar]], decreasing = FALSE),]
return(link)
}
......@@ -149,7 +148,6 @@ linktoarrows <- function(link, size, k, dfvar, decreasing){
link$ang <- - link$ang
link <- rotate(link)
link <- link[order(link$height, decreasing = decreasing),]
link <- link[order(link[[dfvar]], decreasing = FALSE),]
return(link)
}
......@@ -160,4 +158,73 @@ getcircles <- function(x, xid, df, dfid, dfvar,k){
dots[,"r"] <- dots[,dfvar] %>% st_drop_geometry() * k
circles <- st_buffer(dots, dots$nb * k2)
return(circles)
}
# Link to Arrows
linktoarrows2 <- function(link, size, k, dfvar, decreasing){
link$shift <- 0
link$ij <- paste0(link$i,"_",link$j)
link$ji <- paste0(link$j,"_",link$i)
nb <- nrow(link)
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 <- 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$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
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)
}
\ No newline at end of file
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment