R/plot-design.R

In ppforest2: Projection Pursuit Oblique Decision Trees and Random Forests

# ======================================================================
# pptr Visualization — Design system and shared helpers
#
# Named constants for line weights, point sizes, alpha values, and
# structural colors used across all plot types.  These ensure a cohesive
# look and make it easy to adjust the overall visual style in one place.
#
# The design system has two layers:
#
#   1. Structural constants (below): fixed values for non-data elements
#      like edges, borders, cutpoints, and decision boundaries.  These
#      use neutral greys to avoid competing with data-mapped colors.
#
#   2. Data-mapped colors: per-group fill and colour generated by
#      get_group_colors() using evenly-spaced HCL hues.  Applied via
#      scale_fill_manual / scale_color_manual so users can override
#      with + scale_fill_manual(values = ...).
#
# Architecture:
#   - C++ (Visualization.hpp/cpp) computes geometry: node data routing,
#     boundary line clipping, region polygon clipping (Sutherland-Hodgman),
#     and tree layout positioning.
#   - R (plot-*.R files) handles rendering: translates C++ output into
#     ggplot2 layers and assembles composite layouts via patchwork.
# ======================================================================

# Suppress R CMD check NOTEs for ggplot2 aes() column references
utils::globalVariables(c(
  "from_x", "from_y", "to_x", "to_y",
  "importance", "variable",
  "projected",
  "x", "y",
  "x_start", "y_start", "x_end", "y_end",
  "alpha",
  "edge_label", "group", "xmin", "xmax", "ymin", "ymax", "label",
  "xend", "yend", "region_id", "region_group",
  "metric", "x_var", "y_var"
))

#' Guard: abort with a helpful message if ggplot2 is not installed.
#'
#' Called at the top of every public plot method (plot.pptr, plot.pprf).
#' @noRd
check_ggplot2 <- function() {
  if (!requireNamespace("ggplot2", quietly = TRUE)) {
    stop(
      "Package 'ggplot2' is required for plot methods. ",
      "Install it with install.packages('ggplot2').",
      call. = FALSE
    )
  }
}

#' Guard: abort with a helpful message if patchwork is not installed.
#'
#' Called by composite layouts (mosaic, importance grid) that use
#' patchwork to compose multiple ggplot objects into a single plot.
#' @noRd
check_patchwork <- function() {
  if (!requireNamespace("patchwork", quietly = TRUE)) {
    stop(
      "Package 'patchwork' is required for composite plot layouts. ",
      "Install it with install.packages('patchwork').",
      call. = FALSE
    )
  }
}

# ------------------------------------------------------------------
# Design option accessor
#
# Each constant is read from options() with a default fallback, so
# users can customize any value globally:
#
#   options(ppforest2.col_bar = "steelblue")
#   options(ppforest2.alpha_region = 0.4)
#
# Or restore defaults by setting to NULL:
#
#   options(ppforest2.col_bar = NULL)
# ------------------------------------------------------------------
ppforest2_opt <- function(name, default) {
  getOption(paste0("ppforest2.", name), default)
}

# Node dimensions (must match C++ LayoutParams)
ppforest2_node_w <- function() ppforest2_opt("node_w", 0.8)
ppforest2_node_h <- function() ppforest2_opt("node_h", 0.7)
ppforest2_leaf_w <- function() ppforest2_opt("leaf_w", 0.5)
ppforest2_leaf_h <- function() ppforest2_opt("leaf_h", 0.3)

# Line weights
ppforest2_lw_light  <- function() ppforest2_opt("lw_light",  0.4)
ppforest2_lw_medium <- function() ppforest2_opt("lw_medium", 0.6)

# Point sizes
ppforest2_pt_small  <- function() ppforest2_opt("pt_small",  1.2)
ppforest2_pt_medium <- function() ppforest2_opt("pt_medium", 1.8)

# Alpha values
ppforest2_alpha_region <- function() ppforest2_opt("alpha_region", 0.25)
ppforest2_alpha_hist   <- function() ppforest2_opt("alpha_hist",   0.65)
ppforest2_alpha_leaf   <- function() ppforest2_opt("alpha_leaf",   0.30)
ppforest2_alpha_proj   <- function() ppforest2_opt("alpha_proj",   0.60)

# Structural colors (not data-mapped)
ppforest2_col_edge     <- function() ppforest2_opt("col_edge",     "grey55")
ppforest2_col_border   <- function() ppforest2_opt("col_border",   "grey50")
ppforest2_col_cutpoint <- function() ppforest2_opt("col_cutpoint", "grey25")
ppforest2_col_boundary <- function() ppforest2_opt("col_boundary", "grey30")
ppforest2_col_tick     <- function() ppforest2_opt("col_tick",     "grey40")
ppforest2_col_bar      <- function() ppforest2_opt("col_bar",      "#5B8BA0")

#' Shared ggplot2 theme for all non-structure plots.
#'
#' Uses \code{theme_minimal} as a base with slightly larger titles and no
#' minor gridlines.  The tree structure plot uses \code{theme_void()}
#' instead (no axes, no grid) since it renders on an abstract 2D canvas.
#' @noRd
ppforest2_theme <- function() {
  base_size <- ppforest2_opt("base_size", 11)
  ggplot2::theme_minimal(base_size = base_size) +
  ggplot2::theme(
    plot.title       = ggplot2::element_text(size = ggplot2::rel(1.1), hjust = 0),
    plot.title.position = "plot",
    axis.title       = ggplot2::element_text(size = ggplot2::rel(0.85)),
    panel.grid.minor = ggplot2::element_blank()
  )
}

# ======================================================================
# Shared helpers
# ======================================================================

#' Extract variable names from a model.
#'
#' Prefers column names from the training matrix (model$x).  Falls back
#' to "x1", "x2", ... if column names are absent.
#'
#' @param model A pptr or pprf model with \code{$x} and optionally
#'   \code{$vi}.
#' @return Character vector of length p (number of features).
#' @noRd
get_variable_names <- function(model) {
  p <- if (!is.null(model$vi$projections)) {
    length(model$vi$projections)
  } else {
    ncol(model$x)
  }

  if (!is.null(colnames(model$x))) {
    colnames(model$x)
  } else {
    paste0("x", seq_len(p))
  }
}

#' Generate a perceptually-uniform color palette for group labels.
#'
#' Colors are evenly spaced in HCL hue space (lightness = 65, chroma = 100)
#' to ensure maximal visual distinction between groups.  Named by the
#' group label so they can be passed directly to \code{scale_fill_manual()}.
#'
#' @param classes Character vector of unique group labels.
#' @return Named character vector of hex colours, one per group.
#' @noRd
get_group_colors <- function(groups) {
  n <- length(groups)
  hues <- seq(15, 375, length.out = n + 1)[seq_len(n)]
  colors <- grDevices::hcl(h = hues, l = 65, c = 100)
  names(colors) <- groups
  colors
}

#' Equalize two ranges so both span the same distance (for square plots).
#'
#' Both ranges are expanded symmetrically about their midpoints to match
#' the larger span.  Used before \code{coord_fixed(ratio = 1)} to ensure
#' the 2D boundary plot is square without distortion.
#'
#' @param x_range Numeric vector of length 2 (x_min, x_max).
#' @param y_range Numeric vector of length 2 (y_min, y_max).
#' @return List with elements \code{$x} and \code{$y}, each a length-2
#'   numeric vector.
#' @noRd
equalize_ranges <- function(x_range, y_range) {
  x_span <- diff(x_range)
  y_span <- diff(y_range)
  max_span <- max(x_span, y_span)
  x_mid <- mean(x_range)
  y_mid <- mean(y_range)
  list(
    x = c(x_mid - max_span / 2, x_mid + max_span / 2),
    y = c(y_mid - max_span / 2, y_mid + max_span / 2)
  )
}

#' Pad a numeric range symmetrically by a fraction of its span.
#'
#' @param rng Numeric vector of length 2 (min, max).
#' @param frac Fraction of the span to add on each side (default 0.05).
#' @return Numeric vector of length 2 (padded min, padded max).
#' @noRd
pad_range <- function(rng, frac = 0.05) {
  pad <- diff(rng) * frac
  rng + c(-pad, pad)
}