R/ablation_plot.R

In auto-optimization/iraceplot: Plots for Visualizing the Data Produced by the 'irace' Package

#' Create plot from an ablation log
#'
#' @param ablog (`list()`|`character(1)`) Ablation log object returned by [irace::ablation()]. Alternatively, the path to an `.Rdata` file, e.g., `"log-ablation.Rdata"`, from which the object will be loaded.
#' @param type Type of plot. Supported values are `"mean"` and `"boxplot"`. Adding `"rank"` will plot rank per instance instead of raw cost value.
#' @param n (`integer(1)`) Number of steps included in the plot. By default all steps from source to target are included.
#' @param ylab Label of y-axis.
#' @param ylim Numeric vector of length 2 giving the y-axis range. 
#' @param rotate_labs (`logical(1)`) Whether to rotate labels in x-axis. They are rotated by default because they are typically large.
#' @template arg_filename
#' 
#' @template ret_boxplot
#' @author Manuel López-Ibáñez
#' @seealso [irace::ablation()], [irace::plotAblation()]
#' @examples
#' ablog <- read_ablogfile(system.file(package="irace", "exdata", "log-ablation.Rdata"))
#' ablation_plot(ablog)
#' ablation_plot(ablog, type="boxplot", rotate_labs = FALSE)
#' ablation_plot(ablog, type="mean,boxplot", rotate_labs = FALSE)
#' ablation_plot(ablog, type="rank,mean,boxplot", n = 4, rotate_labs = FALSE)
#' ablog <- system.file(package="iraceplot", "exdata", "log-ablation-autoMOPSODTLZ.Rdata")
#' ablation_plot(ablog, type="rank,mean,boxplot")
#' @export
ablation_plot <- function(ablog,
                          type = c("mean", "boxplot", "rank"), n = 0L,
                          ylab = "Mean configuration cost", ylim = NULL,
                          rotate_labs = TRUE, filename = NULL)
{
  type <- trimws(unlist(strsplit(type, ",", fixed=TRUE)))
  type <- match.arg(type, several.ok = TRUE)
  if (missing(ylab) && ("rank" %in% type)) ylab <- "Rank per instance"
  
  if (missing(ablog) || is.null(ablog)) {
    cli_abort("You must provide an {.arg ablog} object generated by {.fun irace::ablation} or the path to the {.file .Rdata} file that contains this object.")
  }
  ablog <- read_ablogfile(ablog)
  if (!ablog$complete)
    cli_abort("The ablog shows that the ablation procedure did not complete cleanly and only contains partial information.")

  trajectory <- ablog$trajectory
  if (n > 0) trajectory <- trajectory[1:(n+1)]
  configurations <- ablog$configurations
  labels <- ablation_labels(trajectory, configurations)
  experiments <- ablog$experiments
  ylim <- NULL
  if ("rank" %in% type) {
    experiments <- matrixStats::rowRanks(experiments, ties.method = "average")
    if (is.null(ylim)) ylim <- c(1L, ncol(experiments))
  }
  experiments <- experiments[,trajectory]
  colnames(experiments) <- trajectory
  means <- matrixStats::colMeans2(experiments)

  data <- experiments %>%
    as.data.frame() %>%
    tidyr::gather("Configuration", "Value")

  p <- ggplot(data, aes(factor(.data$Configuration, levels = trajectory), .data$Value))
  if ("mean" %in% type) {
    p <- p +
      # FIXME: Doesn't look that nice
      #geom_hline(yintercept = means, col = "lightgray", linetype = "dashed") +
      stat_summary(aes(group="Configuration"), fun=mean, geom="line")
  }
  if ("boxplot" %in% type)
    p <- p + geom_boxplot(outlier.fill = NA)
  if ("mean" %in% type)
    p <- p + stat_summary(fun=mean, geom="point", fill="black", shape=23, size=3)

  p <- p + coord_cartesian(ylim = ylim) +
    scale_y_continuous(name = ylab) + 
    scale_x_discrete(name = NULL, labels = labels, guide = guide_axis(angle = if (rotate_labs) 90 else 0))

  # If the value in filename is added the pdf file is created
  if (!is.null(filename)) ggsave(filename, plot = p)
  p
}

ablation_labels <- function(trajectory, configurations)
{
  configurations <- irace::removeConfigurationsMetaData(configurations[trajectory, , drop = FALSE])
  labels <- names(trajectory)
  last <- configurations[1, , drop = FALSE]
  param.names <- colnames(last)
  for (i in 2:length(trajectory)) {
    current <- configurations[i, , drop = FALSE]
    # Select everything that is NOT NA now and was different or NA before.
    select <- !is.na(current) & (is.na(last) | (current != last))
    stopifnot(!anyNA(select))
    labels[i] <- paste0(param.names[select], "=", current[, select], collapse = "\n")
    last <- current
  }
  labels
}