Merge pull request #35 from adayim/revert

Minor bug fix and simple markup support.

Author: adayim

NEWS.md

@@ -1,7 +1,8 @@
 # consort 1.2.3
 
 -   Allow user configuration of arrow graphical parameters and padding with `set_consort_defaults()`.
--   Allow custom bullet characters
+-   Allow custom bullet characters.
+-   Allow simple markup for bold, italic and superscript.
 -   Figure styles will also be applied to grViz plot.
 -   Improved documentation. 
 -   Special thanks to @Ramsas88

R/build_grid.R

@@ -6,7 +6,7 @@
 #'  \code{\link{build_grviz}} or \code{plot(g, grViz = TRUE)} for 
 #' multiple split nodes instead.
 #'
-#' @param x A conosrt object.
+#' @param x A consort object.
 #' 
 #' @return A \code{gList} object
 #' @export 
@@ -54,13 +54,16 @@ build_grid <- function(x) {
   nodes_coord$y <- (vp_height - nodes_coord$y)/vp_height
 
   if(any(grepl("label", names(x)))){
-    label_coord <- calc_coords_label(label_plot, 
-                                     nodes_coord$nd_y, 
+    label_coord <- calc_coords_label(label_plot,
+                                     nodes_coord$nd_y,
                                      max_h = nodes_coord$max_height)
     vp_width <- sum(label_coord$width[1], vp_width)
 
     nodes_coord$x <- (nodes_coord$x + label_coord$width[1])/vp_width
-    
+
+    # Convert label x from char units to NPC so they scale with the viewport
+    label_coord$x <- label_coord$x / vp_width
+
   }else{
     nodes_coord$x <- (nodes_coord$x)/vp_width
   }
@@ -72,22 +75,17 @@ build_grid <- function(x) {
                   y = unit(nodes_coord$y[i], "npc"))
     r$name <- i
 
-    # Skep empty side box
+    # Skip empty side box
     if(is_empty(consort_plot[[i]]$text))
       return(NULL)
 
     return(r)
   }, simplify = FALSE)
 
+  grobs_list <- gList()
   for (i in seq_along(nodes)) {
-    if(is.null(nodes[[i]]))
-      next
-    
-    if (i == 1) {
-      grobs_list <- gList(gList(), nodes[[i]])
-    } else {
+    if(!is.null(nodes[[i]]))
       grobs_list <- gList(grobs_list, nodes[[i]])
-    }
   }
 
   # Connections
@@ -115,28 +113,22 @@ build_grid <- function(x) {
     for(i in seq_along(label_plot)){
       nam <- names(label_plot)[i]
       r <- move_box(label_plot[[nam]]$box,
-                    x = unit(label_coord$x[nam], "char"),
+                    x = unit(label_coord$x[nam], "npc"),
                     y = unit(label_coord$y[nam], "npc"))
       r$name <- nam
 
-      if (i == 1) {
-        lab_grobs <- gList(gList(), r)
-      } else {
-        lab_grobs <- gList(lab_grobs, r)
-      }
+      lab_grobs <- if (i == 1) gList(r) else gList(lab_grobs, r)
     }
 
     grobs_list <- gList(grobs_list, lab_grobs)
 
   }
 
-  grobTree(grobs_list, 
+  grobTree(grobs_list,
            name = "consort",
            vp = viewport(width = unit(0.98, "npc"),
                          height = unit(0.98, "npc")))
-  
-  # return(grobs_list)
-  
+
 }
 
 

R/defaults.R

@@ -11,7 +11,8 @@ consort_defaults_settings <- list(
     arrow_length = 0.1,
     arrow_type = "closed",
     pad_u = 3,
-    bullet = "\u2022"
+    bullet = "\u2022",
+    parse_markup = FALSE
 )
 
 consort_global$defaults <- consort_defaults_settings
@@ -36,6 +37,10 @@ consort_opt <- function(name) {
 #' @param arrow_type Character, arrow type: \code{"closed"} or \code{"open"}.
 #' @param pad_u Numeric, padding between nodes.
 #' @param bullet Character, bullet character for side box items.
+#' @param parse_markup Logical, whether to parse lightweight markup syntax
+#'   (\code{**bold**}, \code{*italic*}, \code{^{superscript}},
+#'   \code{_{subscript}}, \code{__underline__}) in node labels.
+#'   Default is \code{FALSE}.
 #'
 #' @return Invisibly returns the previous defaults (a \code{consort_defaults} object).
 #' @export
@@ -63,7 +68,8 @@ set_consort_defaults <- function(
     arrow_length = NULL,
     arrow_type = NULL,
     pad_u = NULL,
-    bullet = NULL
+    bullet = NULL,
+    parse_markup = NULL
 ) {
 
   old <- get_consort_defaults()
@@ -78,7 +84,8 @@ set_consort_defaults <- function(
     arrow_length = arrow_length,
     arrow_type   = arrow_type,
     pad_u        = pad_u,
-    bullet       = bullet
+    bullet       = bullet,
+    parse_markup = parse_markup
   )
 
   # Keep only non-NULL arguments
@@ -117,6 +124,11 @@ set_consort_defaults <- function(
       stop("`bullet` must be a single character string.")
   }
 
+  if (!is.null(parse_markup)) {
+    if (!is.logical(parse_markup) || length(parse_markup) != 1 || is.na(parse_markup))
+      stop("`parse_markup` must be a single TRUE/FALSE value.")
+  }
+
   # Update stored defaults
   consort_global$defaults <- utils::modifyList(consort_global$defaults, args)
 

R/grid_util.R

@@ -14,7 +14,7 @@ calc_y_coords <- function(consort_plot, nodes_layout, pad_u) {
       prev_bt <- max(heights)
     } else {
       # Extra padding when column count changes (split/merge transition)
-      extra_pad <- if (length(nd_y[[i]]) != length(nd_y[[i - 1]])) 2 * pad_u else pad_u
+      extra_pad <- if (length(heights) != length(nd_y[[i - 1]])) 2 * pad_u else pad_u
       nd_y[[i]] <- prev_bt + extra_pad + heights / 2
       prev_bt <- prev_bt + extra_pad + max(heights)
     }
@@ -275,10 +275,12 @@ gp_consecutive <- function(x){
   int <- 1
   gp <- vector("character", length = length(x))
   gp[1] <- letters[int]
-  for(i in 2:length(x)){
-    if(x[i] != x[i-1])
-      int <- int + 1
-    gp[i] <- letters[int]
+  if(length(x) > 1){
+    for(i in 2:length(x)){
+      if(x[i] != x[i-1])
+        int <- int + 1
+      gp[i] <- letters[int]
+    }
   }
   return(gp)
 }

R/grviz_util.R

@@ -128,22 +128,36 @@ mk_invs_connect <- function(x){
 # Make text alignment
 #' @keywords internal
 mk_text_align <- function(text, just, group = NULL, grviz_style = NULL){
-  # If empty
-  # if(is_empty(text))
-  #   return("")
-
-  jst <- ifelse(just == "center", "",
-                ifelse(just == "left", "\\l", "\r"))
-
-  if(just %in% c("left", "right")){
-    text <- unlist(strsplit(text, "\n"))
-    text <- ifelse(just == "left",
-                   paste(text, collapse = "\\l"),
-                   paste(text, collapse = "\r"))
+
+  if (has_markup(text)) {
+    # Graphviz HTML-like label: <html> instead of "plain"
+    html <- markup_to_html(text)
+
+    if (just == "left") {
+      html <- gsub("<br/>", '<br align="left"/>', html, fixed = TRUE)
+      html <- paste0(html, '<br align="left"/>')
+    } else if (just == "right") {
+      html <- gsub("<br/>", '<br align="right"/>', html, fixed = TRUE)
+      html <- paste0(html, '<br align="right"/>')
+    }
+
+    attr_parts <- sprintf("label = <%s>", html)
+  } else {
+    # Original plain-text label
+    jst <- ifelse(just == "center", "",
+                  ifelse(just == "left", "\\l", "\r"))
+
+    if(just %in% c("left", "right")){
+      text <- unlist(strsplit(text, "\n"))
+      text <- ifelse(just == "left",
+                     paste(text, collapse = "\\l"),
+                     paste(text, collapse = "\r"))
+    }
+
+    attr_parts <- sprintf('label = "%s%s"', text, jst)
   }
 
   # Build attributes
-  attr_parts <- sprintf('label = "%s%s"', text, jst)
   if(!is.null(group)) attr_parts <- paste(attr_parts, sprintf("group=%s", group))
   if(!is.null(grviz_style)) attr_parts <- paste(attr_parts, grviz_style)