R/cvd_palette_scores.R

In vangogh: Vincent van Gogh Colour Palette Generator

#' CVD Accessibility Scores for Van Gogh Palettes
#'
#' @description
#' Pre-computed CVD accessibility scores for all Van Gogh palettes.
#' This data is generated by running check_all_vangogh_cvd() and is included
#' for quick reference without requiring the colorspace package.
#'
#' @format A data frame with CVD accessibility metrics:
#' \describe{
#'   \item{palette}{Name of the Van Gogh palette}
#'   \item{cvd_type}{Type of colour vision deficiency}
#'   \item{min_distance}{Minimum CIELAB distance between colours (higher = more distinguishable)}
#'   \item{accessibility}{Rating: Poor, Fair, Good, or Excellent}
#'   \item{overall_rating}{Average accessibility across all CVD types}
#' }
#'
#' @details
#' Distance interpretation:
#' \itemize{
#'   \item < 10: Poor - colours may be indistinguishable
#'   \item 10-20: Fair - some difficulty distinguishing
#'   \item 20-40: Good - generally distinguishable
#'   \item > 40: Excellent - highly distinguishable
#' }
#'
#' @examples
#' \dontrun{
#' # View CVD scores
#' data(vangogh_cvd_scores)
#'
#' # Find most accessible palettes
#' palette_summary <- aggregate(
#'   min_distance ~ palette, 
#'   data = vangogh_cvd_scores, 
#'   FUN = mean
#' )
#' palette_summary[order(-palette_summary$min_distance), ]
#'
#' # Filter by CVD type
#' deutan_scores <- vangogh_cvd_scores[
#'   vangogh_cvd_scores$cvd_type == "Deuteranopia (red-green)", 
#' ]
#' deutan_scores[order(-deutan_scores$min_distance), ]
#' }
#'
#' @name vangogh_cvd_scores
"vangogh_cvd_scores"


#' Generate CVD Scores Data for Package
#'
#' @description
#' Internal function to generate the vangogh_cvd_scores dataset.
#' Run this when updating the package to refresh CVD scores.
#'
#' @return A data frame with CVD scores
#'
#' @importFrom stats aggregate
#' @keywords internal
generate_cvd_scores_data <- function() {
  
  # This function should be run during package development
  # to generate the vangogh_cvd_scores.rda file
  
  if (!requireNamespace("colorspace", quietly = TRUE)) {
    stop("colorspace package required to generate CVD scores")
  }
  
  vangogh_cvd_scores <- check_all_vangogh_cvd(simulate = FALSE)
  
  # Add overall rating using base R
  palette_means <- stats::aggregate(
    min_distance ~ palette, 
    data = vangogh_cvd_scores, 
    FUN = mean
  )
  
  # Classify overall rating
  palette_means$overall_rating <- ifelse(
    palette_means$min_distance < 10, "Poor",
    ifelse(palette_means$min_distance < 15, "Fair",
           ifelse(palette_means$min_distance < 25, "Good", "Excellent")
    )
  )
  
  # Merge back to main data
  vangogh_cvd_scores <- merge(
    vangogh_cvd_scores, 
    palette_means[, c("palette", "overall_rating")], 
    by = "palette"
  )
  
  # Save to package data directory
  if (!dir.exists("data")) {
    dir.create("data")
  }
  
  save(vangogh_cvd_scores, file = "data/vangogh_cvd_scores.rda", compress = "bzip2")
  
  cat("\nvangogh_cvd_scores.rda created successfully!\n")
  cat("Location: data/vangogh_cvd_scores.rda\n")
  
  return(vangogh_cvd_scores)
}


#' Add CVD Information to Palette Documentation
#'
#' @description
#' Helper function to add CVD accessibility information to your
#' existing palette information functions.
#'
#' @param palette_name Character string specifying the palette name
#'
#' @return List with palette info and CVD scores
#'
#' @importFrom utils data
#' @examples
#' \dontrun{
#' # Get enhanced palette info with CVD data
#' info <- vangogh_palette_info_with_cvd("StarryNight")
#' print(info$cvd_accessibility$summary)
#' }
#'
#' @export
vangogh_palette_info_with_cvd <- function(palette_name) {
  
  # Start with basic info
  info <- list(name = palette_name)
  
  # Try to get existing palette info if function exists
  if (exists("vangogh_palette_info")) {
    tryCatch({
      existing_info <- vangogh_palette_info(palette_name)
      info <- c(info, existing_info)
    }, error = function(e) {
      # Silently continue if function fails
    })
  }
  
  # Try to load CVD scores data
  cvd_data <- tryCatch({
    # First try to load from package data
    utils::data("vangogh_cvd_scores", envir = environment(), package = "vangogh")
    get("vangogh_cvd_scores", envir = environment())
  }, error = function(e) {
    NULL
  })
  
  if (!is.null(cvd_data)) {
    cvd_info <- cvd_data[cvd_data$palette == palette_name, ]
    
    if (nrow(cvd_info) > 0) {
      info$cvd_accessibility <- list(
        scores = cvd_info,
        overall_rating = unique(cvd_info$overall_rating),
        summary = paste0(
          "Overall CVD accessibility: ", unique(cvd_info$overall_rating),
          "\nAverage distance: ", round(mean(cvd_info$min_distance), 1)
        )
      )
    }
  } else {
    # If data not available, try to calculate on the fly
    if (requireNamespace("colorspace", quietly = TRUE)) {
      cvd_info <- check_vangogh_cvd(
        palette_name, 
        simulate = FALSE, 
        return_scores = TRUE
      )
      info$cvd_accessibility <- list(
        scores = cvd_info,
        summary = paste0("Average distance: ", round(mean(cvd_info$min_distance), 1))
      )
    } else {
      info$cvd_accessibility <- "Install 'colorspace' package for CVD accessibility info"
    }
  }
  
  return(info)
}


#' Print CVD Badge for README
#'
#' @description
#' Generates markdown badges for palette CVD accessibility ratings.
#' Useful for including in README or documentation.
#'
#' @param palette_name Character string specifying the palette name
#'
#' @return Character string with markdown badge code
#'
#' @importFrom utils data
#' @examples
#' \dontrun{
#' # Generate badge for StarryNight
#' print_cvd_badge("StarryNight")
#' 
#' # Generate badges for all palettes
#' for (p in names(vangogh_palettes)) {
#'   cat(p, ": ")
#'   print_cvd_badge(p)
#' }
#' }
#'
#' @export
print_cvd_badge <- function(palette_name) {
  
  # Try to load data if not in environment
  vangogh_cvd_scores <- NULL  # Initialize
  if (!exists("vangogh_cvd_scores", envir = .GlobalEnv)) {
    tryCatch({
      utils::data("vangogh_cvd_scores", envir = environment())
    }, error = function(e) {
      return("Data not available - run generate_cvd_scores_data() first")
    })
  } else {
    vangogh_cvd_scores <- get("vangogh_cvd_scores", envir = .GlobalEnv)
  }
  
  if (is.null(vangogh_cvd_scores)) {
    cat("Data not available\n")
    return(invisible(NULL))
  }
  
  cvd_info <- vangogh_cvd_scores[vangogh_cvd_scores$palette == palette_name, ]
  
  if (nrow(cvd_info) == 0) {
    cat(paste0("No CVD data found for ", palette_name, "\n"))
    return(invisible(NULL))
  }
  
  rating <- unique(cvd_info$overall_rating)
  avg_dist <- round(mean(cvd_info$min_distance), 1)
  
  # Color for badge based on rating
  badge_color <- if (rating == "Excellent") {
    "brightgreen"
  } else if (rating == "Good") {
    "green"
  } else if (rating == "Fair") {
    "yellow"
  } else {
    "red"
  }
  
  badge <- paste0(
    "![CVD Accessible](https://img.shields.io/badge/CVD_Accessible-",
    rating, "-", badge_color, ")"
  )
  
  cat(badge, "\n")
  return(invisible(badge))
}


#' Summarize CVD Accessibility Across All Palettes
#'
#' @description
#' Creates a summary table of CVD accessibility for all palettes,
#' useful for documentation and choosing palettes.
#'
#' @return A data frame with palette names and overall CVD metrics
#'
#' @importFrom stats aggregate
#' @importFrom utils data
#' @examples
#' \dontrun{
#' summary <- summarize_cvd_accessibility()
#' print(summary)
#' 
#' # Find best palettes
#' best <- summary[summary$overall_rating == "Excellent", ]
#' print(best)
#' }
#'
#' @export
summarize_cvd_accessibility <- function() {
  
  # Load data if needed
  vangogh_cvd_scores <- NULL  # Initialize
  if (!exists("vangogh_cvd_scores", envir = .GlobalEnv)) {
    tryCatch({
      utils::data("vangogh_cvd_scores", envir = environment())
    }, error = function(e) {
      stop("CVD scores data not found. Run generate_cvd_scores_data() first.")
    })
  } else {
    vangogh_cvd_scores <- get("vangogh_cvd_scores", envir = .GlobalEnv)
  }
  
  if (is.null(vangogh_cvd_scores)) {
    stop("CVD scores data not found. Run generate_cvd_scores_data() first.")
  }
  
  # Aggregate by palette
  summary <- stats::aggregate(
    min_distance ~ palette, 
    data = vangogh_cvd_scores, 
    FUN = function(x) c(
      mean = mean(x),
      min = min(x),
      max = max(x)
    )
  )
  
  # Unpack the matrix column
  summary_df <- data.frame(
    palette = summary$palette,
    avg_distance = summary$min_distance[, "mean"],
    min_distance = summary$min_distance[, "min"],
    max_distance = summary$min_distance[, "max"]
  )
  
  # Add overall rating
  summary_df$overall_rating <- unique(vangogh_cvd_scores$overall_rating)[
    match(summary_df$palette, unique(vangogh_cvd_scores$palette))
  ]
  
  # Sort by average distance
  summary_df <- summary_df[order(-summary_df$avg_distance), ]
  rownames(summary_df) <- NULL
  
  return(summary_df)
}