Refactor facet panel drawing code

R/facet-.R

@@ -133,8 +133,32 @@ Facet <- ggproto("Facet", NULL,
   draw_front = function(data, layout, x_scales, y_scales, theme, params) {
     rep(list(zeroGrob()), vec_unique_count(layout$PANEL))
   },
-  draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
-    cli::cli_abort("Not implemented.")
+  draw_panels = function(self, panels, layout, x_scales = NULL, y_scales = NULL,
+                         ranges, coord, data = NULL, theme, params) {
+
+    free  <- params$free       %||% list(x = FALSE, y = FALSE)
+    space <- params$space_free %||% list(x = FALSE, y = FALSE)
+
+    if ((free$x || free$y) && !coord$is_free()) {
+      cli::cli_abort(
+        "{.fn {snake_class(self)}} can't use free scales with \\
+        {.fn {snake_class(coord)}}."
+      )
+    }
+
+    aspect_ratio <- theme$aspect.ratio
+    if (!is.null(aspect_ratio) && (space$x || space$y)) {
+      cli::cli_abort("Free scales cannot be mixed with a fixed aspect ratio.")
+    }
+
+    table <- self$init_gtable(
+      panels, layout, theme, ranges, params,
+      aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]]),
+      clip = coord$clip
+    )
+
+    table <- self$attach_axes(table, layout, ranges, coord, theme, params)
+    self$attach_strips(table, layout, params, theme)
   },
   draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) {
     panel_dim <-  find_panel(panels)
@@ -173,6 +197,64 @@ Facet <- ggproto("Facet", NULL,
   finish_data = function(data, layout, x_scales, y_scales, params) {
     data
   },
+  init_gtable = function(panels, layout, theme, ranges, params,
+                         aspect_ratio = NULL, clip = "on") {
+
+    # Initialise matrix of panels
+    dim   <- c(max(layout$ROW), max(layout$COL))
+    table <- matrix(list(zeroGrob()), dim[1], dim[2])
+    table[cbind(layout$ROW, layout$COL)] <- panels
+
+    # Set initial sizes
+    widths  <- unit(rep(1, dim[2]), "null")
+    heights <- unit(rep(1 * abs(aspect_ratio %||% 1), dim[1]), "null")
+
+    # When space are free, let panel parameter limits determine size of panel
+    space <- params$space_free %||% list(x = FALSE, y = FALSE)
+    if (space$x) {
+      idx    <- layout$PANEL[layout$ROW == 1]
+      widths <- vapply(idx, function(i) diff(ranges[[i]]$x.range), numeric(1))
+      widths <- unit(widths, "null")
+    }
+
+    if (space$y) {
+      idx <- layout$PANEL[layout$COL == 1]
+      heights <- vapply(idx, function(i) diff(ranges[[i]]$y.range), numeric(1))
+      heights <- unit(heights, "null")
+    }
+
+    # Build gtable
+    table <- gtable_matrix(
+      "layout", table,
+      widths = widths, heights = heights,
+      respect = !is.null(aspect_ratio),
+      clip = clip, z = matrix(1, dim[1], dim[2])
+    )
+
+    # Set panel names
+    table$layout$name <- paste(
+      "panel",
+      rep(seq_len(dim[2]), dim[1]),
+      rep(seq_len(dim[1]), each = dim[2]),
+      sep = "-"
+    )
+
+    # Add spacing between panels
+    spacing <- lapply(
+      c(x = "panel.spacing.x", y = "panel.spacing.y"),
+      calc_element, theme = theme
+    )
+
+    table <- gtable_add_col_space(table, spacing$x)
+    table <- gtable_add_row_space(table, spacing$y)
+    table
+  },
+  attach_axes = function(table, layout, ranges, coord, theme, params) {
+    table
+  },
+  attach_strips = function(table, layout, params, theme) {
+    table
+  },
   vars = function() {
     character(0)
   }

R/facet-grid-.R

@@ -335,175 +335,101 @@ FacetGrid <- ggproto("FacetGrid", Facet,
     }
     data
   },
-  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.")
-    }
 
-    # Fill missing parameters for backward compatibility
-    params$draw_axes   <- params$draw_axes   %||% list(x = FALSE, y = FALSE)
-    params$axis_labels <- params$axis_labels %||% list(x = TRUE,  y = TRUE)
+  attach_axes = function(table, layout, ranges, coord, theme, params) {
+
+    # Setup parameters
+    draw_axes   <- params$draw_axes   %||% list(x = FALSE, y = FALSE)
+    axis_labels <- params$axis_labels %||% list(x = TRUE,  y = TRUE)
 
-    if (!params$axis_labels$x) {
-      cols <- seq_len(nrow(layout))
-      x_axis_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)])
+    dim <- c(max(layout$ROW), max(layout$COL))
+    if (!axis_labels$x) {
+      cols    <- seq_len(nrow(layout))
+      x_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)])
     } else {
-      cols <- which(layout$ROW == 1)
-      x_axis_order <- layout$COL
+      cols    <- which(layout$ROW == 1)
+      x_order <- layout$COL
     }
-    if (!params$axis_labels$y) {
-      rows <- seq_len(nrow(layout))
-      y_axis_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)])
+    if (!axis_labels$y) {
+      rows    <- seq_len(nrow(layout))
+      y_order <- as.integer(layout$PANEL[order(layout$ROW, layout$COL)])
     } else {
-      rows <- which(layout$COL == 1)
-      y_axis_order <- layout$ROW
+      rows    <- which(layout$COL == 1)
+      y_order <- layout$ROW
     }
 
-    ranges <- censor_labels(ranges, layout, params$axis_labels)
-    axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE)
-
-    col_vars <- unique0(layout[names(params$cols)])
-    row_vars <- 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)
+    # Render individual axes
+    ranges <- censor_labels(ranges, layout, axis_labels)
+    axes   <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE)
+    mtx    <- function(x, o) matrix(x[o], dim[1], dim[2], byrow = TRUE)
 
-    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.")
-    }
-    aspect_ratio <- 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)
-    mtx <- function(x) matrix(x, nrow = nrow, ncol = ncol, byrow = TRUE)
-    panel_table <- mtx(panels)
-
-    # @kohske
-    # Now size of each panel is calculated using PANEL$ranges, which is given by
-    # coord_train called by train_range.
-    # So here, "scale" need not to be referred.
-    #
-    # In general, panel has all information for building facet.
-    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")
+    if (draw_axes$x) {
+      table <- weave_axes(table, lapply(axes$x, mtx, o = x_order))
     } else {
-      panel_widths <- rep(unit(1, "null"), ncol)
+      table <- seam_table(table, axes$x$top,    side = "top",    name = "axis-t", z = 3)
+      table <- seam_table(table, axes$x$bottom, side = "bottom", name = "axis-b", z = 3)
     }
-    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")
+
+    if (draw_axes$y) {
+      table <- weave_axes(table, lapply(axes$y, mtx, o = y_order))
     } else {
-      panel_heights <- rep(unit(1 * abs(aspect_ratio), "null"), nrow)
+      table <- seam_table(table, axes$y$left,  side = "left",  name = "axis-l", z = 3)
+      table <- seam_table(table, axes$y$right, side = "right", name = "axis-r", z = 3)
     }
 
-    panel_table <- gtable_matrix("layout", panel_table,
-      panel_widths, panel_heights, respect = respect, clip = coord$clip, z = mtx(1))
-    panel_table$layout$name <- paste0('panel-', rep(seq_len(nrow), ncol), '-', rep(seq_len(ncol), each = nrow))
+    table
+  },
 
-    spacing_x <- calc_element("panel.spacing.x", theme)
-    spacing_y <- calc_element("panel.spacing.y", theme)
-    panel_table <- gtable_add_col_space(panel_table, spacing_x)
-    panel_table <- gtable_add_row_space(panel_table, spacing_y)
+  attach_strips = function(table, layout, params, theme) {
 
-    # Add axes
-    if (params$draw_axes$x) {
-      axes$x <- lapply(axes$x, function(x) mtx(x[x_axis_order]))
-      panel_table <- weave_axes(panel_table, axes$x)$panels
-    } else {
-      panel_table <- gtable_add_rows(panel_table, max_height(axes$x$top), 0)
-      panel_table <- gtable_add_rows(panel_table, max_height(axes$x$bottom), -1)
-      panel_pos_col <- panel_cols(panel_table)
-      panel_table <- 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_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)
-    }
+    col_vars <- unique0(layout[names(params$cols)])
+    row_vars <- unique0(layout[names(params$rows)])
+    attr(col_vars, "type")  <- "cols"
+    attr(row_vars, "type")  <- "rows"
+    attr(col_vars, "facet") <- "grid"
+    attr(row_vars, "facet") <- "grid"
 
-    if (params$draw_axes$y) {
-      axes$y <- lapply(axes$y, function(y) mtx(y[y_axis_order]))
-      panel_table <- weave_axes(panel_table, axes$y)$panels
-    } else {
-      panel_table <- gtable_add_cols(panel_table, max_width(axes$y$left), 0)
-      panel_table <- gtable_add_cols(panel_table, max_width(axes$y$right), -1)
-      panel_pos_rows <- panel_rows(panel_table)
-      panel_table <- 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_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)
-    }
+    strips  <- render_strips(col_vars, row_vars, params$labeller, theme)
+    padding <- convertUnit(calc_element("strip.switch.pad.grid", theme), "cm")
 
-    # 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 <- convertUnit(calc_element("strip.switch.pad.grid", theme), "cm")
-    panel_pos_col <- panel_cols(panel_table)
+    inside_x <- (calc_element("strip.placement.x", theme) %||% "inside") == "inside"
+    shift_x  <- if (inside_x) 1 else 2
+
     if (switch_x) {
-      if (!is.null(strips$x$bottom)) {
-        if (inside_x) {
-          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -2)
-          panel_table <- 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 {
-          if (!all(vapply(axes$x$bottom, is.zero, logical(1)))) {
-            panel_table <- gtable_add_rows(panel_table, strip_padding, -1)
-          }
-          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -1)
-          panel_table <- 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)
-        }
-      }
+      space <- if (!inside_x & table_has_grob(table, "axis-b")) padding
+      table <- seam_table(
+        table, strips$x$bottom, side = "bottom", name = "strip-b",
+        shift = shift_x, z = 2, clip = "on", spacing = space
+      )
     } else {
-      if (!is.null(strips$x$top)) {
-        if (inside_x) {
-          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 1)
-          panel_table <- 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 {
-          if (!all(vapply(axes$x$top, is.zero, logical(1)))) {
-            panel_table <- gtable_add_rows(panel_table, strip_padding, 0)
-          }
-          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 0)
-          panel_table <- 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)
-        }
-      }
+      space <- if (!inside_x & table_has_grob(table, "axis-t")) padding
+      table <- seam_table(
+        table, strips$x$top, side = "top", name = "strip-t",
+        shift = shift_x, z = 2, clip = "on", spacing = space
+      )
     }
-    panel_pos_rows <- panel_rows(panel_table)
+
+    switch_y <- !is.null(params$switch) && params$switch %in% c("both", "y")
+    inside_y <- (calc_element("strip.placement.y", theme) %||% "inside") == "inside"
+    shift_y  <- if (inside_y) 1 else 2
+
     if (switch_y) {
-      if (!is.null(strips$y$left)) {
-        if (inside_y) {
-          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 1)
-          panel_table <- 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 {
-          if (!all(vapply(axes$y$left, is.zero, logical(1)))) {
-            panel_table <- gtable_add_cols(panel_table, strip_padding, 0)
-          }
-          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 0)
-          panel_table <- 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)
-        }
-      }
+      space <- if (!inside_y & table_has_grob(table, "axis-l")) padding
+      table <- seam_table(
+        table, strips$y$left, side = "left", name = "strip-l",
+        shift = shift_y, z = 2, clip = "on", spacing = space
+      )
     } else {
-      if (!is.null(strips$y$right)) {
-        if (inside_y) {
-          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -2)
-          panel_table <- 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 {
-          if (!all(vapply(axes$y$right, is.zero, logical(1)))) {
-            panel_table <- gtable_add_cols(panel_table, strip_padding, -1)
-          }
-          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -1)
-          panel_table <- 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)
-        }
-      }
+      space <- if (!inside_y & table_has_grob(table, "axis-r")) padding
+      table <- seam_table(
+        table, strips$y$right, side = "right", name = "strip-r",
+        shift = shift_y, z = 2, clip = "on", spacing = space
+      )
     }
-    panel_table
+    table
   },
+
   vars = function(self) {
     names(c(self$params$rows, self$params$cols))
   }
@@ -519,3 +445,52 @@ ulevels <- function(x, na.last = TRUE) {
     sort(unique0(x), na.last = na.last)
   }
 }
+
+table_has_grob <- function(table, pattern) {
+  grobs <- table$grobs[grep(pattern, table$layout$name)]
+  !all(vapply(grobs, is.zero, logical(1)))
+}
+
+seam_table <- function(table, grobs = NULL, side, shift = 1, name, z = 1,
+                       clip = "off", spacing = NULL) {
+  if (is.null(grobs)) {
+    return(table)
+  }
+
+  panel_col <- panel_cols(table)
+  panel_row <- panel_rows(table)
+
+  row <- switch(
+    side,
+    bottom = max(panel_row$b) + shift - 1L,
+    top    = min(panel_row$t) - shift,
+    panel_row$t
+  )
+
+  col <- switch(
+    side,
+    right = max(panel_col$r) + shift - 1L,
+    left  = min(panel_col$l) - shift,
+    panel_col$l
+  )
+
+  if (!is.null(spacing)) {
+    table <- switch(
+      side,
+      bottom = , top = gtable_add_rows(table, spacing, row),
+      left = , right = gtable_add_cols(table, spacing, col)
+    )
+    row <- row + as.numeric(side == "bottom")
+    col <- col + as.numeric(side == "right")
+  }
+
+  table <- switch(
+    side,
+    bottom = , top = gtable_add_rows(table, max_height(grobs), row),
+    left = , right = gtable_add_cols(table, max_width(grobs),  col)
+  )
+  name <- paste(name, seq_along(grobs), sep = "-")
+  row  <- row + as.numeric(side %in% c("top", "bottom"))
+  col  <- col + as.numeric(side %in% c("left", "right"))
+  gtable_add_grob(table, grobs, t = row, l = col, name = name, z = z, clip = clip)
+}