R/plot_runs_on_instance.R

In thomasWeise/aitoaEvaluate: An R Package for Evaluating the aitoa Results

#' @title Plot the Progress of Several Runs one Algorithm on One Instance
#' @description Plot the progress of a set of runs of one algorithm on one instance.
#' @param results.dir the directory where the results can be loaded from
#' @param algorithm the algorithm id
#' @param instance the instance id to be plotted
#' @param time.column the time column
#' @param max.time an optional maximal time limit
#' @param run.colors a function to generate the colors for the runs
#' @param run.lty the line type to be used for the runs, can be
#'   vector
#' @param run.lwd the line width to be used for the runs, can be
#'   vector
#' @param make.time.unique should we make the time indices unique (except maybe
#'   for the first and last point)? This makes sense when we want to plot
#'   diagrams over a time axis, as we then have removed redundant points right
#'   away. If \code{make.time.unique==FALSE}, then there may be multiple
#'   improvements at the same time index due to the resolution of the computer
#'   clock (while each improvement will definitely have a unique FE).
#' @param f.must.be.improving \code{true} if the logged objective values must be
#'   strictly improving? This is the default way logs are generated by aitoa.
#'   However, you can also create a log where every single sampled solution is
#'   logged, so then you must set \code{f.must.be.improving=FALSE} to load the
#'   data.
#' @param max.runs.to.plot an optional number giving the maximum number of runs
#'   to be plotted per algorithm
#' @param legend.cex the character scaling for the legend
#' @param legend.bg the background color for the legend
#' @param time.axis.text the text to be used for labeling the time axis,
#'   \code{NA} for omit label
#' @param quality.axis.text the text to be used for labeling the quality axis,
#'   \code{NA} for omit label
#' @param mgp the mgp parameter to be passed to \link[graphics]{plot}
#' @param tck the tck parameter to be passed to \link[graphics]{plot}
#' @param cex the default character scaling
#' @param mar the default margins
#' @param ... parameters to be passed to \link[graphics]{par}
#' @include load_instance_dir.R
#' @include utils.R
#' @importFrom graphics abline legend lines mtext plot
#' @export aitoa.plot.runs.on.instance
#' @include common_styles.R
#' @include legends.R
aitoa.plot.runs.on.instance <- function(results.dir=".",
                                        algorithm,
                                        instance,
                                        time.column=c("t", "fes"),
                                        max.time=NA_integer_,
                                        run.colors=aitoa.distinct.colors,
                                        run.lty=.default.lty,
                                        run.lwd=.default.lwd,
                                        make.time.unique=FALSE,
                                        f.must.be.improving=TRUE,
                                        max.runs.to.plot=NA_integer_,
                                        legend.cex=.legend.cex,
                                        legend.bg=.legend.bg,
                                        time.axis.text=if(time.column=="t") .time.ms.text else .time.fes.text,
                                        quality.axis.text=.quality.text,
                                        mgp=.default.mgp,
                                        tck=.default.tck,
                                        cex=.default.cex,
                                        mar=.default.mar.without.labels,
                                        ...) {

  stopifnot(!is.null(results.dir),
            is.character(results.dir),
            length(results.dir) == 1L,
            !is.na(results.dir),
            !is.null(make.time.unique),
            is.logical(make.time.unique),
            length(make.time.unique) == 1L,
            isTRUE(make.time.unique) || isFALSE(make.time.unique),
            !is.null(f.must.be.improving),
            is.logical(f.must.be.improving),
            length(f.must.be.improving) == 1L,
            isTRUE(f.must.be.improving) || isFALSE(f.must.be.improving),
            !is.null(instance),
            is.character(instance),
            length(instance) == 1L,
            !is.na(instance),
            nchar(instance) > 0L,
            !is.null(algorithm),
            is.character(algorithm),
            length(algorithm) == 1L,
            !is.na(algorithm),
            nchar(algorithm) > 0L,
            is.numeric(max.time),
            is.na(max.time) || is.null(max.time) || (
              is.finite(max.time) && (max.time > 1L)
            ),
            is.function(run.colors)
            );

  time.column <- .time.column(match.arg(time.column));

  if(is.null(max.runs.to.plot)) { max.runs.to.plot <- NA_integer_; }
  stopifnot(is.integer(max.runs.to.plot),
            length(max.runs.to.plot) == 1L,
            is.na(max.runs.to.plot) || (is.finite(max.runs.to.plot) && (max.runs.to.plot>=1L)));

  results.dir <- .dir.exists(results.dir);

  if(is.null(max.time) || is.na(max.time)) {
    max.time <- NA_real_;
  }
  stopifnot(is.numeric(max.time),
            is.na(max.time) || (is.finite(max.time) && max.time > 0L));

  mgp <- .mgp(mgp, .default.mgp);
  tck <- .tck(tck, .default.tck);
  cex <- .cex(cex, .default.cex);
  mar <- .mar(mar, .default.mar.without.labels);

  old.par <- .safe.par(list(mgp=mgp,
                           tck=tck,
                           cex=cex,
                           mar=mar));

  pars <- list(...);
  log.scale.time <- !is.null(pars$log) &&
    grepl("x", pars$log, fixed=TRUE);
  stopifnot(isTRUE(log.scale.time) || isFALSE(log.scale.time));

  .logger("Now processing instance '", instance, "'.");

  dir <- .dir.exists(file.path(results.dir,
                               algorithm,
                               instance));

  data <- aitoa.load.inst.dir(dir, c(time.column, "f"),
                               make.time.unique = make.time.unique,
                               f.must.be.improving=f.must.be.improving,
                               max.runs.to.load=max.runs.to.plot);
  stopifnot(length(data) > 0L);
  if(!is.na(max.runs.to.plot)) {
    stopifnot(length(data) <= max.runs.to.plot);
  }

  lapply(data, function(frame) {
    stopifnot(nrow(frame) > 1L);
    frame <- as.matrix(frame);
    if(!is.na(max.time)) {
      stopifnot(is.finite(max.time),
                max.time > 0L);
      frame <- frame[frame[, 1L] <= max.time, ];
      stopifnot(nrow(frame) >= 1L);
      if(frame[nrow(frame), 1L] < max.time) {
        frame <- rbind(frame,
                       c(max.time, frame[nrow(frame), 2L]));
      }
    }
    if(isTRUE(log.scale.time)) {
      frame[frame[, 1L] < 1L, 1L] <- 1L;
      del <- frame[, 1L] <= 1L;
      if(sum(del) > 2) {
        del <- which(del);
        stopifnot(length(del) >= 3L);
        del <- del[-1L];
        stopifnot(length(del) >= 2L);
        del <- del[-length(del)];
        stopifnot(length(del) >= 1L);
        frame <- frame[-del, ];
      }
    }
    return(frame);
  });

  # done loading the data, now gathering ranges
  # 1. the time range is straightforward
  if(is.na(max.time)) {
    time.range <- max(vapply(data, function(dd) {
        dd[nrow(dd), 1L]
      }, NA_real_))
  } else{
    time.range <- max.time;
  }
  stopifnot(is.finite(time.range),
            time.range > 1L);
  time.range <- range(c(time.range,
                        if(isTRUE(log.scale.time) ||
                           (startsWith(time.column, "fes")))
                          1L else 0L));


  # 2. the function range is more complex
  f.range <-  range(unname(unlist(lapply(data, function(dd) {
      range(dd[, 2L])
  }))));

  # now we can set up the parameters for the plot

  if(is.null(pars$x) || all(is.na(pars$x))) {
    pars$x <- time.range;
  }
  if(is.null(pars$xlim) || all(is.na(pars$xlim))) {
    pars$xlim <- time.range;
  }
  if(is.null(pars$y) || all(is.na(pars$y))) {
    pars$y <- f.range;
  }
  if(is.null(pars$ylim) || all(is.na(pars$ylim))) {
    pars$ylim <- f.range;
  }
  if(is.null(pars$type) || all(is.na(pars$type))) {
    pars$type <- "n";
  }
  if(is.null(pars$xaxs) || all(is.na(pars$xaxs))) {
    pars$xaxs <- "i";
  }
  if(is.null(pars$yaxs) || all(is.na(pars$yaxs))) {
    pars$yaxs <- "i";
  }
  if(is.null(pars$xlab) || all(is.na(pars$xlab))) {
    pars$xlab <- NA_character_;
  }
  if(is.null(pars$ylab) || all(is.na(pars$ylab))) {
    pars$ylab <- NA_character_;
  }

  add.x.axis <- FALSE;
  if(log.scale.time && (is.null(pars$xaxt) || all(is.na(pars$xaxt)))) {
    pars$xaxt <- "n";
    add.x.axis <- TRUE;
  }

  # make the plot
  do.call(plot, pars);

  # if necessary, add an x-axis
  if(add.x.axis) {
    src <- range(pars$x);
    x.ticks <- as.integer(10L ^ seq.int(from=as.integer(ceiling(log10(src[[1L]]))),
                                        to=as.integer(floor(log10(src[[2L]])))));
    axis(side = 1L,
         at = x.ticks,
         labels = as.character(x.ticks));
  }

  run.lty <- .lty.rep(run.lty, .default.lty, length(data));
  run.lwd <- .lwd.rep(run.lwd, .default.lwd, length(data));
  run.colors <- run.colors(length(data));
  stopifnot(is.character(run.colors),
            length(run.colors) == length(data),
            !any(is.na(run.colors)),
            all(nchar(run.colors) > 0L));

  # plot the lines
  for(i in seq_along(data)) {
    lines(data[[i]],
          lty=run.lty[[i]],
          lwd=run.lwd[[i]],
          col=run.colors[[i]],
          type="s");
  }

  legend.cex <- .cex(legend.cex, .legend.cex);
  legend.bg <- .color(legend.bg, .legend.bg);

  if(!(is.null(quality.axis.text) || all(is.na(quality.axis.text)))) {
    stopifnot(is.character(quality.axis.text),
              length(quality.axis.text) == 1L,
              nchar(quality.axis.text) > 0L);
    aitoa.legend.label(x="topleft",
                       legend=quality.axis.text,
                       cex=legend.cex);
  }
  if(!(is.null(time.axis.text) || all(is.na(time.axis.text)))) {
    stopifnot(is.character(time.axis.text),
              length(time.axis.text) == 1L,
              nchar(time.axis.text) > 0L);
    aitoa.legend.label(x="bottomright",
                       legend=time.axis.text,
                       cex=legend.cex);
  }

  .safe.par(old.par);
  invisible(NULL);
}