объединение палитр с помощью colorRampPalette и построение с помощью листовки

Я пытаюсь объединить две схемы colorRampPalette для использования в leaflet и следую этому приятному для-числовой-переменной-в-буклете-в">примере. Этот пример работает нормально, но я не могу заставить его работать для моей работы, воспроизводимый пример ниже. Я использую палитру 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))

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

введите здесь описание изображения

заговор это:

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

графики в порядке, но не дает правильного цвета, выделенный выше порогового значения (1.3) и поэтому не должен быть зеленым, но это так:

введите здесь описание изображения

Я думал, что то, как я создавал палитры, было неправильным, но предварительный просмотр, кажется, предполагает, что я сделал это правильно?

у кого-нибудь есть идеи? спасибо


r colors maps leaflet color-palette
person user63230    schedule 20.02.2020    source источник

Ответы (1)


arrow_upward
5
arrow_downward

Я несколько чувствую ответственность за этот вопрос, так как я написал этот ответ. Я не могу сказать, как листовка назначает цвета полигонам. Но я думаю, мы стали свидетелями того, что ваш подход не работает. Основываясь на своей предыдущей идее, я сделал для вас следующее. Я создал новую непрерывную переменную (т. е. 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), я получу это.

введите здесь описание изображения

person jazzurro    schedule 20.02.2020
comment
Я иду спать. Если вам нужна дополнительная помощь, пожалуйста, подождите до завтра. - person jazzurro; 20.02.2020
comment
отлично, спасибо, так что же такое отображение моего подхода? Он переходит к ближайшему целому числу или что-то в этом роде? Вы могли проложить мой путь и не понять, что это было неправильно! - person user63230; 20.02.2020
comment
еще одно продолжение q, если мы добавим %>% addLegend( pal = mypal, values = nc$category), легенда теперь по понятным причинам имеет 108 категорий. Я мог бы вручную взять образцы из mypal(nc$category) и добавить их как colors =c("#EF9656"... и получить связанные с ними значения nc$PERIMETER, но я чувствую, что есть короткий способ сделать это, если бы мы могли сделать что-то вроде переключения nc$category обратно в непрерывный режим? У вас есть предложения по этому поводу? спасибо - person user63230; 20.02.2020
comment
@user63230 user63230 Я найду время, как только моя работа будет сделана сегодня. - person jazzurro; 21.02.2020
comment
@user63230 user63230 Я только что пришел домой и пересмотрел эту идею. Я опубликую свое обновление в ближайшее время. - person jazzurro; 21.02.2020
comment
@ user63230 Я только что опубликовал свою версию. Я надеюсь, что этого достаточно для вас. - person jazzurro; 21.02.2020
comment
хм, это определенно то, что я имел в виду (спасибо), но я не думаю, что это работает так, как мы думаем, если мы изменим отсечку на x <- sum(nc$PERIMETER < 2.5) и повторим - почти вся легенда будет зеленой, когда мы просто хотим ниже 2,5 зеленого? - person user63230; 21.02.2020
comment
@ user63230 Вы восстановили цветовые палитры? - person jazzurro; 21.02.2020
comment
да, также, когда вы перезапускаете с новой отсечкой (‹2,5), полигон на PERIMETER = 2,365 не становится зеленым, когда должен быть, не знаю, что происходит. - person user63230; 21.02.2020
comment
@user63230 user63230 Кажется, я исправил проблему. Позвольте мне опубликовать то, что я получил на данный момент. После этого мне нужно лечь спать. Надеюсь, ты это понимаешь. - person jazzurro; 21.02.2020
comment
@ user63230 Я получаю Warning message:In st_cast.sf(., "POLYGON") : repeating attributes for all sub-geometries for which they may not be constant. Когда мы повторно запускаем коды, мы можем возиться с nc. Это то, о чем мы хотим знать. - person jazzurro; 21.02.2020
comment
@ user63230 Со своей стороны, когда я меняю значения (1,3 и 2,5), я думаю, что теперь получаю правильные результаты. Это все, что я могу сказать на данный момент. Я вернусь сюда завтра и посмотрю, что происходит на вашей стороне. - person jazzurro; 21.02.2020
comment
Спасибо за всю твою помощь. Ваш новый график выше показывает неправильную легенду, критерии: все, что ниже 2,5, зеленое, но легенда говорит, что все ниже ~ 3,1, это проблема, с которой я тоже сталкиваюсь. - person user63230; 21.02.2020
comment
@user63230 user63230 Я собираюсь лечь спать. И последняя вещь на сегодня: если вы можете, вы хотите создать легенду с цветовым коэффициентом и попытаться изменить метки. Или вы пытаетесь создать легенду с помощью colornumeric, искажая количество цветов, которые вы создаете. Это все, что я могу представить через минуту. - person jazzurro; 21.02.2020
comment
@user63230 user63230 Если мы будем сохранять позитивный настрой, по крайней мере, цвета заливки будут работать. Завтра я найду время и посмотрю, что я могу сделать для легенды. Между тем, пожалуйста, попробуйте некоторые идеи самостоятельно. Надеюсь, мы будем работать вместе и найти решение. - person jazzurro; 21.02.2020
comment
Я думаю, проблема в том, что mypal2, plot(rep(1, 108), col = mypal(nc$ranking), pch = 19, cex = 3) и plot(rep(1, 108), col = mypal2(nc$PERIMETER), pch = 19, cex = 3) разные, хотя должны быть одинаковыми. я думаю, вам нужно создать rc3, rc4 для отдельного rampcols для использования в mypal2. Проблема в том, что я не знаю, какое значение использовать для x, потому что это больше не x <- sum(nc$PERIMETER < 2.5). Ответ, кажется, представляет собой число, представляющее пропорцию вдоль diff(range(nc$PERIMETER))... это кажется хакерским, но, может быть, это возможный способ сделать это? но предпочел бы повторяемый подход.. - person user63230; 21.02.2020
comment
@ user63230 Я думаю, что самым простым и понятным способом было бы использовать одну и ту же палитру в обоих случаях. Если мы сможем найти способ изменить метки в легенде с 1-100 на фактические числа в PERIMETER, я думаю, мы сможем решить эту проблему. Я буду учиться labelFormat в addLenend() сегодня. - person jazzurro; 22.02.2020
comment
@user63230 user63230 У меня есть идея. Позвольте мне немного поиграть. - person jazzurro; 22.02.2020
comment
@ user63230 Я отредактирую свой текст чуть позже, так как у меня есть дела. Но я надеюсь, что вы можете попробовать код. - person jazzurro; 22.02.2020
comment
@ user63230 Думаю, это лучшее, что я могу сделать. Если вам нужны более сложные вещи, я думаю, вы хотите создать еще один вопрос. Есть некоторые пользователи SO, которые могут управлять листовкой лучше, чем я. - person jazzurro; 22.02.2020
comment
это так полезно, большое спасибо. Мне будет интересно посмотреть, как это работает на моих собственных данных в понедельник. Интересно, когда вы говорите, что я использую ranking в качестве индексов, что это за индексы или как они выбираются? Если мы удалим повторяющиеся PERIMETERs (nc2 <- nc2 %>% group_by(PERIMETER) %>% filter(row_number() == 1)), мы получим гораздо более равномерно распределенную легенду! - person user63230; 22.02.2020
comment
@ user63230 Я не совсем понимаю исходный код, но addLegend создает точки останова. Мы использовали 1-100. Если для разрыва выбрано первое значение, PERIMETER[1] является первым значением. Поэтому я попытался извлечь значения, которые используются для разрывов, используя ranking в качестве индексов в квадратных скобках. Я надеюсь, что я имею смысл для вас. Я предложил эту идею в связанном вопросе. Теперь я думаю, что могу сказать, что это завершение предложения. Это было довольно интенсивно. Но я рад, что сейчас все работает. - person jazzurro; 22.02.2020
comment
для тех, кто ищет эквивалент этого, используя ggplot: stackoverflow.com/questions/60327158/ - person user63230; 23.02.2020