diff --git a/.gitignore b/.gitignore index aad19ef3..f2e90466 100644 --- a/.gitignore +++ b/.gitignore @@ -28,3 +28,4 @@ optimizing plotly testing.X data-raw/catlogo.svg vignettes/articles/ggpedigree_config.rds *DESKTOP-16M0RPI's conflicted* +/.claude diff --git a/DESCRIPTION b/DESCRIPTION index e5566fab..55b6a1b9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: ggpedigree Title: Visualizing Pedigrees with 'ggplot2' and 'plotly' -Version: 1.1.1.1 +Version: 1.1.1.9 Date/Publication: 2026 Authors@R: c( person("S. Mason", "Garrison", email= "garrissm@wfu.edu", role = c("aut", "cre", "cph"), @@ -25,6 +25,7 @@ Imports: tidyr Suggests: selectr (>= 0.5-1), + svglite, kinship2, quadprog, ggrepel, diff --git a/NEWS.md b/NEWS.md index d33d5dfb..63b40e5d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,14 @@ # ggpedigree (development version) # ============================== +## New features +* Added more flexibility to overlays, including support for shape-mode overlays with custom numeric codes and colors. +* Added a new vignette to explain the clinical preset and its features. + +## Bug fixes +* Fixed multi-overlay closure bug where all overlays were filtered on the last column in the list due to R's lazy evaluation of function arguments. Local variable assignment now forces evaluation at the correct loop iteration. +* Fixed `preset` (e.g., `"clinical"`) not being forwarded to `getDefaultPlotConfig()` in `ggPedigree()` and `ggPedigreeInteractive()`, which meant preset-driven settings like `overlay_mode = "shape"` and `overlay_include = TRUE` were silently ignored. + # ggpedigree Version: 1.1.1.1 * Hotpatch to fix plotly vignette selectively failing by using tryCatch to catch the error and print a warning instead of failing the whole vignette build. * Also increased test coverage of kinship2_pedigree. diff --git a/R/defaultPlotConfig.R b/R/defaultPlotConfig.R index 801b78a3..e44c72d9 100644 --- a/R/defaultPlotConfig.R +++ b/R/defaultPlotConfig.R @@ -123,6 +123,7 @@ #' @param status_color_affected Color for affected individuals. #' @param status_color_unaffected Color for unaffected individuals. #' @param overlay_shape Shape used for overlaying points in the plot. Default is 4 (cross). +#' When overlay_mode is "shape", accepts named strings: "cross", "slash", "x". #' @param overlay_code_affected Code for affected individuals in overlay. Default is 1. #' @param overlay_code_unaffected Code for unaffected individuals in overlay. Default is 0. #' @param overlay_label_affected Label for affected individuals in overlay. Default is "Affected". @@ -131,6 +132,13 @@ #' @param overlay_alpha_unaffected Alpha for unaffected individuals in overlay. Default is 0. #' @param overlay_color Color for overlay points. Default is "black". #' @param overlay_include Whether to include overlay points in the plot. Default is FALSE. +#' @param overlay_mode Character string specifying the overlay rendering mode. +#' "alpha" (default) uses alpha transparency mapping; "shape" draws a shape overlay +#' on matching individuals (e.g., cross for deceased markers). +#' @param overlay_size Numeric. Size of the shape overlay. Default is NULL (inherits from point_size). +#' Only used when overlay_mode is "shape". +#' @param overlay_stroke Stroke width for the shape overlay. Default is 1.5. +#' Only used when overlay_mode is "shape". #' @param overlay_legend_title Title of the overlay legend. Default is "Overlay". #' @param overlay_legend_show Whether to show the overlay legend. Default is FALSE. #' @param focal_fill_include Whether to fill focal individuals. Default is FALSE. @@ -186,6 +194,25 @@ #' @param recode_missing_sex Whether to recode missing sex codes in the pedigree. Default is TRUE. #' @param debug Whether to enable debugging mode. #' @param add_phantoms Whether to add phantom parents for individuals without parents. +#' @param affected_fill_include Whether to enable affected fill styling. Default is FALSE. +#' @param affected_fill_code_affected Value in the affected fill column that triggers filling. Default is 1. +#' @param affected_fill_code_unaffected Value in the affected fill column for unaffected individuals. Default is 0. +#' @param affected_fill_label_affected Label for affected individuals in fill legend. Default is "Affected". +#' @param affected_fill_label_unaffected Label for unaffected individuals in fill legend. Default is "Unaffected". +#' @param affected_fill_color_affected Color used to fill symbols for affected individuals. Default is "black". +#' @param affected_fill_color_unaffected Color used to fill symbols for unaffected individuals. Default is NA (transparent). +#' @param affected_fill_shape_female Filled shape for affected females. Default is 21 (filled circle). +#' @param affected_fill_shape_male Filled shape for affected males. Default is 22 (filled square). +#' @param affected_fill_shape_unknown Filled shape for affected unknown sex. Default is 23 (filled diamond). +#' @param outline_color_include Whether to enable column-based outline coloring. Default is FALSE. +#' @param outline_color_code_affected Value in the outline color column that triggers colored outlines. Default is 1. +#' @param outline_color_code_unaffected Value in the outline color column for default outlines. Default is 0. +#' @param outline_color_label_affected Label for highlighted outline individuals. Default is "Highlighted". +#' @param outline_color_label_unaffected Label for default outline individuals. Default is "Default". +#' @param outline_color_affected Color used for highlighted outlines. Default is "blue". +#' @param outline_color_unaffected Color used for default (non-highlighted) outlines. Default is "black". +#' @param preset Optional preset name for default styling combinations. +#' Currently supported: "clinical" for standard clinical pedigree styling. Default is "none" (no preset). #' @param ... Additional arguments for future extensibility. #' @return A named list of default plotting and layout parameters. #' @export @@ -325,6 +352,9 @@ getDefaultPlotConfig <- function(function_name = "getDefaultPlotConfig", overlay_alpha_unaffected = 0, overlay_color = "black", overlay_include = FALSE, + overlay_mode = "alpha", + overlay_size = NULL, + overlay_stroke = 1.5, overlay_legend_title = "Overlay", overlay_legend_show = FALSE, # ---- Focal Fill Settings ---- @@ -408,6 +438,28 @@ getDefaultPlotConfig <- function(function_name = "getDefaultPlotConfig", recode_missing_ids = TRUE, recode_missing_sex = TRUE, add_phantoms = FALSE, + # ---- Clinical Pedigree Styling ---- + # -- Affected Fill -- + affected_fill_include = FALSE, + affected_fill_code_affected = 1, + affected_fill_code_unaffected = 0, + affected_fill_label_affected = "Affected", + affected_fill_label_unaffected = "Unaffected", + affected_fill_color_affected = "black", + affected_fill_color_unaffected = NA, + affected_fill_shape_female = 21, + affected_fill_shape_male = 22, + affected_fill_shape_unknown = 23, + # -- Outline Color -- + outline_color_include = FALSE, + outline_color_code_affected = 1, + outline_color_code_unaffected = 0, + outline_color_label_affected = "Highlighted", + outline_color_label_unaffected = "Default", + outline_color_affected = "blue", + outline_color_unaffected = "black", + # -- Preset -- + preset = "none", # ---- Future Extensibility ---- ...) { # Ensure the color palette is a character vector @@ -454,7 +506,7 @@ getDefaultPlotConfig <- function(function_name = "getDefaultPlotConfig", } color_theme_lower <- stringr::str_to_lower(color_theme) - if (color_theme_lower %in% c(grey_color_names, black_color_names)) { + if (color_theme_lower %in% c(grey_color_names, black_color_names) || identical(preset, "clinical")) { color_palette_default <- greyscale_palette_default color_palette_low <- greyscale_low color_palette_mid <- greyscale_mid @@ -625,6 +677,9 @@ getDefaultPlotConfig <- function(function_name = "getDefaultPlotConfig", overlay_color = overlay_color, overlay_alpha_affected = overlay_alpha_affected, overlay_include = overlay_include, + overlay_mode = overlay_mode, + overlay_size = overlay_size, + overlay_stroke = overlay_stroke, overlay_legend_title = overlay_legend_title, overlay_legend_show = overlay_legend_show, @@ -691,7 +746,29 @@ getDefaultPlotConfig <- function(function_name = "getDefaultPlotConfig", recode_missing_ids = recode_missing_ids, recode_missing_sex = recode_missing_sex, add_phantoms = add_phantoms, - debug = debug + debug = debug, + # ---- Clinical Pedigree Styling ---- + # -- Affected Fill -- + affected_fill_include = affected_fill_include, + affected_fill_code_affected = affected_fill_code_affected, + affected_fill_code_unaffected = affected_fill_code_unaffected, + affected_fill_label_affected = affected_fill_label_affected, + affected_fill_label_unaffected = affected_fill_label_unaffected, + affected_fill_color_affected = affected_fill_color_affected, + affected_fill_color_unaffected = affected_fill_color_unaffected, + affected_fill_shape_female = affected_fill_shape_female, + affected_fill_shape_male = affected_fill_shape_male, + affected_fill_shape_unknown = affected_fill_shape_unknown, + # -- Outline Color -- + outline_color_include = outline_color_include, + outline_color_code_affected = outline_color_code_affected, + outline_color_code_unaffected = outline_color_code_unaffected, + outline_color_label_affected = outline_color_label_affected, + outline_color_label_unaffected = outline_color_label_unaffected, + outline_color_affected = outline_color_affected, + outline_color_unaffected = outline_color_unaffected, + # -- Preset -- + preset = preset ) lc_function_name <- stringr::str_to_lower(function_name) if (lc_function_name %in% c("ggrelatednessmatrix")) { @@ -781,6 +858,18 @@ getDefaultPlotConfig <- function(function_name = "getDefaultPlotConfig", core_list$segment_self_angle <- -75 core_list$segment_self_curvature <- -0.15 } - + # Apply clinical preset if specified + if (identical(preset, "clinical")) { + # Clinical defaults: shape by sex, unfilled by default, blue outline for included + core_list$sex_color_include <- FALSE + core_list$sex_shape_include <- TRUE + core_list$outline_include <- TRUE + core_list$outline_color <- core_list$outline_color_unaffected + # Configure overlay for shape mode (e.g., cross for deceased markers) + core_list$overlay_include <- TRUE + core_list$overlay_mode <- "shape" + core_list$overlay_shape <- 4 # Cross shape + core_list$overlay_color <- core_list$color_palette_high + } core_list } diff --git a/R/ggPedigreeInteractive.R b/R/ggPedigreeInteractive.R index fe2c9d83..37b95742 100644 --- a/R/ggPedigreeInteractive.R +++ b/R/ggPedigreeInteractive.R @@ -60,7 +60,9 @@ ggPedigreeInteractive <- function(ped, return_widget = TRUE, hints = NULL, code_male = NULL, - sexVar = "sex") { + sexVar = "sex", + affected_fill_column = NULL, + outline_color_column = NULL) { if (!requireNamespace("plotly", quietly = TRUE)) { stop("The 'plotly' package is required for interactive plots.") } @@ -98,6 +100,7 @@ ggPedigreeInteractive <- function(ped, default_config <- getDefaultPlotConfig( function_name = "ggPedigreeInteractive", personID = personID, + preset = if (is.null(config$preset)) "none" else config$preset, color_theme = ifelse(is.null(config$color_theme), "color", config$color_theme) ) @@ -130,7 +133,9 @@ ggPedigreeInteractive <- function(ped, debug = config$debug, focal_fill_column = focal_fill_column, function_name = "ggPedigreeInteractive", - sexVar = sexVar + sexVar = sexVar, + affected_fill_column = affected_fill_column, + outline_color_column = outline_color_column ) ## 2. Identify data columns for tooltips ---------------------------------- diff --git a/R/ggpedigree.R b/R/ggpedigree.R index d2a1f584..bc18dae7 100644 --- a/R/ggpedigree.R +++ b/R/ggpedigree.R @@ -19,6 +19,15 @@ #' @param hints Data frame with hints for layout adjustments. Default: NULL. #' @param interactive Logical. If TRUE, generates an interactive plot using `plotly`. Default: FALSE. #' @param overlay_column Character string specifying the column name for overlay alpha values. +#' For a single overlay, this is the simplest interface. For multiple overlays, use +#' the \code{overlays} parameter instead. +#' @param overlays A list of overlay specifications for adding multiple independent overlay +#' layers. Each element should be a list with at minimum a \code{column} entry, plus optional +#' entries: \code{code_affected}, \code{shape}, \code{color}, \code{size}, \code{stroke}, +#' \code{mode}. Unspecified entries inherit from the \code{overlay_*} config defaults. +#' When \code{overlays} is provided, \code{overlay_column} is ignored. +#' Example: \code{overlays = list(list(column = "DECES", shape = "cross"), +#' list(column = "PROBAND", shape = 8, color = "red"))} #' @param tooltip_columns Character vector of column names to show when hovering. #' Defaults to c("personID", "sex"). Additional columns present in `ped` #' can be supplied – they will be added to the Plotly tooltip text. @@ -29,6 +38,12 @@ #' @param code_male Integer or string. Value identifying males in the sex column. (typically 0 or 1) Default: 1 #' @param sexVar Character string specifying the column name for sex. Defaults to "sex". #' @param focal_fill_column Character string specifying the column name for focal fill color. +#' @param affected_fill_column Character string specifying the column name for conditional +#' affected fill. When provided, individuals matching the `affected_fill_code_affected` config +#' will have their symbols filled. Default is NULL. +#' @param outline_color_column Character string specifying the column name for outline +#' color control. When provided, individuals matching `outline_color_code_affected` config +#' will have colored outlines (e.g., blue for included). Default is NULL. #' @param config A list of configuration options for customizing the plot. #' See getDefaultPlotConfig for details of each option. The list can include: #' \describe{ @@ -79,13 +94,16 @@ ggPedigree <- function(ped, focal_fill_column = NULL, tooltip_columns = NULL, overlay_column = NULL, + overlays = NULL, return_widget = FALSE, config = list(), debug = FALSE, hints = NULL, interactive = FALSE, code_male = NULL, - sexVar = "sex") { + sexVar = "sex", + affected_fill_column = NULL, + outline_color_column = NULL) { if (!inherits(ped, "data.frame")) { if (rlang::inherits_any(ped, c("ped", "pedigree", "kinship2.pedigree"))) { # Convert ped object to data.frame @@ -125,7 +143,9 @@ ggPedigree <- function(ped, return_widget = return_widget, tooltip_columns = tooltip_columns, code_male = code_male, - sexVar = sexVar + sexVar = sexVar, + affected_fill_column = affected_fill_column, + outline_color_column = outline_color_column ) } else { if (interactive == TRUE && @@ -137,6 +157,7 @@ ggPedigree <- function(ped, default_config <- getDefaultPlotConfig( function_name = "ggpedigree", personID = personID, + preset = if (is.null(config$preset)) "none" else config$preset, color_theme = ifelse(is.null(config$color_theme), "color", config$color_theme) ) @@ -166,13 +187,16 @@ ggPedigree <- function(ped, matID = matID, patID = patID, overlay_column = overlay_column, + overlays = overlays, twinID = twinID, status_column = status_column, focal_fill_column = focal_fill_column, config = config, debug = debug, hints = hints, - sexVar = sexVar + sexVar = sexVar, + affected_fill_column = affected_fill_column, + outline_color_column = outline_color_column ) } } diff --git a/R/ggpedigreeCore.R b/R/ggpedigreeCore.R index 550863a1..69324357 100644 --- a/R/ggpedigreeCore.R +++ b/R/ggpedigreeCore.R @@ -21,13 +21,16 @@ ggPedigree.core <- function(ped, twinID = "twinID", focal_fill_column = NULL, overlay_column = NULL, + overlays = NULL, status_column = NULL, code_male = NULL, config = list(), debug = FALSE, hints = NULL, sexVar = "sex", - function_name = "ggPedigree") { + function_name = "ggPedigree", + affected_fill_column = NULL, + outline_color_column = NULL) { # ----- # STEP 1: Configuration and Preparation # ----- @@ -315,14 +318,51 @@ ggPedigree.core <- function(ped, plotObject = p, config = config, focal_fill_column = focal_fill_column, - status_column = status_column + status_column = status_column, + affected_fill_column = affected_fill_column, + outline_color_column = outline_color_column ) # Add overlay points for affected status if applicable + # Normalize overlays: if overlays list is provided, use it; otherwise fall back + # to single overlay_column for backward compatibility + overlay_specs <- NULL + + if (!is.null(overlays) && is.list(overlays) && length(overlays) > 0) { + overlay_specs <- overlays + } else if (!is.null(overlay_column)) { + # Wrap single overlay_column into a one-element list using config defaults + overlay_specs <- list(list(column = overlay_column)) + } - if (.should_add_overlay(config, overlay_column, status_column, focal_fill_column)) { - # If overlay_column is specified, use it for alpha aesthetic + if (!is.null(overlay_specs)) { + for (spec in overlay_specs) { + spec_column <- spec$column + if (is.null(spec_column) || !spec_column %in% names(ds)) next + spec_mode <- if (!is.null(spec$mode)) spec$mode else config$overlay_mode + + if (spec_mode == "shape") { + # Shape-mode overlay: draw a shape (e.g., cross) on matching individuals + p <- .addShapeOverlay( + plotObject = p, + config = config, + overlay_column = spec_column, + overlay_spec = spec + ) + } else { + # Alpha-mode overlay (default): use alpha transparency mapping + p <- .addOverlay( + plotObject = p, + config = config, + focal_fill_column = focal_fill_column, + status_column = status_column, + overlay_column = spec_column + ) + } + } + } else if (.should_add_overlay(config, overlay_column, status_column, focal_fill_column)) { + # Legacy alpha overlay fallback (status/focal_fill driven, no overlay_column) p <- .addOverlay( plotObject = p, config = config, @@ -398,7 +438,9 @@ ggPedigree.core <- function(ped, plotObject = p, config = config, status_column = status_column, - focal_fill_column = focal_fill_column + focal_fill_column = focal_fill_column, + affected_fill_column = affected_fill_column, + outline_color_column = outline_color_column ) } # add plot_connections to the plot object @@ -427,15 +469,33 @@ ggPedigree.core <- function(ped, .addNodes <- function(plotObject, config, focal_fill_column = NULL, - status_column = NULL) { + status_column = NULL, + affected_fill_column = NULL, + outline_color_column = NULL) { # plot points with appropriate aesthetics if (config$debug == TRUE) { message("Adding nodes to the plot...") message("Focal fill column: ", focal_fill_column) message("Status column: ", status_column) + message("Affected fill column: ", affected_fill_column) + message("Outline color column: ", outline_color_column) } - if (isTRUE(config$outline_include)) { + # Handle outline: either column-based or config-based + if (!is.null(outline_color_column)) { + # Column-based outline coloring (independent from other aesthetics) + plotObject <- plotObject + + ggplot2::geom_point( + ggplot2::aes( + shape = as.factor(.data$sex), + color = as.factor(!!rlang::sym(outline_color_column)) + ), + size = config$point_size * config$outline_multiplier + config$outline_additional_size, + na.rm = TRUE, + alpha = config$outline_alpha, + stroke = config$segment_linewidth + ) + } else if (isTRUE(config$outline_include)) { plotObject <- plotObject + ggplot2::geom_point( ggplot2::aes(shape = as.factor(.data$sex)), @@ -447,6 +507,25 @@ ggPedigree.core <- function(ped, ) } + # Handle affected fill column (clinical pedigree conditional fill) + if (!is.null(affected_fill_column)) { + # Determine node border color for filled shapes + node_border_color <- if (!is.null(config$outline_color_unaffected)) config$outline_color_unaffected else config$outline_color + + # Use filled shapes for affected, unfilled for unaffected + plotObject <- plotObject + + ggplot2::geom_point( + ggplot2::aes( + shape = as.factor(.data$sex), + fill = as.factor(!!rlang::sym(affected_fill_column)) + ), + size = config$point_size, + na.rm = TRUE, + color = node_border_color, + stroke = config$segment_linewidth * 0.5 + ) + return(plotObject) + } # 2) Determine which "node mode" to use (exactly one) node_mode <- .pick_first( @@ -594,6 +673,57 @@ addNodes <- .addNodes #' @rdname dot-addOverlay addOverlay <- .addOverlay +#' @title Add Shape Overlay to ggplot Pedigree Plot +#' @description Draws a shape (cross, slash, or x) over symbols of matching individuals. +#' Used when overlay_mode is "shape" to draw markers on top of pedigree symbols +#' (e.g., cross for deceased individuals). +#' @inheritParams ggPedigree +#' @param plotObject A ggplot object. +#' @param overlay_column Character string specifying the column name for overlay status. +#' @param overlay_spec Optional list of per-overlay settings that override config defaults. +#' Recognized keys: \code{shape}, \code{color}, \code{size}, \code{stroke}, \code{code_affected}. +#' @keywords internal +#' @return A ggplot object with shape overlay markers added. +#' +.addShapeOverlay <- function(plotObject, config, overlay_column, overlay_spec = NULL) { + # Per-overlay spec overrides config defaults + overlay_shape <- if (!is.null(overlay_spec$shape)) overlay_spec$shape else config$overlay_shape + # Support named shape strings for convenience + if (is.character(overlay_shape)) { + shape_code <- switch(overlay_shape, + "cross" = 4L, # x cross (conventional deceased marker) + "slash" = 47L, # / slash + "x" = 8L, # asterisk-like x mark + 4L # default to cross + ) + } else { + shape_code <- as.integer(overlay_shape) + } + spec_size <- if (!is.null(overlay_spec$size)) overlay_spec$size else config$overlay_size + shape_size <- if (!is.null(spec_size)) spec_size else config$point_size + shape_color <- if (!is.null(overlay_spec$color)) overlay_spec$color else config$overlay_color + shape_stroke <- if (!is.null(overlay_spec$stroke)) overlay_spec$stroke else config$overlay_stroke + overlay_code <- if (!is.null(overlay_spec$code_affected)) overlay_spec$code_affected else config$overlay_code_affected + col <- overlay_column + + plotObject <- plotObject + + ggplot2::geom_point( + data = function(d) d[d[[col]] == overlay_code, , drop = FALSE], + ggplot2::aes(x = .data$x_pos, y = .data$y_pos), + shape = shape_code, + size = shape_size, + color = shape_color, + stroke = shape_stroke, + na.rm = TRUE, + inherit.aes = FALSE + ) + + plotObject +} + +#' @rdname dot-addShapeOverlay +addShapeOverlay <- .addShapeOverlay + #' @title Add Self Segments to ggplot Pedigree Plot #' @inheritParams ggPedigree @@ -751,12 +881,74 @@ addSelfSegment <- .addSelfSegment .addScales <- function(plotObject, config, status_column = NULL, - focal_fill_column = NULL) { - # Always shape scale - plotObject <- plotObject + ggplot2::scale_shape_manual( - values = config$sex_shape_values, - labels = config$sex_shape_labels - ) + focal_fill_column = NULL, + affected_fill_column = NULL, + outline_color_column = NULL) { + # Handle affected fill mode: use fillable shapes and fill scale + if (!is.null(affected_fill_column)) { + affected_fill_code <- config$affected_fill_code_affected + fill_color_affected <- config$affected_fill_color_affected + fill_color_unaffected <- config$affected_fill_color_unaffected + + # Use fillable shapes (21=circle, 22=square, 23=diamond) for affected fill mode + fill_shape_values <- c( + config$affected_fill_shape_female, + config$affected_fill_shape_male, + config$affected_fill_shape_unknown + ) + plotObject <- plotObject + ggplot2::scale_shape_manual( + values = fill_shape_values, + labels = config$sex_shape_labels + ) + # Build fill scale: affected code gets affected color; all other levels get unaffected color + all_levels <- levels(plotObject$data[[affected_fill_column]]) + if (is.null(all_levels)) { + all_levels <- unique(as.character(plotObject$data[[affected_fill_column]])) + } + fill_vals <- stats::setNames( + ifelse( + all_levels == as.character(affected_fill_code), + fill_color_affected, + fill_color_unaffected + ), + all_levels + ) + plotObject <- plotObject + ggplot2::scale_fill_manual( + values = fill_vals, + na.value = NA, + guide = "none" + ) + } else { + # Standard shape scale + plotObject <- plotObject + ggplot2::scale_shape_manual( + values = config$sex_shape_values, + labels = config$sex_shape_labels + ) + } + + # Handle outline color column + if (!is.null(outline_color_column)) { + highlight_val <- as.character(config$outline_color_code_affected) + highlight_color <- config$outline_color_affected + default_color <- config$outline_color_unaffected + + all_levels <- levels(plotObject$data[[outline_color_column]]) + if (is.null(all_levels)) { + all_levels <- unique(as.character(plotObject$data[[outline_color_column]])) + } + color_vals <- stats::setNames( + ifelse(all_levels == highlight_val, highlight_color, default_color), + all_levels + ) + plotObject <- plotObject + ggplot2::scale_color_manual( + values = color_vals, + guide = "none" + ) + plotObject <- plotObject + ggplot2::labs( + shape = if (isTRUE(config$sex_legend_show)) config$sex_legend_title else NULL + ) + return(plotObject) + } # Add alpha scale for affected status if applicable if (!is.null(status_column) && diff --git a/man/dot-addNodes.Rd b/man/dot-addNodes.Rd index aabc9819..57ca944b 100644 --- a/man/dot-addNodes.Rd +++ b/man/dot-addNodes.Rd @@ -5,9 +5,23 @@ \alias{addNodes} \title{Add Nodes to ggplot Pedigree Plot} \usage{ -.addNodes(plotObject, config, focal_fill_column = NULL, status_column = NULL) +.addNodes( + plotObject, + config, + focal_fill_column = NULL, + status_column = NULL, + affected_fill_column = NULL, + outline_color_column = NULL +) -addNodes(plotObject, config, focal_fill_column = NULL, status_column = NULL) +addNodes( + plotObject, + config, + focal_fill_column = NULL, + status_column = NULL, + affected_fill_column = NULL, + outline_color_column = NULL +) } \arguments{ \item{plotObject}{A ggplot object.} @@ -35,6 +49,14 @@ addNodes(plotObject, config, focal_fill_column = NULL, status_column = NULL) \item{focal_fill_column}{Character string specifying the column name for focal fill color.} \item{status_column}{Character string specifying the column name for affected status. Defaults to NULL.} + +\item{affected_fill_column}{Character string specifying the column name for conditional +affected fill. When provided, individuals matching the `affected_fill_code_affected` config +will have their symbols filled. Default is NULL.} + +\item{outline_color_column}{Character string specifying the column name for outline +color control. When provided, individuals matching `outline_color_code_affected` config +will have colored outlines (e.g., blue for included). Default is NULL.} } \description{ Add Nodes to ggplot Pedigree Plot diff --git a/man/dot-addOverlay.Rd b/man/dot-addOverlay.Rd index f86a36cc..ee7b61da 100644 --- a/man/dot-addOverlay.Rd +++ b/man/dot-addOverlay.Rd @@ -50,7 +50,9 @@ addOverlay( \item{status_column}{Character string specifying the column name for affected status. Defaults to NULL.} -\item{overlay_column}{Character string specifying the column name for overlay alpha values.} +\item{overlay_column}{Character string specifying the column name for overlay alpha values. +For a single overlay, this is the simplest interface. For multiple overlays, use +the \code{overlays} parameter instead.} } \value{ A ggplot object with added overlay. diff --git a/man/dot-addScales.Rd b/man/dot-addScales.Rd index 8c8bfdcd..2a8e1b1a 100644 --- a/man/dot-addScales.Rd +++ b/man/dot-addScales.Rd @@ -5,9 +5,23 @@ \alias{addScales} \title{Add Scales to ggplot Pedigree Plot} \usage{ -.addScales(plotObject, config, status_column = NULL, focal_fill_column = NULL) +.addScales( + plotObject, + config, + status_column = NULL, + focal_fill_column = NULL, + affected_fill_column = NULL, + outline_color_column = NULL +) -addScales(plotObject, config, status_column = NULL, focal_fill_column = NULL) +addScales( + plotObject, + config, + status_column = NULL, + focal_fill_column = NULL, + affected_fill_column = NULL, + outline_color_column = NULL +) } \arguments{ \item{plotObject}{A ggplot object.} @@ -35,6 +49,14 @@ addScales(plotObject, config, status_column = NULL, focal_fill_column = NULL) \item{status_column}{Character string specifying the column name for affected status. Defaults to NULL.} \item{focal_fill_column}{Character string specifying the column name for focal fill color.} + +\item{affected_fill_column}{Character string specifying the column name for conditional +affected fill. When provided, individuals matching the `affected_fill_code_affected` config +will have their symbols filled. Default is NULL.} + +\item{outline_color_column}{Character string specifying the column name for outline +color control. When provided, individuals matching `outline_color_code_affected` config +will have colored outlines (e.g., blue for included). Default is NULL.} } \value{ A ggplot object with added scales. diff --git a/man/dot-addShapeOverlay.Rd b/man/dot-addShapeOverlay.Rd new file mode 100644 index 00000000..dcc2fe20 --- /dev/null +++ b/man/dot-addShapeOverlay.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ggpedigreeCore.R +\name{.addShapeOverlay} +\alias{.addShapeOverlay} +\alias{addShapeOverlay} +\title{Add Shape Overlay to ggplot Pedigree Plot} +\usage{ +.addShapeOverlay(plotObject, config, overlay_column, overlay_spec = NULL) + +addShapeOverlay(plotObject, config, overlay_column, overlay_spec = NULL) +} +\arguments{ +\item{plotObject}{A ggplot object.} + +\item{config}{A list of configuration options for customizing the plot. + See getDefaultPlotConfig for details of each option. The list can include: +\describe{ + \item{code_male}{Integer or string. Value identifying males in the sex column. (typically 0 or 1) Default: 1} + \item{segment_spouse_color, segment_self_color}{Character. Line colors for respective connection types.} + \item{segment_sibling_color, segment_parent_color, + segment_offspring_color}{Character. Line colors for respective connection types.} + \item{label_text_size, point_size, segment_linewidth}{Numeric. Controls text size, point size, + and line thickness.} + \item{generation_height}{Numeric. Vertical spacing multiplier between generations. Default: 1.} + \item{shape_unknown, shape_female, shape_male, + status_shape_affected}{Integers. Shape codes for plotting each group.} + \item{sex_shape_labels}{Character vector of labels for the sex variable. + (default: c("Female", "Male", "Unknown"))} + \item{unaffected, affected}{Values indicating unaffected/affected status.} + \item{sex_color_include}{Logical. If TRUE, uses color to differentiate sex.} + \item{label_max_overlaps}{Maximum number of overlaps allowed in repelled labels.} + \item{label_segment_color}{Color used for label connector lines.} + }} + +\item{overlay_column}{Character string specifying the column name for overlay status.} + +\item{overlay_spec}{Optional list of per-overlay settings that override config defaults. +Recognized keys: \code{shape}, \code{color}, \code{size}, \code{stroke}, \code{code_affected}.} +} +\value{ +A ggplot object with shape overlay markers added. +} +\description{ +Draws a shape (cross, slash, or x) over symbols of matching individuals. + Used when overlay_mode is "shape" to draw markers on top of pedigree symbols + (e.g., cross for deceased individuals). +} +\keyword{internal} diff --git a/man/getDefaultPlotConfig.Rd b/man/getDefaultPlotConfig.Rd index b914ac9e..c8020729 100644 --- a/man/getDefaultPlotConfig.Rd +++ b/man/getDefaultPlotConfig.Rd @@ -116,6 +116,9 @@ getDefaultPlotConfig( overlay_alpha_unaffected = 0, overlay_color = "black", overlay_include = FALSE, + overlay_mode = "alpha", + overlay_size = NULL, + overlay_stroke = 1.5, overlay_legend_title = "Overlay", overlay_legend_show = FALSE, focal_fill_include = FALSE, @@ -184,6 +187,24 @@ getDefaultPlotConfig( recode_missing_ids = TRUE, recode_missing_sex = TRUE, add_phantoms = FALSE, + affected_fill_include = FALSE, + affected_fill_code_affected = 1, + affected_fill_code_unaffected = 0, + affected_fill_label_affected = "Affected", + affected_fill_label_unaffected = "Unaffected", + affected_fill_color_affected = "black", + affected_fill_color_unaffected = NA, + affected_fill_shape_female = 21, + affected_fill_shape_male = 22, + affected_fill_shape_unknown = 23, + outline_color_include = FALSE, + outline_color_code_affected = 1, + outline_color_code_unaffected = 0, + outline_color_label_affected = "Highlighted", + outline_color_label_unaffected = "Default", + outline_color_affected = "blue", + outline_color_unaffected = "black", + preset = "none", ... ) } @@ -393,7 +414,8 @@ The plot is reversed vertically, so this is needed to nudge labels up instead of \item{status_legend_show}{Whether to show the status legend.} -\item{overlay_shape}{Shape used for overlaying points in the plot. Default is 4 (cross).} +\item{overlay_shape}{Shape used for overlaying points in the plot. Default is 4 (cross). +When overlay_mode is "shape", accepts named strings: "cross", "slash", "x".} \item{overlay_code_affected}{Code for affected individuals in overlay. Default is 1.} @@ -411,6 +433,16 @@ The plot is reversed vertically, so this is needed to nudge labels up instead of \item{overlay_include}{Whether to include overlay points in the plot. Default is FALSE.} +\item{overlay_mode}{Character string specifying the overlay rendering mode. +"alpha" (default) uses alpha transparency mapping; "shape" draws a shape overlay +on matching individuals (e.g., cross for deceased markers).} + +\item{overlay_size}{Numeric. Size of the shape overlay. Default is NULL (inherits from point_size). +Only used when overlay_mode is "shape".} + +\item{overlay_stroke}{Stroke width for the shape overlay. Default is 1.5. +Only used when overlay_mode is "shape".} + \item{overlay_legend_title}{Title of the overlay legend. Default is "Overlay".} \item{overlay_legend_show}{Whether to show the overlay legend. Default is FALSE.} @@ -547,6 +579,43 @@ The plot is reversed vertically, so this is needed to nudge labels up instead of \item{add_phantoms}{Whether to add phantom parents for individuals without parents.} +\item{affected_fill_include}{Whether to enable affected fill styling. Default is FALSE.} + +\item{affected_fill_code_affected}{Value in the affected fill column that triggers filling. Default is 1.} + +\item{affected_fill_code_unaffected}{Value in the affected fill column for unaffected individuals. Default is 0.} + +\item{affected_fill_label_affected}{Label for affected individuals in fill legend. Default is "Affected".} + +\item{affected_fill_label_unaffected}{Label for unaffected individuals in fill legend. Default is "Unaffected".} + +\item{affected_fill_color_affected}{Color used to fill symbols for affected individuals. Default is "black".} + +\item{affected_fill_color_unaffected}{Color used to fill symbols for unaffected individuals. Default is NA (transparent).} + +\item{affected_fill_shape_female}{Filled shape for affected females. Default is 21 (filled circle).} + +\item{affected_fill_shape_male}{Filled shape for affected males. Default is 22 (filled square).} + +\item{affected_fill_shape_unknown}{Filled shape for affected unknown sex. Default is 23 (filled diamond).} + +\item{outline_color_include}{Whether to enable column-based outline coloring. Default is FALSE.} + +\item{outline_color_code_affected}{Value in the outline color column that triggers colored outlines. Default is 1.} + +\item{outline_color_code_unaffected}{Value in the outline color column for default outlines. Default is 0.} + +\item{outline_color_label_affected}{Label for highlighted outline individuals. Default is "Highlighted".} + +\item{outline_color_label_unaffected}{Label for default outline individuals. Default is "Default".} + +\item{outline_color_affected}{Color used for highlighted outlines. Default is "blue".} + +\item{outline_color_unaffected}{Color used for default (non-highlighted) outlines. Default is "black".} + +\item{preset}{Optional preset name for default styling combinations. +Currently supported: "clinical" for standard clinical pedigree styling. Default is "none" (no preset).} + \item{...}{Additional arguments for future extensibility.} } \value{ diff --git a/man/ggPedigree.Rd b/man/ggPedigree.Rd index 7b3dfe4b..bbf43dde 100644 --- a/man/ggPedigree.Rd +++ b/man/ggPedigree.Rd @@ -19,13 +19,16 @@ ggPedigree( focal_fill_column = NULL, tooltip_columns = NULL, overlay_column = NULL, + overlays = NULL, return_widget = FALSE, config = list(), debug = FALSE, hints = NULL, interactive = FALSE, code_male = NULL, - sexVar = "sex" + sexVar = "sex", + affected_fill_column = NULL, + outline_color_column = NULL ) ggpedigree( @@ -42,13 +45,16 @@ ggpedigree( focal_fill_column = NULL, tooltip_columns = NULL, overlay_column = NULL, + overlays = NULL, return_widget = FALSE, config = list(), debug = FALSE, hints = NULL, interactive = FALSE, code_male = NULL, - sexVar = "sex" + sexVar = "sex", + affected_fill_column = NULL, + outline_color_column = NULL ) } \arguments{ @@ -79,7 +85,17 @@ Defaults to c("personID", "sex"). Additional columns present in `ped` can be supplied – they will be added to the Plotly tooltip text. Defaults to NULL, which uses the default tooltip columns.} -\item{overlay_column}{Character string specifying the column name for overlay alpha values.} +\item{overlay_column}{Character string specifying the column name for overlay alpha values. +For a single overlay, this is the simplest interface. For multiple overlays, use +the \code{overlays} parameter instead.} + +\item{overlays}{A list of overlay specifications for adding multiple independent overlay +layers. Each element should be a list with at minimum a \code{column} entry, plus optional +entries: \code{code_affected}, \code{shape}, \code{color}, \code{size}, \code{stroke}, +\code{mode}. Unspecified entries inherit from the \code{overlay_*} config defaults. +When \code{overlays} is provided, \code{overlay_column} is ignored. +Example: \code{overlays = list(list(column = "DECES", shape = "cross"), +list(column = "PROBAND", shape = 8, color = "red"))}} \item{return_widget}{Logical; if TRUE (default) returns a plotly htmlwidget. If FALSE, returns the underlying plotly object (useful for further @@ -114,6 +130,14 @@ customization before printing).} \item{code_male}{Integer or string. Value identifying males in the sex column. (typically 0 or 1) Default: 1} \item{sexVar}{Character string specifying the column name for sex. Defaults to "sex".} + +\item{affected_fill_column}{Character string specifying the column name for conditional +affected fill. When provided, individuals matching the `affected_fill_code_affected` config +will have their symbols filled. Default is NULL.} + +\item{outline_color_column}{Character string specifying the column name for outline +color control. When provided, individuals matching `outline_color_code_affected` config +will have colored outlines (e.g., blue for included). Default is NULL.} } \value{ A `ggplot` object rendering the pedigree diagram. diff --git a/man/ggPedigree.core.Rd b/man/ggPedigree.core.Rd index cc9cb9bd..41288df2 100644 --- a/man/ggPedigree.core.Rd +++ b/man/ggPedigree.core.Rd @@ -16,13 +16,16 @@ ggPedigree.core( twinID = "twinID", focal_fill_column = NULL, overlay_column = NULL, + overlays = NULL, status_column = NULL, code_male = NULL, config = list(), debug = FALSE, hints = NULL, sexVar = "sex", - function_name = "ggPedigree" + function_name = "ggPedigree", + affected_fill_column = NULL, + outline_color_column = NULL ) } \arguments{ @@ -46,7 +49,17 @@ ggPedigree.core( \item{focal_fill_column}{Character string specifying the column name for focal fill color.} -\item{overlay_column}{Character string specifying the column name for overlay alpha values.} +\item{overlay_column}{Character string specifying the column name for overlay alpha values. +For a single overlay, this is the simplest interface. For multiple overlays, use +the \code{overlays} parameter instead.} + +\item{overlays}{A list of overlay specifications for adding multiple independent overlay +layers. Each element should be a list with at minimum a \code{column} entry, plus optional +entries: \code{code_affected}, \code{shape}, \code{color}, \code{size}, \code{stroke}, +\code{mode}. Unspecified entries inherit from the \code{overlay_*} config defaults. +When \code{overlays} is provided, \code{overlay_column} is ignored. +Example: \code{overlays = list(list(column = "DECES", shape = "cross"), +list(column = "PROBAND", shape = 8, color = "red"))}} \item{status_column}{Character string specifying the column name for affected status. Defaults to NULL.} @@ -77,6 +90,14 @@ ggPedigree.core( \item{hints}{Data frame with hints for layout adjustments. Default: NULL.} \item{sexVar}{Character string specifying the column name for sex. Defaults to "sex".} + +\item{affected_fill_column}{Character string specifying the column name for conditional +affected fill. When provided, individuals matching the `affected_fill_code_affected` config +will have their symbols filled. Default is NULL.} + +\item{outline_color_column}{Character string specifying the column name for outline +color control. When provided, individuals matching `outline_color_code_affected` config +will have colored outlines (e.g., blue for included). Default is NULL.} } \description{ This function is the core implementation of the ggPedigree function. diff --git a/man/ggPedigreeInteractive.Rd b/man/ggPedigreeInteractive.Rd index 3d22189c..d530816b 100644 --- a/man/ggPedigreeInteractive.Rd +++ b/man/ggPedigreeInteractive.Rd @@ -23,7 +23,9 @@ ggPedigreeInteractive( return_widget = TRUE, hints = NULL, code_male = NULL, - sexVar = "sex" + sexVar = "sex", + affected_fill_column = NULL, + outline_color_column = NULL ) } \arguments{ @@ -54,7 +56,9 @@ Defaults to NULL, which uses the default tooltip columns.} \item{focal_fill_column}{Character string specifying the column name for focal fill color.} -\item{overlay_column}{Character string specifying the column name for overlay alpha values.} +\item{overlay_column}{Character string specifying the column name for overlay alpha values. +For a single overlay, this is the simplest interface. For multiple overlays, use +the \code{overlays} parameter instead.} \item{config}{A list of configuration options for customizing the plot. See getDefaultPlotConfig for details of each option. The list can include: @@ -87,6 +91,14 @@ customization before printing).} \item{code_male}{Integer or string. Value identifying males in the sex column. (typically 0 or 1) Default: 1} \item{sexVar}{Character string specifying the column name for sex. Defaults to "sex".} + +\item{affected_fill_column}{Character string specifying the column name for conditional +affected fill. When provided, individuals matching the `affected_fill_code_affected` config +will have their symbols filled. Default is NULL.} + +\item{outline_color_column}{Character string specifying the column name for outline +color control. When provided, individuals matching `outline_color_code_affected` config +will have colored outlines (e.g., blue for included). Default is NULL.} } \value{ A plotly htmlwidget (or plotly object if `return_widget = FALSE`) diff --git a/tests/testthat/test-clinicalPedigree.R b/tests/testthat/test-clinicalPedigree.R new file mode 100644 index 00000000..df0e84d3 --- /dev/null +++ b/tests/testthat/test-clinicalPedigree.R @@ -0,0 +1,496 @@ +test_that("affected_fill_column creates filled/unfilled nodes", { + library(BGmisc) + library(svglite) + data("potter") + + # Add an affected fill column + potter$SEP <- ifelse(potter$personID %% 2 == 0, 1, 0) + + p_unaffected_coded <- ggPedigree(potter, + famID = "famID", + personID = "personID", + affected_fill_column = "SEP", + config = list( + sex_color_include = FALSE, + affected_fill_code_affected = 1, + affected_fill_code_unaffected = 0, + affected_fill_color_affected = "#FF0000", + affected_fill_color_unaffected = "black" + ) + ) + p_unaffected_uncoded <- ggPedigree(potter, + famID = "famID", + personID = "personID", + affected_fill_column = "SEP", + config = list( + sex_color_include = FALSE, + affected_fill_code_affected = 1, + affected_fill_color_affected = "#FF0000", + affected_fill_color_unaffected = "black" + ) + ) + + p <- p_unaffected_coded + expect_s3_class(p, "gg") + p <- p_unaffected_uncoded + expect_s3_class(p, "gg") + + # expect to have both affected and unaffected colors in the plot data + built_coded <- ggplot2::ggplot_build(p_unaffected_coded) + built_uncoded <- ggplot2::ggplot_build(p_unaffected_uncoded) + + built_coded_path <- tempfile(fileext = ".svg") + built_uncoded_path <- tempfile(fileext = ".svg") + on.exit(file.remove(built_coded_path), add = TRUE) + on.exit(file.remove(built_uncoded_path), add = TRUE) + ggplot2::ggsave(built_coded_path, plot = p_unaffected_coded) + ggplot2::ggsave(built_uncoded_path, plot = p_unaffected_uncoded) + + built_coded.svg <- readLines(built_coded_path) + built_uncoded.svg <- readLines(built_uncoded_path) + + # delete svg files after reading + + file.remove("built_coded.svg") + file.remove("built_uncoded.svg") + + expect_true(any(grepl("fill:\\s*#FF0000", built_coded.svg))) + expect_true(any(grepl("fill:\\s*#FF0000", built_uncoded.svg))) + + fill_layer_idx_coded <- which(vapply(built_coded$data, function(df) "fill" %in% names(df), logical(1)))[1] + expect_true(!is.na(fill_layer_idx_coded)) + fill_colors_coded <- unique(built_coded$data[[fill_layer_idx_coded]]$fill) + expect_true("red" %in% fill_colors_coded || "#FF0000" %in% fill_colors_coded) + + fill_layer_idx_uncoded <- which(vapply(built_uncoded$data, function(df) "fill" %in% names(df), logical(1)))[1] + expect_true(!is.na(fill_layer_idx_uncoded)) + fill_colors_uncoded <- unique(built_uncoded$data[[fill_layer_idx_uncoded]]$fill) + expect_true("red" %in% fill_colors_uncoded || "#FF0000" %in% fill_colors_uncoded) + + expect_equal(fill_colors_coded, fill_colors_uncoded) + + # is the data the same for both builds (should be, since unaffected_fill_color is just a default for NA values in the data) + expect_equal(built_uncoded$data, built_coded$data) + + + # Build the plot to check layers + built <- ggplot2::ggplot_build(p) + expect_s3_class(built, "ggplot_built") +}) + +test_that("overlay_column with shape mode adds cross overlay", { + library(BGmisc) + data("potter") + + # Add an overlay column (e.g., deceased status) + potter$DECES <- ifelse(potter$personID <= 4, 1, 0) + + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlay_column = "DECES", + config = list( + overlay_include = TRUE, + overlay_mode = "shape", + overlay_shape = "cross", + overlay_code_affected = 1, + overlay_color = "black" + ) + ) + expect_s3_class(p, "gg") + + # The plot should have more layers than a standard plot + p_standard <- ggPedigree(potter, + famID = "famID", + personID = "personID" + ) + expect_true(length(p$layers) > length(p_standard$layers)) +}) + +test_that("outline_color_column applies per-individual outlines", { + library(BGmisc) + data("potter") + + # Add an inclusion column + potter$INCLUS <- ifelse(potter$personID %% 3 == 0, 1, 0) + + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + outline_color_column = "INCLUS", + config = list( + sex_color_include = FALSE, + outline_color_code_affected = 1, + outline_color_affected = "blue", + outline_color_unaffected = "black" + ) + ) + expect_s3_class(p, "gg") + + # Build the plot to check scales + built <- ggplot2::ggplot_build(p) + expect_s3_class(built, "ggplot_built") +}) + +test_that("clinical preset sets correct defaults", { + library(BGmisc) + data("potter") + + potter$SEP <- sample(c(0, 1), nrow(potter), replace = TRUE) + potter$DECES <- sample(c(0, 1), nrow(potter), replace = TRUE) + potter$INCLUS <- sample(c(0, 1), nrow(potter), replace = TRUE) + + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + affected_fill_column = "SEP", + overlay_column = "DECES", + outline_color_column = "INCLUS", + config = list( + preset = "clinical", + affected_fill_code_affected = 1, + affected_fill_code_unaffected = 0, + affected_fill_color_affected = "green", + affected_fill_color_unaffected = "yellow", + overlay_code_affected = 1, + outline_color_code_affected = 1, + outline_color_affected = "blue" + ) + ) + expect_s3_class(p, "gg") +}) + +test_that("all features compose without error", { + library(BGmisc) + data("potter") + + potter$SEP <- sample(c(0, 1), nrow(potter), replace = TRUE) + potter$DECES <- sample(c(0, 1), nrow(potter), replace = TRUE) + potter$INCLUS <- sample(c(0, 1), nrow(potter), replace = TRUE) + + # All features active simultaneously + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + affected_fill_column = "SEP", + overlay_column = "DECES", + outline_color_column = "INCLUS", + config = list( + sex_color_include = FALSE, + affected_fill_code_affected = 1, + affected_fill_color_affected = "black", + overlay_include = TRUE, + overlay_mode = "shape", + overlay_code_affected = 1, + overlay_shape = "cross", + overlay_color = "black", + outline_color_code_affected = 1, + outline_color_affected = "blue", + outline_color_unaffected = "black" + ) + ) + expect_s3_class(p, "gg") + built <- ggplot2::ggplot_build(p) + expect_s3_class(built, "ggplot_built") +}) + +test_that("shape overlay only renders for matching values", { + library(BGmisc) + data("potter") + + # Only person 1 matches + potter$STATUS <- ifelse(potter$personID == 1, 1, 0) + + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlay_column = "STATUS", + config = list( + overlay_include = TRUE, + overlay_mode = "shape", + overlay_code_affected = 1 + ) + ) + expect_s3_class(p, "gg") + + # Build the plot and verify the shape overlay layer has limited points + built <- ggplot2::ggplot_build(p) + # Find the overlay layer (uses shape 4) + overlay_layers <- vapply(built$data, function(d) { + "shape" %in% names(d) && any(d$shape == "4" | d$shape == 4) + }, logical(1)) + # Should have at least one layer with shape 4 for the overlay + expect_true(any(overlay_layers)) +}) + +test_that("config defaults for overlay and affected_fill params follow naming conventions", { + config <- getDefaultPlotConfig() + + # affected_fill uses _code_affected/_code_unaffected pattern + expect_equal(config$affected_fill_include, FALSE) + expect_equal(config$affected_fill_code_affected, 1) + expect_equal(config$affected_fill_code_unaffected, 0) + expect_equal(config$affected_fill_label_affected, "Affected") + expect_equal(config$affected_fill_label_unaffected, "Unaffected") + expect_equal(config$affected_fill_color_affected, "black") + expect_true(is.na(config$affected_fill_color_unaffected)) + expect_equal(config$affected_fill_shape_female, 21) + expect_equal(config$affected_fill_shape_male, 22) + expect_equal(config$affected_fill_shape_unknown, 23) + + # overlay now includes mode/size/stroke params + expect_equal(config$overlay_include, FALSE) + expect_equal(config$overlay_mode, "alpha") + expect_true(is.null(config$overlay_size)) + expect_equal(config$overlay_stroke, 1.5) + expect_equal(config$overlay_shape, 4) + expect_equal(config$overlay_color, "black") + expect_equal(config$overlay_code_affected, 1) + expect_equal(config$overlay_code_unaffected, 0) + + # outline_color uses _code_affected/_code_unaffected pattern + expect_equal(config$outline_color_include, FALSE) + expect_equal(config$outline_color_code_affected, 1) + expect_equal(config$outline_color_code_unaffected, 0) + expect_equal(config$outline_color_label_affected, "Highlighted") + expect_equal(config$outline_color_label_unaffected, "Default") + expect_equal(config$outline_color_affected, "blue") + expect_equal(config$outline_color_unaffected, "black") + + # preset + expect_equal(config$preset, "none") +}) + +test_that("existing behavior unaffected by new params", { + library(BGmisc) + data("potter") + + # Standard usage without new params should be unaffected + p <- ggPedigree(potter, famID = "famID", personID = "personID") + expect_s3_class(p, "gg") + expect_true(all(p$data$personID %in% potter$personID)) + expect_equal(nrow(p$data), nrow(potter)) +}) + +test_that("overlay shape mode supports numeric shape codes", { + library(BGmisc) + data("potter") + + potter$DECES <- ifelse(potter$personID <= 4, 1, 0) + + # Use numeric shape code directly instead of named string + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlay_column = "DECES", + config = list( + overlay_include = TRUE, + overlay_mode = "shape", + overlay_shape = 4, + overlay_code_affected = 1 + ) + ) + expect_s3_class(p, "gg") + built <- ggplot2::ggplot_build(p) + expect_s3_class(built, "ggplot_built") + # Check that the overlay layer uses shape mode with the specified numeric code + overlay_layers <- vapply(built$data, function(d) { + "shape" %in% names(d) && any(d$shape == 4) + }, logical(1)) + expect_true(any(overlay_layers)) +}) + +test_that("clinical preset enables shape-mode overlay", { + config <- getDefaultPlotConfig() + + # Before preset, overlay_mode should be "alpha" + expect_equal(config$overlay_mode, "alpha") + expect_equal(config$overlay_include, FALSE) + + # The clinical preset is applied in ggPedigree(), not in getDefaultPlotConfig() + # So we test it via ggPedigree with the preset + library(BGmisc) + data("potter") + + potter$DECES <- sample(c(0, 1), nrow(potter), replace = TRUE) + + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlay_column = "DECES", + config = list( + preset = "clinical", + overlay_code_affected = 1 + ) + ) + expect_s3_class(p, "gg") + + # Build the plot to check that overlay layer is present + built <- ggplot2::ggplot_build(p) + expect_s3_class(built, "ggplot_built") + # Check that the overlay layer uses shape mode (should have shape aesthetic) + overlay_layers <- vapply(built$data, function(d) { + "shape" %in% names(d) && any(d$shape == "4") + }, logical(1)) + expect_true(any(overlay_layers)) +}) + + +test_that("overlays parameter adds multiple independent shape overlays", { + library(BGmisc) + data("potter") + + potter$DECES <- ifelse(potter$personID <= 4, 1, 0) + potter$PROBAND <- ifelse(potter$personID == 1, 1, 0) + + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlays = list( + list(column = "DECES", code_affected = 1, shape = "cross", color = "black"), + list(column = "PROBAND", code_affected = 1, shape = 8, color = "red") + ), + config = list( + overlay_include = TRUE, + overlay_mode = "shape" + ) + ) + expect_s3_class(p, "gg") + + + # Should have more layers than a standard plot (two extra overlay layers) + p_standard <- ggPedigree(potter, + famID = "famID", + personID = "personID" + ) + expect_true(length(p$layers) >= length(p_standard$layers) + 2) +}) + +test_that("overlays specs override config defaults per-overlay", { + library(BGmisc) + data("potter") + + potter$STATUS_A <- ifelse(potter$personID %% 2 == 0, 1, 0) + potter$STATUS_B <- ifelse(potter$personID %% 3 == 0, 1, 0) + + # Each overlay has different shape and color + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlays = list( + list(column = "STATUS_A", code_affected = 1, shape = "cross", color = "blue"), + list(column = "STATUS_B", code_affected = 1, shape = "slash", color = "red", stroke = 2) + ), + config = list( + overlay_include = TRUE, + overlay_mode = "shape" + ) + ) + expect_s3_class(p, "gg") + built <- ggplot2::ggplot_build(p) + expect_s3_class(built, "ggplot_built") + + # right now both are being applied to status B for some reason + + # Check that both overlay layers have the specified shapes and colors + overlay_a <- vapply(built$data, function(d) { + "shape" %in% names(d) && any(d$shape == "4") && any(d$colour == "blue") + }, logical(1)) + overlay_b <- vapply(built$data, function(d) { + "shape" %in% names(d) && any(d$shape == 47) && any(d$colour == "red") && any(d$stroke == 2) + }, logical(1)) + expect_true(any(overlay_a)) + expect_true(any(overlay_b)) +}) + +test_that("overlays parameter takes precedence over overlay_column", { + library(BGmisc) + data("potter") + + potter$STATUS_A <- ifelse(potter$personID %% 2 == 0, 1, 0) + potter$STATUS_B <- rep(0, nrow(potter)) + + # When both overlays and overlay_column are provided, overlays wins + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlay_column = "STATUS_B", + overlays = list( + list(column = "STATUS_A", code_affected = 1, shape = "cross") + ), + config = list( + overlay_include = TRUE, + overlay_mode = "shape" + ) + ) + expect_s3_class(p, "gg") + + # Build and verify the shape overlay matches STATUS_A not STATUS_B + built <- ggplot2::ggplot_build(p) + overlay_layers <- vapply(built$data, function(d) { + "shape" %in% names(d) && any(d$shape == "4" | d$shape == 4) + }, logical(1)) + expect_true(any(overlay_layers)) +}) + +test_that("single overlay_column still works (backward compat)", { + library(BGmisc) + data("potter") + + potter$DECES <- ifelse(potter$personID <= 4, 1, 0) + + # Old single-column API should still work + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + overlay_column = "DECES", + config = list( + overlay_include = TRUE, + overlay_mode = "shape", + overlay_shape = "cross", + overlay_code_affected = 1 + ) + ) + expect_s3_class(p, "gg") + + p_standard <- ggPedigree(potter, + famID = "famID", + personID = "personID" + ) + expect_true(length(p$layers) > length(p_standard$layers)) +}) + +test_that("affected_fill_color_unaffected is applied in rendered plot", { + library(BGmisc) + data("potter") + + potter$SEP <- ifelse(potter$personID %% 2 == 0, 1, 0) + + p <- ggPedigree(potter, + famID = "famID", + personID = "personID", + affected_fill_column = "SEP", + config = list( + sex_color_include = FALSE, + affected_fill_code_affected = 1, + affected_fill_color_affected = "green", + affected_fill_color_unaffected = "yellow" + ) + ) + expect_s3_class(p, "gg") + + built <- ggplot2::ggplot_build(p) + # Find the layer that has 'fill' in its data + fill_layer <- NULL + for (i in seq_along(built$data)) { + if ("fill" %in% names(built$data[[i]])) { + fill_layer <- built$data[[i]] + break + } + } + expect_false(is.null(fill_layer)) + # Unaffected individuals should have yellow fill, not NA + expect_true("yellow" %in% fill_layer$fill) + # Affected individuals should have green fill + expect_true("green" %in% fill_layer$fill) +}) diff --git a/tests/testthat/test-defaultPlotConfig.R b/tests/testthat/test-defaultPlotConfig.R index fe2a42aa..90ef1614 100644 --- a/tests/testthat/test-defaultPlotConfig.R +++ b/tests/testthat/test-defaultPlotConfig.R @@ -16,7 +16,7 @@ test_that("getDefaultPlotConfig returns expected defaults", { config <- getDefaultPlotConfig() expect_true(is.list(config)) - expect_equal(length(config), 167) # Check number of default parameters + expect_equal(length(config), 188) # Check number of default parameters expect_equal(config$apply_default_scales, TRUE) expect_equal(config$apply_default_theme, TRUE) diff --git a/tests/testthat/test-kinship2_pedigrees.R b/tests/testthat/test-kinship2_pedigrees.R index 8d3bffcf..873b574a 100644 --- a/tests/testthat/test-kinship2_pedigrees.R +++ b/tests/testthat/test-kinship2_pedigrees.R @@ -71,9 +71,9 @@ test_that("pedigree.sexrepair handles 0-indexed sex (min=0 triggers +1 shift)", # sex=c(0,1,0,1): 0 -> 1="male", 1 -> 2="female" after the +1 shift. ped <- ggpedigree:::pedigree( id = 1:4, - dadid = c(0, 0, 1, 1), # dad = subject 1 (sex=0 -> male after shift) - momid = c(0, 0, 2, 2), # mom = subject 2 (sex=1 -> female after shift) - sex = c(0, 1, 0, 1) # shifted up by 1: 0->1="male", 1->2="female" + dadid = c(0, 0, 1, 1), # dad = subject 1 (sex=0 -> male after shift) + momid = c(0, 0, 2, 2), # mom = subject 2 (sex=1 -> female after shift) + sex = c(0, 1, 0, 1) # shifted up by 1: 0->1="male", 1->2="female" ) expect_s3_class(ped, "pedigree") expect_equal(as.character(ped$sex), c("male", "female", "male", "female")) @@ -97,7 +97,7 @@ test_that("pedigree.sexrepair warns when more than 25% unknown", { id = 1:8, dadid = c(0, 0, 1, 1, 0, 0, 5, 5), momid = c(0, 0, 2, 2, 0, 0, 6, 6), - sex = c(1, 2, 1, 3, 1, 2, 3, 3) # 3/8 = 37.5% unknown, > 25% + sex = c(1, 2, 1, 3, 1, 2, 3, 3) # 3/8 = 37.5% unknown, > 25% ), "More than 25%" ) @@ -120,9 +120,9 @@ test_that("pedigree errors when listed father is not male", { expect_error( ggpedigree:::pedigree( id = c(1, 2, 3), - dadid = c(0, 0, 2), # subject 2 listed as father but is female + dadid = c(0, 0, 2), # subject 2 listed as father but is female momid = c(0, 0, 1), - sex = c(2, 2, 1) # subjects 1 and 2 are female + sex = c(2, 2, 1) # subjects 1 and 2 are female ), "Id not male, but is a father" ) @@ -132,7 +132,7 @@ test_that("pedigree errors when dadid not found in id list", { expect_error( ggpedigree:::pedigree( id = c(1, 2, 3), - dadid = c(0, 0, 99), # 99 is not in id + dadid = c(0, 0, 99), # 99 is not in id momid = c(0, 0, 2), sex = c(1, 2, 1) ), @@ -145,7 +145,7 @@ test_that("pedigree errors when listed mother is not female", { ggpedigree:::pedigree( id = c(1, 2, 3), dadid = c(0, 0, 1), - momid = c(0, 0, 3), # subject 3 listed as mother but is male + momid = c(0, 0, 3), # subject 3 listed as mother but is male sex = c(1, 2, 1) ), "Id not female, but is a mother" @@ -157,7 +157,7 @@ test_that("pedigree errors when momid not found in id list", { ggpedigree:::pedigree( id = c(1, 2, 3), dadid = c(0, 0, 1), - momid = c(0, 0, 99), # 99 is not in id + momid = c(0, 0, 99), # 99 is not in id sex = c(1, 2, 1) ), "Value of 'momid' not found in the id list" @@ -168,7 +168,7 @@ test_that("pedigree errors when subject has only one parent", { expect_error( ggpedigree:::pedigree( id = c(1, 2, 3), - dadid = c(0, 0, 1), # subject 3 has dad but no mom + dadid = c(0, 0, 1), # subject 3 has dad but no mom momid = c(0, 0, 0), sex = c(1, 2, 1) ), @@ -233,7 +233,7 @@ test_that("pedigree.process_status errors on wrong length", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - status = c(0, 1) # length 2 vs n=4 + status = c(0, 1) # length 2 vs n=4 ), "Wrong length for affected" ) @@ -246,7 +246,7 @@ test_that("pedigree.process_status errors on invalid code", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - status = c(0, 1, 2, 0) # 2 is invalid + status = c(0, 1, 2, 0) # 2 is invalid ), "Invalid status code" ) @@ -294,7 +294,7 @@ test_that("pedigree.process_affected errors on wrong length", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - affected = c(0, 1, 0) # length 3 vs n=4 + affected = c(0, 1, 0) # length 3 vs n=4 ), "Wrong length for affected" ) @@ -307,7 +307,7 @@ test_that("pedigree.process_affected errors on wrong matrix rows", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - affected = matrix(c(0, 1, 0), nrow = 3) # 3 rows vs n=4 + affected = matrix(c(0, 1, 0), nrow = 3) # 3 rows vs n=4 ), "Wrong number of rows in affected" ) @@ -320,7 +320,7 @@ test_that("pedigree.process_affected errors on invalid code", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - affected = c(0, 1, 0.5, 1) # 0.5 is invalid + affected = c(0, 1, 0.5, 1) # 0.5 is invalid ), "Invalid code for affected status" ) @@ -337,10 +337,10 @@ test_that("pedigree.coerce_relation_code handles factor code input", { ) # Now test with factor code in the relation matrix ped2 <- ggpedigree:::pedigree( - id = 1:4, - dadid = c(0, 0, 1, 1), - momid = c(0, 0, 2, 2), - sex = c(1, 2, 1, 1), + id = 1:4, + dadid = c(0, 0, 1, 1), + momid = c(0, 0, 2, 2), + sex = c(1, 2, 1, 1), relation = data.frame( id1 = 3, id2 = 4, @@ -368,7 +368,7 @@ test_that("pedigree.coerce_relation_code errors on invalid numeric code", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - relation = matrix(c(3, 4, 5), ncol = 3) # code 5 is invalid + relation = matrix(c(3, 4, 5), ncol = 3) # code 5 is invalid ), "Invalid relationship code" ) @@ -381,7 +381,7 @@ test_that("pedigree.coerce_relation_code errors on invalid character code", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - relation = data.frame(id1 = 3, id2 = 4, code = "triplet") # invalid + relation = data.frame(id1 = 3, id2 = 4, code = "triplet") # invalid ), "Invalid relationship code" ) @@ -395,7 +395,7 @@ test_that("pedigree.parse_relation errors on matrix with wrong column count", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - relation = matrix(c(3, 4), ncol = 2) # need 3 columns + relation = matrix(c(3, 4), ncol = 2) # need 3 columns ), "Relation matrix must have 3 columns" ) @@ -409,7 +409,7 @@ test_that("pedigree.parse_relation errors on matrix with wrong column count when momid = c(0, 0, 2, 2, 0, 0), sex = c(1, 2, 1, 2, 1, 2), famid = c(1, 1, 1, 1, 2, 2), - relation = matrix(c(3, 4, 1), ncol = 3) # need 4 columns when has_famid + relation = matrix(c(3, 4, 1), ncol = 3) # need 4 columns when has_famid ), "Relation matrix must have 3 columns \\+ famid" ) @@ -433,7 +433,7 @@ test_that("pedigree.parse_relation errors on dataframe with missing columns", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - relation = data.frame(id1 = 3, id2 = 4) # missing code + relation = data.frame(id1 = 3, id2 = 4) # missing code ), "Relation data frame must have id1, id2, and code" ) @@ -454,11 +454,11 @@ test_that("pedigree.parse_relation errors when relation is not matrix or datafra test_that("pedigree.parse_relation works with dataframe input (with famid)", { ped_list <- ggpedigree:::pedigree( - id = c(1, 2, 3, 4, 1, 2), - dadid = c(0, 0, 1, 1, 0, 0), - momid = c(0, 0, 2, 2, 0, 0), - sex = c(1, 2, 1, 1, 1, 2), - famid = c(1, 1, 1, 1, 2, 2), + id = c(1, 2, 3, 4, 1, 2), + dadid = c(0, 0, 1, 1, 0, 0), + momid = c(0, 0, 2, 2, 0, 0), + sex = c(1, 2, 1, 1, 1, 2), + famid = c(1, 1, 1, 1, 2, 2), relation = data.frame(id1 = 3, id2 = 4, code = 1, famid = 1) ) expect_s3_class(ped_list, "pedigreeList") @@ -468,12 +468,12 @@ test_that("pedigree.parse_relation works with dataframe input (with famid)", { test_that("pedigree.parse_relation errors on dataframe with missing famid column when has_famid", { expect_error( ggpedigree:::pedigree( - id = c(1, 2, 3, 4, 1, 2), - dadid = c(0, 0, 1, 1, 0, 0), - momid = c(0, 0, 2, 2, 0, 0), - sex = c(1, 2, 1, 1, 1, 2), - famid = c(1, 1, 1, 1, 2, 2), - relation = data.frame(id1 = 3, id2 = 4, code = 1) # missing famid column + id = c(1, 2, 3, 4, 1, 2), + dadid = c(0, 0, 1, 1, 0, 0), + momid = c(0, 0, 2, 2, 0, 0), + sex = c(1, 2, 1, 1, 1, 2), + famid = c(1, 1, 1, 1, 2, 2), + relation = data.frame(id1 = 3, id2 = 4, code = 1) # missing famid column ), "Relation data must have id1, id2, code, and family id" ) @@ -482,11 +482,11 @@ test_that("pedigree.parse_relation errors on dataframe with missing famid column test_that("pedigree.parse_relation errors when relation is not matrix or dataframe (with famid)", { expect_error( ggpedigree:::pedigree( - id = c(1, 2, 3, 4, 1, 2), - dadid = c(0, 0, 1, 1, 0, 0), - momid = c(0, 0, 2, 2, 0, 0), - sex = c(1, 2, 1, 1, 1, 2), - famid = c(1, 1, 1, 1, 2, 2), + id = c(1, 2, 3, 4, 1, 2), + dadid = c(0, 0, 1, 1, 0, 0), + momid = c(0, 0, 2, 2, 0, 0), + sex = c(1, 2, 1, 1, 1, 2), + famid = c(1, 1, 1, 1, 2, 2), relation = list(id1 = 3, id2 = 4, code = 1, famid = 1) ), "Relation argument must be a matrix or a dataframe" @@ -501,7 +501,7 @@ test_that("pedigree.process_relation errors when relation member not in pedigree dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - relation = matrix(c(3, 99, 4), ncol = 3) # 99 not in pedigree + relation = matrix(c(3, 99, 4), ncol = 3) # 99 not in pedigree ), "Subjects in relationships that are not in the pedigree" ) @@ -514,7 +514,7 @@ test_that("pedigree.process_relation errors when subject is own twin/spouse", { dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), sex = c(1, 2, 1, 2), - relation = matrix(c(3, 3, 4), ncol = 3) # subject 3 is own spouse + relation = matrix(c(3, 3, 4), ncol = 3) # subject 3 is own spouse ), "is their own spouse or twin" ) @@ -523,11 +523,11 @@ test_that("pedigree.process_relation errors when subject is own twin/spouse", { test_that("pedigree.process_relation errors when twins have different mothers", { expect_error( ggpedigree:::pedigree( - id = c(1, 2, 3, 4, 5, 6), + id = c(1, 2, 3, 4, 5, 6), dadid = c(0, 0, 0, 0, 1, 1), - momid = c(0, 0, 0, 0, 2, 4), # subject 5 has mom 2, subject 6 has mom 4 - sex = c(1, 2, 1, 2, 1, 1), - relation = matrix(c(5, 6, 1), ncol = 3) # MZ twins with different mothers + momid = c(0, 0, 0, 0, 2, 4), # subject 5 has mom 2, subject 6 has mom 4 + sex = c(1, 2, 1, 2, 1, 1), + relation = matrix(c(5, 6, 1), ncol = 3) # MZ twins with different mothers ), "Twins found with different mothers" ) @@ -536,11 +536,11 @@ test_that("pedigree.process_relation errors when twins have different mothers", test_that("pedigree.process_relation errors when twins have different fathers", { expect_error( ggpedigree:::pedigree( - id = c(1, 2, 3, 4, 5, 6), - dadid = c(0, 0, 0, 0, 1, 3), # subject 5 has dad 1, subject 6 has dad 3 - momid = c(0, 0, 0, 0, 2, 2), # both have mom 2 - sex = c(1, 2, 1, 1, 1, 1), - relation = matrix(c(5, 6, 1), ncol = 3) # MZ twins with different fathers + id = c(1, 2, 3, 4, 5, 6), + dadid = c(0, 0, 0, 0, 1, 3), # subject 5 has dad 1, subject 6 has dad 3 + momid = c(0, 0, 0, 0, 2, 2), # both have mom 2 + sex = c(1, 2, 1, 1, 1, 1), + relation = matrix(c(5, 6, 1), ncol = 3) # MZ twins with different fathers ), "Twins found with different fathers" ) @@ -549,11 +549,11 @@ test_that("pedigree.process_relation errors when twins have different fathers", test_that("pedigree.process_relation errors when MZ twins have different sexes", { expect_error( ggpedigree:::pedigree( - id = 1:4, + id = 1:4, dadid = c(0, 0, 1, 1), momid = c(0, 0, 2, 2), - sex = c(1, 2, 1, 2), # subject 3 male, subject 4 female - relation = matrix(c(3, 4, 1), ncol = 3) # MZ twins with different sexes + sex = c(1, 2, 1, 2), # subject 3 male, subject 4 female + relation = matrix(c(3, 4, 1), ncol = 3) # MZ twins with different sexes ), "MZ twins with different sexes" ) @@ -569,17 +569,16 @@ test_that("pedigreeList subscript with numeric index", { affected = cancer, famid = famid ) ) - ped8_num <- minnped[1] # first family by position (numeric) -# ped8_chr <- minnped["1"] - # expect_equal(ped8_num$id, ped8_chr$id) -# ══ Failed tests ════════════════════════════════════════════════════════════════ -#── Error ('test-kinship2_pedigrees.R:573:3'): pedigreeList subscript with numeric index ── -#Error in ``[.pedigreeList`(minnped, "1")`: Family 1 not found -#Backtrace: -# ▆ -# 1. ├─minnped["1"] at test-kinship2_pedigrees.R:573:3 -# 2. └─ggpedigree:::`[.pedigreeList`(minnped, "1") at test-kinship2_pedigrees.R:573:3 - + ped8_num <- minnped[1] # first family by position (numeric) + # ped8_chr <- minnped["1"] + # expect_equal(ped8_num$id, ped8_chr$id) + # ══ Failed tests ════════════════════════════════════════════════════════════════ + # ── Error ('test-kinship2_pedigrees.R:573:3'): pedigreeList subscript with numeric index ── + # Error in ``[.pedigreeList`(minnped, "1")`: Family 1 not found + # Backtrace: + # ▆ + # 1. ├─minnped["1"] at test-kinship2_pedigrees.R:573:3 + # 2. └─ggpedigree:::`[.pedigreeList`(minnped, "1") at test-kinship2_pedigrees.R:573:3 }) test_that("pedigreeList subscript with factor index", { @@ -636,17 +635,17 @@ test_that("pedigreeList subscript errors with too many subscripts", { test_that("pedigreeList subscript handles matrix affected, status, and relation", { # Build a pedigreeList with matrix affected, status, and a relation ped_list <- ggpedigree:::pedigree( - id = c(1, 2, 3, 4, 5, 1, 2, 3), - dadid = c(0, 0, 1, 1, 1, 0, 0, 1), - momid = c(0, 0, 2, 2, 2, 0, 0, 2), - sex = c(1, 2, 1, 1, 2, 1, 2, 1), - famid = c(1, 1, 1, 1, 1, 2, 2, 2), + id = c(1, 2, 3, 4, 5, 1, 2, 3), + dadid = c(0, 0, 1, 1, 1, 0, 0, 1), + momid = c(0, 0, 2, 2, 2, 0, 0, 2), + sex = c(1, 2, 1, 1, 2, 1, 2, 1), + famid = c(1, 1, 1, 1, 1, 2, 2, 2), affected = cbind( - disease = c(0, 0, 1, 0, 1, 0, 0, 1), - smoker = c(1, 0, 0, 1, 0, 1, 0, 1) + disease = c(0, 0, 1, 0, 1, 0, 0, 1), + smoker = c(1, 0, 0, 1, 0, 1, 0, 1) ), - status = c(0, 1, 0, 0, 1, 1, 0, 0), - relation = matrix(c(3, 4, 1, 1), ncol = 4) # MZ twins 3&4 in family 1 + status = c(0, 1, 0, 0, 1, 1, 0, 0), + relation = matrix(c(3, 4, 1, 1), ncol = 4) # MZ twins 3&4 in family 1 ) # Select family 1: relation should be kept, famid removed from relation @@ -675,7 +674,7 @@ test_that("pedigree subscript errors with too many subscripts", { }) test_that("pedigree subscript errors when only one parent is kept", { - ped <- .make_simple_ped() # 1=dad, 2=mom, 3/4/5=children + ped <- .make_simple_ped() # 1=dad, 2=mom, 3/4/5=children # Keep dad and child 3 but not mom → child 3 has dad but no mom expect_error(ped[c(1, 3)], "A subpedigree cannot choose only one parent") }) @@ -698,7 +697,7 @@ test_that("pedigree subscript keeps relation when both members retained", { dadid = c(0, 0, 1, 1, 1), momid = c(0, 0, 2, 2, 2), sex = c(1, 2, 1, 1, 2), - relation = matrix(c(3, 4, 1), ncol = 3) # MZ twins 3 and 4 + relation = matrix(c(3, 4, 1), ncol = 3) # MZ twins 3 and 4 ) # Keep all: relation preserved sub_all <- ped[1:5] @@ -727,11 +726,11 @@ test_that("pedigree subscript preserves famid", { test_that("pedigree subscript handles hints field", { # Build a pedigree with a manually set hints field (order + spouse) ped <- ggpedigree:::pedigree( - id = 1:4, + id = 1:4, dadid = c(0, 0, 1, 0), momid = c(0, 0, 2, 0), - sex = c(1, 2, 1, 2), - relation = matrix(c(1, 4, 4), ncol = 3) # 1 and 4 are spouses (code=4) + sex = c(1, 2, 1, 2), + relation = matrix(c(1, 4, 4), ncol = 3) # 1 and 4 are spouses (code=4) ) # Manually attach a hints structure (as kinship2_autohint would produce) ped$hints <- list( @@ -747,7 +746,7 @@ test_that("pedigree subscript handles hints field", { # Keep subjects 1, 2, 3 (drop subject 4 = one spouse member) sub_no4 <- ped[c(1, 2, 3)] expect_false(is.null(sub_no4$hints)) - expect_null(sub_no4$hints$spouse) # spouse entry dropped since subject 4 is not kept + expect_null(sub_no4$hints$spouse) # spouse entry dropped since subject 4 is not kept }) # ---- print methods ---- diff --git a/vignettes/articles/v11_configuration_extended.Rmd b/vignettes/articles/v11_configuration_extended.Rmd index f81cb802..2e6988f4 100644 --- a/vignettes/articles/v11_configuration_extended.Rmd +++ b/vignettes/articles/v11_configuration_extended.Rmd @@ -345,6 +345,41 @@ ggPedigree( ) ``` +### Multiple overlays with per-overlay customization + +When a single status marker is not enough, you can pass a **list of overlay specs** to the `overlays` argument. Each element of the list is itself a list that names a column and optionally overrides any overlay config key — `shape`, `color`, `stroke`, `size`, and `code_affected` — for that layer only. Config defaults are used for any key you leave out. + +The `hazard` dataset already contains `deathYr` and `onsetYr`, which map naturally onto two independent overlays — deceased individuals (a cross) and those with a recorded disease onset (a slash): + +```{r} +# Derive binary flags from columns already present in hazard +hazard$deceased <- ifelse(!is.na(hazard$deathYr), 1, 0) +hazard$onset <- ifelse(!is.na(hazard$onsetYr), 1, 0) + +ggPedigree( + hazard, + famID = "famID", + personID = "ID", + momID = "momID", + dadID = "dadID", + overlays = list( + list(column = "deceased", code_affected = 1, shape = "cross", color = "black"), + list(column = "onset", code_affected = 1, shape = "slash", color = "red", stroke = 2) + ), + config = list( + code_male = 0, + overlay_include = TRUE, + overlay_mode = "shape" + ) +) +``` + +A few things to note: + +- **`overlay_mode = "shape"`** must be set in `config` (or via a preset such as `"clinical"`) to activate shape-based rendering. Without it the overlay loop falls back to alpha transparency. +- Each spec can carry any combination of per-layer overrides. Specs with no override for a key inherit the matching `config$overlay_*` default, so you only need to specify what differs. +- The specs are rendered as separate `geom_point()` layers in list order, so later specs draw on top of earlier ones for individuals who satisfy both conditions. + ## 6) Focal fill: highlighting relatives of a focal individual A common analysis task is to pick a focal individual and visually emphasize how strongly other individuals are related to that focal person. In `{ggpedigree}`, this is handled by **focal fill**. When focal fill is enabled, node fill colors are mapped to a focal-based value (for example additive genetic relatedness or another focal-derived scalar). diff --git a/vignettes/articles/wfu_potter_pedigree.png b/vignettes/articles/wfu_potter_pedigree.png index a7bc3cf1..2811ffb6 100644 Binary files a/vignettes/articles/wfu_potter_pedigree.png and b/vignettes/articles/wfu_potter_pedigree.png differ