控制每轴ggplot2裁剪

问题描述 投票：0回答：2

这是对 previous question 的扩展，其目标是为每个方面设置不同的限制。该问题的代码存储在 gist 中，此后一直在生产中。

带有示例数据的快速演示：

set.seed(42)
dat <- data.frame(x = seq(0,1,len=101), y = cumsum(runif(101,-1,1)), z=sample(1:3, size=101, replace=TRUE))
dat$y <- dat$y * dat$z
dat$y[50] <- 99
dat$z[50] <- 2L
lims <- data.frame(z=1:3, ymin=0, ymax=c(10,25,30))

ggplot(dat, aes(x, y)) +
  facet_grid(z ~ ., switch="both", scales="free_y") +
  scale_x_continuous(expand = c(0, 0)) +
  geom_line() +
  coord_cartesian_panels(panel_limits = lims, clip = "on")

我现在需要将

geom_label
添加到绘图区域的右侧，outside。 Edit：每个面有多个标签，带有颜色（面之间的顺序不一致）。这样做相对简单：将标签放在屏幕边缘，扩展主题的
plot.margin
，然后关闭剪裁。不幸的是，正如您在 
2
和 
3
方面的两次偏移所想象的那样，禁用剪裁是一个问题。

summ <- aggregate(y ~ z, dat, FUN = function(z) c(lo=mean(z)-3, hi=mean(z)+3)) |>
  do.call(data.frame, args = _) |>
  reshape2::melt("z", variable.name = "ign", value.name = "y") |>
  transform(lbl = sprintf("%0.03f", y)) |>
  transform(fill = factor(ave(z, z, FUN = function(ign) sample(seq_along(ign)))))

ggplot(dat, aes(x, y)) +
  facet_grid(z ~ ., switch="both", scales="free_y") +
  scale_x_continuous(expand = c(0, 0)) +
  geom_line() +
  geom_label(x = 1, aes(y = y, label = lbl, fill = fill), data = summ, hjust = -0.1) +
  coord_cartesian_panels(panel_limits = lims, clip = "off") +
  theme(plot.margin = unit(c(0.5, 0.65 * max(nchar(summ$lbl)), 0.5, 0.5), "char")) +
  scale_fill_discrete(guide = "none")

我想有三种可能的方法来解决这个问题：

  1. 找到另一种方法在右侧添加不需要禁用裁剪的标签。需要明确的是，主题（背景、轴线/刻度/标签等）不应受此影响。这些图还有许多其他组件，我需要图区域在标签开始之前干净地“停止”。

  2. 找到一种方法来夹在

    y
    轴上而不是
    x
    。在这种情况下，我对 x 值有“严格”的控制，所以我不担心在左侧或右侧横行。

  3. 将

    oob
    使用（例如，
    scales::oob_squish
    ）纳入
    ggproto
    使用
    coord_cartesian_panels
    .

  4. 还有什么吗？

r ggplot2 facet clipping
2个回答
1
投票

调整我对这篇文章的回答一个不需要禁用裁剪的选项是使用辅助轴技巧通过复制轴添加标签。要为每个面单独设置中断和标签，我在 

ggh4x::facetted_pos_scales
上绘制并使用 
ggtext::element_markdown
来获得 
geom_label
外观：

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

scale_dup <- function(x) {
  scale_y_continuous(
    sec.axis = dup_axis(
      breaks = summ[summ$z == x, "y", drop = TRUE],
      labels = summ[summ$z == x, "lbl", drop = TRUE]
    )
  )
}

ggplot(dat, aes(x, y)) +
  facet_grid(z ~ ., switch = "both", scales = "free_y") +
  scale_x_continuous(expand = c(0, 0)) +
  geom_line() +
  coord_cartesian_panels(panel_limits = lims, clip = "on") +
  theme(
    axis.ticks.y.right = element_blank(),
    axis.text.y.right = ggtext::element_markdown(
      size = 12,
      linewidth = .25,
      linetype = 1,
      r = unit(.25, "lines"),
      padding = unit(2, "pt")
    )
  ) +
  facetted_pos_scales(
    y = list(
      z == "1" ~ scale_dup(1),
      z == "2" ~ scale_dup(2),
      z == "3" ~ scale_dup(3)
    )
  )

EDIT使用更新的

summ
数据集，可以轻松实现多个标签。但不幸的是
ggtext
不支持CSS属性
background-color
所以拥有不同的
fill
颜色并不是那么容易实现。当然，我们可以将颜色向量传递给 
fill=
的 
element_markdown
参数，但这仅适用于某些有限的情况，即我们不能为每个面板单独设置 
fill
颜色。

ggplot(dat, aes(x, y)) +
  facet_grid(z ~ ., switch = "both", scales = "free_y") +
  scale_x_continuous(expand = c(0, 0)) +
  geom_line() +
  coord_cartesian_panels(panel_limits = lims, clip = "on") +
  theme(
    axis.ticks.y.right = element_blank(),
    axis.text.y.right = ggtext::element_markdown(
      size = 12,
      linewidth = .25,
      linetype = 1,
      r = unit(.25, "lines"),
      padding = unit(2, "pt"),
      fill = scales::hue_pal()(2)
    )
  ) +
  facetted_pos_scales(
    y = list(
      z == "1" ~ scale_dup(1),
      z == "2" ~ scale_dup(2),
      z == "3" ~ scale_dup(3)
    )
  )

0
投票

（我想有理由不考虑单独绘制标签并使用常见的嫌疑人之一（例如 cowplot、patchwork 等）将结果组合在一起）

我写了一个修改版本的

FacetGrid
，它可以为每一层接受单独的裁剪指令。结合在 
clip = c("on", "off")
中指定 
coord_cartesian_panels
似乎有效。

注意：将图例放置在绘图的右侧（即默认图例位置）会弄乱外观，但我认为这是 ggplot grobs 布局方式的固有部分。由于这里的用例没有在右侧放置图例，我认为这不是现在的关键要求。

问题中具有相同用例的演示：

ggplot(dat, aes(x, y)) +
  facet_grid2(z ~ ., switch="both", scales="free_y") +
  scale_x_continuous(expand = c(0, 0)) +
  geom_line() +
  geom_label(x = 1, aes(y = y, label = lbl, fill = fill), data = summ, hjust = -0.1) +
  coord_cartesian_panels(panel_limits = lims, clip = c("on", "off")) +
  theme(plot.margin = unit(c(0.5, 0.65 * max(nchar(summ$lbl)), 0.5, 0.5), "char")) +
  scale_fill_discrete(guide = "none")

通过添加另一个 geom 层进一步演示特定于层的裁剪，但这个裁剪在边缘：

ggplot(dat, aes(x, y)) +
  facet_grid2(z ~ ., switch="both", scales="free_y") +
  scale_x_continuous(expand = c(0, 0)) +
  geom_line() +
  geom_label(x = 1, aes(y = y, label = lbl, fill = fill), data = summ, hjust = -0.1) +
  geom_label(x = 1, aes(y = y-5, label = lbl, fill = fill), data = summ, hjust = 0.5, alpha = 0.5) +
  coord_cartesian_panels(panel_limits = lims, clip = c("on", "off", "on")) +
  theme(plot.margin = unit(c(0.5, 0.65 * max(nchar(summ$lbl)), 0.5, 0.5), "char")) +
  scale_fill_discrete(guide = "none")


facet_grid2
/ 
FacetGrid2
的代码（与原始代码的变化主要是后者的 
draw_panels
函数中间的一个块，以允许为不同的 geom 层提供单独的裁剪选项；其他所有内容都直接继承自我当前版本的 ggplot2 , 即 3.4.2):

library(rlang)

FacetGrid2 <- ggproto(
  "FacetGrid2", ggplot2::FacetGrid,
  draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
    if ((params$free$x || params$free$y) && !coord$is_free()) {
      cli::cli_abort("{.fn {snake_class(coord)}} doesn't support free scales")
    }
    
    cols <- which(layout$ROW == 1)
    rows <- which(layout$COL == 1)
    axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE)
    
    col_vars <- ggplot2:::unique0(layout[names(params$cols)])
    row_vars <- ggplot2:::unique0(layout[names(params$rows)])
    # Adding labels metadata, useful for labellers
    attr(col_vars, "type") <- "cols"
    attr(col_vars, "facet") <- "grid"
    attr(row_vars, "type") <- "rows"
    attr(row_vars, "facet") <- "grid"
    strips <- render_strips(col_vars, row_vars, params$labeller, theme)
    
    aspect_ratio <- theme$aspect.ratio
    if (!is.null(aspect_ratio) && (params$space_free$x || params$space_free$y)) {
      cli::cli_abort("Free scales cannot be mixed with a fixed aspect ratio")
    }
    if (is.null(aspect_ratio) && !params$free$x && !params$free$y) {
      aspect_ratio <- coord$aspect(ranges[[1]])
    }
    if (is.null(aspect_ratio)) {
      aspect_ratio <- 1
      respect <- FALSE
    } else {
      respect <- TRUE
    }
    ncol <- max(layout$COL)
    nrow <- max(layout$ROW)
    
    if (params$space_free$x) {
      ps <- layout$PANEL[layout$ROW == 1]
      widths <- vapply(ps, function(i) diff(ranges[[i]]$x.range), numeric(1))
      panel_widths <- unit(widths, "null")
    } else {
      panel_widths <- rep(unit(1, "null"), ncol)
    }
    if (params$space_free$y) {
      ps <- layout$PANEL[layout$COL == 1]
      heights <- vapply(ps, function(i) diff(ranges[[i]]$y.range), numeric(1))
      panel_heights <- unit(heights, "null")
    } else {
      panel_heights <- rep(unit(1 * abs(aspect_ratio), "null"), nrow)
    }
    
    # changes from here onwards    
    relevant.panel.children <- with(panels[[1]],
                                    which(!grepl("grill|NULL|zeroGrob", childrenOrder)))
    if(length(coord$clip) == 1) {
      panel.layer.grouping <- list(seq_along(panels[[1]]$childrenOrder))
    } else if (length(coord$clip) == length(relevant.panel.children)) {
      panel.layer.grouping <- lapply(relevant.panel.children, function(n) n)
      panel.layer.grouping[[1]] <- seq_len(panel.layer.grouping[[1]])
      panel.layer.grouping[[length(relevant.panel.children)]] <- seq(panel.layer.grouping[[length(relevant.panel.children)]],
                                                                     length(panels[[1]]$childrenOrder))
    } else {
      message("Clipping instruction cannot be matched unambiguously to layers.")
      break()
    }

    by.layer.clip.info <- coord$clip
    panel_table <- vector("list", length = length(by.layer.clip.info))

    for(i in seq_along(by.layer.clip.info)) {
      panels_by_layer <- lapply(panels, 
                                function(p) p$children[panel.layer.grouping[[i]]])
      panel_table_by_layer <- matrix(panels_by_layer, nrow = nrow, ncol = ncol, byrow = TRUE)

      panel_table_by_layer <- gtable::gtable_matrix(paste("layout", i, sep = "-"), panel_table_by_layer,
                                                    panel_widths, panel_heights, respect = respect, 
                                                    clip = by.layer.clip.info[[i]], 
                                                    z = matrix(1, ncol = ncol, nrow = nrow))
      panel_table[[i]] <- panel_table_by_layer
    }

    panel_table_combined <- panel_table[[1]]
    if(length(by.layer.clip.info) > 1) {
      for(i in seq(2, length(by.layer.clip.info))) {
        for(j in seq_len(nrow(panel_table[[i]]))) {
          grob.dimensions <- panel_table[[i]]$layout[j, ]
          panel_table_combined <- gtable::gtable_add_grob(panel_table_combined,
                                                          list(panel_table[[i]]$grobs[[j]]),
                                                          t = grob.dimensions[["t"]],
                                                          l = grob.dimensions[["l"]],
                                                          b = grob.dimensions[["b"]],
                                                          r = grob.dimensions[["r"]],
                                                          z = grob.dimensions[["z"]],
                                                          clip = grob.dimensions[["clip"]],
                                                          name = grob.dimensions[["name"]])
        }
      }
    }
    panel_table <- panel_table_combined

    layout.names <- paste0('panel-', rep(seq_len(nrow), ncol), '-', rep(seq_len(ncol), each = nrow))
    if(length(layout.names) == nrow(panel_table$layout)) {
      panel_table$layout$name <- layout.names
    } else {
      panel_table$layout$name <- paste(rep(layout.names, times = length(by.layer.clip.info)),
                                       rep(seq_along(by.layer.clip.info), each = length(layout.names)),
                                       sep = "-")
    }

    # no changes after this point
    panel_table <- gtable::gtable_add_col_space(panel_table,
                                        theme$panel.spacing.x %||% theme$panel.spacing)
    panel_table <- gtable::gtable_add_row_space(panel_table,
                                        theme$panel.spacing.y %||% theme$panel.spacing)
    
    # Add axes
    panel_table <- gtable::gtable_add_rows(panel_table, max_height(axes$x$top),     0)
    panel_table <- gtable::gtable_add_rows(panel_table, max_height(axes$x$bottom), -1)
    panel_table <- gtable::gtable_add_cols(panel_table, max_width(axes$y$left),     0)
    panel_table <- gtable::gtable_add_cols(panel_table, max_width(axes$y$right),   -1)
    panel_pos_col <- panel_cols(panel_table)
    panel_pos_rows <- panel_rows(panel_table)
    
    panel_table <- gtable::gtable_add_grob(panel_table, axes$x$top, 1, panel_pos_col$l, clip = "off", name = paste0("axis-t-", seq_along(axes$x$top)), z = 3)
    panel_table <- gtable::gtable_add_grob(panel_table, axes$x$bottom, -1, panel_pos_col$l, clip = "off", name = paste0("axis-b-", seq_along(axes$x$bottom)), z = 3)
    panel_table <- gtable::gtable_add_grob(panel_table, axes$y$left, panel_pos_rows$t, 1, clip = "off", name = paste0("axis-l-", seq_along(axes$y$left)), z = 3)
    panel_table <- gtable::gtable_add_grob(panel_table, axes$y$right, panel_pos_rows$t, -1, clip = "off", name = paste0("axis-r-", seq_along(axes$y$right)), z= 3)
    
    # Add strips
    switch_x <- !is.null(params$switch) && params$switch %in% c("both", "x")
    switch_y <- !is.null(params$switch) && params$switch %in% c("both", "y")
    inside_x <- (theme$strip.placement.x %||% theme$strip.placement %||% "inside") == "inside"
    inside_y <- (theme$strip.placement.y %||% theme$strip.placement %||% "inside") == "inside"
    strip_padding <- grid::convertUnit(theme$strip.switch.pad.grid, "cm")
    panel_pos_col <- panel_cols(panel_table)
    if (switch_x) {
      if (!is.null(strips$x$bottom)) {
        if (inside_x || all(vapply(axes$x$bottom, is.zero, logical(1)))) {
          panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$bottom), -2)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$x$bottom, -2, panel_pos_col$l, clip = "on", name = paste0("strip-b-", seq_along(strips$x$bottom)), z = 2)
        } else {
          panel_table <- gtable::gtable_add_rows(panel_table, strip_padding, -1)
          panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$bottom), -1)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$x$bottom, -1, panel_pos_col$l, clip = "on", name = paste0("strip-b-", seq_along(strips$x$bottom)), z = 2)
        }
      }
    } else {
      if (!is.null(strips$x$top)) {
        if (inside_x || all(vapply(axes$x$top, is.zero, logical(1)))) {
          panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$top), 1)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$x$top, 2, panel_pos_col$l, clip = "on", name = paste0("strip-t-", seq_along(strips$x$top)), z = 2)
        } else {
          panel_table <- gtable::gtable_add_rows(panel_table, strip_padding, 0)
          panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$top), 0)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$x$top, 1, panel_pos_col$l, clip = "on", name = paste0("strip-t-", seq_along(strips$x$top)), z = 2)
        }
      }
    }
    panel_pos_rows <- panel_rows(panel_table)
    if (switch_y) {
      if (!is.null(strips$y$left)) {
        if (inside_y || all(vapply(axes$y$left, is.zero, logical(1)))) {
          panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$left), 1)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$y$left, panel_pos_rows$t, 2, clip = "on", name = paste0("strip-l-", seq_along(strips$y$left)), z = 2)
        } else {
          panel_table <- gtable::gtable_add_cols(panel_table, strip_padding, 0)
          panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$left), 0)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$y$left, panel_pos_rows$t, 1, clip = "on", name = paste0("strip-l-", seq_along(strips$y$left)), z = 2)
        }
      }
    } else {
      if (!is.null(strips$y$right)) {
        if (inside_y || all(vapply(axes$y$right, is.zero, logical(1)))) {
          panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$right), -2)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$y$right, panel_pos_rows$t, -2, clip = "on", name = paste0("strip-r-", seq_along(strips$y$right)), z = 2)
        } else {
          panel_table <- gtable::gtable_add_cols(panel_table, strip_padding, -1)
          panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$right), -1)
          panel_table <- gtable::gtable_add_grob(panel_table, strips$y$right, panel_pos_rows$t, -1, clip = "on", name = paste0("strip-r-", seq_along(strips$y$right)), z = 2)
        }
      }
    }
    panel_table
  }
)

# only change from facet_grid is the use of FacetGrid2 instead of FacetGrid
facet_grid2 <- function (rows = NULL, cols = NULL, scales = "fixed", space = "fixed", 
                         shrink = TRUE, labeller = "label_value", as.table = TRUE, 
                         switch = NULL, drop = TRUE, margins = FALSE, facets = lifecycle::deprecated()) {
  if (lifecycle::is_present(facets)) {
    deprecate_warn0("2.2.0", "facet_grid(facets)", "facet_grid(rows)")
    rows <- facets
  }
  if (is.logical(cols)) {
    margins <- cols
    cols <- NULL
  }
  scales <- arg_match0(scales %||% "fixed", c("fixed", "free_x", 
                                              "free_y", "free"))
  free <- list(x = any(scales %in% c("free_x", "free")), y = any(scales %in% 
                                                                   c("free_y", "free")))
  space <- arg_match0(space %||% "fixed", c("fixed", "free_x", 
                                            "free_y", "free"))
  space_free <- list(x = any(space %in% c("free_x", "free")), 
                     y = any(space %in% c("free_y", "free")))
  if (!is.null(switch) && !switch %in% c("both", "x", "y")) {
    cli::cli_abort("{.arg switch} must be either {.val both}, {.val x}, or {.val y}")
  }
  facets_list <- ggplot2:::grid_as_facets_list(rows, cols)
  labeller <- ggplot2:::check_labeller(labeller)
  ggproto(NULL, FacetGrid2, shrink = shrink, 
          params = list(rows = facets_list$rows, 
                        cols = facets_list$cols, margins = margins, free = free, 
                        space_free = space_free, labeller = labeller, as.table = as.table, 
                        switch = switch, drop = drop))
}

免责声明：我没有在其他用例中测试过这个，因为我不需要它，所以......买者自负。 :)

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.