Add wrap_labels()

NAMESPACE

@@ -115,6 +115,7 @@ export(ttheme_gtplain)
 export(ttheme_gtsimple)
 export(ttheme_gtstripes)
 export(ttheme_set)
+export(wrap_labels)
 import(ggplot2)
 import(grid)
 import(scales)

NEWS.md

@@ -13,6 +13,8 @@ Add some new features matching those new in 'ggplot2'. General improvements
 and bug fixes.
 
 -   This version depends on 'ggplot2' >= 3.5.0.
+-   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

R/wrap-labels.R

@@ -0,0 +1,69 @@
+#' Wrap character strings in a vector
+#'
+#' Wrap the members of a character vector to a given maximum width by inserting
+#' new line characters at word boundaries.
+#'
+#' @param x character vector, or an object which can be converted to a character
+#'   vector by \code{as.character}.
+#' @param width a positive integer giving the target column for wrapping lines
+#'   in the output.
+#' @param indent a positive or negative integer giving the indentation of the
+#'   first line in a member character string.
+#' @param new.line character sting; use \code{"<br>"} for HTML encoded strings.
+#'
+#' @details Function \code{wrap_labels()} is a wrapper on \code{link{strwrap}}
+#' that returns a vector of character strings instead of a list of vectors. In
+#' addition to wrapping, indentation is supported. Wrapping is always at white
+#' space, so \code{width = 0} wraps word by word.
+#'
+#' Because the returned value is a character vector of the same length as the
+#' input, this function can be used within a call to \code{aes()} when mapping a
+#' character vector to the \code{label} aesthetic, as long as the character
+#' strings will not be parsed into R expressions. It can be also used to wrap
+#' the strings in a variable stored in a data frame.
+#'
+#' @return A character vector of the same length as \code{x}, with new line
+#'   characters inserted to wrap text lines longer than \code{width}. Names in
+#'   \code{x} are preserved in the returned value, no names are added if none
+#'   are present in \code{x}.
+#'
+#' @examples
+#' my.text <- c(A = "This is the first string",
+#'              B = "This is the second string, which is longer")
+#'
+#' wrap_labels(my.text, width = 20)
+#' wrap_labels(unname(my.text), width = 20)
+#'
+#' cat(wrap_labels(my.text, width = 20), sep = "\n--\n")
+#' cat(wrap_labels(my.text, width = 20, indent = 2), sep = "\n--\n")
+#' cat(wrap_labels(my.text, width = 20, indent = -2), sep = "\n--\n")
+#'
+#' @export
+#'
+wrap_labels <- function(x,
+                        width = 20,
+                        indent = 0,
+                        new.line = "\n") {
+  if (length(x) == 0L) {
+    # avoid returning list() as returned by sapply()
+    return(character(0L))
+  }
+  if (indent < 0) {
+    exdent = - indent
+    indent = 0
+  } else {
+    exdent = 0
+  }
+  sapply(X = x,
+         FUN = function(x) {
+           paste(
+             strwrap(x,
+                     width = width,
+                     prefix = new.line,
+                     initial = "",
+                     indent = indent,
+                     exdent = exdent),
+             collapse = "")
+         },
+         USE.NAMES = FALSE)
+}

tests/testthat/test-wrap-labels.R

@@ -0,0 +1,63 @@
+context("wrap_labels")
+
+test_that("returns always a character vector", {
+
+  expect_is(wrap_labels(" abcd fghij", width = 5), "character")
+  expect_is(wrap_labels(NA, width = 5), "character")
+  expect_is(wrap_labels(TRUE, width = 5), "character")
+  expect_is(wrap_labels(c(123, 1e6), width = 5), "character")
+  expect_is(wrap_labels(c(123, NA), width = 5), "character")
+  expect_is(wrap_labels(c(123, 1e6), width = 5), "character")
+  expect_is(wrap_labels(character(), width = 5), "character")
+
+})
+
+test_that("white space is consumed or replaced", {
+
+expect_equal(wrap_labels("", width = 20), "")
+expect_equal(wrap_labels("\n", width = 20), "")
+expect_equal(wrap_labels("\t", width = 20), "")
+expect_equal(wrap_labels("   ", width = 20), "")
+expect_equal(wrap_labels(" abc ", width = 20), "abc")
+expect_equal(wrap_labels(" ab cd ", width = 20), "ab cd")
+expect_equal(wrap_labels(" ab\ncd ", width = 20), "ab cd")
+expect_equal(wrap_labels(" ab\tcd ", width = 20), "ab cd")
+
+})
+
+test_that("text is wrapped and indented", {
+  my.text <- c(A = "This is the first string",
+               B = "This is the second string, which is longer")
+
+  expect_length(wrap_labels(my.text, width = 10), 2)
+  expect_equal(wrap_labels(my.text[["A"]], width = 20),
+               "This is the first\nstring")
+  expect_named(wrap_labels(my.text, width = 20), c("A", "B"))
+  expect_named(wrap_labels(unname(my.text), width = 20), NULL)
+  expect_equal(wrap_labels(my.text[["A"]], width = 20, indent = 2),
+               "  This is the first\nstring")
+  expect_equal(wrap_labels(my.text[["A"]], width = 20, indent = -2),
+               "This is the first\n  string")
+})
+
+test_that("test width", {
+  my.text.line <- "This is a rather long string that needs wrapping"
+
+  expect_equal(wrap_labels(my.text.line, width = 50), my.text.line)
+  expect_equal(wrap_labels(my.text.line, width = 30),
+               "This is a rather long string\nthat needs wrapping")
+  expect_equal(wrap_labels(my.text.line, width = 20),
+               "This is a rather\nlong string that\nneeds wrapping")
+  expect_equal(wrap_labels(my.text.line, width = 10),
+               "This is a\nrather\nlong\nstring\nthat\nneeds\nwrapping")
+  expect_equal(wrap_labels(my.text.line, width = 5),
+               "This\nis a\nrather\nlong\nstring\nthat\nneeds\nwrapping")
+  # split into words at white space!
+  expect_equal(wrap_labels(my.text.line, width = 0),
+               "This\nis\na\nrather\nlong\nstring\nthat\nneeds\nwrapping")
+  # surprising behaviour of strwrap() retained
+  expect_equal(wrap_labels(my.text.line, width = -10),
+               wrap_labels(my.text.line, width = 0),)
+
+})
+