From 74afa675770c32e02a10d0b8e7721316ec759ee9 Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Mon, 24 Nov 2025 14:35:34 +0000 Subject: [PATCH 01/10] refactor node and flow creation for 2-way sankey --- DESCRIPTION | 2 +- NAMESPACE | 3 +- R/gg_sankey.R | 174 +++----- R/gg_sankey_utils.R | 414 +++++++++--------- inst/shiny/app.R | 10 +- man/calculate_flow_transitions.Rd | 18 - man/create_flow_curves.Rd | 14 +- man/make_flows.Rd | 51 +++ ...culate_node_positions.Rd => make_nodes.Rd} | 8 +- man/make_sankey.Rd | 15 +- man/nodes_down.Rd | 23 - man/nodes_up.Rd | 23 - man/prepare_flow_labels.Rd | 20 - man/prepare_node_labels.Rd | 20 - tests/testthat/test-makes-sankey.R | 4 +- tests/testthat/test-sankey-inputs.R | 15 - tests/testthat/test-sankey_utils.R | 196 +++++++++ 17 files changed, 544 insertions(+), 466 deletions(-) delete mode 100644 man/calculate_flow_transitions.Rd create mode 100644 man/make_flows.Rd rename man/{calculate_node_positions.Rd => make_nodes.Rd} (73%) delete mode 100644 man/nodes_down.Rd delete mode 100644 man/nodes_up.Rd delete mode 100644 man/prepare_flow_labels.Rd delete mode 100644 man/prepare_node_labels.Rd delete mode 100644 tests/testthat/test-sankey-inputs.R create mode 100644 tests/testthat/test-sankey_utils.R diff --git a/DESCRIPTION b/DESCRIPTION index 5b8950e..dded53c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: currentsee Title: Sankey diagrams for malaria CE analysis -Version: 1.0.2 +Version: 1.1.2 Authors@R: c( person("Pete", "Winskill", email = "p.winskill@imperial.ac.uk", role = c("aut", "cre")) ) diff --git a/NAMESPACE b/NAMESPACE index 40de259..d9cb667 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,10 +3,9 @@ export(add_line_breaks_smart) export(contact_card) export(launch_step_app) +export(make_flows) export(make_sankey) export(make_x_labs) -export(nodes_down) -export(nodes_up) export(simulate) export(tab_faqs) export(tab_introduction) diff --git a/R/gg_sankey.R b/R/gg_sankey.R index 4922bed..4e30d01 100644 --- a/R/gg_sankey.R +++ b/R/gg_sankey.R @@ -1,10 +1,10 @@ -#' Create Sankey diagram +#' Create bidirectional Sankey diagram #' -#' Generates a Sankey diagram with customizable nodes, flows, colours, and labels. -#' Supports dead-end flows (NA values), custom labeling, and flexible styling options. +#' Generates a Sankey diagram that can flow both left (down/removing) and right (up/adding) +#' from a central current state, with direction-appropriate flow labels and alignment. #' #' @param x Data frame where each column represents a step and each row represents a flow path -#' @param direction String "up" or "down" to determine prioritisation or deprioritisation flow +#' @param direction String "up", "down", or "updown" to determine flow direction #' @param flow_labels Data frame with columns 'flow_start', 'flow_end', 'flow_label' for custom flow labels (optional) #' @param colours Data frame with columns 'node' and 'colour' for custom node colours, or named vector (optional) #' @param node_width Numeric. Width of node rectangles (default: 0.05) @@ -19,9 +19,8 @@ #' @export make_sankey <- function( x, - direction, - flow_labels = currentsee::flow_labels, - colours = currentsee::colours_df, + flow_labels = NULL, + colours = NULL, node_width = 0.05, node_label_font_size = 3, flow_label_font_size = 2.5, @@ -31,98 +30,68 @@ make_sankey <- function( gradient_res = 3000 ) { - stopifnot(direction %in% c("down", "up")) - if(direction == "up"){ - nodes <- nodes_up(x) - dat <- nodes$up - node_labels <- nodes$up_nodes - } - if(direction == "down"){ - nodes <- nodes_down(x) - dat <- nodes$down - node_labels <- nodes$down_nodes - } - if(is.null(x_names)){ - x_names <- make_x_labs(names(dat)) - } + # Remove any all NA cols + x <- x[,apply(x, 2, function(x){ + !all(is.na(x)) + })] - # Get unique values for colour mapping - unique_values <- unique(unlist(dat[!is.na(dat)])) + # Make node, flows and curves + nodes <- make_nodes(x, node_width = 0.1) + flows <- make_flows(x, nodes) + curves <- create_flow_curves(flows, nodes) - # Handle colours parameter - if (is.null(colours)) { - default_colours <- RColorBrewer::brewer.pal(name = "Set3", n = length(unique_values)) - df_c <- data.frame(var = levels(factor(unique_values)), color = default_colours) - } else if (is.data.frame(colours)) { - df_c <- colours |> - dplyr::rename(var = "node", color = "colour") |> - dplyr::right_join(data.frame(var = levels(factor(unique_values))), by = "var") |> - dplyr::mutate( - color = ifelse( - is.na(.data$color), - RColorBrewer::brewer.pal(name = "Set3", n = length(unique_values))[dplyr::row_number()], - .data$color - ) - ) - } else { - # named vector or plain vector - df_c <- data.frame(var = levels(factor(unique_values)), color = colours) + if(is.null(x_names)){ + x_names <- make_x_labs(names(x)) } - # Calculate node positions and flows - df_n <- calculate_node_positions(dat, node_width) - df_f_base <- calculate_flow_transitions(dat) + p <- ggplot2::ggplot() + + # Flow curves + ggplot2::geom_rect( + data = curves, + ggplot2::aes(xmin =.data$xmin, xmax =.data$xmax, + ymin =.data$ymin, ymax =.data$ymax, + fill =.data$color), + color = NA, # No borders on flow segments + alpha = flow_alpha # Use your flow transparency setting + ) + + ggplot2::scale_fill_identity() + - if (nrow(df_f_base) > 0) { - df_f_positioned <- df_f_base |> - dplyr::left_join(df_c, by = c(Var1 = "var")) |> - dplyr::left_join(df_c, by = c(Var2 = "var"), suffix = c("_left", "_right")) |> - dplyr::left_join(dplyr::select(df_n, -"Freq", -"ymax"), by = c(Var1 = "Var")) |> - dplyr::left_join(dplyr::select(df_n, -"Freq", -"ymax"), by = c(Var2 = "Var"), - suffix = c("_left", "_right")) |> - dplyr::group_by(.data$Var1) |> - dplyr::mutate( - ymin_left = .data$ymin_left + c(0, utils::head(cumsum(.data$Freq), -1)), - ymax_left = .data$ymin_left + .data$Freq - ) |> - dplyr::ungroup() |> - dplyr::group_by(.data$Var2) |> - dplyr::mutate( - ymin_right = .data$ymin_right + c(0, utils::head(cumsum(.data$Freq), -1)), - ymax_right = .data$ymin_right + .data$Freq - ) |> - dplyr::ungroup() + # Need new scale for nodes since we used fill for flows + ggnewscale::new_scale_fill() + - df_f_labels <- prepare_flow_labels(df_f_positioned, flow_labels) - df_f <- create_flow_curves(df_f_positioned, gradient_resolution = gradient_res) + # Nodes + ggplot2::geom_rect( + data = nodes, + ggplot2::aes(xmin =.data$xmin, xmax =.data$xmax, + ymin =.data$ymin, ymax =.data$ymax, + fill =.data$colour), + color = "black" + ) + + ggplot2::scale_fill_identity() + - } else { - df_f <- data.frame(xmin = numeric(0), xmax = numeric(0), - ymin = numeric(0), ymax = numeric(0), color = character(0)) - df_f_labels <- data.frame(Var1 = character(0), Var2 = character(0), - x_center = numeric(0), y_center = numeric(0), - display_label = character(0)) - } + # Node labels + ggplot2::geom_text( + data = nodes, + ggplot2::aes(x =.data$xcenter, y =.data$ycenter, label =.data$label), + inherit.aes = FALSE, + fontface = "bold", + color = "black", + size = node_label_font_size + ) + - # Add colour to node data and prepare labels - df_n <- df_n |> - dplyr::left_join(df_c, by = c(Var = "var")) |> - prepare_node_labels(node_labels) + # Flow labels + ggplot2::geom_text( + data = flows, + ggplot2::aes(x =.data$label_x, y =.data$label_y, + label =.data$flow_label, hjust =.data$hjust), + inherit.aes = FALSE, + fontface = "italic", # Changed to italic to distinguish from node labels + color = "black", + size = flow_label_font_size # Use separate size parameter + ) + - # Plot - p <- ggplot2::ggplot(df_f, - ggplot2::aes(xmin = .data$xmin, xmax = .data$xmax, - ymin = .data$ymin, ymax = .data$ymax)) + - ggplot2::geom_rect(ggplot2::aes(fill = .data$color), color = NA, alpha = flow_alpha) + - ggplot2::scale_fill_identity() + - ggnewscale::new_scale_fill() + - ggplot2::geom_rect(data = df_n, - ggplot2::aes(xmin = .data$xmin, xmax = .data$xmax, - ymin = .data$ymin, ymax = .data$ymax, - fill = .data$color), - color = "black") + - ggplot2::scale_fill_identity() + - ggplot2::scale_x_continuous(breaks = seq_along(dat), labels = x_names, + # Scales and theme + ggplot2::scale_x_continuous(breaks = seq_along(x_names), labels = x_names, minor_breaks = NULL, name = "") + ggplot2::scale_y_continuous(breaks = NULL, labels = NULL) + ggplot2::theme_minimal() + @@ -135,30 +104,5 @@ make_sankey <- function( legend.position = "none" ) - if (nrow(df_n) > 0) { - p <- p + - ggplot2::geom_text( - data = df_n, - ggplot2::aes(x = .data$x_center, y = .data$y_center, label = .data$display_label), - inherit.aes = FALSE, - fontface = "bold", - color = "black", - size = node_label_font_size - ) - } - - if (!is.null(flow_labels) && nrow(df_f_labels) > 0) { - p <- p + - ggplot2::geom_text( - data = df_f_labels, - ggplot2::aes(x = .data$x_center, y = .data$y_center, label = .data$display_label), - inherit.aes = FALSE, - fontface = "italic", - color = "black", - size = flow_label_font_size, - hjust = 0 - ) - } - return(p) } diff --git a/R/gg_sankey_utils.R b/R/gg_sankey_utils.R index 9da9c12..102e4d7 100644 --- a/R/gg_sankey_utils.R +++ b/R/gg_sankey_utils.R @@ -1,40 +1,23 @@ #' @importFrom rlang .data NULL -#' Sigmoid interpolation function for smooth flow curves -#' -#' Creates smooth sigmoid curves for Sankey diagram flows using normal distribution. -#' This function generates smooth transitions between flow start and end points. -#' -#' @param x1 Numeric. Starting x-coordinate of the flow -#' @param x2 Numeric. Ending x-coordinate of the flow -#' @param y1 Numeric. Starting y-coordinate of the flow -#' @param y2 Numeric. Ending y-coordinate of the flow -#' @param n_points Integer. Number of interpolation points for smoothness (default: 5000) -#' -#' @return Numeric vector of interpolated y-coordinates -sankey_sigmoid <- function(x1, x2, y1, y2, n_points = 5000) { - y1 + (y2 - y1) * stats::pnorm(seq(x1, x2, len = n_points), (x1 + x2)/2, (x2 - x1)/6) -} - - #' Calculate node positions and dimensions #' #' Computes the position, size, and center coordinates for each node in the Sankey diagram. #' Handles NA values by excluding them from calculations and centers nodes vertically. #' -#' @param dat Data frame containing the flow data with columns representing steps +#' @param x Data frame containing the flow data with columns representing steps #' @param node_width Numeric. Width of the node rectangles (default: 0.05) #' #' @return Data frame with node positions including Var, Freq, xmin, xmax, ymin, ymax, x_center, y_center -calculate_node_positions <- function(dat, node_width = 0.05) { - rows <- lapply(seq_along(dat), function(i) { - gap <- nrow(dat) / 10 - valid_data <- dat[[i]][!is.na(dat[[i]])] +make_nodes <- function(x, node_width = 0.05) { + rows <- lapply(seq_along(x), function(i) { + gap <- nrow(x) / 10 + valid_data <- x[[i]][!is.na(x[[i]])] if (length(valid_data) == 0) { return(data.frame( - Var = character(0), Freq = numeric(0), + node = character(0), Freq = numeric(0), ymin = numeric(0), ymax = numeric(0), xmin = numeric(0), xmax = numeric(0), x_center = numeric(0), y_center = numeric(0) @@ -42,7 +25,7 @@ calculate_node_positions <- function(dat, node_width = 0.05) { } df <- as.data.frame(table(valid_data)) - names(df) <- c("Var", "Freq") + names(df) <- c("node", "Freq") n <- nrow(df) # gaps go BETWEEN bars: @@ -59,136 +42,236 @@ calculate_node_positions <- function(dat, node_width = 0.05) { # x extents and label centres df$xmin <- i - node_width df$xmax <- i + node_width - df$x_center <- i - df$y_center <- (df$ymin + df$ymax) / 2 + df$xcenter <- i + df$ycenter <- (df$ymin + df$ymax) / 2 df }) - do.call("rbind", rows) + nodes <- do.call("rbind", rows) |> + dplyr::left_join(currentsee::colours_df, by = "node") |> + dplyr::mutate(percent = round(100 * (.data$Freq / nrow(x)))) |> + dplyr::mutate(label = paste0(.data$node, "\n(", .data$percent, "%)")) |> + dplyr::mutate(label = add_line_breaks_smart(.data$label, width = 12)) + + return(nodes) } -#' Calculate flow transitions between columns -#' -#' Determines valid transitions between consecutive columns in the data, -#' excluding transitions involving NA values and computing frequencies. -#' -#' @param dat Data frame containing the flow data with columns representing steps -#' -#' @return Data frame with columns Var1, Var2, and Freq representing transitions -calculate_flow_transitions <- function(dat) { - do.call("rbind", lapply(utils::head(seq_along(dat), -1), function(i) { - # Create a data frame of transitions, excluding rows where either value is NA - transitions <- data.frame( - Var1 = dat[[i]], - Var2 = dat[[i + 1]] - ) +#' Create flow transitions for bidirectional Sankey diagrams +#' +#' Processes intervention scaling data to generate flow transitions between nodes +#' in both upward (adding interventions) and downward (removing interventions) +#' directions. Calculates flow positions, coordinates, and label placements while +#' minimizing visual crossings through intelligent sorting algorithms. +#' +#' @param x Data frame containing intervention scaling data where columns represent +#' different intervention states (named with numeric values: negative for removal +#' steps, 0 for current state, positive for addition steps) and rows represent +#' individual flow paths through the intervention scaling process +#' @param nodes Data frame containing node information +#' +#' @details +#' The function performs several key operations: +#' \itemize{ +#' \item Identifies upward transitions (positive column progressions) representing intervention additions +#' \item Identifies downward transitions (negative column progressions) representing intervention removals +#' \item Calculates flow frequencies and positions within source and destination nodes +#' \item Applies intelligent sorting to minimize visual flow crossings +#' \item Determines appropriate label positioning and alignment based on flow direction +#' \item Joins with external flow_labels data for custom flow descriptions +#' } +#' +#' Flow positioning uses a two-pass sorting algorithm: first sorting flows within +#' each source node by destination position, then sorting flows within each +#' destination node by source position. This approach significantly reduces +#' visual crossing of flow ribbons in the final Sankey diagram. +#' +#' @return Data frame containing detailed flow information with columns: +#' \itemize{ +#' \item \code{flow_start}, \code{flow_end}: Character. Source and destination node names +#' \item \code{direction}: Character. Flow direction ("up" or "down") +#' \item \code{n}: Integer. Number of individual transitions for this flow +#' \item \code{*_start}, \code{*_end}: Numeric. Coordinate boundaries for flow start and end points +#' \item \code{flow_start_center}, \code{flow_end_center}: Numeric. Center positions of flows +#' \item \code{label_x}, \code{label_y}: Numeric. Optimal label positioning coordinates +#' \item \code{hjust}: Numeric. Horizontal text alignment (0 for left, 1 for right) +#' \item \code{flow_label}: Character. Custom flow descriptions (if available in flow_labels) +#' } +#' @export +make_flows <- function(x, nodes){ + cols <- as.numeric(colnames(x)) + + down_transitions <- list() + if(min(cols)<= -1){ + down_transitions <- lapply(-1:min(cols), function(y){ + v12 <- x[,paste0(y:(y+1))] + names(v12) <- c("flow_start", "flow_end") + v12$direction <- "down" + return(v12) + }) |> + dplyr::bind_rows() + } - # Remove rows with NA in either column - transitions <- transitions[!is.na(transitions$Var1) & !is.na(transitions$Var2), ] + up_transitions <- list() + if(max(cols) >= 1){ + up_transitions <- lapply(1:max(cols), function(y){ + v12 <- x[,paste0((y-1):y)] + names(v12) <- c("flow_start", "flow_end") + v12$direction <- "up" + return(v12) + }) |> + dplyr::bind_rows() + } - if(nrow(transitions) == 0) { - return(data.frame(Var1 = character(0), Var2 = character(0), Freq = numeric(0))) - } + start_position <- nodes |> + dplyr::select(dplyr::all_of(c("node", "ymin", "ymax", "xmin", "xmax"))) + names(start_position) = c("node", paste0(names(start_position)[-1], "_start")) + + end_position <- nodes |> + dplyr::select(dplyr::all_of(c("node", "ymin", "ymax", "xmin", "xmax"))) + names(end_position) = c("node", paste0(names(end_position)[-1], "_end")) + + transitions <- down_transitions |> + dplyr::bind_rows(up_transitions) |> + tidyr::drop_na() |> + dplyr::summarise( + n = dplyr::n(),.by = c("flow_start", "flow_end", "direction") + ) |> + dplyr::left_join(start_position, by = c("flow_start" = "node")) |> + dplyr::left_join(end_position, by = c("flow_end" = "node")) |> + dplyr::mutate( + label_start = ifelse(.data$direction == "down",.data$flow_end,.data$flow_start), + label_end = ifelse(.data$direction == "down",.data$flow_start,.data$flow_end) + ) |> + dplyr::left_join( + flow_labels, + by = c("label_start" = "flow_start", "label_end" = "flow_end") + ) |> + dplyr::select(-label_start, -label_end) |> + # Flow starts and ends + dplyr::mutate( + flow_start_x = xmax_start, + flow_end_x = xmin_end + ) |> + # ADD NODE CENTER POSITIONS FOR SORTING + dplyr::left_join( + dplyr::select(nodes, node, ycenter), + by = c("flow_start" = "node") + ) |> + dplyr::rename(start_center = ycenter) |> + dplyr::left_join( + dplyr::select(nodes, node, ycenter), + by = c("flow_end" = "node") + ) |> + dplyr::rename(end_center = ycenter) |> + # Sort for start position + dplyr::arrange(.data$flow_start,.data$end_center) |> # Sort by start node, then by end node position + # Calculate start positions + dplyr::mutate( + flow_start_ymin =.data$ymin_start + c(0, utils::head(cumsum(.data$n), -1)), + flow_start_ymax =.data$flow_start_ymin +.data$n, + .by = "flow_start" + ) |> + # sort for end position + dplyr::arrange(.data$flow_end,.data$start_center) |> # Sort by end node, then by start node position + # Calculate end positions + dplyr::mutate( + flow_end_ymin =.data$ymin_end + c(0, utils::head(cumsum(.data$n), -1)), + flow_end_ymax =.data$flow_end_ymin +.data$n, + .by = "flow_end" + ) |> + # Clean up temporary columns + dplyr::select(-start_center, -end_center) |> + dplyr::mutate( + flow_start_center =.data$flow_start_ymin + ((.data$flow_start_ymax -.data$flow_start_ymin) / 2), + flow_end_center =.data$flow_end_ymin + ((.data$flow_end_ymax -.data$flow_end_ymin) / 2) + ) |> + # Labels + dplyr::mutate( + hjust = ifelse(direction == "down", 1, 0), + label_x = ifelse(direction == "down",.data$flow_end_x,.data$flow_start_x), + label_y = ifelse(direction == "down",.data$flow_end_center,.data$flow_start_center) + ) - table(transitions$Var1, transitions$Var2) |> - as.data.frame() |> - dplyr::filter(.data$Freq > 0) # Only keep actual transitions - })) + return(transitions) } -#' Create detailed flow visualization data with smooth curves +#' Create detailed flow visualization data with node-based color gradients #' -#' Generates the detailed geometric data needed to render smooth gradient flows -#' between nodes, including color interpolation and curve coordinates. +#' Generates smooth gradient flows between nodes using the actual node colors +#' from the nodes data frame for realistic color transitions. #' -#' @param df_f_positioned Data frame with positioned flow data including color and coordinate information +#' @param flows Data frame with flow data including flow_start and flow_end node names +#' @param nodes Data frame with node information including 'node' and 'colour' columns #' @param gradient_resolution Integer. Number of segments for gradient smoothness (default: 2000) #' -#' @return Data frame with detailed flow rendering data including color, xmin, xmax, ymin, ymax -create_flow_curves <- function(df_f_positioned, gradient_resolution = 2000) { - df_f_positioned |> +#' @return Data frame with detailed flow rendering data including color gradients +create_flow_curves <- function(flows, nodes, gradient_resolution = 2000) { + + if (nrow(flows) == 0) { + return(data.frame( + xmin = numeric(0), xmax = numeric(0), + ymin = numeric(0), ymax = numeric(0), + color = character(0) + )) + } + + # Join flows with node colors for start and end nodes + flows_with_colors <- flows |> + dplyr::left_join( + dplyr::select(nodes, node, colour), + by = c("flow_start" = "node") + ) |> + dplyr::rename(color_start = colour) |> + dplyr::left_join( + dplyr::select(nodes, node, colour), + by = c("flow_end" = "node") + ) |> + dplyr::rename(color_end = colour) + + # Create the flow curves with color gradients + flows_with_colors |> dplyr::rowwise() |> dplyr::reframe( - color = grDevices::colorRampPalette( - c(.data$color_left, .data$color_right) - )(gradient_resolution), + # Create color gradient between start and end node colors + color = if(!is.na(.data$color_start) && !is.na(.data$color_end)) { + grDevices::colorRampPalette( + c(.data$color_start,.data$color_end) + )(gradient_resolution) + } else { + # Fallback to single color if one is missing + rep(dplyr::coalesce(.data$color_start,.data$color_end, "#69b3a2"), gradient_resolution) + }, - xmin = seq(.data$xmax_left, .data$xmin_right, + # Create x coordinates for the flow segments + xmin = seq(.data$flow_start_x,.data$flow_end_x, length.out = gradient_resolution) - 0.001, - xmax = .data$xmin + 0.002, + xmax =.data$xmin + 0.002, - ymin = sankey_sigmoid( - .data$xmax_left, .data$xmin_right, - .data$ymin_left, .data$ymin_right, - gradient_resolution + # Create smooth y coordinates using sigmoid interpolation + ymin = sankey_sigmoid(.data$flow_start_x,.data$flow_end_x,.data$flow_start_ymin,.data$flow_end_ymin, + gradient_resolution ), - ymax = sankey_sigmoid( - .data$xmax_left, .data$xmin_right, - .data$ymax_left, .data$ymax_right, - gradient_resolution + ymax = sankey_sigmoid(.data$flow_start_x,.data$flow_end_x,.data$flow_start_ymax,.data$flow_end_ymax, + gradient_resolution ) ) } -#' Prepare flow label positions -#' -#' Calculates optimal positions for flow labels and joins with user-provided -#' label data. Positions labels at the start of flows with proportional spacing. -#' -#' @param df_f_positioned Data frame with positioned flow data -#' @param flow_labels Data frame with columns flow_start, flow_end, flow_label (optional) -#' -#' @return Data frame with flow label positions and text -prepare_flow_labels <- function(df_f_positioned, flow_labels = NULL) { - df_f_labels <- df_f_positioned |> - dplyr::mutate( - flow_distance = .data$xmin_right - .data$xmax_left, - x_center = .data$xmax_left + (.data$flow_distance * 0.01), - y_center = (.data$ymin_left + .data$ymax_left) / 2 - ) |> - dplyr::select(dplyr::all_of(c("Var1", "Var2", "x_center", "y_center"))) |> - dplyr::distinct() - - if (!is.null(flow_labels)) { - df_f_labels <- df_f_labels |> - dplyr::left_join( - flow_labels, - by = c("Var1" = "flow_start", "Var2" = "flow_end") - ) |> - dplyr::mutate( - display_label = dplyr::coalesce(.data$flow_label, - paste(.data$Var1, "\u2192", .data$Var2)) - ) - } else { - df_f_labels <- df_f_labels |> - dplyr::mutate(display_label = paste(.data$Var1, "\u2192", .data$Var2)) - } - - df_f_labels -} - -#' Prepare node labels +#' Sigmoid interpolation function for smooth flow curves #' -#' Joins node data with user-provided labels and creates display labels. -#' Falls back to original values when custom labels are not provided. +#' Creates smooth sigmoid curves for Sankey diagram flows using normal distribution. +#' This function generates smooth transitions between flow start and end points. #' -#' @param df_n Data frame with node data -#' @param node_labels Data frame with columns node and label (optional) +#' @param x1 Numeric. Starting x-coordinate of the flow +#' @param x2 Numeric. Ending x-coordinate of the flow +#' @param y1 Numeric. Starting y-coordinate of the flow +#' @param y2 Numeric. Ending y-coordinate of the flow +#' @param n_points Integer. Number of interpolation points for smoothness (default: 5000) #' -#' @return Data frame with display_label column added -prepare_node_labels <- function(df_n, node_labels = NULL) { - # Join with node_labels if provided - if(!is.null(node_labels)) { - df_n <- df_n |> - dplyr::left_join(node_labels, by = c("Var" = "node")) |> - dplyr::mutate(display_label = dplyr::coalesce(.data$label, .data$Var)) - } else { - df_n <- df_n |> - dplyr::mutate(display_label = .data$Var) - } - - return(df_n) +#' @return Numeric vector of interpolated y-coordinates +sankey_sigmoid <- function(x1, x2, y1, y2, n_points = 5000) { + y1 + (y2 - y1) * stats::pnorm(seq(x1, x2, len = n_points), (x1 + x2)/2, (x2 - x1)/6) } #' Add smart line breaks to text strings @@ -253,85 +336,6 @@ add_line_breaks_smart <- function(x, width = 80, break_words = FALSE) { }, USE.NAMES = FALSE) } -#' Process data for upward scaling Sankey diagram -#' -#' Processes intervention scaling data for upward flows (adding interventions). -#' Extracts columns for current state and 1-3 additional interventions, calculates -#' percentages, creates formatted node labels, and removes columns with all NA values. -#' -#' @param dat Data frame containing intervention scaling data with columns named -#' "0", "1", "2", "3" representing current state and progressive intervention additions -#' -#' @return List containing two elements: -#' \item{up}{Data frame with processed upward scaling data, NA-only columns removed} -#' \item{up_nodes}{Data frame with columns 'node' and 'label' containing formatted -#' node labels with percentages and line breaks for display} -#' -#' @export -nodes_up <- function(dat){ - up <- dat |> - dplyr::select(dplyr::any_of(paste(0:20))) |> - dplyr::select(dplyr::where(~!all(is.na(.x)))) - - up_nodes <- apply(up, 2, function(x){ - table(x) |> - as.data.frame() - }) |> - dplyr::bind_rows() |> - dplyr::mutate(percent = round(100 * (.data$Freq / nrow(up)))) |> - dplyr::mutate(label = paste0(.data$x, "\n(", .data$percent, "%)")) |> - dplyr::mutate(label = add_line_breaks_smart(.data$label, width = 12)) |> - dplyr::select("x", "label") |> - dplyr::rename(node = "x") - - return( - list( - up = up, - up_nodes = up_nodes - ) - ) -} - -#' Process data for downward scaling Sankey diagram -#' -#' Processes intervention scaling data for downward flows (removing interventions). -#' Extracts columns for current state and 1-3 intervention removals, calculates -#' percentages, creates formatted node labels, and removes columns with all NA values. -#' -#' @param dat Data frame containing intervention scaling data with columns named -#' "0", "-1", "-2", "-3" representing current state and progressive intervention removals -#' -#' @return List containing two elements: -#' \item{down}{Data frame with processed downward scaling data, NA-only columns removed} -#' \item{down_nodes}{Data frame with columns 'node' and 'label' containing formatted -#' node labels with percentages and line breaks for display} -#' -#' @export -nodes_down <- function(dat){ - down <- dat |> - dplyr::select(dplyr::any_of(paste(0:-20))) |> - dplyr::select(dplyr::where(~!all(is.na(.x)))) - - down_nodes <- apply(down, 2, function(x){ - table(x) |> - as.data.frame() - }) |> - dplyr::bind_rows() |> - dplyr::mutate(percent = round(100 * (.data$Freq / nrow(down)))) |> - dplyr::mutate(label = paste0(.data$x, "\n(", .data$percent, "%)")) |> - dplyr::mutate(label = add_line_breaks_smart(.data$label, width = 12)) |> - dplyr::select("x", "label") |> - dplyr::rename(node = "x") - - - return( - list( - down = down, - down_nodes = down_nodes - ) - ) -} - #' Create descriptive x-axis labels for intervention scaling #' #' Converts numeric intervention scaling values to descriptive labels for Sankey diff --git a/inst/shiny/app.R b/inst/shiny/app.R index 8a22818..f795705 100644 --- a/inst/shiny/app.R +++ b/inst/shiny/app.R @@ -1,6 +1,10 @@ opts <- getOption("currentsee.app") df <- opts$df +steps <- names(df)[names(df) %in% paste(-20:20)] |> + as.numeric() |> + sort() + library(shiny) library(bslib) library(dplyr) @@ -326,8 +330,7 @@ server <- function(input, output, session) { ) make_sankey( - f, - "up", + f[,paste(steps[steps >= 0])], node_width = 0.3, flow_label_font_size = 4, node_label_font_size = 5 @@ -375,8 +378,7 @@ server <- function(input, output, session) { ) currentsee::make_sankey( - f, - "down", + f[,paste(steps[steps <= 0])], node_width = 0.25, flow_label_font_size = 4, node_label_font_size = 5 diff --git a/man/calculate_flow_transitions.Rd b/man/calculate_flow_transitions.Rd deleted file mode 100644 index 7f68d89..0000000 --- a/man/calculate_flow_transitions.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gg_sankey_utils.R -\name{calculate_flow_transitions} -\alias{calculate_flow_transitions} -\title{Calculate flow transitions between columns} -\usage{ -calculate_flow_transitions(dat) -} -\arguments{ -\item{dat}{Data frame containing the flow data with columns representing steps} -} -\value{ -Data frame with columns Var1, Var2, and Freq representing transitions -} -\description{ -Determines valid transitions between consecutive columns in the data, -excluding transitions involving NA values and computing frequencies. -} diff --git a/man/create_flow_curves.Rd b/man/create_flow_curves.Rd index cd70e3e..a643a6c 100644 --- a/man/create_flow_curves.Rd +++ b/man/create_flow_curves.Rd @@ -2,19 +2,21 @@ % Please edit documentation in R/gg_sankey_utils.R \name{create_flow_curves} \alias{create_flow_curves} -\title{Create detailed flow visualization data with smooth curves} +\title{Create detailed flow visualization data with node-based color gradients} \usage{ -create_flow_curves(df_f_positioned, gradient_resolution = 2000) +create_flow_curves(flows, nodes, gradient_resolution = 2000) } \arguments{ -\item{df_f_positioned}{Data frame with positioned flow data including color and coordinate information} +\item{flows}{Data frame with flow data including flow_start and flow_end node names} + +\item{nodes}{Data frame with node information including 'node' and 'colour' columns} \item{gradient_resolution}{Integer. Number of segments for gradient smoothness (default: 2000)} } \value{ -Data frame with detailed flow rendering data including color, xmin, xmax, ymin, ymax +Data frame with detailed flow rendering data including color gradients } \description{ -Generates the detailed geometric data needed to render smooth gradient flows -between nodes, including color interpolation and curve coordinates. +Generates smooth gradient flows between nodes using the actual node colors +from the nodes data frame for realistic color transitions. } diff --git a/man/make_flows.Rd b/man/make_flows.Rd new file mode 100644 index 0000000..a872108 --- /dev/null +++ b/man/make_flows.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/gg_sankey_utils.R +\name{make_flows} +\alias{make_flows} +\title{Create flow transitions for bidirectional Sankey diagrams} +\usage{ +make_flows(x, nodes) +} +\arguments{ +\item{x}{Data frame containing intervention scaling data where columns represent +different intervention states (named with numeric values: negative for removal +steps, 0 for current state, positive for addition steps) and rows represent +individual flow paths through the intervention scaling process} + +\item{nodes}{Data frame containing node information} +} +\value{ +Data frame containing detailed flow information with columns: +\itemize{ +\item \code{flow_start}, \code{flow_end}: Character. Source and destination node names +\item \code{direction}: Character. Flow direction ("up" or "down") +\item \code{n}: Integer. Number of individual transitions for this flow +\item \code{*_start}, \code{*_end}: Numeric. Coordinate boundaries for flow start and end points +\item \code{flow_start_center}, \code{flow_end_center}: Numeric. Center positions of flows +\item \code{label_x}, \code{label_y}: Numeric. Optimal label positioning coordinates +\item \code{hjust}: Numeric. Horizontal text alignment (0 for left, 1 for right) +\item \code{flow_label}: Character. Custom flow descriptions (if available in flow_labels) +} +} +\description{ +Processes intervention scaling data to generate flow transitions between nodes +in both upward (adding interventions) and downward (removing interventions) +directions. Calculates flow positions, coordinates, and label placements while +minimizing visual crossings through intelligent sorting algorithms. +} +\details{ +The function performs several key operations: +\itemize{ +\item Identifies upward transitions (positive column progressions) representing intervention additions +\item Identifies downward transitions (negative column progressions) representing intervention removals +\item Calculates flow frequencies and positions within source and destination nodes +\item Applies intelligent sorting to minimize visual flow crossings +\item Determines appropriate label positioning and alignment based on flow direction +\item Joins with external flow_labels data for custom flow descriptions +} + +Flow positioning uses a two-pass sorting algorithm: first sorting flows within +each source node by destination position, then sorting flows within each +destination node by source position. This approach significantly reduces +visual crossing of flow ribbons in the final Sankey diagram. +} diff --git a/man/calculate_node_positions.Rd b/man/make_nodes.Rd similarity index 73% rename from man/calculate_node_positions.Rd rename to man/make_nodes.Rd index e574bd4..1f5792e 100644 --- a/man/calculate_node_positions.Rd +++ b/man/make_nodes.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gg_sankey_utils.R -\name{calculate_node_positions} -\alias{calculate_node_positions} +\name{make_nodes} +\alias{make_nodes} \title{Calculate node positions and dimensions} \usage{ -calculate_node_positions(dat, node_width = 0.05) +make_nodes(x, node_width = 0.05) } \arguments{ -\item{dat}{Data frame containing the flow data with columns representing steps} +\item{x}{Data frame containing the flow data with columns representing steps} \item{node_width}{Numeric. Width of the node rectangles (default: 0.05)} } diff --git a/man/make_sankey.Rd b/man/make_sankey.Rd index 6d5f084..3d11f04 100644 --- a/man/make_sankey.Rd +++ b/man/make_sankey.Rd @@ -2,13 +2,12 @@ % Please edit documentation in R/gg_sankey.R \name{make_sankey} \alias{make_sankey} -\title{Create Sankey diagram} +\title{Create bidirectional Sankey diagram} \usage{ make_sankey( x, - direction, - flow_labels = currentsee::flow_labels, - colours = currentsee::colours_df, + flow_labels = NULL, + colours = NULL, node_width = 0.05, node_label_font_size = 3, flow_label_font_size = 2.5, @@ -21,8 +20,6 @@ make_sankey( \arguments{ \item{x}{Data frame where each column represents a step and each row represents a flow path} -\item{direction}{String "up" or "down" to determine prioritisation or deprioritisation flow} - \item{flow_labels}{Data frame with columns 'flow_start', 'flow_end', 'flow_label' for custom flow labels (optional)} \item{colours}{Data frame with columns 'node' and 'colour' for custom node colours, or named vector (optional)} @@ -40,11 +37,13 @@ make_sankey( \item{flow_alpha}{Numeric. Transparency of flow ribbons (default: 0.3)} \item{gradient_res}{Integer. Resolution of flow gradients for smoothness (default: 3000)} + +\item{direction}{String "up", "down", or "updown" to determine flow direction} } \value{ ggplot2 object representing the Sankey diagram } \description{ -Generates a Sankey diagram with customizable nodes, flows, colours, and labels. -Supports dead-end flows (NA values), custom labeling, and flexible styling options. +Generates a Sankey diagram that can flow both left (down/removing) and right (up/adding) +from a central current state, with direction-appropriate flow labels and alignment. } diff --git a/man/nodes_down.Rd b/man/nodes_down.Rd deleted file mode 100644 index c264f55..0000000 --- a/man/nodes_down.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gg_sankey_utils.R -\name{nodes_down} -\alias{nodes_down} -\title{Process data for downward scaling Sankey diagram} -\usage{ -nodes_down(dat) -} -\arguments{ -\item{dat}{Data frame containing intervention scaling data with columns named -"0", "-1", "-2", "-3" representing current state and progressive intervention removals} -} -\value{ -List containing two elements: -\item{down}{Data frame with processed downward scaling data, NA-only columns removed} -\item{down_nodes}{Data frame with columns 'node' and 'label' containing formatted -node labels with percentages and line breaks for display} -} -\description{ -Processes intervention scaling data for downward flows (removing interventions). -Extracts columns for current state and 1-3 intervention removals, calculates -percentages, creates formatted node labels, and removes columns with all NA values. -} diff --git a/man/nodes_up.Rd b/man/nodes_up.Rd deleted file mode 100644 index 62f859d..0000000 --- a/man/nodes_up.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gg_sankey_utils.R -\name{nodes_up} -\alias{nodes_up} -\title{Process data for upward scaling Sankey diagram} -\usage{ -nodes_up(dat) -} -\arguments{ -\item{dat}{Data frame containing intervention scaling data with columns named -"0", "1", "2", "3" representing current state and progressive intervention additions} -} -\value{ -List containing two elements: -\item{up}{Data frame with processed upward scaling data, NA-only columns removed} -\item{up_nodes}{Data frame with columns 'node' and 'label' containing formatted -node labels with percentages and line breaks for display} -} -\description{ -Processes intervention scaling data for upward flows (adding interventions). -Extracts columns for current state and 1-3 additional interventions, calculates -percentages, creates formatted node labels, and removes columns with all NA values. -} diff --git a/man/prepare_flow_labels.Rd b/man/prepare_flow_labels.Rd deleted file mode 100644 index 29b7565..0000000 --- a/man/prepare_flow_labels.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gg_sankey_utils.R -\name{prepare_flow_labels} -\alias{prepare_flow_labels} -\title{Prepare flow label positions} -\usage{ -prepare_flow_labels(df_f_positioned, flow_labels = NULL) -} -\arguments{ -\item{df_f_positioned}{Data frame with positioned flow data} - -\item{flow_labels}{Data frame with columns flow_start, flow_end, flow_label (optional)} -} -\value{ -Data frame with flow label positions and text -} -\description{ -Calculates optimal positions for flow labels and joins with user-provided -label data. Positions labels at the start of flows with proportional spacing. -} diff --git a/man/prepare_node_labels.Rd b/man/prepare_node_labels.Rd deleted file mode 100644 index 9108530..0000000 --- a/man/prepare_node_labels.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gg_sankey_utils.R -\name{prepare_node_labels} -\alias{prepare_node_labels} -\title{Prepare node labels} -\usage{ -prepare_node_labels(df_n, node_labels = NULL) -} -\arguments{ -\item{df_n}{Data frame with node data} - -\item{node_labels}{Data frame with columns node and label (optional)} -} -\value{ -Data frame with display_label column added -} -\description{ -Joins node data with user-provided labels and creates display labels. -Falls back to original values when custom labels are not provided. -} diff --git a/tests/testthat/test-makes-sankey.R b/tests/testthat/test-makes-sankey.R index eec44ad..faab250 100644 --- a/tests/testthat/test-makes-sankey.R +++ b/tests/testthat/test-makes-sankey.R @@ -1,9 +1,9 @@ test_that("make_sankey returns an ggplot", { df <- simulate(3) - sankey <- make_sankey(df, "up") + sankey <- make_sankey(df[,c(paste(0:3))]) expect_s3_class(sankey, "ggplot") - sankey <- make_sankey(df, "down") + sankey <- make_sankey(df[,c(paste(-1:0))]) expect_s3_class(sankey, "ggplot") }) diff --git a/tests/testthat/test-sankey-inputs.R b/tests/testthat/test-sankey-inputs.R deleted file mode 100644 index 329ec79..0000000 --- a/tests/testthat/test-sankey-inputs.R +++ /dev/null @@ -1,15 +0,0 @@ -test_that("make_nodes creates labelled nodes", { - df <- simulate(4) - nodes <- nodes_up(df) - - expect_true(all(c("node", "label") %in% names(nodes$up_nodes))) - expect_equal(nrow(nodes$up), 4) - expect_true(all(!duplicated(nodes$name))) - - nodes <- nodes_down(df) - - expect_true(all(c("node", "label") %in% names(nodes$down_nodes))) - expect_equal(nrow(nodes$down), 4) - expect_true(all(!duplicated(nodes$name))) -}) - diff --git a/tests/testthat/test-sankey_utils.R b/tests/testthat/test-sankey_utils.R new file mode 100644 index 0000000..77f5cce --- /dev/null +++ b/tests/testthat/test-sankey_utils.R @@ -0,0 +1,196 @@ +# Test file: test-sankey-functions.R + +# Simple test data ------------------------------------------------------------- +test_data_simple <- data.frame( + `-1` = c("A", "B", "A"), + `0` = c("A", "A", "B"), + `1` = c("B", "B", "B"), + check.names = FALSE +) + +test_data_with_na <- data.frame( + `0` = c("A", NA, "B"), + `1` = c("A", "B", NA), + check.names = FALSE +) + +test_nodes_simple <- data.frame( + node = c("A", "B"), + ymin = c(-5, 0), + ymax = c(5, 10), + xmin = c(0.95, 1.95), + xmax = c(1.05, 2.05), + ycenter = c(0, 5) +) + +# Tests for make_nodes() ------------------------------------------------------- + +test_that("make_nodes returns a data frame with correct columns", { + result <- make_nodes(test_data_simple) + + expect_s3_class(result, "data.frame") + expect_true("node" %in% names(result)) + expect_true("Freq" %in% names(result)) + expect_true("xmin" %in% names(result)) + expect_true("xmax" %in% names(result)) + expect_true("xcenter" %in% names(result)) +}) + +test_that("make_nodes calculates node width correctly", { + result <- make_nodes(test_data_simple, node_width = 0.1) + + # Check that width is applied correctly + first_node <- result[1, ] + expect_equal(first_node$xmax - first_node$xmin, 0.2) # 2 * node_width +}) + +test_that("make_nodes handles empty columns", { + empty_col_data <- data.frame( + `0` = c("A", "B"), + `1` = c(NA, NA), # Empty column + `2` = c("A", "A"), + check.names = FALSE + ) + + result <- make_nodes(empty_col_data) + + # Should only have nodes from columns 1 and 3 (not column 2) + expect_true(all(result$xcenter %in% c(1, 3))) +}) + +test_that("make_nodes counts frequencies correctly", { + freq_data <- data.frame( + `0` = c("A", "A", "A", "B"), + check.names = FALSE + ) + + result <- make_nodes(freq_data) + + expect_equal(result$Freq[result$node == "A"], 3) + expect_equal(result$Freq[result$node == "B"], 1) +}) + +# Tests for make_flows() ------------------------------------------------------- + +test_that("make_flows returns a data frame with correct columns", { + result <- make_flows(test_data_simple, test_nodes_simple) + + expect_s3_class(result, "data.frame") + expect_true("flow_start" %in% names(result)) + expect_true("flow_end" %in% names(result)) + expect_true("direction" %in% names(result)) + expect_true("n" %in% names(result)) +}) + +test_that("make_flows identifies up and down directions", { + result <- make_flows(test_data_simple, test_nodes_simple) + + expect_true("up" %in% result$direction) + expect_true("down" %in% result$direction) +}) + +test_that("make_flows sets hjust correctly for directions", { + result <- make_flows(test_data_simple, test_nodes_simple) + + # Up flows should be left-aligned (hjust = 0) + up_flows <- result[result$direction == "up", ] + expect_true(all(up_flows$hjust == 0)) + + # Down flows should be right-aligned (hjust = 1) + down_flows <- result[result$direction == "down", ] + expect_true(all(down_flows$hjust == 1)) +}) + +test_that("make_flows handles only positive columns", { + up_only_data <- data.frame( + `0` = c("A", "B"), + `1` = c("A", "A"), + check.names = FALSE + ) + + result <- make_flows(up_only_data, test_nodes_simple) + + expect_true(all(result$direction == "up")) +}) + +test_that("make_flows handles only negative columns", { + down_only_data <- data.frame( + `-1` = c("A", "B"), + `0` = c("A", "A"), + check.names = FALSE + ) + + result <- make_flows(down_only_data, test_nodes_simple) + + expect_true(all(result$direction == "down")) +}) + +test_that("make_flows excludes NA values", { + result <- make_flows(test_data_with_na, test_nodes_simple) + + expect_false(any(is.na(result$flow_start))) + expect_false(any(is.na(result$flow_end))) +}) + +test_that("make_flows calculates correct flow counts", { + count_data <- data.frame( + `0` = c("A", "A", "B"), + `1` = c("A", "B", "B"), + check.names = FALSE + ) + + result <- make_flows(count_data, test_nodes_simple) + + # Should have A->A (1), A->B (1), B->B (1) + a_to_a <- result[result$flow_start == "A" & result$flow_end == "A", ] + expect_equal(a_to_a$n, 1) + + a_to_b <- result[result$flow_start == "A" & result$flow_end == "B", ] + expect_equal(a_to_b$n, 1) + + b_to_b <- result[result$flow_start == "B" & result$flow_end == "B", ] + expect_equal(b_to_b$n, 1) +}) + +test_that("make_flows positions flows within node boundaries", { + result <- make_flows(test_data_simple, test_nodes_simple) + + for(i in 1:nrow(result)) { + start_node <- test_nodes_simple[test_nodes_simple$node == result$flow_start[i], ] + end_node <- test_nodes_simple[test_nodes_simple$node == result$flow_end[i], ] + + expect_gte(result$flow_start_ymin[i], start_node$ymin) + expect_lte(result$flow_start_ymax[i], start_node$ymax) + expect_gte(result$flow_end_ymin[i], end_node$ymin) + expect_lte(result$flow_end_ymax[i], end_node$ymax) + } +}) + +# Simple edge cases ------------------------------------------------------------ + +test_that("make_nodes handles single column", { + single_col <- data.frame(`0` = c("A", "B"), check.names = FALSE) + result <- make_nodes(single_col) + + expect_equal(unique(result$xcenter), 1) + expect_equal(nrow(result), 2) +}) + +test_that("make_flows handles single column gracefully", { + single_col <- data.frame(`0` = c("A", "B"), check.names = FALSE) + result <- make_flows(single_col, test_nodes_simple) + + # Should return empty data frame (no transitions possible) + expect_equal(nrow(result), 0) +}) + +test_that("make_nodes centers nodes vertically", { + result <- make_nodes(test_data_simple) + + # For each column, sum of ymin and ymax should be close to 0 + for(col in unique(result$xcenter)) { + col_nodes <- result[result$xcenter == col, ] + total_span <- sum(col_nodes$ymin + col_nodes$ymax) + expect_equal(total_span, 0, tolerance = 1e-10) + } +}) From 962dc5b4b80d885b187780fca0a5eceeefdb9e9d Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Mon, 24 Nov 2025 15:04:46 +0000 Subject: [PATCH 02/10] checks and tests --- R/gg_sankey.R | 5 ++-- R/gg_sankey_utils.R | 36 ++++++++++++++--------------- data-raw/flow_labels.csv | 1 + data/flow_labels.rda | Bin 591 -> 599 bytes man/make_sankey.Rd | 2 -- tests/testthat/test-sankey_utils.R | 24 ++----------------- vignettes/currentsee.Rmd | 2 +- 7 files changed, 25 insertions(+), 45 deletions(-) diff --git a/R/gg_sankey.R b/R/gg_sankey.R index 4e30d01..6626bba 100644 --- a/R/gg_sankey.R +++ b/R/gg_sankey.R @@ -4,7 +4,6 @@ #' from a central current state, with direction-appropriate flow labels and alignment. #' #' @param x Data frame where each column represents a step and each row represents a flow path -#' @param direction String "up", "down", or "updown" to determine flow direction #' @param flow_labels Data frame with columns 'flow_start', 'flow_end', 'flow_label' for custom flow labels (optional) #' @param colours Data frame with columns 'node' and 'colour' for custom node colours, or named vector (optional) #' @param node_width Numeric. Width of node rectangles (default: 0.05) @@ -33,7 +32,9 @@ make_sankey <- function( # Remove any all NA cols x <- x[,apply(x, 2, function(x){ !all(is.na(x)) - })] + }), drop = FALSE] + + stopifnot(ncol(x) > 1) # Make node, flows and curves nodes <- make_nodes(x, node_width = 0.1) diff --git a/R/gg_sankey_utils.R b/R/gg_sankey_utils.R index 102e4d7..56a2408 100644 --- a/R/gg_sankey_utils.R +++ b/R/gg_sankey_utils.R @@ -144,28 +144,28 @@ make_flows <- function(x, nodes){ label_end = ifelse(.data$direction == "down",.data$flow_start,.data$flow_end) ) |> dplyr::left_join( - flow_labels, + currentsee::flow_labels, by = c("label_start" = "flow_start", "label_end" = "flow_end") ) |> - dplyr::select(-label_start, -label_end) |> + dplyr::select(-.data$label_start, -.data$label_end) |> # Flow starts and ends dplyr::mutate( - flow_start_x = xmax_start, - flow_end_x = xmin_end + flow_start_x = .data$xmax_start, + flow_end_x = .data$xmin_end ) |> # ADD NODE CENTER POSITIONS FOR SORTING dplyr::left_join( - dplyr::select(nodes, node, ycenter), + dplyr::select(nodes, .data$node, .data$ycenter), by = c("flow_start" = "node") ) |> - dplyr::rename(start_center = ycenter) |> + dplyr::rename("start_center" = "ycenter") |> dplyr::left_join( - dplyr::select(nodes, node, ycenter), + dplyr::select(nodes, .data$node, .data$ycenter), by = c("flow_end" = "node") ) |> - dplyr::rename(end_center = ycenter) |> + dplyr::rename("end_center" = "ycenter") |> # Sort for start position - dplyr::arrange(.data$flow_start,.data$end_center) |> # Sort by start node, then by end node position + dplyr::arrange(.data$flow_start, .data$end_center) |> # Sort by start node, then by end node position # Calculate start positions dplyr::mutate( flow_start_ymin =.data$ymin_start + c(0, utils::head(cumsum(.data$n), -1)), @@ -173,7 +173,7 @@ make_flows <- function(x, nodes){ .by = "flow_start" ) |> # sort for end position - dplyr::arrange(.data$flow_end,.data$start_center) |> # Sort by end node, then by start node position + dplyr::arrange(.data$flow_end, .data$start_center) |> # Sort by end node, then by start node position # Calculate end positions dplyr::mutate( flow_end_ymin =.data$ymin_end + c(0, utils::head(cumsum(.data$n), -1)), @@ -181,16 +181,16 @@ make_flows <- function(x, nodes){ .by = "flow_end" ) |> # Clean up temporary columns - dplyr::select(-start_center, -end_center) |> + dplyr::select(-.data$start_center, -.data$end_center) |> dplyr::mutate( flow_start_center =.data$flow_start_ymin + ((.data$flow_start_ymax -.data$flow_start_ymin) / 2), flow_end_center =.data$flow_end_ymin + ((.data$flow_end_ymax -.data$flow_end_ymin) / 2) ) |> # Labels dplyr::mutate( - hjust = ifelse(direction == "down", 1, 0), - label_x = ifelse(direction == "down",.data$flow_end_x,.data$flow_start_x), - label_y = ifelse(direction == "down",.data$flow_end_center,.data$flow_start_center) + hjust = ifelse(.data$direction == "down", 1, 0), + label_x = ifelse(.data$direction == "down",.data$flow_end_x,.data$flow_start_x), + label_y = ifelse(.data$direction == "down",.data$flow_end_center,.data$flow_start_center) ) return(transitions) @@ -219,15 +219,15 @@ create_flow_curves <- function(flows, nodes, gradient_resolution = 2000) { # Join flows with node colors for start and end nodes flows_with_colors <- flows |> dplyr::left_join( - dplyr::select(nodes, node, colour), + dplyr::select(nodes, .data$node, .data$colour), by = c("flow_start" = "node") ) |> - dplyr::rename(color_start = colour) |> + dplyr::rename("color_start" = "colour") |> dplyr::left_join( - dplyr::select(nodes, node, colour), + dplyr::select(nodes, .data$node, .data$colour), by = c("flow_end" = "node") ) |> - dplyr::rename(color_end = colour) + dplyr::rename("color_end" = "colour") # Create the flow curves with color gradients flows_with_colors |> diff --git a/data-raw/flow_labels.csv b/data-raw/flow_labels.csv index 6c1e323..0bc9280 100644 --- a/data-raw/flow_labels.csv +++ b/data-raw/flow_labels.csv @@ -60,3 +60,4 @@ flow_start,flow_end,flow_label "cm, itn, vaccine","cm, itn, irs, vaccine",Add irs "cm, itn, chem","cm, itn, irs, chem",Add irs "cm, itn, chem, vaccine","cm, itn, irs, chem, vaccine",Add irs +"cm, itn","cm, itn, irs",Add irs diff --git a/data/flow_labels.rda b/data/flow_labels.rda index e2fdc076e62d3293626303e7f9f28e0017f541b9..8ccbd2b38802da421a370fba463f41bd3a629268 100644 GIT binary patch literal 599 zcmV-d0;v5$T4*^jL0KkKS>-UR#Q+4%|A7Dh|NsC0`_Cl+9zefm-+%xCKmy#b#6Sjm zk)uX~APo%~FpUi~Xc}bDXwjf)h|mcdq)KV(GypU-000bt00000a|xp(Lqj2iXk;|e zpaT(;AQ(U}1w|xN$TUMnYM9UyL6G$Upfm;()Xb*T!g^=FhH28d_KbBiYS`J>(AnC; z8+46ULrsX>qj%SYPL+|<$-Q?yS;^6{)v|Bc-r&M(r1&iBb?g{0f>{(T8*bspppDzf zU%`buN@K{bT-o$#TT*MJ3$d@a<^Tave6QP1KtK(eZ2jk)+D$hItun=K65C8ssI>j( zjPuV0!%Shz>#3tew6>P$5lrrbC1M+uE@^edVPSA*a2F(8t;PjP%<$sNir8B$vlK#x zkkqh{^g=??L12kXCMy;KVu+K`WSZ=VnOP)ulTulr!B~>f7%X8aRw7uk(2roi%PD0s zF>qoiC4`wsYJe9=A*;6=3uUQA5M~9X!x3#40D`fJRJO*eOA(E!R6#(HY_=F9D=iw! zQDrHWnZLWs&xqWodXFMJr;#3xPR3Gs(s`4*Ie*ODo2P5I=L7y9|5=|u4+EG`KS2#3 zYV{lkBU*1q8|N|^<9;~jLOn6%nr6hzF(>*tWaBv#Q0&cn;&Af`@#X`DBd#iX-q8;H ziR{qVv$ubK5eHVtGcI0B9Nkpa2G%Gynh^8Z?2eJ!mu%!P;+`45)KSQrrQYz=@2INn|2x zB|GMU8@Q$ABKN}PSA%sD{w+9{xD*XY4h(Rr;qAOP8BpEcqf38-hl-ycB}%bYughbb zpQER$&8u-!U454-<+hTr*IluzkU#^pn>#bmY8uWdY|6F86-*^*YJT&^dFO$}Ok(A+ ztD{6wQFIiv&q0$844>xM z^0^aODKc0DVORuu$38+{LS7=G20ur~ILyvl1L%KbC{U?QWJm>p1i(`G4PcDd7LqX$ z1cabQsxd6Ydm{>xp-%zHd#|GRhnU-eh}5R3TisHTn+00Pl|X~`v>>YxkI7iqcan6} z5HiFew=#BUv`=XfQa~gSh@%KakQz);$pwVD^S?lzDMTW!5o}SjDFThw?2^oiateY( dWC@<)-5P-cZa{(l06ORVUC9*TLPB}O%lreC_B{Xq diff --git a/man/make_sankey.Rd b/man/make_sankey.Rd index 3d11f04..1d7ac8d 100644 --- a/man/make_sankey.Rd +++ b/man/make_sankey.Rd @@ -37,8 +37,6 @@ make_sankey( \item{flow_alpha}{Numeric. Transparency of flow ribbons (default: 0.3)} \item{gradient_res}{Integer. Resolution of flow gradients for smoothness (default: 3000)} - -\item{direction}{String "up", "down", or "updown" to determine flow direction} } \value{ ggplot2 object representing the Sankey diagram diff --git a/tests/testthat/test-sankey_utils.R b/tests/testthat/test-sankey_utils.R index 77f5cce..89986e0 100644 --- a/tests/testthat/test-sankey_utils.R +++ b/tests/testthat/test-sankey_utils.R @@ -168,29 +168,9 @@ test_that("make_flows positions flows within node boundaries", { # Simple edge cases ------------------------------------------------------------ -test_that("make_nodes handles single column", { +test_that("Error on single column", { single_col <- data.frame(`0` = c("A", "B"), check.names = FALSE) - result <- make_nodes(single_col) - - expect_equal(unique(result$xcenter), 1) - expect_equal(nrow(result), 2) -}) - -test_that("make_flows handles single column gracefully", { - single_col <- data.frame(`0` = c("A", "B"), check.names = FALSE) - result <- make_flows(single_col, test_nodes_simple) - - # Should return empty data frame (no transitions possible) - expect_equal(nrow(result), 0) + expect_error(make_sankey(single_col)) }) -test_that("make_nodes centers nodes vertically", { - result <- make_nodes(test_data_simple) - # For each column, sum of ymin and ymax should be close to 0 - for(col in unique(result$xcenter)) { - col_nodes <- result[result$xcenter == col, ] - total_span <- sum(col_nodes$ymin + col_nodes$ymax) - expect_equal(total_span, 0, tolerance = 1e-10) - } -}) diff --git a/vignettes/currentsee.Rmd b/vignettes/currentsee.Rmd index faab58b..cc2e918 100644 --- a/vignettes/currentsee.Rmd +++ b/vignettes/currentsee.Rmd @@ -65,7 +65,7 @@ in the RStudio viewer or an HTML document. ```{r sankey, out.width='100%'} make_sankey( - df, "up" + df[,paste(0:3)] ) ``` From df57e2a2c652651de41a6ab98f26b89a0563ad56 Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 08:51:16 +0000 Subject: [PATCH 03/10] Add twoway to app, and highlight current x label --- R/gg_sankey.R | 8 ++++-- R/gg_sankey_utils.R | 2 +- inst/shiny/app.R | 60 +++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 65 insertions(+), 5 deletions(-) diff --git a/R/gg_sankey.R b/R/gg_sankey.R index 6626bba..dde56c3 100644 --- a/R/gg_sankey.R +++ b/R/gg_sankey.R @@ -37,13 +37,17 @@ make_sankey <- function( stopifnot(ncol(x) > 1) # Make node, flows and curves - nodes <- make_nodes(x, node_width = 0.1) + nodes <- make_nodes(x, node_width = node_width) flows <- make_flows(x, nodes) curves <- create_flow_curves(flows, nodes) if(is.null(x_names)){ x_names <- make_x_labs(names(x)) } + x_name_colour <- rep("#36454F", length(x_names)) + x_name_colour[x_names == "Current"] <- "black" + x_name_size <- rep(x_label_font_size, length(x_names)) + x_name_size[x_names == "Current"] <- x_label_font_size * 1.4 p <- ggplot2::ggplot() + # Flow curves @@ -101,7 +105,7 @@ make_sankey <- function( axis.title.y = ggplot2::element_blank(), axis.text.y = ggplot2::element_blank(), axis.ticks.y = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(size = x_label_font_size, color = "black"), + axis.text.x = ggplot2::element_text(size = x_name_size, color = x_name_colour), legend.position = "none" ) diff --git a/R/gg_sankey_utils.R b/R/gg_sankey_utils.R index 56a2408..417fc49 100644 --- a/R/gg_sankey_utils.R +++ b/R/gg_sankey_utils.R @@ -189,7 +189,7 @@ make_flows <- function(x, nodes){ # Labels dplyr::mutate( hjust = ifelse(.data$direction == "down", 1, 0), - label_x = ifelse(.data$direction == "down",.data$flow_end_x,.data$flow_start_x), + label_x = ifelse(.data$direction == "down",.data$flow_end_x - 0.08, .data$flow_start_x) + 0.05, label_y = ifelse(.data$direction == "down",.data$flow_end_center,.data$flow_start_center) ) diff --git a/inst/shiny/app.R b/inst/shiny/app.R index f795705..0585185 100644 --- a/inst/shiny/app.R +++ b/inst/shiny/app.R @@ -81,6 +81,13 @@ ui <- bslib::card( height = "620px", bslib::navset_card_pill( + bslib::nav_panel( + "Full pathway", + br(), + br(), + uiOutput("sankey_container"), + h4(""), # spacer to avoid scrollbars + ), bslib::nav_panel( "Removing interventions", br(), @@ -331,7 +338,7 @@ server <- function(input, output, session) { make_sankey( f[,paste(steps[steps >= 0])], - node_width = 0.3, + node_width = 0.2, flow_label_font_size = 4, node_label_font_size = 5 ) @@ -379,7 +386,7 @@ server <- function(input, output, session) { currentsee::make_sankey( f[,paste(steps[steps <= 0])], - node_width = 0.25, + node_width = 0.2, flow_label_font_size = 4, node_label_font_size = 5 ) @@ -397,6 +404,55 @@ server <- function(input, output, session) { ) }) + # --------------------------------------------------------------------------- + # 9. Render "full" Sankey (mirror logic). + # --------------------------------------------------------------------------- + output$sankey <- renderPlot({ + d_use <- current_subset() + + current_vals <- unique(as.character(d_use$current)) + current_vals <- current_vals[!is.na(current_vals)] + validate( + need( + length(current_vals) == 1 && current_vals != "All", + "Choose a value for ‘current’ in the left panel to show the Sankey." + ), + need( + nrow(d_use) > 0, + "No matching pathways for this combination of filters." + ) + ) + + f <- sankey_inputs() + validate( + need( + nrow(f) > 0, + "No matching pathways for this combination of filters." + ) + ) + + currentsee::make_sankey( + f[,paste(steps)], + node_width = 0.2, + flow_label_font_size = 4, + node_label_font_size = 5 + ) + }) + + output$sankey_container <- renderUI({ + f <- sankey_inputs() + n_cols <- sum(names(f[, !sapply(f, function(x) all(is.na(x)))]) %in% paste(-20:20)) + plot_width <- n_cols * 200 + + plotOutput( + "sankey", + height = "500px", + width = paste0(plot_width, "px") + ) + }) + + + # --------------------------------------------------------------------------- # Calculate and display filtering percentage # --------------------------------------------------------------------------- From 813322744e63b8bf97235859990394caac4c0970 Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 08:58:37 +0000 Subject: [PATCH 04/10] Simplfy plot selection --- inst/shiny/app.R | 50 +++++++++++++++++++++++++----------------------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/inst/shiny/app.R b/inst/shiny/app.R index 0585185..7d54d0e 100644 --- a/inst/shiny/app.R +++ b/inst/shiny/app.R @@ -78,31 +78,33 @@ ui <- width = 3 ), mainPanel( - bslib::card( - height = "620px", - bslib::navset_card_pill( - bslib::nav_panel( - "Full pathway", - br(), - br(), - uiOutput("sankey_container"), - h4(""), # spacer to avoid scrollbars + # Plot type selector + div( + style = "margin-bottom: 20px;", + radioButtons( + "plot_type", + "Select view:", + choices = list( + "Full pathway" = "full", + "Removing interventions" = "down", + "Adding interventions" = "up" ), - bslib::nav_panel( - "Removing interventions", - br(), - br(), - uiOutput("sankey_down_container"), - h4("") # spacer to avoid scrollbars - ), - bslib::nav_panel( - "Adding interventions", - br(), - br(), - uiOutput("sankey_up_container"), - h4("") # spacer to avoid scrollbars - ) + selected = "full", + inline = TRUE ) + ), + + conditionalPanel( + condition = "input.plot_type == 'full'", + uiOutput("sankey_container") + ), + conditionalPanel( + condition = "input.plot_type == 'down'", + uiOutput("sankey_down_container") + ), + conditionalPanel( + condition = "input.plot_type == 'up'", + uiOutput("sankey_up_container") ) ) ) @@ -395,7 +397,7 @@ server <- function(input, output, session) { output$sankey_down_container <- renderUI({ f <- sankey_inputs() n_cols <- sum(names(f[, !sapply(f, function(x) all(is.na(x)))]) %in% paste(0:-20)) - plot_width <- n_cols * 200 + plot_width <- n_cols * 220 plotOutput( "sankey_down", From e671c0ec395489c8bfffe77ee21eeff07d396a0b Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 09:11:51 +0000 Subject: [PATCH 05/10] Simplify app logic, remove upload --- R/app_utils.R | 148 ++++++++++++ inst/shiny/app.R | 584 ++++++++++------------------------------------- 2 files changed, 274 insertions(+), 458 deletions(-) create mode 100644 R/app_utils.R diff --git a/R/app_utils.R b/R/app_utils.R new file mode 100644 index 0000000..5fa248a --- /dev/null +++ b/R/app_utils.R @@ -0,0 +1,148 @@ +#' Get Filter Variables +#' +#' Identifies which columns in the data should be used as filter variables +#' by excluding core Sankey construction columns. +#' +#' @param data A data frame containing the pathway data +#' @return A character vector of column names to be used as filter variables +get_filter_vars <- function(data) { + core_cols <- c("-4", "-3", "-2", "-1", "0", "1", "2", "3", "4") + c("current", setdiff(names(data), c("current", core_cols))) +} + +#' Apply Filter Selections +#' +#' Subsets the data based on user filter selections from Shiny inputs. +#' Filters are only applied when selection is not NULL or "All". +#' +#' @param data A data frame to be filtered +#' @param filter_vars Character vector of column names to filter on +#' @param input Shiny input object containing filter selections +#' @return A filtered data frame +apply_filters <- function(data, filter_vars, input) { + filtered_data <- data + + for (var in filter_vars) { + selection <- input[[var]] + if (!is.null(selection) && selection != "All") { + filtered_data <- filtered_data[filtered_data[[var]] == selection, , drop = FALSE] + } + } + + filtered_data +} + +#' Validate Current Selection +#' +#' Validates that the 'current' column has exactly one non-NA value +#' that is not "All", which is required for Sankey plot generation. +#' +#' @param data A data frame containing a 'current' column +#' @return NULL (function validates or throws error via shiny::validate) +validate_current_selection <- function(data) { + current_vals <- unique(as.character(data$current)) + current_vals <- current_vals[!is.na(current_vals)] + + validate( + need( + length(current_vals) == 1 && current_vals != "All", + "Choose a value for 'current' in the left panel to show the Sankey." + ), + need( + nrow(data) > 0, + "No matching pathways for this combination of filters." + ) + ) +} + +#' Create Sankey Plot +#' +#' Generates a Sankey diagram with standardized parameters after +#' validating the input data. +#' +#' @param data A data frame containing pathway data +#' @param step_columns Character vector of column names representing steps +#' @return A Sankey plot object from currentsee::make_sankey() +create_sankey_plot <- function(data, step_columns) { + validate_current_selection(data) + + validate( + need( + nrow(data) > 0, + "No matching pathways for this combination of filters." + ) + ) + + currentsee::make_sankey( + data[, step_columns], + node_width = 0.2, + flow_label_font_size = 4, + node_label_font_size = 5 + ) +} + +#' Calculate Plot Width +#' +#' Calculates dynamic plot width based on the number of non-empty columns +#' within a specified step range. +#' +#' @param data A data frame containing the plot data +#' @param step_range Numeric vector of step values to include (e.g., -20:20) +#' @param width_per_col Numeric, width in pixels per column (default: 220) +#' @return Numeric value representing total plot width in pixels +calculate_plot_width <- function(data, step_range, width_per_col = 220) { + n_cols <- sum(names(data[, !sapply(data, function(x) all(is.na(x)))]) %in% paste(step_range)) + n_cols * width_per_col +} + +#' Create Coverage Value Box +#' +#' Generates a styled HTML div showing data coverage percentage with +#' color-coded background and optional warning for low coverage. +#' +#' @param original_rows Numeric, total number of rows in original dataset +#' @param filtered_rows Numeric, number of rows after filtering +#' @return HTML div element with coverage information and styling +create_coverage_box <- function(original_rows, filtered_rows) { + percentage <- if (original_rows == 0) 0 else round((filtered_rows / original_rows) * 100, 1) + + # Dynamic color based on coverage percentage + bg_color <- case_when( + percentage >= 80 ~ "#28a745", + percentage >= 60 ~ "#6cb04a", + percentage >= 40 ~ "#9bc53d", + percentage >= 25 ~ "#ffc107", + percentage >= 15 ~ "#fd7e14", + TRUE ~ "#dc3545" + ) + + # Warning for very low coverage + subtitle_text <- if (percentage < 10) { + div( + style = "font-size: 0.9em; margin-top: 8px; font-weight: bold;", + "\u26a0 very few records matched" + ) + } else { + NULL + } + + div( + style = paste0( + "background: linear-gradient(135deg, ", bg_color, " 0%, ", + adjustcolor(bg_color, alpha.f = 0.8), " 100%); ", + "border-radius: 12px; padding: 20px; text-align: center; ", + "color: white; box-shadow: 0 4px 15px rgba(0,0,0,0.2); ", + "margin-bottom: 20px; transition: all 0.3s ease;" + ), + div( + style = "display: flex; align-items: center; justify-content: center; margin-bottom: 10px;", + bsicons::bs_icon("funnel", size = "1.2em", style = "margin-right: 15px;"), + span("Records Matched", style = "font-size: 1.2em; font-weight: 500; margin-left: 8px;") + ), + div( + style = "font-size: 2.5em; font-weight: bold; margin-bottom: 5px;", + paste0(percentage, "%") + ), + subtitle_text + ) +} diff --git a/inst/shiny/app.R b/inst/shiny/app.R index 7d54d0e..274eb92 100644 --- a/inst/shiny/app.R +++ b/inst/shiny/app.R @@ -11,518 +11,186 @@ library(dplyr) library(tidyr) library(bsicons) -ui <- - fluidPage( - # Include the external CSS - tags$head( - tags$link(rel = "stylesheet", type = "text/css", href = "custom.css") - ), - navbarPage( - title = div( - class = "app-navbar-brand", - img(src = "M3CPI_transparent.png", alt = "M3CPI Logo"), - div( - class = "app-brand-text", - div("M3CPI", class = "app-brand-title"), - div("modelling to inform malaria intervention prioritisation", - class = "app-brand-subtitle") - ) - ), - theme = shinythemes::shinytheme("readable"), +# Helper Functions -------------------------------------------------------- - # Page 1: Introduction ------------------------------------------------------- - tab_introduction(), - # ---------------------------------------------------------------------------- - # Page 2: Methods ------------------------------------------------------- - tab_methods(), - # ---------------------------------------------------------------------------- +# UI Definition ----------------------------------------------------------- - # Page 3: How to interpret output -------------------------------------------- - tabPanel( - "How to interpret output", - fluidPage( - tags$iframe( - src = "sankey_101.pdf", - width = "100%", - height = "600px", - style = "border: none;" - ) +ui <- fluidPage( + tags$head( + tags$link(rel = "stylesheet", type = "text/css", href = "custom.css") + ), + navbarPage( + title = div( + class = "app-navbar-brand", + img(src = "M3CPI_transparent.png", alt = "M3CPI Logo"), + div( + class = "app-brand-text", + div("M3CPI", class = "app-brand-title"), + div("modelling to inform malaria intervention prioritisation", + class = "app-brand-subtitle") + ) + ), + theme = shinythemes::shinytheme("readable"), + + tab_introduction(), + tab_methods(), + + tabPanel( + "How to interpret output", + fluidPage( + tags$iframe( + src = "sankey_101.pdf", + width = "100%", + height = "600px", + style = "border: none;" ) - ), - # ---------------------------------------------------------------------------- - - # Page 3: Output ------------------------------------------------------------- - tabPanel( - "Explore", - fluidPage( - h3("Cost-effective intervention pathways"), - br(), - br(), - sidebarLayout( - sidebarPanel( - - uiOutput("dynamic_value_box"), - - # Dynamic filter inputs -------------------------------------------- - uiOutput("dynamic_filters"), - br(), - br(), - - # Optional CSV upload ---------------------------------------------- - fileInput( - "csv_upload", - "Upload CSV to replace default inputs", - accept = c(".csv", "text/csv", "text/comma-separated-values") - ), - width = 3 - ), - mainPanel( - # Plot type selector - div( - style = "margin-bottom: 20px;", - radioButtons( - "plot_type", - "Select view:", - choices = list( - "Full pathway" = "full", - "Removing interventions" = "down", - "Adding interventions" = "up" - ), - selected = "full", - inline = TRUE - ) - ), + ) + ), - conditionalPanel( - condition = "input.plot_type == 'full'", - uiOutput("sankey_container") - ), - conditionalPanel( - condition = "input.plot_type == 'down'", - uiOutput("sankey_down_container") - ), - conditionalPanel( - condition = "input.plot_type == 'up'", - uiOutput("sankey_up_container") + tabPanel( + "Explore", + fluidPage( + h3("Cost-effective intervention pathways"), + br(), br(), + sidebarLayout( + sidebarPanel( + uiOutput("coverage_box"), + uiOutput("filter_controls"), + width = 3 + ), + mainPanel( + div( + style = "margin-bottom: 20px;", + radioButtons( + "plot_type", + "Select view:", + choices = list( + "Full pathway" = "full", + "Removing interventions" = "down", + "Adding interventions" = "up" + ), + selected = "full", + inline = TRUE ) + ), + conditionalPanel( + condition = "input.plot_type == 'full'", + uiOutput("sankey_full_container") + ), + conditionalPanel( + condition = "input.plot_type == 'down'", + uiOutput("sankey_down_container") + ), + conditionalPanel( + condition = "input.plot_type == 'up'", + uiOutput("sankey_up_container") ) ) ) - ), - # ---------------------------------------------------------------------------- - - # Page 4: FAQs --------------------------------------------------------------- - tab_faqs(), - # ---------------------------------------------------------------------------- + ) + ), - # Page 5: Modelling team ----------------------------------------------------- - tab_team() - # ---------------------------------------------------------------------------- - ) + tab_faqs(), + tab_team() ) +) +# Server Logic ------------------------------------------------------------ server <- function(input, output, session) { - # --------------------------------------------------------------------------- - # 0. Columns we consider "core" to Sankey construction. - # Everything NOT in this list will become a filter dropdown automatically. - # Adjust this list to match what make_nodes / make_links require. - # --------------------------------------------------------------------------- - core_cols <- c("-4", "-3", "-2", "-1", "0", "1", "2", "3", "4") - - # --------------------------------------------------------------------------- - # 1. Working dataset. - # Starts as df from opts, replaced on upload after validation. - # --------------------------------------------------------------------------- - df_current <- reactiveVal(df) - - - # --------------------------------------------------------------------------- - # 2. Handle CSV upload with sanity checks. - # --------------------------------------------------------------------------- - observeEvent(input$csv_upload, { - req(input$csv_upload) - - d_new <- tryCatch( - read.csv(input$csv_upload$datapath, check.names = FALSE), - error = function(e) NULL - ) + # Reactive values + filter_vars <- reactive(get_filter_vars(df)) - required_cols <- c("step", "current") # minimal cols to proceed - missing_cols <- setdiff(required_cols, names(d_new)) - - if (is.null(d_new) || length(missing_cols) > 0) { - showModal(modalDialog( - title = "Upload error", - paste0( - "The uploaded file is missing required columns: ", - paste(missing_cols, collapse = ", "), - ". Please upload a file with at least these columns." - ), - easyClose = TRUE, - footer = modalButton("OK") - )) - return(NULL) - } - - df_current(d_new) - }) - - - # --------------------------------------------------------------------------- - # 3. filter_vars(): which columns should get dropdowns? - # It's all non-core columns in the *current* data, excluding anything - # that looks continuous/too granular if you want to be picky. - # For now we include everything that's not in core_cols. - # --------------------------------------------------------------------------- - filter_vars <- reactive({ - d <- df_current() - c("current", setdiff(names(d), c("current", core_cols))) + filtered_data <- reactive({ + apply_filters(df, filter_vars(), input) }) - - # --------------------------------------------------------------------------- - # 4. current_subset(): apply all active filter selections to df_current(). - # For each filter var v: - # - if input[[v]] is NULL or "All", we don't filter on v - # - otherwise we keep only rows matching that value - # --------------------------------------------------------------------------- - current_subset <- reactive({ - d <- df_current() + # Dynamic filter controls + output$filter_controls <- renderUI({ fvars <- filter_vars() - if (length(fvars) == 0) { - return(d) - } - - for (v in fvars) { - sel <- input[[v]] - if (!is.null(sel) && sel != "All") { - d <- d[d[[v]] == sel, , drop = FALSE] - } - } - - d - }) - - - # --------------------------------------------------------------------------- - # 5. Render the dynamic filter dropdowns initially. - # We create one selectInput per filter var. - # Each starts at "All". - # (We'll keep them in sync in the observer below.) - # --------------------------------------------------------------------------- - output$dynamic_filters <- renderUI({ - d <- df_current() - fvars <- filter_vars() - - lapply(fvars, function(v) { - vals <- sort(unique(as.character(d[[v]]))) + lapply(fvars, function(var) { + values <- sort(unique(as.character(df[[var]]))) selectInput( - inputId = v, - label = v, - choices = c("All", vals), - selected = "All", + inputId = var, + label = var, + choices = c("All", values), + selected = "All", selectize = TRUE ) }) }) - - # --------------------------------------------------------------------------- - # 6. Keep dropdowns mutually consistent. - # - # Idea: - # - For each filter var v, we update its choices based on all the OTHER - # filters' current selections. - # - # Why not just use current_subset() for all of them? - # Because that would lock v to its existing selection immediately. - # Instead, for each v we: - # 1. start from full df_current() - # 2. apply all filters EXCEPT v - # 3. whatever unique values remain in column v become its allowed choices - # - # We also try to keep your current selection if it's still valid. - # --------------------------------------------------------------------------- + # Keep filter dropdowns mutually consistent observe({ - d_full <- df_current() - fvars <- filter_vars() - - # Nothing to do if we don't have any filter vars yet (e.g. before upload). - if (length(fvars) == 0) { - return(NULL) - } + fvars <- filter_vars() - for (v in fvars) { + if (length(fvars) == 0) return(NULL) - # Build "partial subset" applying all filters except v - d_partial <- d_full - for (u in fvars) { - if (u == v) next - sel_u <- input[[u]] - if (!is.null(sel_u) && sel_u != "All") { - d_partial <- d_partial[d_partial[[u]] == sel_u, , drop = FALSE] + for (var in fvars) { + # Apply all filters except the current one + partial_data <- df + for (other_var in fvars) { + if (other_var == var) next + selection <- input[[other_var]] + if (!is.null(selection) && selection != "All") { + partial_data <- partial_data[partial_data[[other_var]] == selection, , drop = FALSE] } } - # Valid choices for v under other filters - poss_vals <- sort(unique(as.character(d_partial[[v]]))) - poss_choices <- c("All", poss_vals) + # Update choices based on remaining valid values + valid_values <- sort(unique(as.character(partial_data[[var]]))) + valid_choices <- c("All", valid_values) - # Keep current selection if it's still valid, else "All" - current_sel <- isolate(input[[v]]) - if (is.null(current_sel) || !(current_sel %in% poss_choices)) { - current_sel <- "All" + # Preserve current selection if still valid + current_selection <- isolate(input[[var]]) + if (is.null(current_selection) || !(current_selection %in% valid_choices)) { + current_selection <- "All" } updateSelectInput( session, - inputId = v, - choices = poss_choices, - selected = current_sel + inputId = var, + choices = valid_choices, + selected = current_selection ) } }) - - # --------------------------------------------------------------------------- - # 7. Helper: given a subsetted df, build the Sankey node/link inputs. - # - Split into up/down by step sign - # - Call your helper fns - # Returns a list(nodes_up, links_up, nodes_down, links_down) - # --------------------------------------------------------------------------- - sankey_inputs <- reactive({ - current_subset() + # Coverage indicator + output$coverage_box <- renderUI({ + create_coverage_box(nrow(df), nrow(filtered_data())) }) - - # --------------------------------------------------------------------------- - # 8. Render "Increasing spend" Sankey. - # - # We still require that "current" is pinned down sensibly, - # because the story you're telling needs a specific 'current' - # (or at least not "All"). - # - # current is in core_cols, not guaranteed to be in filter_vars, - # so we read it out of the *subset*. - # - # We'll accept this if there's exactly one non-NA current in the subset - # and it's not "All". - # --------------------------------------------------------------------------- - output$sankey_up <- renderPlot({ - d_use <- current_subset() - - # Check current is defined sensibly in the subset - current_vals <- unique(as.character(d_use$current)) - current_vals <- current_vals[!is.na(current_vals)] - - validate( - need( - length(current_vals) == 1 && current_vals != "All", - "Choose a value for ‘current’ in the left panel to show the Sankey." - ), - need( - nrow(d_use) > 0, - "No matching pathways for this combination of filters." - ) - ) - - f <- sankey_inputs() - validate( - need( - nrow(f) > 0, - "No matching pathways for this combination of filters." - ) - ) - - make_sankey( - f[,paste(steps[steps >= 0])], - node_width = 0.2, - flow_label_font_size = 4, - node_label_font_size = 5 - ) - }) - - output$sankey_up_container <- renderUI({ - f <- sankey_inputs() - n_cols <- sum(names(f[, !sapply(f, function(x) all(is.na(x)))]) %in% paste(0:20)) - plot_width <- n_cols * 220 - - plotOutput( - "sankey_up", - height = "500px", - width = paste0(plot_width, "px") - ) + # Sankey plot renderers + output$sankey_full <- renderPlot({ + create_sankey_plot(filtered_data(), paste(steps)) }) - - # --------------------------------------------------------------------------- - # 9. Render "Decreasing spend" Sankey (mirror logic). - # --------------------------------------------------------------------------- output$sankey_down <- renderPlot({ - d_use <- current_subset() - - current_vals <- unique(as.character(d_use$current)) - current_vals <- current_vals[!is.na(current_vals)] - validate( - need( - length(current_vals) == 1 && current_vals != "All", - "Choose a value for ‘current’ in the left panel to show the Sankey." - ), - need( - nrow(d_use) > 0, - "No matching pathways for this combination of filters." - ) - ) - - f <- sankey_inputs() - validate( - need( - nrow(f) > 0, - "No matching pathways for this combination of filters." - ) - ) - - currentsee::make_sankey( - f[,paste(steps[steps <= 0])], - node_width = 0.2, - flow_label_font_size = 4, - node_label_font_size = 5 - ) + create_sankey_plot(filtered_data(), paste(steps[steps <= 0])) }) - output$sankey_down_container <- renderUI({ - f <- sankey_inputs() - n_cols <- sum(names(f[, !sapply(f, function(x) all(is.na(x)))]) %in% paste(0:-20)) - plot_width <- n_cols * 220 - - plotOutput( - "sankey_down", - height = "500px", - width = paste0(plot_width, "px") - ) - }) - - # --------------------------------------------------------------------------- - # 9. Render "full" Sankey (mirror logic). - # --------------------------------------------------------------------------- - output$sankey <- renderPlot({ - d_use <- current_subset() - - current_vals <- unique(as.character(d_use$current)) - current_vals <- current_vals[!is.na(current_vals)] - validate( - need( - length(current_vals) == 1 && current_vals != "All", - "Choose a value for ‘current’ in the left panel to show the Sankey." - ), - need( - nrow(d_use) > 0, - "No matching pathways for this combination of filters." - ) - ) - - f <- sankey_inputs() - validate( - need( - nrow(f) > 0, - "No matching pathways for this combination of filters." - ) - ) - - currentsee::make_sankey( - f[,paste(steps)], - node_width = 0.2, - flow_label_font_size = 4, - node_label_font_size = 5 - ) + output$sankey_up <- renderPlot({ + create_sankey_plot(filtered_data(), paste(steps[steps >= 0])) }) - output$sankey_container <- renderUI({ - f <- sankey_inputs() - n_cols <- sum(names(f[, !sapply(f, function(x) all(is.na(x)))]) %in% paste(-20:20)) - plot_width <- n_cols * 200 - - plotOutput( - "sankey", - height = "500px", - width = paste0(plot_width, "px") - ) + # Dynamic plot containers with appropriate widths + output$sankey_full_container <- renderUI({ + plot_width <- calculate_plot_width(filtered_data(), -20:20, 200) + plotOutput("sankey_full", height = "500px", width = paste0(plot_width, "px")) }) - - - # --------------------------------------------------------------------------- - # Calculate and display filtering percentage - # --------------------------------------------------------------------------- - output$filter_percentage <- renderText({ - original_rows <- nrow(df_current()) # Denominator: original data - filtered_rows <- nrow(current_subset()) # Numerator: filtered data - - if (original_rows == 0) { - percentage <- 0 - } else { - percentage <- round((filtered_rows / original_rows) * 100, 1) - } - - paste0(percentage, "%") + output$sankey_down_container <- renderUI({ + plot_width <- calculate_plot_width(filtered_data(), 0:-20, 220) + plotOutput("sankey_down", height = "500px", width = paste0(plot_width, "px")) }) - # Optional: Dynamic % coverage - output$dynamic_value_box <- renderUI({ - original_rows <- nrow(df_current()) - filtered_rows <- nrow(current_subset()) - - if (original_rows == 0) { - percentage <- 0 - } else { - percentage <- round((filtered_rows / original_rows) * 100, 1) - } - - # Custom color for smooth gradient - bg_color <- if (percentage >= 80) "#28a745" - else if (percentage >= 60) "#6cb04a" - else if (percentage >= 40) "#9bc53d" - else if (percentage >= 25) "#ffc107" - else if (percentage >= 15) "#fd7e14" - else "#dc3545" - - # Warning for very low coverage - subtitle_text <- if (percentage < 10) { - div( - style = "font-size: 0.9em; margin-top: 8px; font-weight: bold;", - "\u26a0 very low coverage" - ) - } else { - NULL - } - - # Fully custom value box - div( - style = paste0( - "background: linear-gradient(135deg, ", bg_color, " 0%, ", - adjustcolor(bg_color, alpha.f = 0.8), " 100%); ", - "border-radius: 12px; padding: 20px; text-align: center; ", - "color: white; box-shadow: 0 4px 15px rgba(0,0,0,0.2); ", - "margin-bottom: 20px; transition: all 0.3s ease;" - ), - # Title row - div( - style = "display: flex; align-items: center; justify-content: center; margin-bottom: 10px;", - bsicons::bs_icon("funnel", size = "1.2em", style = "margin-right: 8px;"), - span(" Data Coverage", style = "font-size: 1.2em; font-weight: 500;") - ), - # Percentage value - div( - style = "font-size: 2.5em; font-weight: bold; margin-bottom: 5px;", - paste0(percentage, "%") - ), - # Subtitle/warning - subtitle_text - ) + output$sankey_up_container <- renderUI({ + plot_width <- calculate_plot_width(filtered_data(), 0:20, 220) + plotOutput("sankey_up", height = "500px", width = paste0(plot_width, "px")) }) } From 477022b7a788b489b53214414b9cdd9439592630 Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 09:14:09 +0000 Subject: [PATCH 06/10] docs --- DESCRIPTION | 2 +- R/gg_sankey_utils.R | 2 +- man/apply_filters.Rd | 22 ++++++++++++++++++++++ man/calculate_plot_width.Rd | 22 ++++++++++++++++++++++ man/create_coverage_box.Rd | 20 ++++++++++++++++++++ man/create_sankey_plot.Rd | 20 ++++++++++++++++++++ man/get_filter_vars.Rd | 18 ++++++++++++++++++ man/validate_current_selection.Rd | 18 ++++++++++++++++++ 8 files changed, 122 insertions(+), 2 deletions(-) create mode 100644 man/apply_filters.Rd create mode 100644 man/calculate_plot_width.Rd create mode 100644 man/create_coverage_box.Rd create mode 100644 man/create_sankey_plot.Rd create mode 100644 man/get_filter_vars.Rd create mode 100644 man/validate_current_selection.Rd diff --git a/DESCRIPTION b/DESCRIPTION index dded53c..3970a52 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: currentsee Title: Sankey diagrams for malaria CE analysis -Version: 1.1.2 +Version: 1.1.3 Authors@R: c( person("Pete", "Winskill", email = "p.winskill@imperial.ac.uk", role = c("aut", "cre")) ) diff --git a/R/gg_sankey_utils.R b/R/gg_sankey_utils.R index 417fc49..b1a9705 100644 --- a/R/gg_sankey_utils.R +++ b/R/gg_sankey_utils.R @@ -165,7 +165,7 @@ make_flows <- function(x, nodes){ ) |> dplyr::rename("end_center" = "ycenter") |> # Sort for start position - dplyr::arrange(.data$flow_start, .data$end_center) |> # Sort by start node, then by end node position + dplyr::arrange(.data$flow_start, .data$end_center) |> # Calculate start positions dplyr::mutate( flow_start_ymin =.data$ymin_start + c(0, utils::head(cumsum(.data$n), -1)), diff --git a/man/apply_filters.Rd b/man/apply_filters.Rd new file mode 100644 index 0000000..7708b5f --- /dev/null +++ b/man/apply_filters.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_utils.R +\name{apply_filters} +\alias{apply_filters} +\title{Apply Filter Selections} +\usage{ +apply_filters(data, filter_vars, input) +} +\arguments{ +\item{data}{A data frame to be filtered} + +\item{filter_vars}{Character vector of column names to filter on} + +\item{input}{Shiny input object containing filter selections} +} +\value{ +A filtered data frame +} +\description{ +Subsets the data based on user filter selections from Shiny inputs. +Filters are only applied when selection is not NULL or "All". +} diff --git a/man/calculate_plot_width.Rd b/man/calculate_plot_width.Rd new file mode 100644 index 0000000..a2917cf --- /dev/null +++ b/man/calculate_plot_width.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_utils.R +\name{calculate_plot_width} +\alias{calculate_plot_width} +\title{Calculate Plot Width} +\usage{ +calculate_plot_width(data, step_range, width_per_col = 220) +} +\arguments{ +\item{data}{A data frame containing the plot data} + +\item{step_range}{Numeric vector of step values to include (e.g., -20:20)} + +\item{width_per_col}{Numeric, width in pixels per column (default: 220)} +} +\value{ +Numeric value representing total plot width in pixels +} +\description{ +Calculates dynamic plot width based on the number of non-empty columns +within a specified step range. +} diff --git a/man/create_coverage_box.Rd b/man/create_coverage_box.Rd new file mode 100644 index 0000000..0a981b1 --- /dev/null +++ b/man/create_coverage_box.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_utils.R +\name{create_coverage_box} +\alias{create_coverage_box} +\title{Create Coverage Value Box} +\usage{ +create_coverage_box(original_rows, filtered_rows) +} +\arguments{ +\item{original_rows}{Numeric, total number of rows in original dataset} + +\item{filtered_rows}{Numeric, number of rows after filtering} +} +\value{ +HTML div element with coverage information and styling +} +\description{ +Generates a styled HTML div showing data coverage percentage with +color-coded background and optional warning for low coverage. +} diff --git a/man/create_sankey_plot.Rd b/man/create_sankey_plot.Rd new file mode 100644 index 0000000..eeee1e2 --- /dev/null +++ b/man/create_sankey_plot.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_utils.R +\name{create_sankey_plot} +\alias{create_sankey_plot} +\title{Create Sankey Plot} +\usage{ +create_sankey_plot(data, step_columns) +} +\arguments{ +\item{data}{A data frame containing pathway data} + +\item{step_columns}{Character vector of column names representing steps} +} +\value{ +A Sankey plot object from currentsee::make_sankey() +} +\description{ +Generates a Sankey diagram with standardized parameters after +validating the input data. +} diff --git a/man/get_filter_vars.Rd b/man/get_filter_vars.Rd new file mode 100644 index 0000000..5327332 --- /dev/null +++ b/man/get_filter_vars.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_utils.R +\name{get_filter_vars} +\alias{get_filter_vars} +\title{Get Filter Variables} +\usage{ +get_filter_vars(data) +} +\arguments{ +\item{data}{A data frame containing the pathway data} +} +\value{ +A character vector of column names to be used as filter variables +} +\description{ +Identifies which columns in the data should be used as filter variables +by excluding core Sankey construction columns. +} diff --git a/man/validate_current_selection.Rd b/man/validate_current_selection.Rd new file mode 100644 index 0000000..2cb451c --- /dev/null +++ b/man/validate_current_selection.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/app_utils.R +\name{validate_current_selection} +\alias{validate_current_selection} +\title{Validate Current Selection} +\usage{ +validate_current_selection(data) +} +\arguments{ +\item{data}{A data frame containing a 'current' column} +} +\value{ +NULL (function validates or throws error via shiny::validate) +} +\description{ +Validates that the 'current' column has exactly one non-NA value +that is not "All", which is required for Sankey plot generation. +} From 09f740a53120113e339b980802d1bb0ef2fc9397 Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 09:18:51 +0000 Subject: [PATCH 07/10] Supress ggplot theme warning --- R/gg_sankey.R | 18 ++++++++++-------- R/gg_sankey_utils.R | 12 ++++++------ 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/R/gg_sankey.R b/R/gg_sankey.R index dde56c3..d93a9ad 100644 --- a/R/gg_sankey.R +++ b/R/gg_sankey.R @@ -100,14 +100,16 @@ make_sankey <- function( minor_breaks = NULL, name = "") + ggplot2::scale_y_continuous(breaks = NULL, labels = NULL) + ggplot2::theme_minimal() + - ggplot2::theme( - panel.grid = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(size = x_name_size, color = x_name_colour), - legend.position = "none" - ) + suppressWarnings({ + ggplot2::theme( + panel.grid = ggplot2::element_blank(), + axis.title.y = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.ticks.y = ggplot2::element_blank(), + axis.text.x = ggplot2::element_text(size = x_name_size, color = x_name_colour), + legend.position = "none" + ) + }) return(p) } diff --git a/R/gg_sankey_utils.R b/R/gg_sankey_utils.R index b1a9705..cd5aab3 100644 --- a/R/gg_sankey_utils.R +++ b/R/gg_sankey_utils.R @@ -147,7 +147,7 @@ make_flows <- function(x, nodes){ currentsee::flow_labels, by = c("label_start" = "flow_start", "label_end" = "flow_end") ) |> - dplyr::select(-.data$label_start, -.data$label_end) |> + dplyr::select(-"label_start", -"label_end") |> # Flow starts and ends dplyr::mutate( flow_start_x = .data$xmax_start, @@ -155,12 +155,12 @@ make_flows <- function(x, nodes){ ) |> # ADD NODE CENTER POSITIONS FOR SORTING dplyr::left_join( - dplyr::select(nodes, .data$node, .data$ycenter), + dplyr::select(nodes, "node", "ycenter"), by = c("flow_start" = "node") ) |> dplyr::rename("start_center" = "ycenter") |> dplyr::left_join( - dplyr::select(nodes, .data$node, .data$ycenter), + dplyr::select(nodes, "node", "ycenter"), by = c("flow_end" = "node") ) |> dplyr::rename("end_center" = "ycenter") |> @@ -181,7 +181,7 @@ make_flows <- function(x, nodes){ .by = "flow_end" ) |> # Clean up temporary columns - dplyr::select(-.data$start_center, -.data$end_center) |> + dplyr::select(-"start_center", -"end_center") |> dplyr::mutate( flow_start_center =.data$flow_start_ymin + ((.data$flow_start_ymax -.data$flow_start_ymin) / 2), flow_end_center =.data$flow_end_ymin + ((.data$flow_end_ymax -.data$flow_end_ymin) / 2) @@ -219,12 +219,12 @@ create_flow_curves <- function(flows, nodes, gradient_resolution = 2000) { # Join flows with node colors for start and end nodes flows_with_colors <- flows |> dplyr::left_join( - dplyr::select(nodes, .data$node, .data$colour), + dplyr::select(nodes, "node", "colour"), by = c("flow_start" = "node") ) |> dplyr::rename("color_start" = "colour") |> dplyr::left_join( - dplyr::select(nodes, .data$node, .data$colour), + dplyr::select(nodes, "node", "colour"), by = c("flow_end" = "node") ) |> dplyr::rename("color_end" = "colour") From 70e6c42f2896969540c061c255a0b3aeb0177a95 Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 09:23:26 +0000 Subject: [PATCH 08/10] Add app utils testing --- tests/testthat/test-App-utils.R | 255 ++++++++++++++++++++++++++++++++ 1 file changed, 255 insertions(+) create mode 100644 tests/testthat/test-App-utils.R diff --git a/tests/testthat/test-App-utils.R b/tests/testthat/test-App-utils.R new file mode 100644 index 0000000..4ab5db2 --- /dev/null +++ b/tests/testthat/test-App-utils.R @@ -0,0 +1,255 @@ +# Test data setup +setup_test_data <- function() { + data.frame( + current = c("A", "A", "B", "B"), + region = c("North", "South", "North", "South"), + intervention = c("ITN", "IRS", "ITN", "SMC"), + `-2` = c("baseline", "baseline", "ITN", "ITN"), + `-1` = c("baseline", "ITN", "ITN", "ITN+IRS"), + `0` = c("ITN", "ITN", "ITN+IRS", "ITN+IRS+SMC"), + `1` = c("ITN+IRS", "ITN+IRS", "ITN+IRS+SMC", NA), + `2` = c("ITN+IRS+SMC", NA, NA, NA), + check.names = FALSE, + stringsAsFactors = FALSE + ) +} + +# Mock input object for testing +mock_input <- function(selections = list()) { + structure(selections, class = "reactivevalues") +} + +# Tests for get_filter_vars() ------------------------------------------------ + +test_that("get_filter_vars returns correct filter variables", { + test_data <- setup_test_data() + + result <- get_filter_vars(test_data) + expected <- c("current", "region", "intervention") + + expect_equal(result, expected) + expect_type(result, "character") +}) + +test_that("get_filter_vars handles data with only core columns", { + core_only_data <- data.frame( + current = c("A", "B"), + `-1` = c("x", "y"), + `0` = c("y", "z"), + `1` = c("z", "w"), + check.names = FALSE + ) + + result <- get_filter_vars(core_only_data) + expect_equal(result, "current") +}) + +test_that("get_filter_vars handles empty data frame", { + empty_data <- data.frame() + result <- get_filter_vars(empty_data) + expect_equal(result, "current") +}) + +# Tests for apply_filters() -------------------------------------------------- + +test_that("apply_filters works with single filter", { + test_data <- setup_test_data() + filter_vars <- c("region") + input <- list(region = "North") + + result <- apply_filters(test_data, filter_vars, input) + + expect_equal(nrow(result), 2) + expect_true(all(result$region == "North")) +}) + +test_that("apply_filters works with multiple filters", { + test_data <- setup_test_data() + filter_vars <- c("region", "intervention") + input <- list(region = "North", intervention = "ITN") + + result <- apply_filters(test_data, filter_vars, input) + + expect_equal(nrow(result), 2) + expect_equal(result$region, c("North", "North")) + expect_equal(result$intervention, c("ITN", "ITN")) +}) + +test_that("apply_filters ignores 'All' selections", { + test_data <- setup_test_data() + filter_vars <- c("region", "intervention") + input <- list(region = "All", intervention = "ITN") + + result <- apply_filters(test_data, filter_vars, input) + + expect_equal(nrow(result), 2) # Only filtered by intervention + expect_true(all(result$intervention == "ITN")) +}) + +test_that("apply_filters ignores NULL selections", { + test_data <- setup_test_data() + filter_vars <- c("region", "intervention") + input <- list(region = NULL, intervention = "ITN") + + result <- apply_filters(test_data, filter_vars, input) + + expect_equal(nrow(result), 2) # Only filtered by intervention + expect_true(all(result$intervention == "ITN")) +}) + +test_that("apply_filters returns original data when no filters applied", { + test_data <- setup_test_data() + filter_vars <- c("region", "intervention") + input <- list(region = "All", intervention = "All") + + result <- apply_filters(test_data, filter_vars, input) + + expect_equal(result, test_data) +}) + +test_that("apply_filters returns empty data frame when no matches", { + test_data <- setup_test_data() + filter_vars <- c("region") + input <- list(region = "NonExistent") + + result <- apply_filters(test_data, filter_vars, input) + + expect_equal(nrow(result), 0) + expect_equal(ncol(result), ncol(test_data)) +}) + +# Tests for validate_current_selection() ------------------------------------- + +test_that("validate_current_selection passes with valid single current", { + test_data <- data.frame(current = c("A", "A", "A")) + + # Should not throw an error + expect_silent(validate_current_selection(test_data)) +}) + +test_that("validate_current_selection fails with multiple current values", { + test_data <- data.frame(current = c("A", "B", "A")) + + expect_error( + validate_current_selection(test_data), + "Choose a value for 'current'" + ) +}) + +test_that("validate_current_selection fails with 'All' current value", { + test_data <- data.frame(current = c("All", "All")) + + expect_error( + validate_current_selection(test_data), + "Choose a value for 'current'" + ) +}) + +test_that("validate_current_selection fails with empty data", { + test_data <- data.frame(current = character(0)) + + expect_error( + validate_current_selection(test_data), + "No matching pathways" + ) +}) + +test_that("validate_current_selection handles NA values correctly", { + test_data <- data.frame(current = c("A", "A", NA)) + + expect_silent(validate_current_selection(test_data)) +}) + +# Tests for calculate_plot_width() ------------------------------------------- + +test_that("calculate_plot_width calculates correctly with default width", { + test_data <- data.frame( + `-1` = c("a", "b"), + `0` = c("c", "d"), + `1` = c("e", "f"), + `2` = c(NA, NA), # This column should be excluded + check.names = FALSE + ) + + result <- calculate_plot_width(test_data, -1:2, 220) + expected <- 3 * 220 # 3 non-empty columns + + expect_equal(result, expected) +}) + +test_that("calculate_plot_width works with custom width per column", { + test_data <- data.frame( + `-1` = c("a", "b"), + `0` = c("c", "d"), + check.names = FALSE + ) + + result <- calculate_plot_width(test_data, -1:0, 100) + expected <- 2 * 100 + + expect_equal(result, expected) +}) + +test_that("calculate_plot_width handles no matching columns", { + test_data <- data.frame( + other_col = c("a", "b") + ) + + result <- calculate_plot_width(test_data, -1:1, 220) + expect_equal(result, 0) +}) + +test_that("calculate_plot_width excludes all-NA columns", { + test_data <- data.frame( + `-1` = c("a", "b"), + `0` = c(NA, NA), + `1` = c("c", "d"), + check.names = FALSE + ) + + result <- calculate_plot_width(test_data, -1:1, 220) + expected <- 2 * 220 # Only 2 non-empty columns + + expect_equal(result, expected) +}) + +# Tests for create_coverage_box() -------------------------------------------- + +test_that("create_coverage_box calculates percentage correctly", { + result <- create_coverage_box(100, 75) + + # Check that the result contains the percentage + expect_true(grepl("75%", as.character(result))) +}) + +test_that("create_coverage_box handles zero original rows", { + result <- create_coverage_box(0, 0) + + expect_true(grepl("0%", as.character(result))) +}) + +test_that("create_coverage_box shows warning for low coverage", { + result <- create_coverage_box(100, 5) # 5% coverage + + result_str <- as.character(result) + expect_true(grepl("5%", result_str)) + expect_true(grepl("very few records matched", result_str)) +}) + +test_that("create_coverage_box doesn't show warning for good coverage", { + result <- create_coverage_box(100, 50) # 50% coverage + + result_str <- as.character(result) + expect_true(grepl("50%", result_str)) + expect_false(grepl("very few records matched", result_str)) +}) + +test_that("create_coverage_box uses correct colors for different percentages", { + # High coverage (80%+) - should be green + high_result <- create_coverage_box(100, 85) + expect_true(grepl("#28a745", as.character(high_result))) + + # Low coverage (<15%) - should be red + low_result <- create_coverage_box(100, 10) + expect_true(grepl("#dc3545", as.character(low_result))) +}) From f12fdcb58debcb16a4ce4eaf2dccc19cfc0974a9 Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 09:23:50 +0000 Subject: [PATCH 09/10] Add app utils testing --- tests/testthat/test-App-utils.R | 5 ----- 1 file changed, 5 deletions(-) diff --git a/tests/testthat/test-App-utils.R b/tests/testthat/test-App-utils.R index 4ab5db2..84e69aa 100644 --- a/tests/testthat/test-App-utils.R +++ b/tests/testthat/test-App-utils.R @@ -14,11 +14,6 @@ setup_test_data <- function() { ) } -# Mock input object for testing -mock_input <- function(selections = list()) { - structure(selections, class = "reactivevalues") -} - # Tests for get_filter_vars() ------------------------------------------------ test_that("get_filter_vars returns correct filter variables", { From 18cfcb70a9cf25d3e646123d1eb5f01cfc353a9a Mon Sep 17 00:00:00 2001 From: Peter Winskill Date: Wed, 26 Nov 2025 10:06:22 +0000 Subject: [PATCH 10/10] Check fixes --- DESCRIPTION | 1 - R/app_utils.R | 24 ++++++++++++------------ 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3970a52..7bfc22f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -18,7 +18,6 @@ Imports: rlang, bslib, bsicons, - RColorBrewer, ggplot2, ggnewscale, tidyr diff --git a/R/app_utils.R b/R/app_utils.R index 5fa248a..947b774 100644 --- a/R/app_utils.R +++ b/R/app_utils.R @@ -43,12 +43,12 @@ validate_current_selection <- function(data) { current_vals <- unique(as.character(data$current)) current_vals <- current_vals[!is.na(current_vals)] - validate( - need( + shiny::validate( + shiny::need( length(current_vals) == 1 && current_vals != "All", "Choose a value for 'current' in the left panel to show the Sankey." ), - need( + shiny::need( nrow(data) > 0, "No matching pathways for this combination of filters." ) @@ -66,8 +66,8 @@ validate_current_selection <- function(data) { create_sankey_plot <- function(data, step_columns) { validate_current_selection(data) - validate( - need( + shiny::validate( + shiny::need( nrow(data) > 0, "No matching pathways for this combination of filters." ) @@ -107,7 +107,7 @@ create_coverage_box <- function(original_rows, filtered_rows) { percentage <- if (original_rows == 0) 0 else round((filtered_rows / original_rows) * 100, 1) # Dynamic color based on coverage percentage - bg_color <- case_when( + bg_color <- dplyr::case_when( percentage >= 80 ~ "#28a745", percentage >= 60 ~ "#6cb04a", percentage >= 40 ~ "#9bc53d", @@ -118,7 +118,7 @@ create_coverage_box <- function(original_rows, filtered_rows) { # Warning for very low coverage subtitle_text <- if (percentage < 10) { - div( + shiny::div( style = "font-size: 0.9em; margin-top: 8px; font-weight: bold;", "\u26a0 very few records matched" ) @@ -126,20 +126,20 @@ create_coverage_box <- function(original_rows, filtered_rows) { NULL } - div( + shiny::div( style = paste0( "background: linear-gradient(135deg, ", bg_color, " 0%, ", - adjustcolor(bg_color, alpha.f = 0.8), " 100%); ", + grDevices::adjustcolor(bg_color, alpha.f = 0.8), " 100%); ", "border-radius: 12px; padding: 20px; text-align: center; ", "color: white; box-shadow: 0 4px 15px rgba(0,0,0,0.2); ", "margin-bottom: 20px; transition: all 0.3s ease;" ), - div( + shiny::div( style = "display: flex; align-items: center; justify-content: center; margin-bottom: 10px;", bsicons::bs_icon("funnel", size = "1.2em", style = "margin-right: 15px;"), - span("Records Matched", style = "font-size: 1.2em; font-weight: 500; margin-left: 8px;") + shiny::span("Records Matched", style = "font-size: 1.2em; font-weight: 500; margin-left: 8px;") ), - div( + shiny::div( style = "font-size: 2.5em; font-weight: bold; margin-bottom: 5px;", paste0(percentage, "%") ),