Nothing
# 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
}
n <- min(11, ncolor)
colors <- colorRampPalette(brewer(n))(ncolor)
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,]
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.