R中的双变量Choropleth映射

Question

我正在寻找一种通用的解决方案，以使用栅格文件在R中创建bivariate choropleth maps。

我发现以下代码here几乎可以满足我的需要，但有其局限性：它只能处理两个轴上介于0和1之间的数据。在我的特定用例中，一个轴的范围是0-1，而另一轴在-1和1之间。不管我的特定用例是什么，我认为一个能够处理不同数据范围的更通用的功能对许多人来说都是有用的。 / p>

我已经尝试过更新函数colmat中的代码以处理负面数据，但对我而言，一生都无法正常工作。为了清楚起见，我避免发布所有失败的尝试，并仔细阅读下面在上面链接中找到的代码，以期希望有人能够提供解决方案。

当前代码首先使用colmat创建一个颜色矩阵。然后，在bivariate.map中使用生成的颜色矩阵以及包含数据的两个栅格文件。我认为理想的解决方案是首先基于两个栅格创建颜色矩阵（以便它可以根据您的实际数据正确地对数据进行分箱，而不是当前介于0和1之间的解决方案）。

````
library(classInt)
library(raster)
library(rgdal)
library(dismo)
library(XML)
library(maps)
library(sp)

# Creates dummy rasters
rasterx<- raster(matrix(rnorm(400),5,5))
rasterx[rasterx <=0]<-1
rastery<- raster(matrix(rnorm(400),5,5))


# This function creates a colour matrix
# At present it cannot handle negative values i.e. the matrix spans from 0 to 1 along both axes
colmat<-function(nquantiles=10, upperleft=rgb(0,150,235, maxColorValue=255), upperright=rgb(130,0,80, maxColorValue=255), bottomleft="grey", bottomright=rgb(255,230,15, maxColorValue=255), xlab="x label", ylab="y label"){

  my.data<-seq(0,1,.01)
  my.class<-classIntervals(my.data,n=nquantiles,style="quantile")
  my.pal.1<-findColours(my.class,c(upperleft,bottomleft))
  my.pal.2<-findColours(my.class,c(upperright, bottomright))
  col.matrix<-matrix(nrow = 101, ncol = 101, NA)

  for(i in 1:101){
    my.col<-c(paste(my.pal.1[i]),paste(my.pal.2[i]))
    col.matrix[102-i,]<-findColours(my.class,my.col)
  }

  plot(c(1,1),pch=19,col=my.pal.1, cex=0.5,xlim=c(0,1),ylim=c(0,1),frame.plot=F, xlab=xlab, ylab=ylab,cex.lab=1.3)

  for(i in 1:101){
    col.temp<-col.matrix[i-1,]
    points(my.data,rep((i-1)/100,101),pch=15,col=col.temp, cex=1)
  }

  seqs<-seq(0,100,(100/nquantiles))
  seqs[1]<-1
  col.matrix<-col.matrix[c(seqs), c(seqs)]

}

# Creates colour matrix
col.matrix<-colmat(nquantiles=2, upperleft="blue", upperright="yellow", bottomleft="green", bottomright="red", xlab="Species Richness", ylab="Change in activity hours")

# Function to create bivariate map, given the colour ramp created previously
bivariate.map<-function(rasterx, rastery, colormatrix=col.matrix, nquantiles=10){

  quanmean<-getValues(rasterx)
  temp<-data.frame(quanmean, quantile=rep(NA, length(quanmean)))
  brks<-with(temp, quantile(temp,na.rm=TRUE, probs = c(seq(0,1,1/nquantiles))))
  r1<-within(temp, quantile <- cut(quanmean, breaks = brks, labels = 2:length(brks),include.lowest = TRUE))
  quantr<-data.frame(r1[,2]) 
  quanvar<-getValues(rastery)
  temp<-data.frame(quanvar, quantile=rep(NA, length(quanvar)))
  brks<-with(temp, quantile(temp,na.rm=TRUE, probs = c(seq(0,1,1/nquantiles))))
  r2<-within(temp, quantile <- cut(quanvar, breaks = brks, labels = 2:length(brks),include.lowest = TRUE))
  quantr2<-data.frame(r2[,2])
  as.numeric.factor<-function(x) {as.numeric(levels(x))[x]}
  col.matrix2<-colormatrix
  cn<-unique(colormatrix)

  for(i in 1:length(col.matrix2)){
    ifelse(is.na(col.matrix2[i]),col.matrix2[i]<-1,col.matrix2[i]<-which(col.matrix2[i]==cn)[1])
  }

  cols<-numeric(length(quantr[,1]))
  for(i in 1:length(quantr[,1])){
    a<-as.numeric.factor(quantr[i,1])
    b<-as.numeric.factor(quantr2[i,1])
    cols[i]<-as.numeric(col.matrix2[b,a])}
  r<-rasterx
  r[1:length(r)]<-cols
  return(r)

}

# Creates map
bivmap<-bivariate.map(rasterx,rastery, colormatrix=col.matrix, nquantiles=2)

# Plots a map
plot(bivmap,frame.plot=F,axes=F,box=F,add=F,legend=F,col=as.vector(col.matrix)) ````

理想情况下，更通用的功能是获取两个栅格文件，确定这两个栅格的数据范围，然后根据用户指定的仓/分位数创建一个双变量chhorpleth映射。

Answer 1

可能您已经自行解决了这个问题，在这种情况下，我很高兴进行一些更新（我现在正在处理同一问题）。否则，我只是找到了一些链接，希望它们可以帮助您解决此问题

http://lenkiefer.com/2017/04/24/bivariate-map/

http://rpubs.com/apsteinmetz/prek

最佳

Answer 2

以下是基于您的代码的一些想法

三个功能

makeCM <- function(breaks=10, upperleft, upperright, lowerleft, lowerright) { 
   m <- matrix(ncol=breaks, nrow=breaks)
   b <- breaks-1
   b <- (0:b)/b
   col1 <- rgb(colorRamp(c(upperleft, lowerleft))(b), max=255)
   col2 <- rgb(colorRamp(c(upperright, lowerright))(b), max=255)
   cm <- apply(cbind(col1, col2), 1, function(i) rgb(colorRamp(i)(b), max=255))
   cm[, ncol(cm):1 ]

}

plotCM <- function(cm, xlab="", ylab="", main="") {
    n <- cm
    n <- matrix(1:length(cm), nrow=nrow(cm), byrow=TRUE)
    r <- raster(n)
    cm <- cm[, ncol(cm):1 ]
    image(r, col=cm, axes=FALSE, xlab=xlab, ylab=ylab, main=main)
}


rasterCM <- function(x, y, n) {
    q1 <- quantile(x, seq(0,1,1/(n)))
    q2 <- quantile(y, seq(0,1,1/(n)))
    r1 <- cut(x, q1, include.lowest=TRUE)
    r2 <- cut(y, q2, include.lowest=TRUE)
    overlay(r1, r2, fun=function(i, j) {
        (j-1) * n + i
    })
}   

示例数据

library(raster)
set.seed(42)
r <- raster(ncol=50, nrow=50, xmn=0, xmx=10, ymn=0,ymx=10, crs="+proj=utm +zone=1")
x <- init(r, "x") * runif(ncell(r), .5, 1)
y <- init(r, "y") * runif(ncell(r), .5, 1)

现在使用了功能

breaks <- 5
cmat <- makeCM(breaks, "blue", "yellow", "green", "red")
xy <- rasterCM(x, y, breaks)

par(mfrow=c(2,2), mai=c(.5,.5,.5,.5), las=1)
plot(x)
plot(y)
par(mai=c(1,1,1,1))
plotCM(cmat, "var1", "var2", "legend")
par(mai=c(.5,.5,.5,.5))
image(xy, col=cmat, las=1)