R/plot.R

In IOHprofiler/IOHanalyzer: Data Analysis Part of 'IOHprofiler'

# font No. 1...
f1 <- list(family = 'Old Standard TT, serif',
           size = 11,
           color = 'black')

# font No. 2...
f2 <- list(family = 'Old Standard TT, serif',
           size = 13,
           color = 'black')

# font No. 3...
f3 <- function() {
  list(
    family = 'Old Standard TT, serif',
    size = getOption("IOHanalyzer.tick_fontsize", default = 12),
    color = 'black'
  )
}

legend_right <- function() {
  list(
    x = 1.01,
    y = 1,
    orientation = 'v',
    font = list(
      size = getOption("IOHanalyzer.legend_fontsize", default = 18),
      family = 'Old Standard TT, serif'
    )
  )
}

legend_inside <- function() {
  list(
    x = .01,
    y = 1,
    orientation = 'v',
    bgcolor = 'rgba(255, 255, 255, 0)',
    bordercolor = 'rgba(255, 255, 255, 0)',
    font = list(
      size = getOption("IOHanalyzer.legend_fontsize", default = 18),
      family = 'Old Standard TT, serif'
    )
  )
}

legend_inside2 <- function() {
  list(
    x = 0.7,
    y = 0.1,
    orientation = 'v',
    bgcolor = 'rgba(255, 255, 255, 0.5)',
    bordercolor = 'rgba(255, 255, 255, 0.8)',
    font = list(
      size = getOption("IOHanalyzer.legend_fontsize", default = 18),
      family = 'Old Standard TT, serif'
    )
  )
}

#TODO: Make the y-value configurable
legend_below <- function() {
  list(
    y = -0.2,
    orientation = 'h',
    font = list(
      size = getOption("IOHanalyzer.legend_fontsize", default = 18),
      family = 'Old Standard TT, serif'
    )
  )
}

legend_custom <- function() {
  list(
    x = getOption("IOHanalyzer.custom_legend_x", default = 0.5),
    y = getOption("IOHanalyzer.custom_legend_y", default = -0.2),
    orientation = 'h',
    font = list(
      size = getOption("IOHanalyzer.legend_fontsize", default = 18),
      family = 'Old Standard TT, serif'
    )
  )
}


legend_location <- function() {
  opt <- getOption('IOHanalyzer.legend_location', default = 'below')
  if (opt == 'outside_right')
    return(legend_right())
  else if (opt == 'inside_left')
    return(legend_inside())
  else if (opt == 'inside_right')
    return(legend_inside2())
  else if (opt == 'below')
    return(legend_below())
  else if (opt == 'custom')
    return(legend_custom())
  # else if (opt == 'below2') return(legend_below2())
  else
    warning(paste0("The selected legend option (", opt, ") is not implemented"))
}

# TODO: create font object as above for title, axis...

#' Template for creating plots in the IOHanalyzer-style
#'
#' @param title Title for the plot
#' @param x.title X-axis label
#' @param y.title Y-axis label
#'
#' @export
#' @examples
#' IOH_plot_ly_default("Example plot","x-axis","y-axis")
IOH_plot_ly_default <-
  function(title = NULL,
           x.title = NULL,
           y.title = NULL) {
    plot_ly() %>%
      layout(
        title = list(
          text = title,
          font = list(
            size = getOption("IOHanalyzer.title_fontsize", default = 16),
            family = 'Old Standard TT, serif'
          )
        ),
        autosize = T,
        hovermode = 'compare',
        legend = legend_location(),
        paper_bgcolor = 'rgb(255,255,255)',
        plot_bgcolor = getOption('IOHanalyzer.bgcolor'),
        font = list(
          size = getOption("IOHanalyzer.label_fontsize", default = 16),
          family = 'Old Standard TT, serif'
        ),
        autosize = T,
        showlegend = T,
        xaxis = list(
          # title = list(text = x.title, font = f3),
          title = x.title,
          gridcolor = getOption('IOHanalyzer.gridcolor'),
          showgrid = TRUE,
          showline = FALSE,
          showticklabels = TRUE,
          tickcolor = getOption('IOHanalyzer.tickcolor'),
          ticks = 'outside',
          ticklen = 9,
          tickfont = f3(),
          exponentformat = 'e',
          zeroline = F
        ),
        yaxis = list(
          # title = list(text = y.title, font = f3),
          title = y.title,
          gridcolor = getOption('IOHanalyzer.gridcolor'),
          showgrid = TRUE,
          showline = FALSE,
          showticklabels = TRUE,
          tickcolor = getOption('IOHanalyzer.tickcolor'),
          ticks = 'outside',
          ticklen = 9,
          tickfont = f3(),
          exponentformat = 'e',
          zeroline = F
        )
      )
  }

t <- theme_grey() +
  theme(text = element_text(size = 15),
        plot.title = element_text(hjust = 0.5))



theme_set(t)

gg_beanplot <-
  function(mapping,
           data,
           p = NULL,
           width = 3,
           fill = 'grey',
           colour = 'grey',
           alpha = 1,
           kernel = 'gaussian',
           bw = 'SJ',
           draw_quantiles = NULL,
           trim = TRUE,
           na.rm = FALSE,
           show.legend = NA,
           point.shape = 20,
           show.sample = T,
           show.violin = T,
           linetype = 'solid') {
    set.seed(42)
    x <- as.character(mapping$x)
    y <- as.character(mapping$y)
    df <-
      data[, c(x, y)] %>% rename_(.dots = c('x' = x, 'y' = y))

    if (!is.numeric(df$x))
      df$x <- tryCatch(
        as.numeric(df$x),
        # in case x is a factor...
        warning = function(w)
          return(match(x, as.factor(x)))
      )

    if (is.null(p))
      p <- ggplot()

    if (show.violin)
      p <-
      p + geom_violin(
        data = data,
        mapping = mapping,
        trim = trim,
        draw_quantiles = draw_quantiles,
        bw = bw,
        kernel = kernel,
        scale = 'width',
        width = width,
        alpha = alpha
      )
    if (show.sample)
      p <-
      p + geom_jitter(
        data = df,
        aes(x, y),
        height = 0,
        width = width / 2,
        alpha = 0.45,
        shape = point.shape,
        size = 3.5
      )
    # geom_segment(aes(x = x - width / 2.2, xend = x + width / 2.2, y = y, yend = y),
    #              df, col = 'black', size = 0.2, alpha = 0.3, linetype = linetype)
    p
  }


Set1 <-
  function(n)
    colorspace::sequential_hcl(
      n,
      h = c(360, 40),
      c. = c(100, NA, 90),
      l = c(28, 90),
      power = c(1, 1.1),
      gamma = NULL,
      fixup = TRUE,
      alpha = 1
    )#, palette = NULL, rev = FALSE)

Set2 <-
  function(n)
    colorspace::sequential_hcl(
      n,
      c(261, 26),
      c. = c(50, NA, 70),
      l = c(54, 77),
      power = c(0.5, NA),
      gamma = NULL,
      fixup = TRUE,
      alpha = 1
    )#, palette = NULL, rev = FALSE)

Set3 <-
  function(n)
    colorspace::sequential_hcl(
      n,
      c(-88, 59),
      c. = c(60, 75, 55),
      l = c(40, 90),
      power = c(0.1, 1.2),
      gamma = NULL,
      fixup = TRUE,
      alpha = 1
    )#, palette = NULL, rev = FALSE)

IOHanalyzer_env$used_colorscheme <- Set2
IOHanalyzer_env$id_colors <- NULL

#' Set the colorScheme of the IOHanalyzer plots
#'
#' @param schemename Three default colorschemes are implemented:
#' \itemize{
#' \item Default
#' \item Variant 1
#' \item Variant 2
#' \item Variant 3
#' }
#' And it is also possible to select "Custom", which allows uploading of a custom set of colors
#' @param ids The names of the algorithms (or custom ids, see `change_id`) for which to set the colors
#' @param path The path to the file containing the colors to use. Only used if
#' schemename is "Custom"
#'
#' @export
#'
#' @examples
#' set_color_scheme("Default", get_algId(dsl))
set_color_scheme <- function(schemename, ids, path = NULL) {
  if (schemename == "Custom" && !is.null(path)) {
    dt <- fread(path, header = T)
    if (any(colnames(dt) != c("ids", "colors", "linestyles"))) {
      warning("Incorrect file-format has been uploaded.")
    }
    else{
      dt <- setorder(as.data.table(dt), cols = 'ids')
      IOHanalyzer_env$id_colors <- dt
    }
    return()
  }
  else {
    if (schemename == "Default") {
      options(IOHanalyzer.max_colors = 2)
    }
    else {
      if (schemename == "Variant 1")
        IOHanalyzer_env$used_colorscheme <- Set1
      else if (schemename == "Variant 2")
        IOHanalyzer_env$used_colorscheme <- Set2
      else if (schemename == "Variant 3")
        IOHanalyzer_env$used_colorscheme <- Set3
      options(IOHanalyzer.max_colors = length(ids))
    }
    create_color_scheme(ids)
  }
}

#' Get datatable of current color (and linestyle) scheme to file
#'
#' @return data.table object with 3 columns: ids, colors, linestyles
#' @export
#' @examples
#' get_color_scheme_dt()
get_color_scheme_dt <- function() {
  return(IOHanalyzer_env$id_colors)
}

#' Helper function to create default color scheme
#'
#' @noRd
create_color_scheme <- function(ids) {
  if (length(ids) == 0) {
    return(NULL)
  }
  ids <- sort(ids, method = 'radix')
  colors <- color_palettes(length(ids))
  linestyles <-
    rep(c("solid", "dash", "dot"), ceiling(length(colors) / 3))[1:length(colors)]
  IOHanalyzer_env$id_colors <-
    data.table(ids, colors, linestyles)
}

#' Get colors according to the current colorScheme of the IOHanalyzer
#'
#' @param ids_in List of algorithms (or custom ids, see `change_id`) for which to get colors
#'
#' @export
#'
#' @examples
#' get_color_scheme(get_algId(dsl))
get_color_scheme <- function(ids_in) {
  ids_in <- sort(ids_in, method = 'radix')
  if (is.null(IOHanalyzer_env$id_colors))
    create_color_scheme(ids_in)
  cdt <- IOHanalyzer_env$id_colors
  colors <- subset(cdt, ids %in% ids_in)[['colors']]
  if (is.null(colors) || length(colors) != length(ids_in)) {
    return(color_palettes(length(ids_in)))
  }
  names(colors) <- ids_in
  return(colors)
}


#' Get line styles according to the current styleScheme of the IOHanalyzer
#'
#' @param ids_in List of algorithms (or custom ids, see `change_id`) for which to get linestyles
#'
#' @export
#'
#' @examples
#' get_line_style(get_algId(dsl))
get_line_style <- function(ids_in) {
  ids_in <- sort(ids_in, method = 'radix')
  if (is.null(IOHanalyzer_env$id_colors))
    create_color_scheme(ids_in)
  cdt <- IOHanalyzer_env$id_colors
  linestyles <- subset(cdt, ids %in% ids_in)[['linestyles']]
  if (is.null(linestyles) ||
      length(linestyles) != length(ids_in)) {
    return(rep(
      c(
        "solid",
        "dot",
        "dash",
        "longdash",
        "dashdot",
        "longdashdot"
      ),
      ceiling(length(ids_in) / 3)
    )[1:length(ids_in)])
  }
  return(linestyles)
}

# TODO: incoporate more colors
color_palettes <- function(ncolor) {
  # TODO: FIX IT!
  max_colors <- getOption("IOHanalyzer.max_colors", 2)
  if (ncolor <= max_colors)
    return(IOHanalyzer_env$used_colorscheme(ncolor))

  brewer <- function(n) {
    colors <- RColorBrewer::brewer.pal(n, 'Spectral')
    colors[colors == "#FFFFBF"] <- "#B2B285"
    colors[colors == "#E6F598"] <- "#86FF33"
    colors[colors == '#FEE08B'] <- "#FFFF33"
    colors
  }

  color_fcts <-
    c(colorRamps::primary.colors,
      IOHanalyzer_env$used_colorscheme)

  n <- min(11, ncolor)
  colors <- brewer(n)
  ncolor <- ncolor - n

  i <- 1
  while (ncolor > 0) {
    n <- min(8, ncolor)
    if (i > length(color_fcts)) {
      colors <- c(colors, colorRamps::primary.colors(ncolor))
      break
    } else {
      colors <- c(colors, color_fcts[[i]](n))
      ncolor <- ncolor - n
    }
    i <- i + 1
  }
  colors
}

#' Save plotly figure in multiple format
#'
#' NOTE: This function requires orca to be installed
#'
#' @param p plotly object. The plot to be saved
#' @param file String. The name of the figure file, with the extension of the required file-format
#' @param width Optional. Width of the figure
#' @param height Optional. Height of the figure
#' @param ... Additional arguments for orca
#' @export
#' @examples
#' \dontrun{
#' p <- Plot.RT.Single_Func(dsl[1])
#' save_plotly(p, 'example_file.png')
#' }
save_plotly <- function(p,
                        file,
                        width = NULL,
                        height = NULL,
                        ...) {
  if (!requireNamespace("withr", quietly = TRUE)) {
    stop("Package \"withr\" needed for this function to work. Please install it.",
         call. = FALSE)
  }



  des <- dirname(file)
  file <- basename(file)

  pwd <- tempdir()
  if (is.null(width))
    width <-
    getOption("IOHanalyzer.figure_width", default = NULL)
  if (is.null(height))
    height <-
    getOption("IOHanalyzer.figure_height", default = NULL)

  use_kaleido <- T

  if (!requireNamespace("reticulate", quietly = TRUE)) {
    use_kaleido <- F
  }

  if (use_kaleido) {
    use_kaleido <- reticulate::py_module_available('kaleido')
  }

  if (use_kaleido) {
    reticulate::py_run_string("import sys")
    withr::with_dir(pwd, save_image(p, file, width = width, height = height, ...))
  } else {
    tryCatch({
      more_args <- NULL
      format <- tools::file_ext(file)

      if (!getOption("IOHanalyzer.orca_use_gpu", TRUE)) {
        more_args <- c('--disable-gpu')
      }

      if (format %in% c('svg', 'png', 'jpeg', 'webp', 'pdf', 'eps'))
        withr::with_dir(
          pwd,
          orca(
            p,
            file,
            format = format,
            width = width,
            height = height,
            more_args = more_args,
            ...
          )
        )
      else {
        file_svg <- paste0(file, '.svg')
        withr::with_dir(
          pwd,
          orca(
            p,
            file_svg,
            format = 'svg',
            width = width,
            height = height,
            more_args = more_args,
            ...
          )
        )
        invisible(system(paste(
          'inkscape',
          file.path(pwd, file_svg),
          paste0('--export-', format, ' ', file.path(pwd, file))
        ),
        intern = T))
      }
    }, error = function(e) {
      stop("Image saving failed. Please ensure that either kaleido or orca is available.")
    })
  }

  file.rename(file.path(pwd, file), file.path(des, file))
}

#' Helper function from 'eaf' package
#'
#' @noRd
add.extremes <- function(x, extremes, maximise)
{
  best1 <- if (maximise[1])
    max
  else
    min
  best2 <- if (maximise[2])
    max
  else
    min
  rbind(c(best1(x[, 1]), extremes[2]), x, c(extremes[1], best2(x[, 2])))
}

#' Helper function from 'eaf' package
#'
#' @noRd
points.steps <- function(x)
{
  n <- nrow(x)
  if (n == 1L)
    return(x)
  x <-
    rbind(x, cbind(x = x[-1L, 1L, drop = FALSE], y = x[-n, 2L, drop = FALSE]))
  idx <- c(as.vector(outer(c(0L, n), 1L:(n - 1L), "+")), n)
  stopifnot(length(idx) == nrow(x))
  stopifnot(!anyDuplicated(idx))
  x[idx,]
}