Continued Geom Dev

NAMESPACE

@@ -5,7 +5,6 @@ S3method(ggplot_add,swim_label)
 S3method(ggplot_add,swim_lane)
 S3method(ggplot_add,swim_point)
 S3method(grid.draw,ggswim_obj)
-S3method(print,ggswim_layer)
 S3method(print,ggswim_obj)
 export("%+%")
 export(GeomSwimArrow)
@@ -88,6 +87,7 @@ importFrom(rlang,enquo)
 importFrom(rlang,get_expr)
 importFrom(rlang,is_atomic)
 importFrom(rlang,is_empty)
+importFrom(rlang,list2)
 importFrom(rlang,quo)
 importFrom(rlang,quo_is_symbolic)
 importFrom(stats,setNames)

R/geom_swim_arrow.R

@@ -5,7 +5,11 @@
 #' continuation of events such as ongoing treatment, implying that the activity
 #' or status extends beyond the plotted period.
 #'
-#' @param data A dataframe prepared for use with [geom_swim_arrow()]
+#' @details
+#' Please note that [geom_swim_arrow()] requires a `data` argument and does not
+#' inherit data like other functions.
+#'
+#' @param data A dataframe prepared for use with [geom_swim_arrow()]. Required.
 #' @inheritParams ggplot2::geom_segment
 #' @param position Position adjustment. ggswim accepts either "stack", or "identity"
 #' depending on the use case. Default "identity".
@@ -21,7 +25,6 @@
 #' @section Aesthetics:
 #' [geom_swim_arrow()] understands the following aesthetics (required aesthetics are in bold):
 #'
-#' - **`x`**
 #' - **`y`**
 #' - **xend**
 #' - `alpha`
@@ -57,7 +60,7 @@
 #'
 #' @export
 
-geom_swim_arrow <- function(mapping = NULL, data = NULL,
+geom_swim_arrow <- function(mapping = NULL, data,
                             stat = "identity", position = "identity",
                             ...,
                             arrow_colour = "black",
@@ -68,109 +71,46 @@ geom_swim_arrow <- function(mapping = NULL, data = NULL,
                             lineend = "butt",
                             linejoin = "round",
                             na.rm = FALSE,
-                            show.legend = FALSE,
-                            inherit.aes = TRUE) {
-  structure(
-    "geom_swim_arrow",
-    class = c("swim_arrow", "ggswim_layer"),
+                            show.legend = FALSE) {
+  # Set proportional default for arrow_neck_length
+  x_val <- retrieve_original_aes(data = data, aes_mapping = mapping, aes_var = "xend")
+
+  if (is.null(arrow_neck_length)) {
+    arrow_neck_length <- max(data[[x_val]]) * 0.15
+  }
+
+  layer_obj <- layer(
+    data = data,
+    mapping = mapping,
     stat = stat,
+    geom = GeomSwimArrow,
     position = position,
-    mapping = mapping,
-    data = data,
     show.legend = show.legend,
-    inherit.aes = inherit.aes,
-    arrow_colour = arrow_colour,
-    arrow_head_length = arrow_head_length,
-    arrow_neck_length = arrow_neck_length,
-    arrow_type = arrow_type,
-    params = list(
-      na.rm = na.rm,
+    params = list2(
+      arrow = arrow,
+      arrow.fill = arrow_fill,
+      arrow_colour = arrow_colour,
+      arrow_head_length = arrow_head_length,
+      arrow_neck_length = arrow_neck_length,
+      arrow_type = arrow_type,
       lineend = lineend,
       linejoin = linejoin,
-      arrow = NULL,
-      arrow.fill = arrow_fill,
-      ... = ...
+      na.rm = na.rm,
+      ...
     )
   )
+
+  # Add custom attribute and modify class
+  attr(layer_obj, "swim_class") <- "swim_arrow"
+  class(layer_obj) <- c("swim_arrow", class(layer_obj))
+
+  layer_obj
 }
 
 #' @export
 ggplot_add.swim_arrow <- function(object, plot, object_name) {
-  # Unpack vars ----
-  data <- attr(object, "data")
-  mapping <- attr(object, "mapping")
-  position <- attr(object, "position") # nolint: object_usage_linter
-  arrow_neck_length <- attr(object, "arrow_neck_length")
-  arrow_fill <- attr(object, "params")$arrow.fill
-  arrow_type <- attr(object, "arrow_type")
-  arrow_head_length <- attr(object, "arrow_head_length")
-
-  attr(object, "params")$arrow <- arrow(
-    type = arrow_type,
-    length = arrow_head_length
-  )
-
-  # Implement UI checks ----
-  # Give warning supplied if `arrow_fill` !NULL and `arrow_type` "open"
-  check_arrow_fill_type(arrow_type, arrow_fill)
-  # Give error if arrow_neck_length not a name or numeric val
-  check_arrow_neck_length(arrow_neck_length)
-  # Check that all params are provided due to inability to support inheritance (#44)
-  check_missing_aes_params(
-    mapping = mapping,
-    params = c("xend", "y"),
-    parent_func = "geom_swim_arrow()"
-  )
-
-  check_missing_params(
-    param = data,
-    name = "data",
-    parent_func = "geom_swim_arrow()"
-  )
-
-  x_val <- retrieve_original_aes(data, aes_mapping = unlist(mapping), aes_var = "xend") # nolint: object_usage_linter
-  y_val <- retrieve_original_aes(data, aes_mapping = unlist(mapping), aes_var = "y")
-
-  xend <- NULL # define to avoid global variable note
-
-  new_arrow_data <- data |>
-    mutate(
-      .by = all_of(y_val),
-      xend = case_when(
-        position == "identity" ~ max(.data[[x_val]], na.rm = TRUE),
-        position == "stack" ~ sum(.data[[x_val]], na.rm = TRUE),
-        TRUE ~ NA
-      )
-    )
-
-  # If NULL, neck length to be a 0.15 proportion
-  if (is.null(arrow_neck_length)) {
-    arrow_neck_length <- max(new_arrow_data$xend) * 0.15
-  }
-
-  # Change mapping vals
-  new_arrow_mapping <- aes(
-    x = xend,
-    y = .data[[y_val]],
-    xend = arrow_neck_length + xend
-  )
-
-  new_layer <- layer(
-    data = new_arrow_data,
-    mapping = new_arrow_mapping,
-    stat = attr(object, "stat"),
-    geom = GeomSwimArrow,
-    position = attr(object, "position"),
-    show.legend = attr(object, "show.legend"),
-    inherit.aes = attr(object, "inherit.aes"),
-    params = attr(object, "params")
-  )
-
-  # Add a reference class to the layer attributes
-  new_layer$swim_class <- "swim_arrow"
-
   # TODO: Determine if below better than just:   plot <- plot + new_layer
-  plot$layers <- append(plot$layers, new_layer)
+  plot$layers <- append(plot$layers, object)
 
   # Return
   if (!"ggswim_obj" %in% class(plot)) {
@@ -180,22 +120,42 @@ ggplot_add.swim_arrow <- function(object, plot, object_name) {
   plot
 }
 
-#' @rdname geom_swim_lane
+#' @rdname geom_swim_arrow
 #' @format NULL
 #' @usage NULL
 #' @export
-GeomSwimArrow <- ggproto("GeomSwimArrow", Geom,
-  required_aes = c("x", "y", "xend"),
+GeomSwimArrow <- ggproto("GeomSwimArrow", GeomSegment,
+  required_aes = c("y", "xend"),
   non_missing_aes = c("linetype", "linewidth"),
+  optional_aes = c("arrow_colour", "arrow_head_length", "arrow_type", "arrow_neck_length"),
   default_aes = aes(
     colour = "black",
     linewidth = 0.5,
     size = 2,
     linetype = 1,
     alpha = NA
   ),
-  draw_panel = function(data, panel_params, coord, arrow = NULL, arrow.fill = NULL,
+  setup_data = function(data, params) {
+    arrow_neck_length <- params$arrow_neck_length
+
+    # If NULL, neck length to be a 0.15 proportion
+    if (is.null(params$arrow_neck_length)) {
+      arrow_neck_length <- max(data$xend) * 0.15
+    }
+
+    data <- data |>
+      mutate(
+        x = xend,
+        xend = arrow_neck_length + xend
+      )
+
+    data
+  },
+  draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL,
                         lineend = "butt", linejoin = "round", na.rm = FALSE) {
+    arrow <- arrow(type = data$arrow_type, length = data$arrow_head_length) # Change arrow type and head length
+    data$colour <- data$arrow_colour # Change arrow neck and outline color
+
     # Return all components
     grid::gList(
       GeomSegment$draw_panel(data, panel_params, coord,

R/geom_swim_label.R

@@ -57,62 +57,53 @@ geom_swim_label <- function(mapping = NULL, data = NULL,
                             na.rm = FALSE,
                             show.legend = NA,
                             inherit.aes = TRUE) {
-  structure(
-    "geom_swim_label",
-    class = c("swim_label", "ggswim_layer"),
+  mapping$label <- mapping$label_vals
+  mapping$colour <- mapping$label_names
+
+  layer_obj <- layer(
+    data = data,
+    mapping = mapping,
     stat = stat,
+    geom = GeomSwimLabel,
     position = position,
-    mapping = mapping,
-    data = data,
     show.legend = show.legend,
     inherit.aes = inherit.aes,
-    params = list(
-      na.rm = na.rm,
+    params = list2(
       parse = parse,
       label.padding = label.padding,
       label.r = label.r,
       label.size = label.size,
       size.unit = size.unit,
-      ... = ...
+      na.rm = na.rm,
+      ...
     )
   )
+
+  # Add custom attribute and modify class
+  attr(layer_obj, "swim_class") <- "swim_label"
+  class(layer_obj) <- c("swim_label", class(layer_obj))
+
+  layer_obj
 }
 
 #' @export
 ggplot_add.swim_label <- function(object, plot, object_name) {
   # Unpack vars ----
-  mapping <- attr(object, "mapping")
+  mapping <- object$mapping
 
   # Enforce checks ----
   check_supported_mapping_aes(
     mapping = mapping,
     unsupported_aes = "fill",
-    parent_func = "geom_swim_point()"
-  )
-
-  # Convert label mapping params to linked standard params for intuitive API
-  names(mapping)[names(mapping) == "label_vals"] <- "label"
-  names(mapping)[names(mapping) == "label_names"] <- "colour"
-
-  new_layer <- layer(
-    data = attr(object, "data"),
-    mapping = mapping,
-    stat = attr(object, "stat"),
-    geom = GeomSwimLabel,
-    position = attr(object, "position"),
-    key_glyph = "label",
-    show.legend = attr(object, "show.legend"),
-    inherit.aes = attr(object, "inherit.aes"),
-    params = attr(object, "params")
+    parent_func = "geom_swim_label()"
   )
 
-  # Tag the layer with a reference attribute
-  new_layer$swim_class <- "marker_label"
+  object$mapping <- mapping
 
-  plot$layers <- append(plot$layers, new_layer)
+  plot$layers <- append(plot$layers, object)
 
   # Fix legend ----
-  label_override <- get_label_override(plot, new_layer)
+  label_override <- get_label_override(plot, object)
 
   plot <- plot +
     guides(
@@ -135,14 +126,10 @@ ggplot_add.swim_label <- function(object, plot, object_name) {
 #' @format NULL
 #' @usage NULL
 #' @export
-GeomSwimLabel <- ggproto("GeomSwimLabel", Geom,
-  required_aes = c("x", "y", "label"),
-  default_aes = aes(
-    colour = NA, fill = NA, size = 3.88, angle = 0,
-    hjust = 0.5, vjust = 0.5, alpha = NA, family = "", fontface = 1,
-    lineheight = 1.2
-  ),
-  draw_panel = function(data, panel_params, coord, parse = FALSE,
+GeomSwimLabel <- ggproto("GeomSwimLabel", GeomLabel,
+  required_aes = c("x", "y", "label_vals", "label_names"),
+  optional_aes = c("label"),
+  draw_panel = function(self, data, panel_params, coord, parse = FALSE,
                         na.rm = FALSE,
                         label.padding = unit(0.25, "lines"),
                         label.r = unit(0.15, "lines"),