Merge pull request #8 from AllanCameron/stage_merge

Handled plotmath expressions

R/geom_textpath.R

@@ -46,6 +46,8 @@
 #' @param offset A [`unit()`][grid::unit()] of length 1 to determine the offset
 #'   of the text from the path. If not `NULL`, this overrules the `vjust`
 #'   setting.
+#' @param parse If set to **TRUE** this will coerce the labels into expressions,
+#'   allowing plotmath syntax to be used.
 #'
 #' @details
 #' There are limitations inherent in the plotting of text elements in
@@ -182,7 +184,7 @@ geom_textpath <- function(
   inherit.aes = TRUE,  ...,
   lineend = "butt", linejoin = "round", linemitre = 10,
   include_line = TRUE, cut_path = NA, flip_inverted = TRUE,
-  halign = "left", offset = NULL
+  halign = "left", offset = NULL, parse = FALSE
   )
 {
   layer(geom = GeomTextpath, mapping = mapping, data = data, stat = stat,
@@ -198,6 +200,7 @@ geom_textpath <- function(
           flip_inverted = flip_inverted,
           halign        = halign,
           offset        = offset,
+          parse         = parse,
           ...
         ))
 }
@@ -243,7 +246,7 @@ GeomTextpath <- ggproto("GeomTextpath", Geom,
     data, panel_params, coord,
     lineend = "butt", linejoin = "round", linemitre = 10,
     cut_path = NA, flip_inverted = TRUE, halign = "left",
-    offset = NULL
+    offset = NULL, parse = FALSE
   ) {
 
     #---- type conversion, checks & warnings ---------------------------#
@@ -299,10 +302,16 @@ GeomTextpath <- ggproto("GeomTextpath", Geom,
       )
     }
 
+    safe_labels <- if(parse) {
+        safe_parse(as.character(data$label[first]))
+      } else {
+        data$label[first]
+      }
+
     #---- Dispatch data to grob -----------------------------#
 
     textpathGrob(
-      label = data$label[first],
+      label = safe_labels,
       x = data$x,
       y = data$y,
       id = data$group,

R/geometry_helpers.R

@@ -72,7 +72,7 @@
 
   # Offset text by anchorpoints
   xpos <- c("xmin", "xmid", "xmax")
-  letters[, xpos] <- letters[, xpos] + anchor[letters$y_id]
+  letters[xpos] <- sapply(letters[xpos], `+`, anchor[letters$y_id])
 
   # Project text to curves
   letters <- .project_text(letters, offset)
@@ -255,6 +255,31 @@ measure_text <- function(label, gp = gpar(), ppi = 72,
   return(ans)
 }
 
+# This is a simpler version of measure_text for expressions only
+
+measure_exp <- function(label, gp = gpar(), ppi = 72, vjust = 0.5)
+{
+  size <- gp$fontsize %||% 11
+  if(length(size) != length(label) & length(size) != 1)
+  {
+    stop("The fontsize vector in gpar does not match the number of labels.")
+  }
+  width  <- convertUnit(stringWidth(label), unitTo = "in", valueOnly = TRUE)
+  height <- convertUnit(stringHeight(label), unitTo = "in", valueOnly = TRUE)
+  width  <- width * size / 11
+  height <- height * size / 11
+  ymin   <- -(height * (vjust - 0.5))
+  lapply(seq_along(label), function(i) {
+    structure(list(glyph = label[i],
+                   xmin = 0,
+                   xmid = width[i] / 2,
+                   xmax = width[i],
+                   y_id = 1),
+              offset = ymin,
+              metrics = list(width = width[i]))
+  })
+}
+
 #' Get anchor points
 #'
 #' This is a helper function that calculates for every offset what the anchor
@@ -315,7 +340,7 @@ measure_text <- function(label, gp = gpar(), ppi = 72,
 #' NULL
 .project_text <- function(text, offset) {
   arclength <- offset$arc_length
-  index <- x <- unlist(text[, c("xmin", "xmid", "xmax")])
+  index <- x <- unlist(text[c("xmin", "xmid", "xmax")])
   membr <- rep(text$y_id, 3)
 
   # Find indices along arc lengths
@@ -341,7 +366,8 @@ measure_text <- function(label, gp = gpar(), ppi = 72,
 
   # Restore dimensions
   # Column 1 comes from `xmin`, 2 from `xmid` and 3 from `xmax`
-  dim(old_len) <- dim(new_x) <- dim(new_y) <- dim(lengs) <- c(nrow(text), 3)
+  nrows <- length(text$glyph) # nrow(text) will return null for expressions
+  dim(old_len) <- dim(new_x) <- dim(new_y) <- dim(lengs) <- c(nrows, 3)
 
   # Calculate text angles
   dx <- new_x[, 3] - new_x[, 1]

R/grob_textpath.R

@@ -93,7 +93,19 @@ textpathGrob <- function(
 
   # Reconstitute data
   gp_text <- gp_fill_defaults(gp_text)
-  label   <- measure_text(label, gp_text, vjust = vjust, halign = halign)
+
+  if(length(gp_text$fontsize) == 1) {
+    gp_text$fontsize <- rep(gp_text$fontsize, n_label)
+  }
+
+  if(is.language(label))
+  {
+    label <- measure_exp(label, gp_text, vjust = vjust)
+
+  } else {
+    label <- as.character(label)
+    label <- measure_text(label, gp_text, vjust = vjust, halign = halign)
+  }
 
   if (!is.unit(x)) {
     x <- unit(x, default.units)
@@ -151,15 +163,17 @@ makeContent.textpath <- function(x) {
   }
   x$textpath <- NULL
 
-
   ## ---- Data manipulation -------------------------------------------- #
 
+  path$size <- rep(v$gp_text$fontsize, run_len(path$id))
+
   # Get gradients, angles and path lengths for each group
   path <- split(path, path$id)
 
+  wid <- sapply(v$label, function(x) max(x$xmax, na.rm = TRUE))
+
   # Handle point-like textpaths
-  if(any({singletons <- vapply(path, nrow, integer(1)) == 1})){
-    wid <- vapply(v$label, function(x) max(x$xmax, na.rm = TRUE), numeric(1))
+  if (any({singletons <- sapply(path, nrow) == 1})) {
     path[singletons] <- Map(.pathify,
                             data    = path[singletons],
                             hjust   = v$hjust[singletons],
@@ -177,17 +191,15 @@ makeContent.textpath <- function(x) {
     p
   })
 
+
   # Get the actual text string positions and angles for each group
   text <- Map(
-    .get_path_points,
-    path = path, label = v$label,
-    hjust = v$hjust, halign = v$halign,
-    flip_inverted = v$flip_inverted
-  )
+      .get_path_points,
+      path = path, label = v$label,
+      hjust = v$hjust, halign = v$halign,
+      flip_inverted = v$flip_inverted
+    )
   text_lens <- vapply(text, nrow, integer(1))
-
-  ## ---- Build text grob ---------------------------------------------- #
-
   text <- rbind_dfs(text)
 
   if (!all(v$gp_path$lty %in% c("0", "blank", NA))) {
@@ -327,3 +339,6 @@ dedup_path <- function(x, y, id, tolerance = 1000 * .Machine$double.eps) {
    data$y <- y
    data
 }
+
+
+

R/utils.R

@@ -136,3 +136,19 @@ approx_multiple <- function(x, xout, y = matrix()) {
 
   approx(seq_along(x), x, seq_along(x))$y
 }
+
+
+
+safe_parse <- function (text)
+{
+  if (!is.character(text)) stop("`text` must be a character vector")
+
+  out <- vector("expression", length(text))
+  for (i in seq_along(text)) {
+      expr <- parse(text = text[[i]])
+      out[[i]] <- if (length(expr) == 0)
+          NA
+      else expr[[1]]
+  }
+  out
+}

tests/testthat/test-textpathgrob.R

@@ -37,6 +37,16 @@ test_that("textpathGrobs can be created", {
                              angle = 0,
                              polar_params = list(x = .5, y = .5, theta = "x")))
 
+  # Plotmath expression with point-like path
+  expect_silent(textpathGrob(label = expression(paste("y = ", x^2))))
+
+  # Plotmath expressions with paths
+  expect_silent(textpathGrob(label = c(expression(paste("y = ", x^2)),
+                                      expression(paste("x = ", y^2))),
+                              x = c(0, 1, 0, 1),
+                              y = c(0, 1, 0, 0.5),
+                              id = c(1, 1, 2, 2)))
+
   # Error should be thrown with invalid input
   expect_error(textpathGrob(label = c("Hello", "World", "lorem", "ipsum"),
                              x = c(0, 1, 1.5, 2, 3, 4),