r - 将调色板与 colorRampPalette 合并并使用传单进行绘图

Question

我正在尝试合并两个 colorRampPalette在 leaflet 中使用的方案并且一直在关注这个不错的 example .该示例工作正常，但我似乎无法让它为我的工作工作，下面是可重现的示例。我正在使用 RdYlGn调色板，我希望低于阈值的数字为深绿色，高于阈值的数字为红色(跳过一些内部颜色)。

对于我的例子，我的截止日期是 nc$PERIMETER < 1.3 所以我希望这个值以下的数字是绿色的，而所有高于红色的数字(颜色 #FDAE61 以后)。

library(sf)  
library(leaflet)
library(RColorBrewer)

#palette im using
palette <- rev(brewer.pal(11, "RdYlGn"))
# [1] "#006837" "#1A9850" "#66BD63" "#A6D96A" "#D9EF8B" "#FFFFBF" "#FEE08B" "#FDAE61" "#F46D43" "#D73027" "#A50026"
previewColors(colorNumeric(palette = palette, domain = 0:10), values = 0:10)


# preparing the shapefile
nc <- st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE) %>% 
  st_transform(st_crs(4326)) %>% 
  st_cast('POLYGON')
nc

x <- sum(nc$PERIMETER < 1.3)  
x # number of values below threshold = 21


### Create an asymmetric color range
## Make vector of colors for values smaller than 1.3 (21 colors)
rc1 <- colorRampPalette(colors = c("#006837", "#1A9850"), space = "Lab")(x)    #21 

## Make vector of colors for values larger than 1.3 
rc2 <- colorRampPalette(colors = c("#FDAE61", "#A50026"), space = "Lab")(length(nc$PERIMETER) - x)

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

mypal <- colorNumeric(palette = rampcols, domain = nc$PERIMETER)
previewColors(colorNumeric(palette = rampcols, domain = NULL), values = 1:length(nc$PERIMETER))

查看预览，它似乎有效(1.3 以下的 21 个值应为绿色):



绘制它:

leaflet() %>%
  addTiles() %>%
  addPolygons(data = nc,
              fillOpacity = 0.7,
              fillColor = ~mypal(PERIMETER),
              popup = paste("PERIMETER: ", nc$PERIMETER) )

绘图正常但没有给出正确的颜色，突出显示的颜色高于阈值(1.3)，因此不应为绿色，但它是:



我认为我创建调色板的方式是错误的，但预览似乎表明我做得对吗？

谁有想法？谢谢

Answer 1

自从我写了那个答案以来，我有点觉得对这个问题负责。我不知道传单是如何为多边形分配颜色的。但我认为我们目睹了您的方法行不通。根据我之前的想法，我为您做了以下工作。我创建了一个新的连续变量(即 ranking )。此信息是 PERIMETER 中值的顺序.这样，最小值PERIMETER (即 0.999)肯定会获得第一种颜色。在我之前的回答中，我建议使用 colorFactor() ，但这让你很难创造传奇。所以这里是额外的信息。创建图例时，我使用了 ranking在 colorNumeric()并创建了一个调色板，即 mypal2 .我们使用相同的信息来填充多边形并添加图例，但我们使用不同的函数(colorFactor 或 colorNumeric)。有了图例后，我们必须更改标签格式。因此我们使用 labelFormat() .我正在使用 ranking作为索引并在 PERIMETER 中获取值.

library(sf)  
library(leaflet)
library(RColorBrewer)

#palette im using
palette <- rev(brewer.pal(11, "RdYlGn"))
# [1] "#006837" "#1A9850" "#66BD63" "#A6D96A" "#D9EF8B" "#FFFFBF" "#FEE08B" "#FDAE61" "#F46D43" "#D73027" "#A50026"
previewColors(colorNumeric(palette = palette, domain = 0:10), values = 0:10)


# preparing the shapefile
nc2 <- st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE) %>% 
       st_transform(st_crs(4326))


# Add sequence information in order to create 108 categories for
# colorFactor(). I sorted the data and added the sequence information.

arrange(nc2, PERIMETER) %>% 
mutate(ranking = 1:n()) -> nc2

x <- sum(nc2$PERIMETER < 1.3)   
x # number of values below threshold = 21


### Create an asymmetric color range
## Make vector of colors for values smaller than 1.3 (21 colors)
rc1 <- colorRampPalette(colors = c("#006837", "#1A9850"), space = "Lab")(x)    #21 

## Make vector of colors for values larger than 1.3 
rc2 <- colorRampPalette(colors = c("#FDAE61", "#A50026"), space = "Lab")(length(nc2$PERIMETER) - x)

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

# Create a palette to fill in the polygons
mypal <- colorFactor(palette = rampcols, domain = factor(nc2$ranking))
previewColors(colorNumeric(palette = rampcols, domain = NULL), values = 1:length(nc$PERIMETER))


# Create a palette for a legend with ranking again. But this time with
# colorNumeric()

mypal2 <- colorNumeric(palette = rampcols, domain = nc2$ranking)

leaflet() %>%
addTiles() %>%
addPolygons(data = nc2,
            fillOpacity = 0.7,
            fillColor = ~mypal(nc2$ranking),
            popup = paste("PERIMETER: ", nc2$PERIMETER)) %>% 
addLegend(position = "bottomright", pal = mypal2, values = nc2$ranking,
          title = "PERIMETER",
          opacity = 0.7,
          labFormat = labelFormat(transform = function(x) nc2$PERIMETER[x]))

如果我将阈值级别设置为 2.3(小于 2.3)，就会得到这个。