Skip to content

Commit

Permalink
Merge pull request #3 from mikmart/develop
Browse files Browse the repository at this point in the history 
Rewrite panel drawing
  • Loading branch information
@mikmart
mikmart authored Oct 7, 2024
2 parents 513525d + cbfea03 commit aa5f873
Show file tree
Hide file tree
Showing 14 changed files with 1,992 additions and 407 deletions.
5 changes: 3 additions & 2 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ BugReports: https://github.com/mikmart/ggragged/issues
Depends:
ggplot2
Imports:
grid,
gtable,
rlang,
vctrs
Expand All @@ -24,14 +25,15 @@ Suggests:
nlme,
ragg,
rmarkdown,
roxygen2,
testthat (>= 3.0.0),
vdiffr
VignetteBuilder:
knitr
Config/testthat/edition: 3
Encoding: UTF-8
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.2.3
RoxygenNote: 7.3.2
Collate:
'facet_ragged.R'
'facet_ragged_rows.R'
Expand All @@ -40,4 +42,3 @@ Collate:
'grid.R'
'gtable.R'
'layout.R'
'utils.R'
4 changes: 4 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,10 @@
* Added a vignette showing examples of usage in broader context.
* Fixed an issue that caused the package to fail to build (with an "argument is
missing" error message) when an older version of ggplot2 was installed.
* Added new parameters `strips` and `axes` to facets that control whether strips
and axes respectively are drawn between adjacent panels.
* Fixed an issue that caused some axes to be rendered incorrectly when using
free scales with `coord_flip()` (#2).

# ggragged 0.1.0

Expand Down
247 changes: 219 additions & 28 deletions R/facet_ragged.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,14 +7,22 @@
#' nested or partially crossed relationships between faceting variables.
#'
#' @param rows,cols A set of variables or expressions quoted by [ggplot2::vars()],
#' the combinations of which define panels to be included in the grid.
#' the combinations of which define the panels to be included in the layout.
#' @param ... Arguments reserved for future use.
#' @param scales Should all panels share the same scales (`"fixed"`),
#' x-axes vary (`"free_x"`), y-axes vary (`"free_y"`), or both (`"free"`)?
#' Panels within groups always share the scale along the grouping dimension.
#' @param switch By default, facet labels are positioned to the top and right
#' of the panels. Use `"x"` to switch the top strip to the bottom,
#' use `"y"` to switch the right strip to the left, or `"both"`.
#' @param scales Should all panels share the same scales (`"fixed"`), x-axes
#' vary (`"free_x"`), y-axes vary (`"free_y"`), or both (`"free"`)? Panels
#' within groups always share the scale along the grouping dimension.
#' @param switch Determines how facet label strips are positioned. By default
#' (`"none"`), strips are drawn to the top and right of the panels. Use `"x"`
#' to switch the top strip to the bottom, use `"y"` to switch the right strip
#' to the left, or `"both"` to do both.
#' @param strips Determines which facet label strips are drawn. By default
#' (`"margins"`), strips between panels along the grouping dimension will be
#' suppressed. Use `"all"` to always draw both strips.
#' @param axes Determines which axes are drawn. By default (`"margins"`), axes
#' between panels will be suppressed if they are fixed. Use `"all_x"` to
#' always draw x-axes, `"all_y"` to always draw y-axes, or `"all"` to always
#' draw both axes.
#' @inheritParams ggplot2::facet_wrap
#'
#' @returns A `Facet` that can be added to a `ggplot`.
Expand Down Expand Up @@ -57,36 +65,219 @@ NULL
FacetRagged <- ggproto("FacetRagged", Facet,
shrink = TRUE,

setup_params = function(data, params) {
params <- Facet$setup_params(data, params)
params$rows <- rlang::quos_auto_name(params$rows)
params$cols <- rlang::quos_auto_name(params$cols)
params$free <- list(
x = params$scales %in% c("free_x", "free"),
y = params$scales %in% c("free_y", "free")
)
params$switch <- list(
x = params$switch %in% c("x", "both"),
y = params$switch %in% c("y", "both")
)
params$axes <- list(
x = params$axes %in% c("all_x", "all"),
y = params$axes %in% c("all_y", "all")
)
params$strip.position <- c(
if (params$switch$x) "bottom" else "top",
if (params$switch$y) "left" else "right"
)
params
},

map_data = function(data, layout, params) {
FacetGrid$map_data(data, layout, params)
},

vars = function(self) {
names(c(self$params$rows, self$params$cols))
},

draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
table <- self$init_gtable(panels, layout, ranges, coord, theme, params)
table <- self$attach_axes(table, layout, ranges, coord, theme, params)
table <- self$attach_strips(table, layout, theme, params)
table
},

init_gtable = function(panels, layout, ranges, coord, theme, params) {
if (!coord$is_free() && (params$free$x || params$free$y))
stop("Can't use free scales with a fixed coordinate system.")
aspect_ratio <- theme$aspect.ratio %||% coord$aspect(ranges[[1]])

# Create an empty table with dimensions from layout
rows_count <- max(layout$ROW)
cols_count <- max(layout$COL)
widths <- rep(unit(1, "null"), cols_count)
heights <- rep(unit(aspect_ratio %||% 1, "null"), rows_count)
table <- gtable(widths, heights, respect = !is.null(aspect_ratio))

# Insert panel grobs according to layout and add spacing
panel_name <- sprintf("panel-%d", layout$PANEL)
table <- gtable_add_grob(table, panels, layout$ROW, layout$COL, name = panel_name)
table <- gtable_add_col_space(table, calc_element("panel.spacing.x", theme))
table <- gtable_add_row_space(table, calc_element("panel.spacing.y", theme))

table
},

attach_axes = function(table, layout, ranges, coord, theme, params) {
axes <- render_axes(ranges, ranges, coord, theme)
axes <- list(
t = lapply(axes$x, `[[`, "top"),
b = lapply(axes$x, `[[`, "bottom"),
l = lapply(axes$y, `[[`, "left"),
r = lapply(axes$y, `[[`, "right")
)
add_panel_decorations(table, layout, axes, kind = "axis")
},

attach_strips = function(table, layout, theme, params) {
# Render strips with faceting variable data
cols_data <- layout[names(params$cols)]
rows_data <- layout[names(params$rows)]
strips <- render_strips(cols_data, rows_data, params$labeller, theme)
strips <- c(strips$x, strips$y)

# Zero out strips which shouldn't be added
for (side in c("top", "bottom", "left", "right"))
if (!side %in% params$strip.position)
strips[[side]][] <- list(zeroGrob())

# Make strips stick correctly in zero-sized rows/cols
for (side in c("top", "bottom", "left", "right"))
strips[[side]] <- lapply(strips[[side]], set_strip_viewport, side)

add_panel_decorations(table, layout, strips, kind = "strip")
}
)

new_facet_ragged <- function(parent, rows, cols, ..., scales, switch, labeller) {
rlang::check_dots_empty()

scales <- rlang::arg_match0(scales, c("fixed", "free_x", "free_y", "free"))
switch <- if (!is.null(switch)) rlang::arg_match0(switch, c("x", "y", "both")) else "none"

ggproto(
NULL,
parent,
params = list(
rows = rlang::quos_auto_name(rows),
cols = rlang::quos_auto_name(cols),
free = list(
x = scales %in% c("free_x", "free"),
y = scales %in% c("free_y", "free")
),
switch = list(
x = switch %in% c("x", "both"),
y = switch %in% c("y", "both")
),
labeller = labeller
add_panel_decorations <- function(table, layout, grobs, kind) {
kind <- rlang::arg_match0(kind, c("axis", "strip"))

# Add rows for horizontal decorations
for (t in rev(panel_rows(table)$t)) {
table <- gtable_add_rows(table, max_height(grobs$t), t - 1)
table <- gtable_add_rows(table, max_height(grobs$b), t + 1)
}

# Add columns for vertical decorations
for (l in rev(panel_cols(table)$l)) {
table <- gtable_add_cols(table, max_width(grobs$l), l - 1)
table <- gtable_add_cols(table, max_width(grobs$r), l + 1)
}

# Find panel positions after layout changes
panel_rows_pos <- panel_rows(table)
panel_cols_pos <- panel_cols(table)

t <- panel_rows_pos$t[layout$ROW] - 1
b <- panel_rows_pos$b[layout$ROW] + 1
l <- panel_cols_pos$l[layout$COL] - 1
r <- panel_cols_pos$r[layout$COL] + 1

# Add decorations around panels
table <- gtable_add_grob(table, grobs$t, t, l + 1, name = sprintf("%s-t-%d", kind, layout$PANEL))
table <- gtable_add_grob(table, grobs$b, b, l + 1, name = sprintf("%s-b-%d", kind, layout$PANEL))
table <- gtable_add_grob(table, grobs$l, t + 1, l, name = sprintf("%s-l-%d", kind, layout$PANEL))
table <- gtable_add_grob(table, grobs$r, t + 1, r, name = sprintf("%s-r-%d", kind, layout$PANEL))

table
}

set_strip_viewport <- function(strip, side) {
strip$vp <- switch(
substr(side, 1, 1),
# TODO: `clip = "off"` not needed in ggplot2 dev version (3.5.1.9000), could be removed in the future.
t = grid::viewport(clip = "off", height = grid::grobHeight(strip), y = unit(0, "npc"), just = "bottom"),
b = grid::viewport(clip = "off", height = grid::grobHeight(strip), y = unit(1, "npc"), just = "top"),
l = grid::viewport(clip = "off", width = grid::grobWidth(strip), x = unit(1, "npc"), just = "right"),
r = grid::viewport(clip = "off", width = grid::grobWidth(strip), x = unit(0, "npc"), just = "left"),
stop("internal error: invalid side: ", side)
)
strip
}

cull_inner_panel_decorations <- function(table, layout, sides, kind) {
kind <- rlang::arg_match0(kind, c("axis", "strip"))
for (side in sides) {
# Remove grobs from inner panels
panels <- panels_with_neighbour(layout, side)
names <- sprintf("%s-%s-%d", kind, side, panels)
table <- gtable_set_grobs(table, names, list(zeroGrob()))

# And the space allocated for them
table <- switch(
side,
t = ,
b = gtable_set_height(table, names, unit(0, "cm")),
l = ,
r = gtable_set_width(table, names, unit(0, "cm")),
stop("internal error: invalid side: ", side)
)

# Shift axes at inner margins to start at strip edge. It would be much
# cleaner to have the axes attached to the strips, but that doesn't play
# nicely with how ggplot2 expects the axes to be present in the gtable.
if (kind == "strip")
table <- shift_inner_margin_axes(table, layout, side)
}
table
}

panels_with_neighbour <- function(layout, side) {
neighbour <- switch(
side,
t = list(PANEL = layout$PANEL, ROW = layout$ROW - 1, COL = layout$COL),
b = list(PANEL = layout$PANEL, ROW = layout$ROW + 1, COL = layout$COL),
l = list(PANEL = layout$PANEL, ROW = layout$ROW, COL = layout$COL - 1),
r = list(PANEL = layout$PANEL, ROW = layout$ROW, COL = layout$COL + 1),
stop("internal error: invalid side: ", side)
)
merge(layout[c("ROW", "COL")], neighbour)$PANEL
}

margin_panels <- function(layout, side) {
setdiff(layout$PANEL, panels_with_neighbour(layout, side))
}

shift_inner_margin_axes <- function(table, layout, side) {
for (panel in margin_panels(layout, side)) {
if (is_panel_on_outer_margin(layout, panel, side)) next

# Get the strip and axis, bailing if either isn't there
strip_name <- sprintf("strip-%s-%d", side, panel)
strip <- gtable_get_grob(table, strip_name)
if (is.null(strip) || inherits(strip, "zeroGrob")) next

axis_name <- sprintf("axis-%s-%d", side, panel)
axis <- gtable_get_grob(table, axis_name)
if (is.null(axis) || inherits(axis, "zeroGrob")) next

# Shift the axis to start at the edge of the strip
axis <- switch(
side,
t = grob_shift_viewport(axis, y = +grid::grobHeight(strip)),
b = grob_shift_viewport(axis, y = -grid::grobHeight(strip)),
l = grob_shift_viewport(axis, x = -grid::grobWidth(strip)),
r = grob_shift_viewport(axis, x = +grid::grobWidth(strip)),
stop("internal error: invalid side: ", side)
)
table <- gtable_set_grobs(table, axis_name, list(axis))
}
table
}

is_panel_on_outer_margin <- function(layout, panel, side) {
switch(
side,
t = layout[match(panel, layout$PANEL), "ROW"] == min(layout$ROW),
b = layout[match(panel, layout$PANEL), "ROW"] == max(layout$ROW),
l = layout[match(panel, layout$PANEL), "COL"] == min(layout$COL),
r = layout[match(panel, layout$PANEL), "COL"] == max(layout$COL),
stop("internal error: invalid side: ", side)
)
}
Loading

0 comments on commit aa5f873

Please sign in to comment.