如何在 R 中为传单中的数值变量设置不对称颜色渐变

我想让传单调色板以零为中心（红白绿发散）。我已经尝试过中所说的这个帖子 https://stackoverflow.com/questions/29262824/r-center-color-palette-on-0。当我尝试手动创建颜色时，我得到了红绿发散，但无法将其居中为零。

My Code

regions@data <- data.frame(region <- c("APAC (excl. China)", "Africa", 
                                       "Americas", "Europe", "Greater China", "Middle East"),
                           change_targeted <- c(36,-21,25,4,173,34))

color = "#666"
weight = 0.5
opacity = 1
fillOpacity = 1
dashArray = ""
hl_color = "black"
hl_weight = 1
hl_dashArray = ""

library(RColorBrewer)
nHalf = nrow(regions@data)/2
Min = min(regions@data[,"change_targeted"])
Max = max(regions@data[,"change_targeted"])
Thresh = 0

## Make vector of colors for values below threshold
rc1 = colorRampPalette(colors = c("red", "white"), space="Lab")(nHalf)    
## Make vector of colors for values above threshold
rc2 = colorRampPalette(colors = c("white", "green"), space="Lab")(nHalf)
rampcols = c(rc1, rc2)
## In your example, this line sets the color for values between 49 and 51. 
rampcols[c(nHalf, nHalf+1)] = rgb(t(col2rgb("white")), maxColorValue=256) 

rb1 = seq(Min, Thresh, length.out=nHalf+1)
rb2 = seq(Thresh, Max, length.out=nHalf+1)[-1]
rampbreaks = c(rb1, rb2)

pal <- colorNumeric(
  palette = rampcols, #"Blues", #YlGnBu,YlOrRd
  domain = regions@data$change_targeted)

leaflet(regions, options = leafletOptions(zoomControl = FALSE, 
attributionControl=FALSE)) %>%
  addPolygons(color = color, 
            weight = weight, #smoothFactor = 0.5,
            opacity = opacity, fillOpacity = fillOpacity,
              dashArray = dashArray,
              fillColor = ~pal(change_targeted),
              highlightOptions = highlightOptions(color = hl_color, 
                                                  weight = hl_weight,
                                                  dashArray = hl_dashArray,
                                                  bringToFront = TRUE),
              label = 
~as.character(paste0(region,"",round(change_targeted,1),"%")),
              labelOptions = labelOptions(noHide = T, textOnly = F, 
direction = "left",
                                          textsize = "12px")) %>%
  setView(35, 36, 0.5) %>%
   addLegend("bottomright", pal = pal, values = ~change_targeted,
            title = NULL,
            labFormat = labelFormat(suffix = "%"), opacity=1)

我的地图图表

理想情况下，我希望只有非洲有红色，其余地区有白色到绿色调色板

由于我没有您的数据、区域，因此我选择使用我一直在 Stack Overflow 上回答一些问题的虚拟数据。我希望你不介意。乔什的回答基本上给了你正确的方向。您可能误解了他的代码。在那个问题 https://stackoverflow.com/questions/10985224/r-heatmap-with-diverging-colour-palette/10986203#10986203，他创建并组合了两个调色板。然后，他手动将中点颜色设置为绿色。您想知道他在每个调色板中创造了 50 种颜色。你的故事是另一个故事；你需要扭曲他的答案。您想要使用红色、白色和绿色创建不对称的颜色范围。您需要创建红色和白色之间的 20 种颜色（即 -20 和 0 之间），以及白色和绿色之间的 180 种颜色（即 0 和 180 之间）。您可以根据实际数据更改这些范围。

现在您想使用 Josh 的代码。您不必使用所有它。您所需要做的就是创建两个调色板并将它们组合起来。完成后，您就可以开始了。在下面的代码中，我跳过了突出显示选项，以尽量减少这种情况。

library(raster)
library(dplyr)
library(leaflet)
library(RColorBrewer)

### Get UK polygon data
UK <- getData("GADM", country = "GB", level = 2)

### Create dummy data
set.seed(111)
mydf <- data.frame(place = unique(UK$NAME_2),
                   value = sample(x = -20:180, size = n_distinct(UK$NAME_2), replace = TRUE))

### Create an asymmetric color range

## Make vector of colors for values smaller than 0 (20 colors)
rc1 <- colorRampPalette(colors = c("red", "white"), space = "Lab")(20)

## Make vector of colors for values larger than 0 (180 colors)
rc2 <- colorRampPalette(colors = c("white", "green"), space = "Lab")(180)

## Combine the two color palettes
rampcols <- c(rc1, rc2)

mypal <- colorNumeric(palette = rampcols, domain = mydf$value)

## If you want to preview the color range, run the following code
previewColors(colorNumeric(palette = rampcols, domain = NULL), values = -20:180)


leaflet() %>% 
addProviderTiles("OpenStreetMap.Mapnik") %>%
setView(lat = 55, lng = -3, zoom = 6) %>%
addPolygons(data = UK,
            stroke = FALSE, smoothFactor = 0.2, fillOpacity = 0.3,
            fillColor = ~mypal(mydf$value),
            popup = paste("Region: ", UK$NAME_2, "<br>",
                          "Value: ", mydf$value, "<br>")) %>%
addLegend(position = "bottomright", pal = mypal, values = mydf$value,
          title = "UK value",
          opacity = 1)