Update positions to handle x and y vectors of any length

Edited position_nudge_center() and position_nudge_to() to allow vectors of any length passed to x and y. I rewrote position_nudge_keep() adding support for groups and controlling keeping or not the original position.

R/position-nudge-center.R

@@ -10,16 +10,10 @@
 #' region, either in opposite directions or radially from a virtual \emph{center
 #' point}.
 #'
-#' The wrapper \code{position_nudge_keep()} with exactly the same signature and
-#' behaviour as \code{\link[ggplot2]{position_nudge}} provides an easier to remember name
-#' when the desire is only to have access to both the original and nudged
-#' coordinates.
-#'
 #' @family position adjustments
 #'
 #' @param x,y Amount of vertical and horizontal distance to move. A numeric
-#'   vector of length 1, or of the same length as rows there are in \code{data},
-#'   with nudge values in data rows order.
+#'   vector, that is recycled if shorter than the number of rows in \code{data}.
 #' @param center_x,center_y The coordinates of the virtual origin out from which
 #'   nudging radiates or splits in opposite directions. A numeric vector of
 #'   length 1 or of the same length as rows there are in \code{data}, or a
@@ -63,7 +57,7 @@
 #'   which case \code{x} or \code{y} are adjusted to ensure these segments are of the same
 #'   lengths as those at other angles.
 #'
-#'   This position is most useful when labeling points forming a cloud or
+#'   This position is most useful when labelling points forming a cloud or
 #'   grouped along vertical or horizontal lines or "divides".
 #'
 #' @seealso [ggplot2::position_nudge()], [ggrepel::position_nudge_repel()].
@@ -171,38 +165,19 @@
 #'   geom_point() +
 #'   geom_line() +
 #'   geom_text_s(aes(label = y),
-#'               position = position_nudge_center(x = -0.9,
-#'                                                y = -2.7,
-#'                                                center_x = mean,
-#'                                                center_y = max))
-#'
-#' ggplot(df, aes(x, z)) +
-#'   geom_point() +
-#'   geom_line() +
-#'   geom_text_s(aes(label = y),
 #'               position = position_nudge_center(x = 0.9,
 #'                                                y = 2.7,
 #'                                                center_x = mean,
 #'                                                center_y = max))
 #'
-#' above_max <- function(x) {1.2 * max(x)}
-#' ggplot(df, aes(x, z)) +
-#'   geom_point() +
-#'   geom_line() +
-#'   geom_text_s(aes(label = y),
-#'               position = position_nudge_center(x = -1.2,
-#'                                                y = -3,
-#'                                                center_x = mean,
-#'                                                center_y = above_max))
-#'
 #' ggplot(df, aes(x, z, color = group)) +
 #'   geom_point() +
 #'   geom_line(color = "black", linetype = "dotted") +
 #'   geom_text_s(aes(label = y),
 #'               position = position_nudge_center(x = -1.2,
 #'                                                y = -3,
 #'                                                center_x = 0,
-#'                                                center_y = above_max))
+#'                                                center_y = "above_max"))
 #'
 #' ggplot(df, aes(x, z, color = group)) +
 #'   geom_point() +
@@ -298,6 +273,8 @@ PositionNudgeCenter <-
 
       list(x = self$x,
            y = self$y,
+           x.reorder = !is.null(self$x) && length(self$x) > 1 && length(self$x) < nrow(data),
+           y.reorder = !is.null(self$y) && length(self$y) > 1 && length(self$y) < nrow(data),
            center_x = self$center_x,
            center_y = self$center_y,
            kept.origin = self$kept.origin,
@@ -344,14 +321,14 @@ PositionNudgeCenter <-
         # compute focal center by group
         if (is.function(params$center_x)) {
           x_ctr <- params$center_x(as.numeric(data[in.grp, "x"]))
-        } else if(is.numeric(params$center_x)) {
+        } else if (is.numeric(params$center_x)) {
           x_ctr <- params$center_x[1]
         } else {
           x_ctr <- -Inf # ensure all observations are to the right
         }
         if (is.function(params$center_y)) {
           y_ctr <- params$center_y(as.numeric(data[in.grp, "y"]))
-        } else if(is.numeric(params$center_y)) {
+        } else if (is.numeric(params$center_y)) {
           y_ctr <- params$center_y[1]
         } else {
           y_ctr <- -Inf # ensure all observations are above
@@ -399,8 +376,18 @@ PositionNudgeCenter <-
             warning("Ignoring unrecognized direction \"",
                     params$direction, "\".")
           }
-          x_nudge[in.grp] <- params$x
-          y_nudge[in.grp] <- params$y
+          # behaviour similar to position_nudge() except for handling of vectors of nudges
+          # and possibly respecting groups for alternating nudges
+          if (params$x.reorder && length(params$x) > 1 && length(params$x < sum(in.grp))) {
+            x_nudge[in.grp] <- rep_len(params$x, sum(in.grp))[order(order(data$x[in.grp]))]
+          } else {
+            x_nudge[in.grp] <- rep_len(params$x, sum(in.grp))
+          }
+          if (params$y.reorder && length(params$y) > 1 && length(params$y < sum(in.grp))) {
+            y_nudge[in.grp] <- rep_len(params$y, sum(in.grp))[order(order(data$y[in.grp]))]
+          } else {
+            y_nudge[in.grp] <- rep_len(params$y, sum(in.grp))
+          }
         }
       }
       # transform only the dimensions for which new coordinates exist
@@ -429,16 +416,95 @@ PositionNudgeCenter <-
 #'
 position_nudge_centre <- position_nudge_center
 
-#' @rdname position_nudge_center
+#' Nudge points a fixed distance
+#'
+#' The function \code{position_nudge_keep()} has an additional parameters
+#' compared to \code{\link[ggplot2]{position_nudge}}, \code{obey_grouping} and
+#' by default the same behaviour when the values passed as arguments to \code{x}
+#' and \code{y} have length one.
+#'
+#' @details When \code{x} or \code{y} have length > 1, they are treated
+#'   specially. If the lengths is the same as there are rows in data, the nudges
+#'   are applied in the order of the rows in data. When they are shorter, they
+#'   are recycled and applied to the data values after ordering. This makes it
+#'   possible to have alternating mudging right and left or up and down. If
+#'   \code{obey_grouping = TRUE} is passed in the call, the alternation will
+#'   take place within groups.
+#'
+#'   As other position functions from package 'ggpp', \code{position_nudge_keep()}
+#'   by default renames and keeps the original positions of the observations in
+#'   \code{data} making it possible to draw connecting segments or conencting
+#'   arrows.
+#'
+#' @family position adjustments
+#'
+#' @param x,y Amount of vertical and horizontal distance to move. A numeric
+#'   vector of length 1, or of the same length as rows there are in \code{data},
+#'   with nudge values in data rows order.
+#' @param obey_grouping A logical flag indicating whether to obey or not
+#'   groupings of the observations. By default, grouping is obeyed when both of
+#'   the variables mapped to \emph{x} and \emph{y} are continuous numeric and
+#'   ignored otherwise.
+#' @param kept.origin One of \code{"original"} or \code{"none"}.
+#'
+#' @note Irrespective of the action, the ordering of rows in \code{data} is
+#'   preserved.
+#'
+#' @return A \code{"Position"} object.
 #'
 #' @export
 #'
-position_nudge_keep <- function(x = 0, y = 0) {
-  position_nudge_center(x = x,
-                        y = y,
-                        center_x = NULL,
-                        center_y = NULL,
-                        direction = NULL,
-                        obey_grouping = NULL,
-                        kept.origin = "original")
-}
+#' @examples
+#' df <- data.frame(
+#'   x = c(1,3,2,5,4,2.5),
+#'   y = c("abc","cd","d","c","bcd","a")
+#' )
+#'
+#' # Plain nudging, same as with ggplot2::position_nudge()
+#'
+#' ggplot(df, aes(x, y, label = y)) +
+#'   geom_point() +
+#'   geom_text_s(hjust = "left", vjust = "bottom",
+#'               position = position_nudge_keep(x = 0.2, y = 0.2))
+#'
+#' # alternating nudging
+#' ggplot(df, aes(x, y, label = y)) +
+#'   geom_point() +
+#'   geom_text_s(position = position_nudge_keep(x = c(0.2, -0.2)))
+#'
+#' # direct nudging
+#' ggplot(df, aes(x, y, label = y)) +
+#'   geom_point() +
+#'   geom_text_s(position = position_nudge_keep(x = rep_len(c(0.2, -0.2), 6)))
+#'
+position_nudge_keep <-
+  function(x = 0,
+           y = 0,
+           obey_grouping = NULL,
+           kept.origin = c("original", "none")) {
+
+    kept.origin <- rlang::arg_match(kept.origin)
+
+    if (is.null(obey_grouping)) {
+      # default needs to be set in panel_function when we have access to data
+      obey_grouping <- NA
+    }
+
+    if (lubridate::is.duration(x)) {
+      x <- as.numeric(x)
+    }
+    if (lubridate::is.duration(y)) {
+      y <- as.numeric(y)
+    }
+
+    # we reuse the code from the position defined above
+    ggplot2::ggproto(NULL, PositionNudgeCenter,
+                     x = x,
+                     y = y,
+                     center_x = NULL,
+                     center_y = NULL,
+                     kept.origin = kept.origin,
+                     direction = "none",
+                     obey_grouping = obey_grouping
+    )
+  }

R/position-nudge-line.R

@@ -15,8 +15,7 @@
 #' @family position adjustments
 #'
 #' @param x,y Amount of vertical and horizontal distance to move. A numeric
-#'   vector of length 1, or of the same length as rows there are in \code{data},
-#'   with nudge values in data rows order.
+#'   vector of length 1 or longer.
 #' @param xy_relative Nudge relative to \emph{x} and \emph{y} data expanse, ignored unless
 #'   \code{x} and \code{y} are both \code{NA}s.
 #' @param abline a vector of length two giving the intercept and slope.

R/position-nudge-to.R

@@ -13,20 +13,25 @@
 #'
 #' @param x,y Coordinates of the destination position. A vector of mode
 #'   \code{numeric}, that is extended if needed, to the same length as rows
-#'   there are in \code{data}. The values are applied in the order of the
-#'   observations in data. The default, \code{NULL}, leaves the original
+#'   there are in \code{data}. The default, \code{NULL}, leaves the original
 #'   coordinates unchanged.
 #' @param x.action,y.action character string, one of \code{"none"}, or
 #'   \code{"spread"}. With \code{"spread"} evenly distributing the positions
 #'   within the range of argument \code{x} or \code{y}, if non-null, or the
 #'   range the variable mapped to \emph{x} or \code{y}, otherwise.
 #' @param kept.origin One of \code{"original"} or \code{"none"}.
 #'
-#' @details The nudged \code{x} or \code{y} replace the original ones in
+#' @details The nudged to \code{x} and/or \code{y} values replace the original ones in
 #'   \code{data}, while the original coordinates are returned in \code{x_orig}
 #'   and \code{y_orig}. Values supported are those of \emph{mode} numeric,
 #'   thus including dates and times.
 #'
+#'   If the length of \code{x} and/or \code{y} is more than one but less than
+#'   rows are present in the data, the vector is both recycled and reordered so
+#'   that the nudges are applied sequentially based on the data values. If their
+#'   length matches the number of rows in data, they are assumed to be already
+#'   in data order.
+#'
 #' @note Irrespective of the action, the ordering of rows in \code{data} is
 #'   preserved.
 #'
@@ -44,25 +49,54 @@
 #'   label = c("abc","cd","d","c","bcd","a")
 #' )
 #'
+#' # default does nothing
+#' ggplot(df, aes(x, y, label = label)) +
+#'   geom_point() +
+#'   geom_text(position = position_nudge_to())
+#'
+#' # a single y (or x) value nudges all observations to this data value
 #' ggplot(df, aes(x, y, label = label)) +
 #'   geom_point() +
 #'   geom_text(position = position_nudge_to(y = 3))
 #'
+#' # with a suitable geom, segments or arrows can be added
 #' ggplot(df, aes(x, y, label = label)) +
 #'   geom_point() +
 #'   geom_text_s(position = position_nudge_to(y = 3))
 #'
+#' # alternating in y value order because y has fewer values than rows in data
+#' ggplot(df, aes(x, y, label = label)) +
+#'   geom_point() +
+#'   geom_text_s(position = position_nudge_to(y = c(3, 0)))
+#'
+#' ggplot(df, aes(x, y, label = label)) +
+#'   geom_point() +
+#'   geom_text_s(position = position_nudge_to(y = c(0, 3)))
+#'
+#' # in data row order because y has as many values as rows in data
+#' ggplot(df, aes(x, y, label = label)) +
+#'   geom_point() +
+#'   geom_text_s(position = position_nudge_to(y = rep_len(c(0, 3), 6)))
+#'
+#' # spread the values at equal distance within the available space
 #' ggplot(df, aes(x, y, label = label)) +
 #'   geom_point() +
 #'   geom_text_s(position =
 #'     position_nudge_to(y = 3, x.action = "spread"))
 #'
+#' # spread the values at equal distance within the range given by x
 #' ggplot(df, aes(x, y, label = label)) +
 #'   geom_point() +
 #'   geom_text_s(position =
 #'     position_nudge_to(y = 3, x = c(2,4), x.action = "spread"),
 #'     hjust = "center")
 #'
+#' ggplot(df, aes(x, y, label = label)) +
+#'   geom_point() +
+#'   geom_text_s(position =
+#'     position_nudge_to(y = 3, x = c(0,6), x.action = "spread"),
+#'     hjust = "center")
+#'
 position_nudge_to <-
   function(x = NULL,
            y = NULL,
@@ -110,6 +144,8 @@ PositionNudgeTo <-
            y = self$y,
            x.action = self$x.action,
            y.action = self$y.action,
+           x.reorder = !is.null(self$x) && length(self$x) > 1 && length(self$x) < nrow(data),
+           y.reorder = !is.null(self$y) && length(self$y) > 1 && length(self$y) < nrow(data),
            kept.origin = self$kept.origin
       )
     },
@@ -123,11 +159,15 @@ PositionNudgeTo <-
         if (params$x.action == "none") {
           params$x <- rep_len(0, nrow(data))
         } else if (params$x.action == "spread") {
-           params$x <- range(x_orig)
+          params$x <- range(x_orig)
         }
       } else if (is.numeric(params$x)) {
         if (params$x.action == "none") {
-          params$x <- rep_len(params$x, nrow(data)) - x_orig
+          if (params$x.reorder) {
+            params$x <- rep_len(params$x, nrow(data))[match(1:nrow(data), order(data$x))] - x_orig
+          } else {
+            params$x <- rep_len(params$x, nrow(data)) - x_orig
+          }
         } else if (params$x.action == "spread") {
           params$x <- range(params$x)
         }
@@ -148,7 +188,11 @@ PositionNudgeTo <-
         }
       } else if (is.numeric(params$y)) {
         if (params$y.action == "none") {
-          params$y <- rep_len(params$y, nrow(data)) - y_orig
+          if (params$y.reorder) {
+            params$y <- rep_len(params$y, nrow(data))[match(1:nrow(data), order(data$y))] - y_orig
+          } else {
+            params$y <- rep_len(params$y, nrow(data)) - y_orig
+          }
         } else if (params$y.action == "spread") {
           params$y <- range(params$y)
         }
@@ -157,7 +201,7 @@ PositionNudgeTo <-
         # evenly spaced sequence ordered as in data
         params$y <- seq(from = params$y[1],
                         to = params$y[2],
-                        length.out = nrow(data))[order(order(data$y))] - y_orig
+                        length.out = nrow(data))[match(1:nrow(data), order(data$y))] - y_orig
       }
 
       # As in 'ggplot2' we apply the nudge to xmin, xmax, xend, ymin, ymax, and yend.

_pkgdown.yml

@@ -45,6 +45,7 @@ reference:
   - title: Positions
     desc: Advanced nudge functions
     contents:
+    - position_nudge_keep
     - position_nudge_to
     - position_nudge_center
     - position_nudge_line