diff --git a/NEWS.md b/NEWS.md index d5f1df0..0e38233 100644 --- a/NEWS.md +++ b/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 diff --git a/R/build_grid.R b/R/build_grid.R index cc354eb..1fe7773 100644 --- a/R/build_grid.R +++ b/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) - + } diff --git a/R/defaults.R b/R/defaults.R index 100c3db..0d43a54 100644 --- a/R/defaults.R +++ b/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) diff --git a/R/grid_util.R b/R/grid_util.R index 7928eb5..ddc1269 100644 --- a/R/grid_util.R +++ b/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) } \ No newline at end of file diff --git a/R/grviz_util.R b/R/grviz_util.R index a3413d1..0139bdc 100644 --- a/R/grviz_util.R +++ b/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: instead of "plain" + html <- markup_to_html(text) + + if (just == "left") { + html <- gsub("
", '
', html, fixed = TRUE) + html <- paste0(html, '
') + } else if (just == "right") { + html <- gsub("
", '
', html, fixed = TRUE) + html <- paste0(html, '
') + } + + 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) diff --git a/R/markup.R b/R/markup.R new file mode 100644 index 0000000..9c493f8 --- /dev/null +++ b/R/markup.R @@ -0,0 +1,177 @@ +# Markup parsing and conversion utilities +# +# Supported markup syntax: +# **bold** -> bold text +# *italic* -> italic text +# ^{superscript} -> superscript text +# _{subscript} -> subscript text +# __underline__ -> underlined text + +# Check if markup parsing is enabled and text contains markup patterns +#' @keywords internal +has_markup <- function(text) { + if (!isTRUE(consort_opt("parse_markup"))) + return(FALSE) + if (is.null(text) || !is.character(text) || length(text) != 1 || + is.na(text) || !nzchar(text)) + return(FALSE) + grepl("\\*\\*.+?\\*\\*|__.+?__|\\*.+?\\*|\\^\\{.+?\\}|_\\{.+?\\}", + text, perl = TRUE) +} + +# Parse markup text into a list of segments +# Each segment is list(text = "...", style = "plain"|"bold"|"italic"|...) +#' @keywords internal +parse_markup <- function(text) { + if (is.null(text) || !nzchar(text)) { + return(list(list(text = "", style = "plain"))) + } + + # Combined pattern — order matters: ** before *, __ before _{} + pattern <- "\\*\\*(.+?)\\*\\*|__(.+?)__|\\*(.+?)\\*|\\^\\{(.+?)\\}|_\\{(.+?)\\}" + + matches <- gregexpr(pattern, text, perl = TRUE)[[1]] + + if (matches[1] == -1) { + return(list(list(text = text, style = "plain"))) + } + + match_starts <- as.integer(matches) + match_lengths <- attr(matches, "match.length") + + segments <- list() + pos <- 1L + + for (i in seq_along(match_starts)) { + # Plain text before this match + if (match_starts[i] > pos) { + segments <- c(segments, list(list( + text = substr(text, pos, match_starts[i] - 1L), + style = "plain" + ))) + } + + matched <- substr(text, match_starts[i], + match_starts[i] + match_lengths[i] - 1L) + + # Determine which alternative matched + if (grepl("^\\*\\*(.+?)\\*\\*$", matched, perl = TRUE)) { + inner <- sub("^\\*\\*(.+?)\\*\\*$", "\\1", matched, perl = TRUE) + segments <- c(segments, list(list(text = inner, style = "bold"))) + + } else if (grepl("^__(.+?)__$", matched, perl = TRUE)) { + inner <- sub("^__(.+?)__$", "\\1", matched, perl = TRUE) + segments <- c(segments, list(list(text = inner, style = "underline"))) + + } else if (grepl("^\\*(.+?)\\*$", matched, perl = TRUE)) { + inner <- sub("^\\*(.+?)\\*$", "\\1", matched, perl = TRUE) + segments <- c(segments, list(list(text = inner, style = "italic"))) + + } else if (grepl("^\\^\\{(.+?)\\}$", matched, perl = TRUE)) { + inner <- sub("^\\^\\{(.+?)\\}$", "\\1", matched, perl = TRUE) + segments <- c(segments, list(list(text = inner, style = "superscript"))) + + } else if (grepl("^_\\{(.+?)\\}$", matched, perl = TRUE)) { + inner <- sub("^_\\{(.+?)\\}$", "\\1", matched, perl = TRUE) + segments <- c(segments, list(list(text = inner, style = "subscript"))) + } + + pos <- match_starts[i] + match_lengths[i] + } + + # Remaining text after last match + if (pos <= nchar(text)) { + segments <- c(segments, list(list( + text = substr(text, pos, nchar(text)), + style = "plain" + ))) + } + + segments +} + +# Split parsed segments into lines at \n boundaries in plain segments +#' @keywords internal +split_segments_by_newline <- function(segments) { + lines <- list() + current_line <- list() + + for (seg in segments) { + if (seg$style == "plain" && grepl("\n", seg$text, fixed = TRUE)) { + # Sentinel preserves trailing empty strings dropped by strsplit + parts <- strsplit(paste0(seg$text, "\a"), "\n", fixed = TRUE)[[1]] + parts[length(parts)] <- sub("\a$", "", parts[length(parts)]) + + for (j in seq_along(parts)) { + if (j > 1L) { + # Close current line + if (length(current_line) == 0L) + current_line <- list(list(text = "", style = "plain")) + lines[[length(lines) + 1L]] <- current_line + current_line <- list() + } + if (nzchar(parts[j])) { + current_line[[length(current_line) + 1L]] <- + list(text = parts[j], style = "plain") + } + } + } else { + current_line[[length(current_line) + 1L]] <- seg + } + } + + # Final line + if (length(current_line) == 0L) + current_line <- list(list(text = "", style = "plain")) + lines[[length(lines) + 1L]] <- current_line + + lines +} + +# Build a grid gpar for a given markup style, based on a base gpar +#' @keywords internal +segment_gpar <- function(style, base_gp) { + if (is.null(base_gp)) base_gp <- gpar() + gp <- base_gp + if (style == "bold") { + gp$fontface <- "bold" + } else if (style == "italic") { + gp$fontface <- "italic" + } else if (style %in% c("superscript", "subscript")) { + cex <- if (is.null(gp$cex)) 1 else gp$cex + gp$cex <- cex * 0.7 + } + gp +} + +# Convert markup text to HTML for Graphviz HTML-like labels +#' @keywords internal +markup_to_html <- function(text) { + if (is.null(text) || !nzchar(text)) return(text) + + # Escape HTML special characters first + text <- gsub("&", "&", text, fixed = TRUE) + text <- gsub("<", "<", text, fixed = TRUE) + text <- gsub(">", ">", text, fixed = TRUE) + + # Replace markup with HTML tags (order: ** before *, __ before _{}) + text <- gsub("\\*\\*(.+?)\\*\\*", "\\1", text, perl = TRUE) + text <- gsub("__(.+?)__", "\\1", text, perl = TRUE) + text <- gsub("\\*(.+?)\\*", "\\1", text, perl = TRUE) + text <- gsub("\\^\\{(.+?)\\}", "\\1", text, perl = TRUE) + text <- gsub("_\\{(.+?)\\}", "\\1", text, perl = TRUE) + + # Duplicate the space after bold/italic/underline closing tags: one copy + + # inside the tag (measured with the styled font metrics) and the original + # outside. Graphviz tends to underestimate node width when mixing styled + # and plain text; the extra space compensates for the difference. + text <- gsub(" ", " ", text, fixed = TRUE) + text <- gsub(" ", " ", text, fixed = TRUE) + text <- gsub(" ", " ", text, fixed = TRUE) + + # Newlines to
+ text <- gsub("\n", "
", text, fixed = TRUE) + + text +} diff --git a/R/textbox.R b/R/textbox.R index 5b192ff..b32f229 100644 --- a/R/textbox.R +++ b/R/textbox.R @@ -76,6 +76,10 @@ grid.textbox <- function(...) { } get_hw <- function(x) { + if (has_markup(x$label)) { + return(get_hw_formatted(x)) + } + t <- textGrob(label = x$label, gp = x$txt_gp) # Add padding padding <- unit(1 * ifelse(is.null(x$txt_gp$cex), 1, @@ -89,6 +93,41 @@ get_hw <- function(x) { list(width = width, height = height) } +# Measure width/height for formatted (markup) text +get_hw_formatted <- function(x) { + segments <- parse_markup(x$label) + lines <- split_segments_by_newline(segments) + + cex <- ifelse(is.null(x$txt_gp$cex), 1, x$txt_gp$cex) + padding <- unit(1 * cex, "char") + + # Width of each line in inches + line_widths <- sapply(lines, function(line_segs) { + sum(sapply(line_segs, function(seg) { + gp <- segment_gpar(seg$style, x$txt_gp) + t <- textGrob(label = seg$text, gp = gp) + convertWidth(grobWidth(t), "inches", valueOnly = TRUE) + })) + }) + + width <- convertWidth(unit(max(line_widths), "inches"), "char") + padding + + # Height from a dummy multi-line textGrob (correct line spacing) + n_lines <- length(lines) + dummy_text <- paste(rep("Xg", n_lines), collapse = "\n") + dummy <- textGrob(label = dummy_text, gp = x$txt_gp) + height <- convertHeight(grobHeight(dummy), "char") + padding + + # Extra room for super/subscript offsets + has_ss <- any(sapply(segments, function(s) + s$style %in% c("superscript", "subscript"))) + if (has_ss) { + height <- height + unit(0.3 * cex, "char") + } + + list(width = width, height = height) +} + #' @export makeContext.textbox <- function(x) { hw <- get_hw(x) @@ -114,21 +153,26 @@ makeContent.textbox <- function(x) { # Add padding padding <- unit(3 * ifelse(is.null(x$txt_gp$cex), 1, x$txt_gp$cex), "mm") - # Align text - tx_x <- switch(x$just, - "right" = unit(1, "npc") - 0.5 * padding, - "left" = 0.5 * padding, - "center" = unit(.5, "npc") - ) + if (has_markup(x$label)) { + text_grobs <- make_formatted_content(x) + } else { + # Align text + tx_x <- switch(x$just, + "right" = unit(1, "npc") - 0.5 * padding, + "left" = 0.5 * padding, + "center" = unit(.5, "npc") + ) - t <- textGrob( - label = x$label, - x = tx_x, - y = 0.5, - just = x$just, - gp = x$txt_gp, - name = paste0(x$name, ".text") - ) + t <- textGrob( + label = x$label, + x = tx_x, + y = 0.5, + just = x$just, + gp = x$txt_gp, + name = paste0(x$name, ".text") + ) + text_grobs <- gList(t) + } hw <- get_hw(x) @@ -141,7 +185,86 @@ makeContent.textbox <- function(x) { name = paste0(x$name, ".box") )) - setChildren(x, gList(rr, t)) + setChildren(x, do.call(gList, c(list(rr), as.list(text_grobs)))) +} + +# Render formatted (markup) text as positioned grid grobs +make_formatted_content <- function(x) { + segments <- parse_markup(x$label) + lines <- split_segments_by_newline(segments) + n_lines <- length(lines) + + cex <- ifelse(is.null(x$txt_gp$cex), 1, x$txt_gp$cex) + padding <- unit(3 * cex, "mm") + + grob_list <- list() + + for (i in seq_along(lines)) { + line_segs <- lines[[i]] + + # Vertical position: evenly distribute lines top-to-bottom + y_frac <- 1 - (2 * i - 1) / (2 * n_lines) + y_base <- unit(y_frac, "npc") + + # Measure each segment width (in inches, resolved now) + seg_info <- lapply(seq_along(line_segs), function(j) { + seg <- line_segs[[j]] + gp <- segment_gpar(seg$style, x$txt_gp) + tg <- textGrob(seg$text, gp = gp, just = "left") + w <- convertWidth(grobWidth(tg), "inches", valueOnly = TRUE) + list(grob = tg, style = seg$style, width_in = w) + }) + + total_width_in <- sum(sapply(seg_info, "[[", "width_in")) + + # Horizontal start position based on justification + start_x <- switch(x$just, + "center" = unit(0.5, "npc") - unit(total_width_in / 2, "inches"), + "left" = padding * 0.5, + "right" = unit(1, "npc") - padding * 0.5 - unit(total_width_in, "inches"), + unit(0.5, "npc") - unit(total_width_in / 2, "inches") + ) + + cum_x_in <- 0 + + for (j in seq_along(seg_info)) { + si <- seg_info[[j]] + + # Vertical offset for super/subscript + y_off <- switch(si$style, + "superscript" = unit(0.4 * cex, "char"), + "subscript" = unit(-0.3 * cex, "char"), + unit(0, "mm") + ) + + si$grob$x <- start_x + unit(cum_x_in, "inches") + si$grob$y <- y_base + y_off + si$grob$name <- sprintf("%s.text.%d.%d", x$name, i, j) + + grob_list[[length(grob_list) + 1L]] <- si$grob + + # Draw underline beneath the segment + if (si$style == "underline") { + seg_w <- unit(si$width_in, "inches") + ul_y <- y_base - unit(0.55 * cex, "char") + ul_x0 <- start_x + unit(cum_x_in, "inches") + ul <- segmentsGrob( + x0 = ul_x0, x1 = ul_x0 + seg_w, + y0 = ul_y, y1 = ul_y, + gp = gpar( + col = if (!is.null(x$txt_gp$col)) x$txt_gp$col else "black", + lwd = max(0.5, 0.8 * cex) + ), + name = sprintf("%s.ul.%d.%d", x$name, i, j) + ) + grob_list[[length(grob_list) + 1L]] <- ul + } + + cum_x_in <- cum_x_in + si$width_in + } + } + + do.call(gList, grob_list) } #' @export diff --git a/README.Rmd b/README.Rmd index cc2b45b..db94420 100644 --- a/README.Rmd +++ b/README.Rmd @@ -44,6 +44,7 @@ This is a basic example which shows you how to solve a create CONSORT diagram wi ```{r example} library(consort) +library(grid) ## basic example code ``` @@ -73,9 +74,12 @@ head(df) ```{r diagram, fig.width = 7, fig.height = 6} + +set_consort_defaults(txt_gp = gpar(cex = 0.6), parse_markup = TRUE) + out <- consort_plot(data = df, order = c(trialno = "Population", - exc = "Excluded", + exc = "**Excluded**", arm = "Randomized patient", fow1 = "Lost of Follow-up", trialno = "Finished Followup", @@ -84,15 +88,14 @@ out <- consort_plot(data = df, side_box = c("exc", "fow1", "fow2"), allocation = "arm", labels = c("1" = "Screening", "2" = "Randomization", - "5" = "Final"), - cex = 0.6) + "5" = "Final")) plot(out) ``` As the `grid` plotting is not very ideal, calculation of the coodinates for the nodes are not easy job and tried my best. Feel free to PR if you want to improve. Or you can produce `Graphviz` plot by setting `grViz = TRUE` in `plot`. This will use `DiagrammeR` to print the plot. The plot is ideal for Shiny or HTML output. -```{r} +```{r eval=FALSE} plot(out, grViz = TRUE) ``` diff --git a/README.md b/README.md index c19f138..e76e412 100644 --- a/README.md +++ b/README.md @@ -43,6 +43,7 @@ diagram with a given subject disposition data: ``` r library(consort) +library(grid) ## basic example code ``` @@ -78,9 +79,12 @@ head(df) ``` ``` r + +set_consort_defaults(txt_gp = gpar(cex = 0.6), parse_markup = TRUE) + out <- consort_plot(data = df, order = c(trialno = "Population", - exc = "Excluded", + exc = "**Excluded**", arm = "Randomized patient", fow1 = "Lost of Follow-up", trialno = "Finished Followup", @@ -89,13 +93,13 @@ out <- consort_plot(data = df, side_box = c("exc", "fow1", "fow2"), allocation = "arm", labels = c("1" = "Screening", "2" = "Randomization", - "5" = "Final"), - cex = 0.6) + "5" = "Final")) +#> Please define this via `set_consort_defaults(txt_gp = gpar(cex = ...))` instead. plot(out) ``` - + As the `grid` plotting is not very ideal, calculation of the coodinates for the nodes are not easy job and tried my best. Feel free to PR if you @@ -107,8 +111,6 @@ The plot is ideal for Shiny or HTML output. plot(out, grViz = TRUE) ``` - - Or save this `Graphviz` plot to `png` or `pdf` ``` r diff --git a/man/figures/README-diagram-1.png b/man/figures/README-diagram-1.png index ef79930..66b20b4 100644 Binary files a/man/figures/README-diagram-1.png and b/man/figures/README-diagram-1.png differ diff --git a/man/set_consort_defaults.Rd b/man/set_consort_defaults.Rd index 25aada6..52d85c0 100644 --- a/man/set_consort_defaults.Rd +++ b/man/set_consort_defaults.Rd @@ -16,7 +16,8 @@ set_consort_defaults( arrow_length = NULL, arrow_type = NULL, pad_u = NULL, - bullet = NULL + bullet = NULL, + parse_markup = NULL ) get_consort_defaults() @@ -44,6 +45,11 @@ init_consort_defaults() \item{bullet}{Character, bullet character for side box items.} +\item{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}.} + \item{x}{A \code{consort_defaults} object.} \item{...}{Not used.} diff --git a/tests/testthat/_snaps/auto/autogen-last.png b/tests/testthat/_snaps/auto/autogen-last.png index 4725fdc..78d3f50 100644 Binary files a/tests/testthat/_snaps/auto/autogen-last.png and b/tests/testthat/_snaps/auto/autogen-last.png differ diff --git a/tests/testthat/_snaps/auto/autogen-nolab.png b/tests/testthat/_snaps/auto/autogen-nolab.png index db7778e..cf4c9d0 100644 Binary files a/tests/testthat/_snaps/auto/autogen-nolab.png and b/tests/testthat/_snaps/auto/autogen-nolab.png differ diff --git a/tests/testthat/_snaps/auto/autogen.png b/tests/testthat/_snaps/auto/autogen.png index 757a062..970917c 100644 Binary files a/tests/testthat/_snaps/auto/autogen.png and b/tests/testthat/_snaps/auto/autogen.png differ diff --git a/tests/testthat/_snaps/build_grviz/build-grviz-withopts.png b/tests/testthat/_snaps/build_grviz/build-grviz-withopts.png index 77e7a05..51fb2f2 100644 Binary files a/tests/testthat/_snaps/build_grviz/build-grviz-withopts.png and b/tests/testthat/_snaps/build_grviz/build-grviz-withopts.png differ diff --git a/tests/testthat/_snaps/build_grviz/build-grviz.png b/tests/testthat/_snaps/build_grviz/build-grviz.png index 586aad7..51ec68f 100644 Binary files a/tests/testthat/_snaps/build_grviz/build-grviz.png and b/tests/testthat/_snaps/build_grviz/build-grviz.png differ diff --git a/tests/testthat/_snaps/build_grviz/end-miss-grviz.png b/tests/testthat/_snaps/build_grviz/end-miss-grviz.png index 09d2ec2..89ddb4e 100644 Binary files a/tests/testthat/_snaps/build_grviz/end-miss-grviz.png and b/tests/testthat/_snaps/build_grviz/end-miss-grviz.png differ diff --git a/tests/testthat/_snaps/build_grviz/multi-miss-grviz.png b/tests/testthat/_snaps/build_grviz/multi-miss-grviz.png index 6367d19..43f70fa 100644 Binary files a/tests/testthat/_snaps/build_grviz/multi-miss-grviz.png and b/tests/testthat/_snaps/build_grviz/multi-miss-grviz.png differ diff --git a/tests/testthat/_snaps/manually/manually-gen.png b/tests/testthat/_snaps/manually/manually-gen.png index 4937434..e141553 100644 Binary files a/tests/testthat/_snaps/manually/manually-gen.png and b/tests/testthat/_snaps/manually/manually-gen.png differ diff --git a/tests/testthat/_snaps/multiple-split/multiple-split-nokick.png b/tests/testthat/_snaps/multiple-split/multiple-split-nokick.png index c24e4f7..e5eef5a 100644 Binary files a/tests/testthat/_snaps/multiple-split/multiple-split-nokick.png and b/tests/testthat/_snaps/multiple-split/multiple-split-nokick.png differ diff --git a/tests/testthat/_snaps/multiple-split/multiple-split.png b/tests/testthat/_snaps/multiple-split/multiple-split.png index 752981d..89ba893 100644 Binary files a/tests/testthat/_snaps/multiple-split/multiple-split.png and b/tests/testthat/_snaps/multiple-split/multiple-split.png differ diff --git a/tests/testthat/test-markup.R b/tests/testthat/test-markup.R new file mode 100644 index 0000000..6309b60 --- /dev/null +++ b/tests/testthat/test-markup.R @@ -0,0 +1,259 @@ + +# --- Parser tests ----------------------------------------------------------- + +test_that("has_markup returns FALSE when parse_markup is disabled", { + init_consort_defaults() + expect_false(has_markup("**bold**")) + expect_false(has_markup("*italic*")) +}) + +test_that("has_markup detects markup patterns when enabled", { + old <- set_consort_defaults(parse_markup = TRUE) + on.exit(set_consort_defaults(parse_markup = old$parse_markup), add = TRUE) + + expect_true(has_markup("**bold**")) + expect_true(has_markup("*italic*")) + expect_true(has_markup("^{super}")) + expect_true(has_markup("_{sub}")) + expect_true(has_markup("__underline__")) + expect_true(has_markup("text **with** markup")) + + expect_false(has_markup("plain text")) + expect_false(has_markup("")) + expect_false(has_markup(NULL)) + expect_false(has_markup(NA_character_)) +}) + +test_that("parse_markup handles plain text", { + segs <- parse_markup("hello world") + expect_length(segs, 1) + expect_equal(segs[[1]]$text, "hello world") + expect_equal(segs[[1]]$style, "plain") +}) + +test_that("parse_markup handles bold", { + segs <- parse_markup("**bold**") + expect_length(segs, 1) + expect_equal(segs[[1]]$text, "bold") + expect_equal(segs[[1]]$style, "bold") +}) + +test_that("parse_markup handles italic", { + segs <- parse_markup("*italic*") + expect_length(segs, 1) + expect_equal(segs[[1]]$text, "italic") + expect_equal(segs[[1]]$style, "italic") +}) + +test_that("parse_markup handles superscript and subscript", { + segs <- parse_markup("x^{2}") + expect_length(segs, 2) + expect_equal(segs[[1]]$text, "x") + expect_equal(segs[[2]]$text, "2") + expect_equal(segs[[2]]$style, "superscript") + + segs2 <- parse_markup("H_{2}O") + expect_length(segs2, 3) + expect_equal(segs2[[2]]$text, "2") + expect_equal(segs2[[2]]$style, "subscript") +}) + +test_that("parse_markup handles underline", { + segs <- parse_markup("__underline__") + expect_length(segs, 1) + expect_equal(segs[[1]]$text, "underline") + expect_equal(segs[[1]]$style, "underline") +}) + +test_that("parse_markup handles mixed markup", { + segs <- parse_markup("**Enrolled** (n=300)\n*p* < 0.05^{1}") + styles <- sapply(segs, "[[", "style") + texts <- sapply(segs, "[[", "text") + + expect_equal(styles, c("bold", "plain", "italic", "plain", "superscript")) + expect_equal(texts[[1]], "Enrolled") + expect_equal(texts[[3]], "p") + expect_equal(texts[[5]], "1") +}) + +test_that("parse_markup returns plain for empty/NULL", { + segs <- parse_markup("") + expect_equal(segs[[1]]$text, "") + expect_equal(segs[[1]]$style, "plain") + + segs2 <- parse_markup(NULL) + expect_equal(segs2[[1]]$text, "") +}) + +# --- Newline splitting ------------------------------------------------------- + +test_that("split_segments_by_newline splits plain text at newlines", { + segs <- list(list(text = "line1\nline2", style = "plain")) + lines <- split_segments_by_newline(segs) + expect_length(lines, 2) + expect_equal(lines[[1]][[1]]$text, "line1") + expect_equal(lines[[2]][[1]]$text, "line2") +}) + +test_that("split_segments_by_newline keeps non-plain segments intact", { + segs <- list( + list(text = "before\n", style = "plain"), + list(text = "bold", style = "bold"), + list(text = "\nafter", style = "plain") + ) + lines <- split_segments_by_newline(segs) + expect_length(lines, 3) + expect_equal(lines[[2]][[1]]$text, "bold") + expect_equal(lines[[2]][[1]]$style, "bold") +}) + +# --- HTML conversion --------------------------------------------------------- + +test_that("markup_to_html converts tags correctly", { + expect_equal(markup_to_html("**bold**"), "bold") + expect_equal(markup_to_html("*italic*"), "italic") + expect_equal(markup_to_html("^{sup}"), "sup") + expect_equal(markup_to_html("_{sub}"), "sub") + expect_equal(markup_to_html("__underline__"), "underline") +}) + +test_that("markup_to_html escapes HTML special characters", { + expect_equal(markup_to_html("a < b & c"), "a < b & c") + expect_equal(markup_to_html("**a < b**"), "a < b") +}) + +test_that("markup_to_html converts newlines to
", { + expect_equal(markup_to_html("a\nb"), "a
b") +}) + +test_that("markup_to_html duplicates space inside bold/italic/underline tags", { + # Space is duplicated: one inside the tag + one outside + expect_equal(markup_to_html("**bold** text"), "bold text") + expect_equal(markup_to_html("*italic* text"), "italic text") + expect_equal(markup_to_html("__underline__ text"), "underline text") + # No space after tag — nothing to duplicate + expect_equal(markup_to_html("**bold**\ntext"), "bold
text") +}) + +# --- segment_gpar ------------------------------------------------------------ + +test_that("segment_gpar sets fontface for bold/italic", { + base <- gpar(fontsize = 12) + expect_equal(segment_gpar("bold", base)$fontface, "bold") + expect_equal(segment_gpar("italic", base)$fontface, "italic") +}) + +test_that("segment_gpar scales cex for super/subscript", { + base <- gpar(cex = 1) + expect_equal(segment_gpar("superscript", base)$cex, 0.7) + expect_equal(segment_gpar("subscript", base)$cex, 0.7) +}) + +test_that("segment_gpar leaves plain text unchanged", { + base <- gpar(fontsize = 12) + gp <- segment_gpar("plain", base) + expect_null(gp$fontface) + expect_equal(gp$fontsize, 12) +}) + +# --- Grid rendering (smoke tests) ------------------------------------------- + +test_that("textbox with markup creates valid grob when enabled", { + old <- set_consort_defaults(parse_markup = TRUE) + on.exit(set_consort_defaults(parse_markup = old$parse_markup), add = TRUE) + + bx <- textbox(text = "**Enrolled** (n=300)") + expect_s3_class(bx, "textbox") + + bx2 <- textbox(text = "H_{2}O is *water*") + expect_s3_class(bx2, "textbox") +}) + +test_that("textbox with markup renders without error", { + old <- set_consort_defaults(parse_markup = TRUE) + on.exit(set_consort_defaults(parse_markup = old$parse_markup), add = TRUE) + + skip_on_ci() + png(tf <- tempfile(fileext = ".png"), width = 400, height = 200) + on.exit({ dev.off(); unlink(tf) }, add = TRUE) + + grid::grid.newpage() + expect_no_error(grid::grid.draw(textbox(text = "**Bold** and *italic*"))) + expect_no_error(grid::grid.draw( + textbox(text = "x^{2} + H_{2}O\n__underlined__", y = 0.3) + )) +}) + +test_that("textbox ignores markup when parse_markup is FALSE", { + init_consort_defaults() # parse_markup = FALSE + bx <- textbox(text = "**bold** text") + # label is stored as-is (not parsed) + expect_equal(bx$label, "**bold** text") +}) + +# --- grViz integration ------------------------------------------------------- + +test_that("mk_text_align uses HTML label for markup text when enabled", { + old <- set_consort_defaults(parse_markup = TRUE) + on.exit(set_consort_defaults(parse_markup = old$parse_markup), add = TRUE) + + result <- mk_text_align("**bold** text", just = "center") + expect_true(grepl("label = <", result, fixed = TRUE)) + # Space duplicated: one inside + one outside the bold tag + expect_true(grepl("bold ", result, fixed = TRUE)) +}) + +test_that("mk_text_align uses plain label without markup", { + init_consort_defaults() + result <- mk_text_align("plain text", just = "center") + expect_true(grepl('label = "', result, fixed = TRUE)) +}) + +test_that("mk_text_align uses plain label when parse_markup is FALSE", { + init_consort_defaults() # parse_markup = FALSE + result <- mk_text_align("**bold** text", just = "center") + expect_true(grepl('label = "', result, fixed = TRUE)) + expect_false(grepl("", result, fixed = TRUE)) +}) + +test_that("mk_text_align HTML label handles alignment", { + old <- set_consort_defaults(parse_markup = TRUE) + on.exit(set_consort_defaults(parse_markup = old$parse_markup), add = TRUE) + + result_left <- mk_text_align("**bold**\nmore", just = "left") + expect_true(grepl('align="left"', result_left, fixed = TRUE)) + + result_right <- mk_text_align("**bold**\nmore", just = "right") + expect_true(grepl('align="right"', result_right, fixed = TRUE)) +}) + +# --- Full pipeline (build_grviz) -------------------------------------------- + +test_that("build_grviz handles markup in nodes when enabled", { + old <- set_consort_defaults(parse_markup = TRUE) + on.exit(set_consort_defaults(parse_markup = old$parse_markup), add = TRUE) + + g <- add_box(txt = "**Enrolled** (n=300)") + g <- add_side_box(g, txt = "Excluded^{1} (n=15)") + g <- add_box(g, txt = "*Randomised*") + + txt <- build_grviz(g) + # Space duplicated: one inside + one outside the bold tag + expect_true(grepl("Enrolled ", txt, fixed = TRUE)) + expect_true(grepl("1", txt, fixed = TRUE)) + # No space after *Randomised* (end of text), so tag is unchanged + expect_true(grepl("Randomised", txt, fixed = TRUE)) +}) + +# --- set_consort_defaults validation ----------------------------------------- + +test_that("set_consort_defaults validates parse_markup", { + expect_error(set_consort_defaults(parse_markup = "yes"), + "parse_markup") + expect_error(set_consort_defaults(parse_markup = NA), + "parse_markup") + expect_error(set_consort_defaults(parse_markup = c(TRUE, FALSE)), + "parse_markup") +}) + +init_consort_defaults() diff --git a/vignettes/consort_diagram.Rmd b/vignettes/consort_diagram.Rmd index e4fd87c..2e9e4dd 100644 --- a/vignettes/consort_diagram.Rmd +++ b/vignettes/consort_diagram.Rmd @@ -11,8 +11,10 @@ vignette: > ```{r, include = FALSE} knitr::opts_chunk$set( + dpi = 300, collapse = TRUE, - comment = "#>" + comment = "#>", + message = FALSE ) ``` @@ -116,11 +118,84 @@ The package has some default settings for the line width, color, arrow type and get_consort_defaults() ``` +The available options are: + +| Option | Type | Default | Description | +|---|---|---|---| +| `arrow_gp` | `gpar()` | `gpar(col = "black", lwd = 1)` | Graphical parameters for arrows (colour, line width, line type, etc.). | +| `txt_gp` | `gpar()` | `gpar(cex = 1, col = "black")` | Graphical parameters for the text inside boxes (font size, colour, font family, etc.). | +| `box_gp` | `gpar()` | `gpar(fill = "white")` | Graphical parameters for the box border and fill colour. | +| `label_txt_gp` | `gpar()` | `gpar(col = "#4F81BD", cex = 1, fontface = "bold")` | Graphical parameters for the phase/stage label text. | +| `label_box_gp` | `gpar()` | `gpar(fill = "#A9C7FD")` | Graphical parameters for the phase/stage label box. | +| `arrow_length` | numeric | `0.1` | Length of the arrowhead in inches. | +| `arrow_type` | character | `"closed"` | Arrow type: `"closed"` (filled) or `"open"`. | +| `pad_u` | numeric | `3` | Padding between nodes (in grid unit multiples). | +| `bullet` | character | `"\u2022"` | Bullet character used in side box item lists (e.g. `"\u2013"` for en-dash, `"-"` for hyphen). | +| `parse_markup` | logical | `FALSE` | Whether to parse lightweight markup (`**bold**`, `*italic*`, etc.) in node labels. See [Text formatting with markup] below. | + +The `gpar()` options are merged with the existing defaults, so you only need to specify the properties you want to change. Previous settings can be restored by capturing the return value: + +```{r set-restore, eval = FALSE} +set_consort_defaults(arrow_gp = gpar(col = "red", lwd = 2)) +# ... draw diagram ... +init_consort_defaults() # restore +``` + + +# Text formatting with markup + +Node labels support a lightweight markup syntax for text formatting. This works with both the `grid` and `Graphviz` rendering backends. Markup parsing is **off by default**; enable it with: + +```r +set_consort_defaults(parse_markup = TRUE) +``` + +The following styles are available: + +| Markup | Result | +|---|---| +| `**text**` | **Bold** | +| `*text*` | *Italic* | +| `^{text}` | Superscript | +| `_{text}` | Subscript | +| `__text__` | Underline | + +Markup can be mixed with plain text and line breaks (`\n`) as usual. + + +*Note*: the markup may not be perfect. There is known issue with Graphviz that the combination of bold and normal text may not render correctly and it may overlap with the surrounding text. If you encounter this issue, you can try to add some extra space around the styled text. + + + +## Example + +```{r markup-grid, fig.width = 7, fig.height = 5, out.width="70%"} +library(grid) +set_consort_defaults(txt_gp = gpar(cex = 0.8), parse_markup = TRUE) + +g <- add_box(txt = "**Patients screened** (n=300)") |> + add_side_box(txt = "Excluded^{1} (n=15):\n\u2022 MRI not collected (n=3)\n\u2022 Other (n=12)") |> + add_box(txt = "__Randomised__ (n=285)") |> + add_split(txt = c("*Arm A* (n=143)", "*Arm B* (n=142)")) |> + add_box(txt = c("Analysed (n=128)", "Analysed (n=135)")) |> + add_label_box(txt = c("1" = "Screening", "3" = "Randomisation")) +plot(g) +``` + +The same diagram can be rendered with `Graphviz`: + +```{r markup-grviz, out.width="70%", fig.width = 3, fig.height = 1.5} +plot(g, grViz = TRUE) +``` + +Formatting is applied per-segment, so you can combine styles within a single label — for example `"**Enrolled** (n=300)\n*p* < 0.05^{1}"` renders "Enrolled" in bold, "p" in italic, and "1" as a superscript footnote marker. + +Plain text without any markup is rendered exactly as before. # Working example (self generation) ## Single arm -```{r single-arms, message=FALSE, fig.width = 6, fig.height = 6} +```{r single-arms, fig.width = 6, fig.height = 6, out.width="70%"} out <- consort_plot(data = dispos.data, orders = c(trialno = "Population", exclusion = "Excluded", @@ -136,7 +211,7 @@ plot(out) ## Multiple phase and multiple arms -```{r multiple-phase, fig.width = 9, fig.height = 6} +```{r multiple-phase, fig.width = 9, fig.height = 6, out.width="90%"} g <- consort_plot(data = dispos.data, orders = c(trialno = "Population", exclusion1 = "Excluded", @@ -209,7 +284,7 @@ plot(p) The previous is to easily generate a consort diagram based on a disposition data, here we show how to create a consort diagram by providing the label text manually. ## Provide text -```{r providetext1, fig.width = 7, fig.height = 4} +```{r providetext1, fig.width = 7, fig.height = 4, out.width="60%"} library(grid) # Might want to change some settings set_consort_defaults(txt_gp = gpar(cex = 0.8)) @@ -236,7 +311,7 @@ plot(g) ## Missing nodes and multiple split There might be some cases that the nodes will be missing, this can be handled as well. You can also have multiple splits, but multiple splits for the `grid` hasn't been implemented yet. You can use `plot(g, grViz = TRUE)` to produce the consort plot. -```{r providetext2} +```{r providetext2, fig.width = 3, fig.height = 1.5, out.width="80%"} g <- add_box(txt = c("Study 1 (n=8)", "Study 2 (n=12)", "Study 3 (n=12)")) g <- add_box(g, txt = "Included All (n=20)") g <- add_side_box(g, txt = "Excluded (n=7):\n\u2022 MRI not collected (n=3)") @@ -281,7 +356,7 @@ plot(g) ``` ## Using disposition table -```{r disposition-data, fig.width = 7, fig.height = 6.5} +```{r disposition-data, fig.width = 7, fig.height = 6.5, out.width="70%"} set_consort_defaults(txt_gp = gpar(cex = 0.8)) dispos.data$arm <- factor(dispos.data$arm) @@ -316,7 +391,7 @@ plot(g) ## For Shiny and HTML Although all the efforts has been made to precisely calculate the coordinates of the nodes, it is not very accurate due to limit of my own knowledge. But you can utilize the [DiagrammeR](https://CRAN.R-project.org/package=DiagrammeR) to produce plots for Shiny and HTML by setting `grViz = TRUE` in `plot`. You can get `Graphviz` code with `build_grviz` of the plot. In addition, use [DiagrammeRsvg](https://CRAN.R-project.org/package=DiagrammeRsvg) and [rsvg](https://CRAN.R-project.org/package=rsvg) save plot in various formats. -```{r save-plot} +```{r save-plot, fig.width = 3, fig.height = 1.5, out.width="70%"} plot(g, grViz = TRUE) ```