Р: Раскрасить ggplot в два цвета, чтобы обозначить ничью?

Эта небольшая функция смешает вектор цветов в один цвет:

mixer <- function(colors) {
  paste0("#",
    col2rgb(colors) |>
      rowMeans() |>
      round() |>
      as.raw() |> 
      as.character() |> 
      paste0(collapse = ""))
}

Итак, если вы возьмете фрейм данных со связанными цветами, вы можете сделать:

my_df <- my_df %>% 
  summarise(actual_color = mixer(favorite_color), 
            favorite_color = paste(favorite_color, collapse = " + "),
            .by = NAME)

nc_merged <- merge(nc, my_df, by = "NAME", all.x = TRUE)

ggplot(data = nc_merged) +
  geom_sf(aes(fill = favorite_color)) +
  scale_fill_manual(values = setNames(unique(my_df[-1])[[1]], 
                                      unique(my_df[-1])[[2]])) +
  theme_minimal() +
  labs(title = "Favorite Color by County",
       fill = "Favorite Color")

Другой вариант — градиентировать цвета в общих цветовых состояниях, но его все равно сложно читать или интерпретировать.

Вам нужно будет добавить библиотеку ggnewscale

Вы заметили, что в вашей легенде красный отмечен синим? (Ни один из цветов не выровнен правильно.) Это проблема сортировки (сортировка цветов перед назначением их values). Вы увидите это измененное в моем коде.

Когда были созданы favorite_color и, следовательно, my_df, любые округа с разделенной геометрией (например, Крейвен, Картерет и т. д.) были перечислены более одного раза. Эти округа имеют противоречивые цветовые обозначения. У вас 108 строк в my_df, но в Северной Каролине всего 100 округов.

Вот как я решил эту проблему в вашем коде для этих двух кадров:

favorite_color <- replicate(length(unique(nc$NAME)), { # note `length...`
  sample_size <- sample(1:3, 1)
  sample(colors, sample_size, replace = FALSE)
})

my_df <- data.frame(NAME = unique(nc$NAME),            # note `unique...`
                    favorite_color = sapply(
                      favorite_color, function(x) paste(x, collapse = ", ")))

Поскольку удаление цветов с помощью NA не сработает для этого кода, я добавил еще один столбец, в котором сохраняются исходные данные цвета, прежде чем они будут заменены на NA в вашем коде.

my_df$fc2 <- my_df$favorite_color   # keep full color data

Подход, который я использую здесь, немного неуклюж, и обработка графика перед рендерингом занимает немало времени.

Шаг 1:

Постройте сетки для градиентов в состояниях с более чем одним цветом.

Это получено из другого ответа ТАК.

В этой пользовательской функции первая функция включает аргумент cellsize. Чем меньше вы сделаете эти значения, тем лучше будет выглядеть градиент. Однако чем меньше вы сделаете эти значения, тем больше времени потребуется для визуализации графика.

gradPoly <- function(mp) {        # create grid squares within shape to gradient
  my_mp <- st_make_grid(mp, cellsize = c(.05, .05)) 
  long <- st_coordinates(st_centroid(my_mp, warn = F))[, 1]
  return(st_sf(longitude = long, geometry = my_mp) %>% 
           st_intersection(st_geometry(mp)))
}   # this code will render a warning in the console

Шаг 2:

Создайте градиентные цветовые шкалы для состояний с более чем одним цветом.

scaler <- function(mp, plt) {
  wds = strsplit(mp$fc2, ', ')[[1]]  # extract colors assigned
  val = length(wds)                  # quantity of colors assigned
  ifelse(val < 3,                    # 2 colors or 3 colors in the gradient
         return(plt + scale_fill_gradient(low = wds[1], high = wds[2], guide = "none")),
         return(plt + scale_fill_gradient2(low = wds[1], mid = wds[2], high = wds[3], guide = "none",
                                                midpoint = median(gradPoly(mp)$longitude))))
}

Шаг 3:

Определите округа, которым присвоено более одного цвета.

# which counties have more than one fave?
these <- filter(my_df, is.na(favorite_color)) %>% select(NAME) %>% 
  arrange(NAME) %>% unlist()

Шаг 4:

Постройте пустой участок для строительства. В конце вы добавите границы к geom_sf, так что это будет верхний слой.

plt <- ggplot(data = nc_merged) +      # essentially the code from the question
  theme_minimal() +
  labs(title = "Favorite Color by County (with Ties)",
       fill = "Favorite Color")

Шаг 5:

Добавьте градиент округа для каждого применимого округа. Выполнение этого кода займет горячую минуту; также потребуется некоторое время для рендеринга сюжета.

for(j in unique(these)) {      # for each county with more than one favorite
  dta <- filter(nc_merged, NAME == j)     # extract county data                       # more than one color
  plt <- plt + new_scale_fill() +         # add to existing plot
    geom_sf(data = gradPoly(dta),         # call the function gradPoly()
            aes(fill = longitude), color = NA) # build gradient grid
  plt <- scaler(dta, plt)                 # add gradient for grid with scaler()
}

Шаг 6:

Добавьте на график оставшиеся одноцветные округа и границы.

(plt <- plt + new_scale_fill() + new_scale_color() +
  geom_sf(aes(fill = favorite_color), color = "black") +   # from question
  scale_fill_manual(values = sort(colors), na.value = NA)) # values modified

График (ячейки сетки 0,05 x 0,05) (1,08 минуты на рендеринг)

Чтобы дать вам представление о том, что дает изменение размера ячейки сетки, вот тот же график, но с cellsize = c(.01, .01) (1,9 минуты на рендеринг).

Весь используемый код в одном месте

(проще скопировать + вставить)

library(sf)
library(dplyr)
library(ggplot2)
library(ggnewscale)

# code from question
nc <- st_read(system.file("gpkg/nc.gpkg", package = "sf"), quiet = TRUE) %>%
  st_transform(st_crs(4326)) %>%
  st_cast("POLYGON")

set.seed(123)
colors <- c("red", "blue", "green", "yellow", "purple", "orange")
favorite_color <- replicate(length(unique(nc$NAME)), { # <- I ADDED: unique NAME only
  sample_size <- sample(1:3, 1)
  sample(colors, sample_size, replace = FALSE)
})

my_df <- data.frame(
  NAME = unique(nc$NAME),               # <---- I ADDED: unique NAME only
  favorite_color = sapply(favorite_color, 
                          function(x) paste(x, collapse = ", ")))

my_df$fc2 <- my_df$favorite_color       # <---- I ADDED: keep full color data
my_df$favorite_color[sapply(favorite_color, length) > 1] <- NA

nc_merged <- merge(nc, my_df, by = "NAME", all.x = TRUE)

gradPoly <- function(mp) { # create grid squares for gradient
  my_mp <- st_make_grid(mp, cellsize = c(.05, .05)) 
  long <- st_coordinates(st_centroid(my_mp, warn = F))[, 1]
  return(st_sf(longitude = long, geometry = my_mp) %>% 
           st_intersection(st_geometry(mp)))
}

scaler <- function(mp, plt) {
  wds = strsplit(mp$fc2, ', ')[[1]]  # extract colors assigned
  val = length(wds)                  # quantity of colors assigned
  ifelse(val < 3,                    # 2 colors or 3 colors in the gradient
         return(plt + scale_fill_gradient(low = wds[1], high = wds[2], guide = "none")),
         return(plt + scale_fill_gradient2(low = wds[1], mid = wds[2], high = wds[3], guide = "none",
                                                midpoint = median(gradPoly(mp)$longitude))))
}

# which counties have more than one fave?
these <- filter(my_df, is.na(favorite_color)) %>% select(NAME) %>% 
  arrange(NAME) %>% unlist()

plt <- ggplot(data = nc_merged) +      # essentially the code from the question
  theme_minimal() +
  labs(title = "Favorite Color by County (with Ties)",
       fill = "Favorite Color")

for(j in unique(these)) {      # for each county with more than one favorite
  dta <- filter(nc_merged, NAME == j)     # extract county data                       # more than one color
  plt <- plt + new_scale_fill() +         # add to existing plot
    geom_sf(data = gradPoly(dta),         # call the function gradPoly()
            aes(fill = longitude), color = NA) # build gradient grid
  plt <- scaler(dta, plt)                 # add gradient for grid with scaler()
}

(plt <- plt + new_scale_fill() + new_scale_color() +
    geom_sf(aes(fill = favorite_color), color = "black") +   # from question
    scale_fill_manual(values = sort(colors), na.value = NA)) # values modified