Merge branch 'develop-0.5.7'

NEWS.md

@@ -16,9 +16,9 @@ General improvements and bug fixes.
 -   Add helper function `wrap_labels()`, useful to insert new lines into
 characters strings stored in a vector.
 -   Add `as_npc()`, `as_npcx()` and `as_npcy()` helper functions that translate
-positions given as character strings in numeric values in [0..1] into NPC
-(Normalised Parent Coordinates) and validate the range of numeric values if
-passed directly as arguments. The returned values belong to class `AsIs` and
+positions given as character strings into numeric values in [0..1] corresponding
+to NPC (Normalised Parent Coordinates) and validate the range of numeric values
+if passed directly as arguments. The returned values belong to class `AsIs` and
 ready to use in aesthetic mappings.
 -   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 
@@ -36,11 +36,15 @@ the plot, even when using the additional features available in 'ggplot2' in
 -   Update `geom_text_s()`, `geom_label_s()`. `geom_text_pairwise()` and 
 `geom_label_pairwise()` so that they respect the `alpha` component of
 color defintions.
+-   Update `stat_fmt_table()` to allow application of functions to columns.
 -   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.
 -   Fix bug in `geom_label_s()`, `colour_target = "box.line"` ignored.
+-   Fix bug in in `shrink_segments()` giving a spureous error with totel 
+shrinkage > 1 mm. Affecting all geometries with formal parameters `box.padding` 
+and `point.padding`.
 
 # ggpp 0.5.6
 

R/geom-text-linked.r

@@ -121,8 +121,8 @@
 #' @param nudge_x,nudge_y Horizontal and vertical adjustments to nudge the
 #'   starting position of each text label. The units for \code{nudge_x} and
 #'   \code{nudge_y} are the same as for the data units on the x-axis and y-axis.
-#' @param default.colour,default.color A colour definition to use for elements not targeted by
-#'   the colour aesthetic.
+#' @param default.colour,default.color A colour definition to use for elements
+#'   not targeted by the colour aesthetic.
 #' @param colour.target,color.target A vector of character strings; \code{"all"},
 #'   \code{"text"}, \code{"segment"}, \code{"box"}, \code{"box.line"}, and
 #'   \code{"box.fill"} or \code{"none"}.
@@ -549,7 +549,7 @@ GeomTextS <-
 # arbitrary positions along the axis.
 #
 # We support "position" (could be called "away") when nudging or other
-# displacement has been applied and the original postion saved.
+# displacement has been applied and the original position saved.
 #
 # This function can handle either hjust or vjust, but only one at a time.
 compute_just2d <- function(data,
@@ -588,7 +588,9 @@ compute_just2d <- function(data,
         just[position] <- "middle"
       } else {
         just[position] <-
-          c("left", "middle", "right")[2L + 1L * sign(data[[ab_orig[1L]]][position] - data[[ab[1L]]][position])]
+          c("left", "middle", "right")[2L + 1L *
+                                         sign(data[[ab_orig[1L]]][position] -
+                                                data[[ab[1L]]][position])]
       }
     }
 
@@ -681,14 +683,14 @@ compute_just <- function(just, a, b = a, angle = 0) {
 # shorten segments to add padding
 # code based on https://stackoverflow.com/questions/22649781/
 #
+# box.padding and point.pading givern in mm
+#
 shrink_segments <- function(data,
                             box.padding = 0,
                             point.padding = 0,
                             min.segment.length = 0.5) {
   stopifnot("'box.padding' must be >= 0" = box.padding >= 0,
-            "'point.padding' must be >= 0" =  point.padding >= 0,
-            "'box.padding + point.padding' must be < 1" =
-              (box.padding + point.padding) < 1)
+            "'point.padding' must be >= 0" =  point.padding >= 0)
   segments.data <- data[ , c("x_orig", "y_orig", "x", "y")]
   starting.length <- apply(segments.data, 1,
                            function(x) stats::dist(rbind(x[1:2], x[3:4])))

R/stat-format-table.R

@@ -1,9 +1,10 @@
 #' @title Select and slice a tibble nested in \code{data}
 #'
 #' @description \code{stat_fmt_tb} selects, reorders and/or renames columns and
-#'   or rows of a tibble nested in \code{data}. This stat is intended to be used
-#'   to pre-process \code{tibble} objects mapped to the \code{label} aesthetic
-#'   before adding them to a plot with \code{geom_table}.
+#'   or rows of a tibble nested in \code{data}. It can also apply user supplied
+#'   functions to data columns. This stat is intended to be used to pre-process
+#'   \code{tibble} objects mapped to the \code{label} aesthetic before adding
+#'   them to a plot with \code{geom_table}.
 #'
 #' @param mapping The aesthetic mapping, usually constructed with
 #'   \code{\link[ggplot2]{aes}} or \code{\link[ggplot2]{aes_}}. Only needs to be
@@ -26,10 +27,11 @@
 #' @param na.rm	a logical indicating whether \code{NA} values should be stripped
 #'   before the computation proceeds.
 #' @param digits integer indicating the number of significant digits to be
-#'   retained in data.
+#'   retained in data. Use \code{digits = Inf} to skip.
 #' @param tb.vars,tb.rows character or numeric vectors, optionally named, used
 #'   to select and/or rename the columns or rows in the table
 #'   returned.
+#' @param tb.funs named list of functions to be applied to \code{data} columns.
 #' @param table.theme NULL, list or function A 'gridExtra' \code{ttheme}
 #'   definition, or a constructor for a \code{ttheme} or \code{NULL} for
 #'   default.
@@ -40,6 +42,10 @@
 #' @param parse If \code{TRUE}, the labels will be parsed into expressions and
 #'   displayed as described in \code{?plotmath}.
 #'
+#' @details One or more functions to be applied can be passed in a named list to
+#'   parameter `tb.funs`. Functions are matched by name to columns, after column
+#'   selection and renaming have been applied.
+#'
 #' @seealso See \code{\link{geom_table}} for details on how tables respond
 #'   to mapped aesthetics and table themes. For details on predefined table
 #'   themes see \code{\link{ttheme_gtdefault}}.
@@ -87,6 +93,15 @@
 #'                tb.rows = 1:3) +
 #'   expand_limits(x = c(0,3), y = c(-2, 6))
 #'
+#' # apply functions to columns
+#' ggplot(my.df, aes(x, y, label = tbs)) +
+#'   stat_fmt_tb(tb.vars = c(value = 1, group = 2),
+#'                tb.rows = 1:3,
+#'                tb.funs = list(group = function(x) {sprintf("italic(%s)", x)},
+#'                               value = function(x) {ifelse(x > 2, "bold(zz)", x)}),
+#'                parse = TRUE) +
+#'   expand_limits(x = c(0,3), y = c(-2, 6))
+#'
 #' # selection, reordering and renaming by column position
 #' ggplot(my.df, aes(x, y, label = tbs)) +
 #'   stat_fmt_tb(tb.vars = c(group = 2, value = 1),
@@ -104,6 +119,7 @@ stat_fmt_tb <- function(mapping = NULL,
                         geom = "table",
                         tb.vars = NULL,
                         tb.rows = NULL,
+                        tb.funs = list(),
                         digits = 3,
                         position = "identity",
                         table.theme = NULL,
@@ -120,6 +136,7 @@ stat_fmt_tb <- function(mapping = NULL,
     position = position, show.legend = show.legend, inherit.aes = inherit.aes,
     params = list(tb.vars = tb.vars,
                   tb.rows = tb.rows,
+                  tb.funs = tb.funs,
                   digits = digits,
                   table.theme = table.theme,
                   table.rownames = table.rownames,
@@ -141,6 +158,7 @@ StatFmtTb <-
                                               scales,
                                               tb.vars = NULL,
                                               tb.rows = NULL,
+                                              tb.funs = list(),
                                               digits = 3) {
                      stopifnot(is.list(data$label))
 
@@ -222,6 +240,21 @@ StatFmtTb <-
                          }
                        }
 
+                       funs2apply <-
+                         intersect(names(tb.funs), colnames(temp_tb))
+
+                       for (f in funs2apply) {
+                         if (is.character(tb.funs[[f]])) {
+                           tb.funs[[f]] <- match.fun(tb.funs[[f]])
+                         }
+                         if (is.function(tb.funs[[f]])) {
+                           temp_tb[[f]] <- tb.funs[[f]](temp_tb[[f]])
+                         } else {
+                           warning("'tb.funs[[", f, "]]' is not a function or a visible function name", sep = "")
+                           temp_tb[[f]] <- NA
+                         }
+                       }
+
                        data$label[tb.idx] <- list(temp_tb)
 
                      }

tests-not/gapminder-gg-club.R

@@ -0,0 +1,41 @@
+library(tidyverse)
+library(ggrepel)
+library(ggpp)
+
+country.labels <- c("Chile" = "República de Chile", "United States" = "United States of America")
+
+# Using a repulsive geom from 'ggrepel'
+gapminder::gapminder |>
+  filter(year == 2002) |>
+  ggplot() +
+  aes(gdpPercap, lifeExp) +
+  geom_point(colour = "darkgrey") +
+  geom_text_repel(
+    aes(label = ifelse(country %in% names(country.labels),
+                       wrap_labels(country.labels, width = 15)[as.character(country)],
+                       "")),
+    hjust = 0,
+    nudge_y = c(-6, 4),
+    nudge_x = 1000,
+    na.rm = TRUE,
+    box.padding = 0.3,
+    point.padding = 0.3,
+    arrow = arrow(length = unit(2, "mm"), type = "closed")
+  )
+
+# Using a non-repulsive geom 'ggpp'
+gapminder::gapminder |>
+  filter(year == 2002) |>
+  ggplot() +
+  aes(gdpPercap, lifeExp) +
+  geom_point(colour = "darkgrey") +
+  geom_text_s(
+    aes(label = wrap_labels(country.labels, width = 15)[as.character(country)]),
+    hjust = 0.5,
+    nudge_y = c(-3, 3),
+    nudge_x = c(-1000, 100),
+    na.rm = TRUE,
+    box.padding = 1,
+    point.padding = 1,
+    arrow = arrow(length = unit(2, "mm"), type = "closed")
+  )