условно заполнить текстовые поля ggtext в facet_wrap

Question

Можно ли условно заполнить эти [ggtext][1]текстовые поля? Допустим, цвет "красный", если "пикап".

library(cowplot)
library(tidyverse)
library(ggtext)

ggplot(mpg, aes(cty, hwy)) + 
  geom_point() +
  facet_wrap(~class) +
  theme_half_open(12) +
  background_grid() +
  theme(
    strip.background = element_blank(),
    strip.text = element_textbox(
      size = 12,
      color = "white", fill = "#5D729D", box.color = "#4A618C",
      halign = 0.5, linetype = 1, r = unit(5, "pt"), width = unit(1, "npc"),
      padding = margin(2, 0, 1, 0), margin = margin(3, 3, 3, 3)
    )
  )

Answer 1

Вы можете перехватить процедуру рисования элемента и внести некоторые изменения стиля.

library(ggplot2)
library(cowplot)
library(rlang)
library(ggtext)


element_textbox_highlight <- function(..., hi.labels = NULL, hi.fill = NULL,
                                      hi.col = NULL, hi.box.col = NULL) {
  structure(
    c(element_textbox(...),
      list(hi.labels = hi.labels, hi.fill = hi.fill, hi.col = hi.col, hi.box.col = hi.box.col)
    ),
    class = c("element_textbox_highlight", "element_textbox", "element_text", "element")
  )
}

element_grob.element_textbox_highlight <- function(element, label = "", ...) {
  if (label %in% element$hi.labels) {
    element$fill <- element$hi.fill %||% element$fill
    element$colour <- element$hi.col %||% element$colour
    element$box.colour <- element$hi.box.col %||% element$box.colour
  }
  NextMethod()
}


ggplot(mpg, aes(cty, hwy)) + 
  geom_point() +
  facet_wrap(~class) +
  theme_half_open(12) +
  background_grid() +
  theme(
    strip.background = element_blank(),
    strip.text = element_textbox_highlight(
      size = 12,
      color = "white", fill = "#5D729D", box.color = "#4A618C",
      halign = 0.5, linetype = 1, r = unit(5, "pt"), width = unit(1, "npc"),
      padding = margin(2, 0, 1, 0), margin = margin(3, 3, 3, 3),
      # this is new relative to element_textbox():
      hi.labels = c("minivan", "suv"),
      hi.fill = "#F89096", hi.box.col = "#A6424A", hi.col = "black"
    )
  )

^{Создано 21.02.2020 с помощью пакета REPEX (v0.3.0)}

Изменить: расширение до 3 (или более цветов) на основе отзывов от @Claus_Wilke

library(ggplot2)
library(cowplot)
library(rlang)
library(ggtext)


element_textbox_highlight <- function(..., 
                                      hi.labels = NULL, hi.fill = NULL,
                                      hi.col = NULL, hi.box.col = NULL,
                                      hi.labels2 = NULL, hi.fill2 = NULL,
                                      hi.col2 = NULL, hi.box.col2 = NULL) {
  structure(
    c(element_textbox(...),
      list(hi.labels = hi.labels, hi.fill = hi.fill, hi.col = hi.col, hi.box.col = hi.box.col,
           hi.labels2 = hi.labels2, hi.fill2 = hi.fill2, hi.col2 = hi.col2, hi.box.col2 = hi.box.col2)
    ),
    class = c("element_textbox_highlight", "element_textbox", "element_text", "element",
              "element_textbox_highlight", "element_textbox", "element_text", "element")
  )
}

element_grob.element_textbox_highlight <- function(element, label = "", ...) {
  if (label %in% element$hi.labels) {
    element$fill <- element$hi.fill %||% element$fill
    element$colour <- element$hi.col %||% element$colour
    element$box.colour <- element$hi.box.col %||% element$box.colour
  }
  if (label %in% element$hi.labels2) {
    element$fill <- element$hi.fill2 %||% element$fill
    element$colour <- element$hi.col2 %||% element$colour
    element$box.colour <- element$hi.box.col2 %||% element$box.colour
  }
  NextMethod()
}


ggplot(mpg, aes(cty, hwy)) + 
  geom_point() +
  facet_wrap(~class) +
  theme_half_open(12) +
  background_grid() +
  theme(
    strip.background = element_blank(),
    strip.text = element_textbox_highlight(
      size = 12,
      # unnamed set (all facet windows except named sets below)
      color = "white", fill = "#5D729D", box.color = "#4A618C",
      halign = 0.5, linetype = 1, r = unit(5, "pt"), width = unit(1, "npc"),
      padding = margin(2, 0, 1, 0), margin = margin(3, 3, 3, 3),
      # this is new relative to element_textbox():
      # first named set
      hi.labels = c("minivan", "suv"),
      hi.fill = "#F89096", hi.box.col = "#A6424A", hi.col = "black",
      # add second named set 
      hi.labels2 = c("compact", "pickup"),
      hi.fill2 = "green", hi.box.col2 = "#A6424A", hi.col2 = "black"
    )
  )

Answer 2

ggh4xпакет имеетfacet_wrap2иstrip_themedэто делает манипулирование фасетами очень простым.

      library(ggplot2)
library(ggtext)
library(ggh4x)

# # match desired color to the `pickup` class
car_class <- sort(unique(mpg$class))
strip_color <- ifelse(car_class == "pickup", "darkred", "darkblue")
strip_color_scale <- setNames(strip_color, car_class)
strip_color_scale
#>    2seater    compact    midsize    minivan     pickup subcompact        suv 
#> "darkblue" "darkblue" "darkblue" "darkblue"  "darkred" "darkblue" "darkblue"

# set strip background color
strip_background <- strip_themed(
  text_x = elem_list_text(colour = "white", face = 'bold'),
  background_x = elem_list_rect(fill = strip_color_scale)
  )

ggplot(mpg, aes(cty, hwy)) + 
  geom_point() +
  # use facet_wrap2 from `ggh4x`
  facet_wrap2(~ class, strip = strip_background) +
  theme_bw(base_size = 12)

^{Создано 27 марта 2023 г. с использованием reprex v2.0.2.}