R/ternable.R

In prefviz: Visualizes Preference Data via Ternary Plots in Two and Higher Dimensions

#' Create a ternable object
#' 
#' @description
#' Creates a ternable object, which contains observation coordinates, simplex vertices, and edges
#' necessary for building a ternary plot in both two and higher dimensions.
#' 
#' @param data A data frame containing the item (alternative) columns used to construct the ternary plot.
#' @param items <[`tidy-select`][dplyr::dplyr_tidy_select]> Columns representing the 
#'   items to be plotted as vertices of the simplex. Default is [everything()],
#'   which selects all columns. Must select at least 3 columns. All columns must be
#'   non-negative and sum to 1. 
#' @param group Optional column name indicating the grouping variable. If specified, 
#'   the data will be grouped by this variable. This is useful 
#'   for creating paths between observations within each group.
#' @param order_by Optional column name indicating the order variable. If specified, 
#'   the data will be ordered by this variable. This is useful 
#'   for creating paths between observations within each group.
#' @param decreasing Logical. If `TRUE`, paths are ordered in decreasing order
#'   of `order_by`. If `FALSE` (default), ordering is increasing.
#' @param na_method Character string specifying how to handle missing values in
#'   `order_by`. One of:
#'   * `"drop_na"` (default): drop only rows where `order_by` is `NA`;
#'   * `"drop_group"`: drop entire groups that contain any `NA` in `order_by`.
#' @param ... Additional arguments (currently unused, reserved for future extensions).
#' 
#' @return A ternable object (S3 class) containing:
#'   \item{`data`}{: The validated and normalized data frame}
#'   \item{`data_coord`}{: Transformed coordinates for all observations}
#'   \item{`data_edges`}{: Edge connections for drawing paths between observations}
#'   \item{`simplex_vertices`}{: Vertex coordinates and labels for the simplex}
#'   \item{`simplex_edges`}{: Edge connections for drawing the simplex boundary}
#'   \item{`vertex_labels`}{: Labels of the vertices, same as names of the selected item columns}
#'
#' @examples
#' 
#' # Load and transform the dataset
#' prefviz::aecdop25_transformed
#' 
#' # Create the ternable object
#' tern <- as_ternable(prefviz::aecdop25_transformed, items = ALP:IND)
#' tern
#'
#' @export
as_ternable <- function(data, 
                    items = dplyr::everything(), 
                    group = NULL, 
                    order_by = NULL, 
                    decreasing = FALSE,
                    na_method  = c("drop_na", "drop_group"),...) {
  stopifnot(is.data.frame(data))

  item_col_ind <- tidyselect::eval_select(
      rlang::enquo(items), 
      data)
  item_col_chr <- colnames(data)[item_col_ind]

  group_quo <- rlang::enquo(group)
  if (rlang::quo_is_null(group_quo)) {
    group_col_chr <- character(0)
  } else {
    group_col_ind <- tidyselect::eval_select(group_quo, data)
    group_col_chr <- colnames(data)[group_col_ind]
  }

  order_quo <- rlang::enquo(order_by)
  if (rlang::quo_is_null(order_quo)) {
    order_col_chr <- character(0)
  } else {
    order_col_ind <- tidyselect::eval_select(order_quo, data)
    order_col_chr <- colnames(data)[order_col_ind]
  }

  validate_df <- validate_ternable(data, item_col_chr)

  new_ternable(validate_df, 
    item_col_chr, 
    group_col_chr, 
    order_col_chr,
    decreasing,
    na_method,
    ...)
}

#' Validate input for ternable
#' @description
#' Internal validation function that checks compositional data requirements
#' and normalizes if necessary.
#'
#' @param data A data frame
#' @param item_col_chr Character vector of item column names
#'
#' @return The validated (and possibly normalized) data frame, invisibly
#'
#' @keywords internal
#' @noRd
validate_ternable <- function(data, item_col_chr) {
  alt_data <- data[, item_col_chr, drop = FALSE]

  # At least 3 items
  if (ncol(alt_data) < 3) {
    stop(
      "At least 3 items are required.",
      call. = FALSE
    )
  }

  # All items are numeric
  if (!all(sapply(alt_data, is.numeric))) {
    stop(
      "All item columns must be numeric.",
      call. = FALSE
    )
  }
  
  # No negative values allowed
  if (any(alt_data < 0, na.rm = TRUE)) {
    stop(
      "Item values cannot be negative.",
      call. = FALSE
    )
  }

  # Normalize if rows don't sum to 1
  row_sums <- rowSums(alt_data, na.rm = TRUE)
  tolerance <- 1e-8
  
  if (!all(abs(row_sums - 1) < tolerance)) {
    warning(
      "Not all rows sum to 1. Normalizing items automatically.",
      call. = FALSE
    )
    data[, item_col_chr] <- alt_data / row_sums
  }

  invisible(data)
}

#' Low-level constructor for ternable objects
#'
#' @description
#' Constructor that builds the ternable object after validation. 
#' Users should use [as_ternable()] instead.
#'
#' @param data A validated data frame
#' @param item_col_chr Character vector of item column names
#' @param group_col_chr Character vector of group column names
#' @param ... Additional arguments (unused for now)
#'
#' @return A ternable object
#'
#' @keywords internal
#' @noRd
new_ternable <- function(data, item_col_chr, group_col_chr, 
                        order_col_chr, decreasing, na_method,...) {
  stopifnot(is.data.frame(data))
  stopifnot(is.character(item_col_chr))
  stopifnot(is.character(group_col_chr))
  stopifnot(is.character(order_col_chr))

  # Reorder data if order_by is specified
  if (length(order_col_chr) > 0) {
    data <- ordered_path_df(data, group_col_chr, order_col_chr, decreasing, na_method)
  }

  # Get ternary coordinates of the data
  cart_df <- helmert_transform(data, items = item_col_chr)

  # Define the simplex
  simp <- geozoo::simplex(p = length(item_col_chr) - 1)
  colnames(simp$points) <- paste0("x", seq_len(ncol(simp$points)))
  simp_points <- tibble::as_tibble(simp$points)

  # Define the vertex labels
  simp_points$labels <- item_col_chr

  # Define data edges
  data_edges <- add_data_edges(data, group_col_chr)

  structure(
    list(
      data = data,
      ternary_coord = cart_df,
      data_edges = as.matrix(data_edges),
      simplex_vertices = simp_points,
      simplex_edges = as.matrix(simp$edges),
      vertex_labels = item_col_chr
    ),
    class = "ternable"
  )
}

#' Print method for ternable objects
#'
#' @param x A ternable object
#' @param ... Additional arguments passed to print methods
#'
#' @return The object, invisibly
#'
#' @keywords internal
#' @export
print.ternable <- function(x, ...) {
  cat("Ternable object\n")
  cat("----------------\n")
  cat("Items:", paste(x$vertex_labels, collapse = ", "), "\n")
  cat("Vertices:", nrow(x$simplex_vertices), "\n")
  cat("Edges:", nrow(x$simplex_edges), "\n")
  invisible(x)
}