plot.ped() gains new argument foldLabs

* Add examples

R/ped_plot.R

@@ -65,6 +65,15 @@
 #' # Rename some individuals
 #' plot(x, labs = c(FATHER = "fa", "boy"))
 #'
+#' # By default, long names are folded to width ~12 characters
+#' plot(x, labs = c("Very long father's name" = "fa"), margin = 2)
+#'
+#' # Folding width may be adjusted ...
+#' plot(x, labs = c("Very long father's name" = "fa"), foldLabs = 6)
+#'
+#' # ... or switched off (requires larger margin!)
+#' plot(x, labs = c("Very long father's name" = "fa"), foldLabs = FALSE)
+#'
 #' # By default, labels are trimmed for initial/trailing line breaks ...
 #' plot(x, labs = c("\nFA" = "fa"))
 #'

R/plot_internal.R

@@ -100,6 +100,10 @@
 #'   as a DAG, i.e., with arrows connecting parent-child pairs.
 #' @param labs A vector or function controlling the individual labels in the
 #'   plot. By default, `labels(x)` are used. See Details for valid formats.
+#' @param foldLabs A number or function controlling the folding of long labels.
+#'   If a number, line breaks are inserted at roughly this width, trying to
+#'   break at break-friendly characters. If a function, this is applied to each
+#'   label.
 #' @param trimLabs A logical, by default TRUE. Removes line breaks and tabs from
 #'   both ends of the labels (after adding genotypes, if `marker` is not NULL).
 #' @param cex Expansion factor controlling font size. This also affects symbol
@@ -268,7 +272,7 @@ NULL
 #' @rdname internalplot
 #' @export
 .pedAnnotation = function(x, title = NULL, marker = NULL, sep = "/", missing = "-", showEmpty = FALSE,
-                          labs = labels(x), trimLabs = TRUE, col = 1, fill = NA, lty = 1, lwd = 1,
+                          labs = labels(x), foldLabs = 12, trimLabs = TRUE, col = 1, fill = NA, lty = 1, lwd = 1,
                           hatched = NULL, hatchDensity = 25, aff = NULL, carrier = NULL,
                           deceased = NULL, starred = NULL, textAnnot = NULL,
                           textInside = NULL, textAbove = NULL, fouInb = "autosomal", ...) {
@@ -293,6 +297,12 @@ NULL
 
   textu = .prepLabs(x, labs)
 
+  # Fold
+  if(isCount(foldLabs))
+    textu = vapply(textu, function(s) smartfold(s, width = foldLabs), FUN.VALUE = "")
+  else if(is.function(foldLabs))
+    textu = vapply(textu, foldLabs, FUN.VALUE = "")
+
   # Add stars to labels
   if(is.function(starred))
     starred = starred(x)

R/utils.R

@@ -139,3 +139,33 @@ listIdentical = function(x) {
     return(TRUE)
   all(vapply(x[-1], identical, y = x[[1]], logical(1)))
 }
+
+
+# Fold a single string at roughly the given width; try to break at nice places
+# TODO: Not optimised (and probably reinventing the wheel here).
+# Better idea: Start with strsplit(s, "")
+smartfold = function(s, width = 10, breakAt = c(' ', '-', '.', ':', ')', ']')) {
+  width = as.integer(max(width, 2))
+  nch = nchar(s)
+  if(nch < width + 3)
+    return(s)
+
+  res = character(0)
+  remaining = s
+  while(nch >= width + 3) {
+    b = width # default next brea, if no better
+    for (ch in breakAt) {
+      pos = gregexpr(ch, remaining, fixed = TRUE)[[1]] |> as.integer() # all positions
+      goodpos = pos[pos >= width - 2 & pos <= width + 3 & pos <= nch - 3]
+      if(length(goodpos)) {
+        b = max(goodpos)
+        break
+      }
+    }
+    res = c(res, substr(remaining, 1, b))
+    remaining = substr(remaining, b + 1, nch)
+    nch = nchar(remaining)
+  }
+  res = c(res, remaining)
+  paste0(res, collapse = "\n")
+}