Merge branch 'add-draw-key' into develop-0.5.7

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: ggpp
 Type: Package
 Title: Grammar Extensions to 'ggplot2'
-Version: 0.5.6.9000
-Date: 2024-03-03
+Version: 0.5.6.9001
+Date: 2024-03-04
 Authors@R:
     c(
     person("Pedro J.", "Aphalo", email = "[email protected]", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-3385-972X")),
@@ -58,3 +58,45 @@ BugReports: https://github.com/aphalo/ggpp/issues
 Encoding: UTF-8
 RoxygenNote: 7.3.1
 VignetteBuilder: knitr
+Collate: 
+    'annotate.r'
+    'compute-npc.r'
+    'dark-or-light.R'
+    'example-data.R'
+    'geom-grob.R'
+    'ggpp-legend-draw.R'
+    'utilities.R'
+    'ggp2-margins.R'
+    'geom-label-linked.r'
+    'geom-label-npc.r'
+    'geom-label-pairwise.r'
+    'geom-margin-arrow.r'
+    'geom-margin-grob.r'
+    'geom-margin-point.r'
+    'geom-plot.R'
+    'geom-point-linked.r'
+    'geom-quadrant-lines.R'
+    'geom-table.R'
+    'geom-text-linked.r'
+    'geom-text-npc.r'
+    'geom-text-pairwise.R'
+    'ggpp.R'
+    'position-nudge-center.R'
+    'position-nudge-dodge.R'
+    'position-nudge-dodge2.R'
+    'position-nudge-jitter.R'
+    'position-nudge-line.R'
+    'position-nudge-stack.R'
+    'position-nudge-to.R'
+    'scale-continuous-npc.r'
+    'stat-apply.R'
+    'stat-dens1d-filter.r'
+    'stat-dens1d-labels.r'
+    'stat-dens2d-filter.r'
+    'stat-dens2d-labels.r'
+    'stat-format-table.R'
+    'stat-functions.R'
+    'stat-panel-counts.R'
+    'stat-quadrant-counts.R'
+    'try-data-frame.R'
+    'weather-data.R'

NAMESPACE

@@ -45,6 +45,8 @@ export(annotate)
 export(compute_npcx)
 export(compute_npcy)
 export(dark_or_light)
+export(draw_key_label_s)
+export(draw_key_text_s)
 export(geom_grob)
 export(geom_grob_npc)
 export(geom_label_npc)

NEWS.md

@@ -8,14 +8,23 @@ editor_options:
 
 # ggpp 0.5.7
 
--   Fix bug in `geom_point_s()`, `alpha_target = "point"` ignored.
--   Update `geom_point_s()` adding parameter `move.point` to allow its use to highlight point at the original position with an arrow with its start given
-by the action of a position function.
--   Change in `geom_point_s()` the end at which the tip of the arrow is drawn to its most frequently used direction, even if opposite to the default for
+-   This version depends on 'ggplot2' >= 3.5.0.
+-   Update `geom_point_s()` adding parameter `move.point` to allow its use to 
+highlight points at the original position with an arrow with its start given by 
+the action of a position function.
+-   Change in `geom_point_s()` the end at which the tip of the arrow is drawn
+to its most frequently used direction, even if opposite to the default for
 `geom_text_s()` and `geom_label_s()`.
 -   Update `geom_text_s()`, `geom_label_s()`. `geom_text_pairwise()` and 
 `geom_label_pairwise()` adding parameter `size.unit` tracking change in 
 `geom_text()` and `geom_label()` in 'ggplot2' 3.5.0.
+-   Update `geom_text_s()`, `geom_label_s()`. `geom_text_pairwise()` and 
+`geom_label_pairwise()` so that graphic elements in the keys match those in
+the plot, even when using the additional features not availablr in 'ggplot2'.
+-   Fix in `geom_text_s()`, `geom_label_s()`. `geom_text_pairwise()` and 
+`geom_label_pairwise()` an infrequent problem with incomplete guides in 
+'ggplot2' 3.5.0.
+-   Fix bug in `geom_point_s()`, `alpha_target = "point"` ignored.
 
 # ggpp 0.5.6
 

R/geom-label-linked.r

@@ -1,4 +1,5 @@
 #' @rdname geom_text_s
+#' @include ggp2-margins.R utilities.R ggpp-legend-draw.R
 #'
 #' @param label.padding Amount of padding around label. Defaults to 0.25 lines.
 #' @param label.r Radius of rounded corners. Defaults to 0.15 lines.
@@ -89,6 +90,8 @@ GeomLabelS <-
   ggplot2::ggproto("GeomLabelS", ggplot2::Geom,
                    required_aes = c("x", "y", "label"),
 
+                   non_missing_aes = "angle",
+
                    default_aes = ggplot2::aes(
                      colour = "black",
                      fill = "white",
@@ -123,6 +126,11 @@ GeomLabelS <-
 
                      add.segments <- add.segments && all(c("x_orig", "y_orig") %in% colnames(data))
 
+                     # ensure compatibility with 'ggplot2'
+                     if (exists("label.size", data)) {
+                       data$line.width <- data$label.size * .pt / ggplot2::.stroke
+                       data$label.size <- NULL
+                     }
                      data$label <- as.character(data$label)
                      data <- subset(data, !is.na(label) & label != "")
                      if (nrow(data) == 0L) {
@@ -251,7 +259,7 @@ GeomLabelS <-
 
                    },
 
-                   draw_key = ggplot2::draw_key_text
+                   draw_key = draw_key_label_s
   )
 
 labelGrob <- function(label, x = grid::unit(0.5, "npc"), y = grid::unit(0.5, "npc"),

R/geom-label-pairwise.r

@@ -1,4 +1,5 @@
 #' @rdname geom_text_pairwise
+#' @include ggp2-margins.R utilities.R ggpp-legend-draw.R
 #'
 #' @param label.padding Amount of padding around label. Defaults to 0.25 lines.
 #' @param label.r Radius of rounded corners. Defaults to 0.15 lines.
@@ -233,5 +234,5 @@ GeomLabelPairwise <-
 
                    },
 
-                   draw_key = ggplot2::draw_key_label
+                   draw_key = draw_key_label_s
   )

R/geom-text-linked.r

@@ -1,4 +1,5 @@
 #' @title Linked Text
+#' @include ggp2-margins.R utilities.R ggpp-legend-draw.R
 #'
 #' @description Linked text geometries are most useful for adding data labels to
 #'   plots. `geom_text_s()` and `geom_label_s()` add text to the plot and for
@@ -22,7 +23,9 @@
 #'   elements the mappings to colour and alpha aesthetics are applied.
 #'   Differently to \code{geom_label()}, \code{geom_label_s()} obeys aesthetic
 #'   mappings to \code{linewidth} and \code{linetype} applied to the line at the
-#'   edge of the label box.
+#'   edge of the label box. These features are reflected in the plot key, except
+#'   for the segment, assumed not to be used to display information
+#'   independently of other graphic elements.
 #'
 #'   Layer functions \code{geom_text_s()} and \code{geom_label_s()} use by
 #'   default \code{\link{position_nudge_keep}} which is backwards compatible
@@ -519,7 +522,7 @@ GeomTextS <-
 
                    },
 
-                   draw_key = ggplot2::draw_key_text
+                   draw_key = draw_key_text_s
   )
 
 # heavily modified from geom-text.r from 'ggplot2' 3.1.0

R/geom-text-pairwise.R

@@ -1,4 +1,5 @@
-#' Label pairwise comparisons
+#' @title Label pairwise comparisons
+#' @include ggp2-margins.R utilities.R ggpp-legend-draw.R
 #'
 #' @description Add a plot layer with a text label and a segment connecting two
 #'   values along the \code{x} aesthetic. These are usually two levels of a
@@ -452,5 +453,5 @@ GeomTextPairwise <-
 
                    },
 
-                   draw_key = draw_key_text
+                   draw_key = draw_key_text_s
   )

R/ggpp-legend-draw.R

@@ -0,0 +1,119 @@
+#' Key glyphs for legends
+#'
+#' Each geom has an associated function that draws the key when the geom needs
+#' to be displayed in a legend. These functions are called `draw_key_*()`, where
+#' `*` stands for the name of the respective key glyph. The key glyphs can be
+#' customized for individual geoms by providing a geom with the `key_glyph`
+#' argument (see [`layer()`] or examples below.)
+#'
+#' @return A grid grob.
+#' @param data A single row data frame containing the scaled aesthetics to
+#'   display in this key
+#' @param params A list of additional parameters supplied to the geom.
+#' @param size Width and height of key in mm.
+#' @examples
+#' p <- ggplot(economics, aes(date, psavert, color = "savings rate"))
+#' # key glyphs can be specified by their name
+#' p + geom_line(key_glyph = "timeseries")
+#'
+#' # key glyphs can be specified via their drawing function
+#' p + geom_line(key_glyph = draw_key_rect)
+#'
+#' @keywords internal
+#' @name ggpp_draw_key
+NULL
+
+#' @export
+#' @rdname ggpp_draw_key
+draw_key_text_s <- function(data, params, size) {
+  data  <- replace_null(unclass(data), label = "a", angle = 0)
+  hjust <- ifelse(data$hjust %in% c("left", "middle", "right"),
+                  compute_just(data$hjust %||% 0.5),
+                  0.5)
+  vjust <- ifelse(data$vjust %in% c("left", "middle", "right"),
+                  compute_just(data$vjust %||% 0.5),
+                  0.5)
+  just  <- rotate_just(data$angle, hjust, vjust)
+  grob  <- titleGrob(
+    data$label,
+    x = unit(just$hjust, "npc"), y = unit(just$vjust, "npc"),
+    angle = data$angle,
+    hjust = hjust,
+    vjust = vjust,
+    gp = gpar(
+      col = ifelse(params$colour.target %in% c("text", "all"),
+                   alpha(data$colour %||% data$fill %||% params$default.colour %||% "black",
+                         data$alpha %||% params$default.alpha %||% 1),
+                   params$default.colour %||% "black"),
+      fontfamily = data$family   %||% "",
+      fontface   = data$fontface %||% 1,
+      fontsize   = (data$size %||% 3.88) * .pt
+    ),
+    margin = margin(0.1, 0.1, 0.1, 0.1, unit = "lines"),
+    margin_x = TRUE, margin_y = TRUE
+  )
+  attr(grob, "width")  <- convertWidth(grobWidth(grob),   "cm", valueOnly = TRUE)
+  attr(grob, "height") <- convertHeight(grobHeight(grob), "cm", valueOnly = TRUE)
+  grob
+}
+
+#' @export
+#' @rdname ggpp_draw_key
+draw_key_label_s <- function(data, params, size) {
+  data <- replace_null(unclass(data), label = "a", angle = 0)
+  params$label.size <- params$label.size %||% 0.25
+  hjust <- ifelse(data$hjust %in% c("left", "middle", "right"),
+                  compute_just(data$hjust %||% 0.5),
+                  0.5)
+  vjust <- ifelse(data$vjust %in% c("left", "middle", "right"),
+                  compute_just(data$vjust %||% 0.5),
+                  0.5)
+  just  <- rotate_just(data$angle, hjust, vjust)
+  padding <- rep(params$label.padding %||% unit(0.25, "lines"), length.out = 4)
+  descent <- font_descent(
+    family = data$family %||% "",
+    face = data$fontface %||% 1,
+    size = data$size %||% 3.88
+  )
+  grob <- labelGrob(
+    data$label,
+    x = unit(just$hjust, "npc"),
+    y = unit(just$vjust, "npc") + descent,
+    angle = data$angle,
+    just = c(hjust, vjust),
+    padding = padding,
+    r = params$label.r %||% unit(0.15, "lines"),
+    text.gp = gpar(
+      col = ifelse(params$colour.target %in% c("text", "all"),
+                   alpha(data$colour %||% data$fill %||% params$default.colour  %||% "black",
+                         data$alpha%||% params$default.alpha %||% 1),
+                   params$default.colour %||% "black"),
+      fontfamily = data$family   %||% "",
+      fontface   = data$fontface %||% 1,
+      fontsize   = (data$size %||% 3.88) * .pt
+    ),
+    rect.gp = gpar(
+      col  = if (isTRUE(all.equal(params$label.size, 0))) {
+        NA
+        } else {
+        ifelse(params$colour.target %in% c("box", "all"),
+                     alpha(data$colour %||% data$fill %||% params$default.colour %||% "black",
+                           data$alpha %||% params$default.alpha %||% 1),
+               params$default.colour %||% "black")
+        },
+      fill = alpha(data$fill %||% "white",
+                   data$alpha %||% params$default.alpha %||% 1),
+      lwd  = (data$linewidth %||% 0.25) * ggplot2::.stroke,
+      lty = data$linetype %||% "solid"
+    )
+  )
+  angle  <- deg2rad(data$angle %||% 0)
+  text   <- grob$children[[2]]
+  width  <- convertWidth(grobWidth(text),   "cm", valueOnly = TRUE)
+  height <- convertHeight(grobHeight(text), "cm", valueOnly = TRUE)
+  x <- c(0, 0, width, width)
+  y <- c(0, height, height, 0)
+  attr(grob, "width")  <- diff(range(x * cos(angle) - y * sin(angle)))
+  attr(grob, "height") <- diff(range(x * sin(angle) + y * cos(angle)))
+  grob
+}

R/utilities.R

@@ -28,6 +28,10 @@ parse_safe <- function(text) {
   out
 }
 
+# Helpers to convert degrees to radians and vice versa
+rad2deg <- function(rad) rad * 180 / pi
+deg2rad <- function(deg) deg * pi / 180
+
 
 # function from ggplot2, needed in annotate() but not exported
 compact <- function (x)
@@ -71,13 +75,13 @@ dummy_data <- function() new_data_frame(list(x = NA), n = 1)
 # and express this pattern as:
 #
 # replace_null(obj, name1 = value, name2 = value)
-replace_null <- function(obj, ..., env = caller_env()) {
+replace_null <- function(obj, ..., env = rlang::caller_env()) {
   # Collect dots without evaluating
-  dots <- enexprs(...)
+  dots <- rlang::enexprs(...)
   # Select arguments that are null in `obj`
   nms  <- names(dots)
   nms  <- nms[vapply(obj[nms], is.null, logical(1))]
   # Replace those with the evaluated dots
-  obj[nms] <- inject(list(!!!dots[nms]), env = env)
+  obj[nms] <- rlang::inject(list(!!!dots[nms]), env = env)
   obj
 }

inst-not/test-linked-geom.R

@@ -68,7 +68,7 @@ get_guide_data(p1, aesthetic = "alpha")
 p2 <-
   ggplot(my.cars, aes(wt, mpg, label = name)) +
   geom_point() +
-  geom_text_s(aes(size = wt), nudge_x = -0.1, hjust = "right") +
+  geom_text_s(aes(size = wt), nudge_x = -0.1, hjust = "right", colour = "red", colour.target = "segment") +
   scale_radius(range = c(3,6)) + # override scale_area()
   expand_limits(x = c(1.8, 5.5))
 
@@ -102,14 +102,16 @@ p3
 p4 <-
   ggplot(my.cars, aes(wt, mpg, label = name)) +
   geom_point() +
-  geom_label_s(aes(size = wt), nudge_x = -0.1, hjust = "right") +
+  geom_label_s(aes(size = wt), nudge_x = -0.1, nudge_y = -0.1, hjust = "right",
+               colour.target = "text", default.colour = "grey80",
+               linetype = "dashed", linewidth = 0.5) +
   scale_radius(range = c(3,6)) + # override scale_area()
   expand_limits(x = c(1.8, 5.5))
 
-get_guide_data(p4, aesthetic = "size")
-
 p4
 
+get_guide_data(p4, aesthetic = "size")
+
 ###
 
 p5 <-