bivariate Raster-Plots in R

Question

Ich habe eine Herausforderung beim Zeichnen einer bivariaten Raster-Daten in einem Diagramm mit einer Legende für beide Variablen. Meine erste Schicht ist eine kontinuierliche Variable zwischen -2 und 2, während die zweite Schicht eine kategorische Variable ist (in Jahren von 1980 bis 2011). Ich brauche Hilfe beim Plotten der Daten als ein Rastr-Plot mit einem Farbschema und einer Legende, die both variables as shown here zeigt. Ich schätze Ihre Hilfe.

r <- raster(ncols=100, nrows=100) 
r[] <- runif(ncell(r)) 
crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84" 


r1 <- raster(ncols=100, nrows=100) 
r1[] <- 1980:2011 
crs(r1) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84" 

dta=stack(r,r1) 

Answer 1

Siehe ?raster::plot für Beispiele oder tun spplot(dta)

Answer 2

ich erfolgreich den Code aus the site angewendet Sie erwähnt.

kpacks <- c("classInt", 'raster', 'rgdal', 
      'dismo', 'XML', 'maps', 'sp') 
new.packs <- kpacks[!(kpacks %in% installed.packages()[, "Package"])] 
if (length(new.packs)) 
    install.packages(new.packs) 
lapply(kpacks, require, character.only = T) 
remove(kpacks, new.packs) 


r <- raster(ncols = 100, nrows = 100) 
r[] <- runif(ncell(r)) 
crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84" 


r1 <- raster(ncols = 100, nrows = 100) 
r1[] <- sample(1980:2011, 10000, replace = T) 
crs(r1) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84" 

dta = stack(r, r1) 
plot(dta) 

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)] 
    } 

col.matrix <- 
    colmat(
    nquantiles = 10, 
    upperleft = "blue", 
    upperright = "yellow", 
    bottomleft = "green", 
    bottomright = "red", 
    xlab = "My x label", 
    ylab = "My y label" 
) 


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) 
    } 

my.colors = colorRampPalette(c("white", "lightblue", "yellow", "orangered", "red")) 
plot(
    r, 
    frame.plot = F, 
    axes = F, 
    box = F, 
    add = F, 
    legend.width = 1, 
    legend.shrink = 1, 
    col = my.colors(255) 
) 
map(interior = T, add = T) 

bivmap <- bivariate.map(r, r1, colormatrix = col.matrix, nquantiles = 10) 

# Plot the bivariate map: 

plot(
    bivmap, 
    frame.plot = F, 
    axes = F, 
    box = F, 
    add = F, 
    legend = F, 
    col = as.vector(col.matrix) 
) 
col.matrix