объединение палитр с colorRampPalette и черчение с листовкой

Question

Я пытаюсь объединить две colorRampPalette схемы для использования в leaflet и следую этому хорошему примеру . Этот пример работает нормально, но я не могу заставить его работать для моей работы, воспроизводимый пример ниже. Я использую палитру RdYlGn и хочу, чтобы числа ниже порога были темно-зелеными, а цифры выше порога - более красными (пропуская некоторые из внутренних цветов).

Для моего примера мой предел равен nc$PERIMETER <1,3, поэтому я хочу, чтобы числа под этим значением были зелеными, а все, что выше, - более красным (цвет <code>#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))

глядя на предварительный просмотр, он, кажется, сработал (21 значение до 1,3 должно быть зеленым):

построение графика:

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, либо colorNumeri c). Как только у нас появится легенда, мы должны изменить формат этикетки. Следовательно, мы используем 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), я получаю это.