symbols <-
c(
"circle-open",
"diamond-open",
"square-open",
"cross-open",
"triangle-up-open",
"triangle-down-open"
)
get_legends <- function(dsList) {
N <- length(dsList)
legends <- sapply(dsList, function(d)
get_id(d))
if (length(unique(legends)) < N) {
funcId <- sapply(dsList, function(d)
attr(d, 'funcId'))
if (length(unique(funcId)) > 1)
legends <- paste0(legends, '-F', funcId)
}
if (length(unique(legends)) < N) {
DIM <- sapply(dsList, function(d)
attr(d, 'DIM'))
if (length(unique(DIM)) > 1)
legends <- paste0(legends, '-', DIM, 'D')
}
legends
}
insert_best_parts <- function(from_data, to_data, best_is_min) {
if (all(is.na(from_data)))
to_data
else
if (best_is_min)
pmin(from_data, to_data, na.rm = T)
else
pmax(from_data, to_data, na.rm = T)
}
generate_rbga <- function(color, a) {
paste0('rgba(', paste0(color, collapse = ','), ',', a, ')')
}
grad_functions <- c(
scaled_edges = function(count, amount, intensity) {
scale <- (intensity + 1) / 2
color_end <- floor(scale * amount * 2)
if (count < color_end)
1 / color_end
else
0
}
,
fixed_edges = function(count, amount, intensity) {
scale <- (intensity + 1) / 2
color_center <- floor(scale * amount) + 1
if (count <= color_center)
1 / (2 * color_center)
else
1 / (2 * (amount - color_center))
}
)
#S3 generics
# TODO: decide which parameters need to be in the generics
#' Plot lineplot of the ERTs of a DataSetList
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param Fstart The starting function value.
#' @param Fstop The final function value.
#' @param show.ERT Whether or not to show the ERT-values
#' @param show.CI Whether or not to show the standard deviations
#' @param show.mean Whether or not to show the mean hitting times
#' @param show.median Whether or not to show the median hitting times
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param scale.reverse Wheter or not to reverse the x-axis (when using minimization)
#' @param backend Which plotting library to use. Can be 'plotly' or 'ggplot2'
#' @param includeOpts Whether or not to include all best points reached by each algorithm
#' @param p Existing plot to which to add the current data
#' @return A plot of ERT-values of the DataSetList
#' @export
#' @examples
#' Plot.RT.Single_Func(subset(dsl, funcId == 1))
Plot.RT.Single_Func <- function(dsList,
Fstart = NULL,
Fstop = NULL,
show.ERT = T,
show.CI = F,
show.mean = F,
show.median = F,
backend = NULL,
scale.xlog = F,
scale.ylog = F,
scale.reverse = F,
includeOpts = F,
p = NULL)
UseMethod("Plot.RT.Single_Func", dsList)
#' Plot lineplot of the expected function values of a DataSetList
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param RTstart The starting runtime value.
#' @param RTstop The final runtime value.
#' @param show.CI Whether or not to show the standard deviations
#' @param show.mean Whether or not to show the mean runtimes
#' @param show.median Whether or not to show the median runtimes
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param scale.reverse Wheter or not to reverse the x-axis (when using minimization)
#' @param backend Which plotting library to use. Can be 'plotly' or 'ggplot2'
#'
#' @return A plot of ERT-values of the DataSetList
#' @export
#' @examples
#' Plot.FV.Single_Func(subset(dsl, funcId == 1))
Plot.FV.Single_Func <-
function(dsList,
RTstart = NULL,
RTstop = NULL,
show.CI = F,
show.mean = T,
show.median = F,
backend = NULL,
scale.xlog = F,
scale.ylog = F,
scale.reverse = F)
UseMethod("Plot.FV.Single_Func", dsList)
#' Plot probablity mass function of the runtimes of a DataSetList at a certain target function value
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param ftarget The target function value.
#' @param show.sample Whether or not to show the individual runtime samples
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param backend Which plotting library to use. Can be 'plotly' or 'ggplot2'
#'
#' @return A plot of the probablity mass function of the runtimes at a the
#' target function value of the DataSetList
#' @export
#' @examples
#' Plot.RT.PMF(subset(dsl, funcId == 1), 14)
Plot.RT.PMF <-
function(dsList,
ftarget,
show.sample = F,
scale.ylog = F,
backend = NULL)
UseMethod("Plot.RT.PMF", dsList)
#' Plot histograms of the runtimes of a DataSetList at a certain target function value
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param ftarget The target function value.
#' @param plot_mode How to plot the different hisograms for each algorithm. Can be either
#' 'overlay' to show all algorithms on one plot, or 'subplot' to have one plot per algorithm.
#' @param use.equal.bins Whether to determine one bin size for all plots or have individual
#' bin sizes for each algorithm
#'
#' @return A plot of the histograms of the runtimes at a the
#' target function value of the DataSetList
#' @export
#' @examples
#' Plot.RT.Histogram(subset(dsl, funcId == 1), 14)
Plot.RT.Histogram <-
function(dsList,
ftarget,
plot_mode = 'overlay',
use.equal.bins = F)
UseMethod("Plot.RT.Histogram", dsList)
#' Plot the empirical cumulative distriburtion as a function of the running times of
#' a DataSetList at certain target function values
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param ftargets The target function values
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#'
#' @return A plot of the empirical cumulative distriburtion as a function of
#' the running times of the DataSetList at the target function values
#' @export
#' @examples
#' \dontshow{data.table::setDTthreads(1)}
#' Plot.RT.ECDF_Per_Target(subset(dsl, funcId == 1), 14)
Plot.RT.ECDF_Per_Target <-
function(dsList, ftargets, scale.xlog = F)
UseMethod("Plot.RT.ECDF_Per_Target", dsList)
#' Plot the aggregated empirical cumulative distriburtion as a function of the running times of
#' a DataSetList.
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param fstart The starting function value
#' @param fstop The final function value
#' @param fstep The spacing between starting and final function values
#' @param show.per_target Whether or not to show the individual ECDF-curves for each target
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#'
#' @return A plot of the empirical cumulative distriburtion as a function of
#' the running times of the DataSetList
#' @export
#' @examples
#' \dontshow{data.table::setDTthreads(1)}
#' Plot.RT.ECDF_Single_Func(subset(dsl, funcId == 1))
Plot.RT.ECDF_Single_Func <-
function(dsList,
fstart = NULL,
fstop = NULL,
fstep = NULL,
show.per_target = F,
scale.xlog = F)
UseMethod("Plot.RT.ECDF_Single_Func", dsList)
#' Radarplot of the area under the aggregated ECDF-curve of a DataSetList.
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param fstart The starting function value
#' @param fstop The final function value
#' @param fstep The spacing between starting and final function values
#' @param fval_formatter Function to format the function-value labels
#'
#' @return A radarplot of the area under the aggregated ECDF-curve of the DataSetList
#' @export
#' @examples
#' \dontshow{data.table::setDTthreads(1)}
#' Plot.RT.ECDF_AUC(subset(dsl, funcId == 1))
Plot.RT.ECDF_AUC <- function(dsList,
fstart = NULL,
fstop = NULL,
fstep = NULL,
fval_formatter = as.integer)
UseMethod("Plot.RT.ECDF_AUC", dsList)
#' Plot probablity density function of the function values of a DataSetList at
#' a certain target runtime
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param runtime The target runtime
#' @param show.sample Whether or not to show the individual function value samples
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#'
#' @return A plot of the probablity density function of the runtimes at a the
#' target function value of the DataSetList
#' @export
#' @examples
#' Plot.FV.PDF(subset(dsl, funcId == 1), 100)
Plot.FV.PDF <-
function(dsList,
runtime,
show.sample = F,
scale.ylog = F)
UseMethod("Plot.FV.PDF", dsList)
#' Plot histograms of the function values of a DataSetList at a certain target runtime
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param runtime The target runtime
#' @param plot_mode How to plot the different hisograms for each algorithm. Can be either
#' 'overlay' to show all algorithms on one plot, or 'subplot' to have one plot per algorithm.
#' @param use.equal.bins Whether to determine one bin size for all plots or have individual
#' bin sizes for each algorithm
#'
#' @return A plot of the histograms of the function values at a the
#' target runtime of the DataSetList
#' @export
#' @examples
#' Plot.FV.Histogram(subset(dsl, funcId == 1), 100)
Plot.FV.Histogram <-
function(dsList,
runtime,
plot_mode = 'overlay',
use.equal.bins = F)
UseMethod("Plot.FV.Histogram", dsList)
#' Plot the empirical cumulative distriburtion as a function of the target values of
#' a DataSetList at certain target runtimes
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param runtimes The target runtimes
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.reverse Whether or not to reverse the x-axis (when using minimization)
#'
#' @return A plot of the empirical cumulative distriburtion as a function of
#' the fucntion values of the DataSetList at the target runtimes
#' @export
#' @examples
#' \dontshow{data.table::setDTthreads(1)}
#' Plot.FV.ECDF_Per_Target(subset(dsl, funcId == 1), 10)
Plot.FV.ECDF_Per_Target <-
function(dsList,
runtimes,
scale.xlog = F,
scale.reverse = F)
UseMethod("Plot.FV.ECDF_Per_Target", dsList)
#' Plot the aggregated empirical cumulative distriburtion as a function of the function values of
#' a DataSetList.
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param rt_min The starting runtime
#' @param rt_max The final runtime
#' @param rt_step The spacing between starting and final runtimes
#' @param show.per_target Whether or not to show the individual ECDF-curves for each runtime
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.reverse Whether or not to reverse the x-axis (when using minimization)
#'
#' @return A plot of the empirical cumulative distriburtion as a function of
#' the function values of the DataSetList
#' @export
#' @examples
#' \dontshow{data.table::setDTthreads(1)}
#' Plot.FV.ECDF_Single_Func(subset(dsl, funcId == 1))
Plot.FV.ECDF_Single_Func <-
function(dsList,
rt_min = NULL,
rt_max = NULL,
rt_step = NULL,
scale.xlog = F,
show.per_target = F,
scale.reverse = F)
UseMethod("Plot.FV.ECDF_Single_Func", dsList)
#' Radarplot of the area under the aggregated ECDF-curve of a DataSetList.
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param rt_min The starting runtime
#' @param rt_max The final runtime
#' @param rt_step The spacing between starting and final runtimes
#'
#' @return A radarplot of the area under the aggregated ECDF-curve of the DataSetList
#' @export
#' @examples
#' \dontshow{data.table::setDTthreads(1)}
#' Plot.FV.ECDF_AUC(subset(dsl, funcId == 1))
Plot.FV.ECDF_AUC <- function(dsList,
rt_min = NULL,
rt_max = NULL,
rt_step = NULL)
UseMethod("Plot.FV.ECDF_AUC", dsList)
#' Plot the parameter values recorded in a DataSetList (aligned by funcion value)
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param f_min The starting function value.
#' @param f_max The final function value.
#' @param show.mean Whether or not to show the mean parameter values
#' @param show.median Whether or not to show the median parameter values
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param algids Which algorithms from dsList to use
#' @param par_name Which parameters to create plots for; set to NULL to use all
#' parameters found in dsList.
#' @param show.CI Whether or not to show the standard deviation
#'
#' @return A plot of for every recorded parameter in the DataSetList
#' @export
#' @examples
#' Plot.RT.Parameters(subset(dsl, funcId == 1))
Plot.RT.Parameters <- function(dsList,
f_min = NULL,
f_max = NULL,
algids = 'all',
par_name = NULL,
scale.xlog = F,
scale.ylog = F,
show.mean = T,
show.median = F,
show.CI = F)
UseMethod("Plot.RT.Parameters", dsList)
#' Plot the parameter values recorded in a DataSetList (aligned by budget)
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param rt_min The starting budget value.
#' @param rt_max The final budget value.
#' @param show.mean Whether or not to show the mean parameter values
#' @param show.median Whether or not to show the median parameter values
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param algids Which algorithms from dsList to use
#' @param par_name Which parameters to create plots for; set to NULL to use all
#' parameters found in dsList.
#' @param show.CI Whether or not to show the standard deviation
#'
#' @return A plot of for every recorded parameter in the DataSetList
#' @export
#' @examples
#' Plot.FV.Parameters(subset(dsl, funcId == 1))
Plot.FV.Parameters <- function(dsList,
rt_min = NULL,
rt_max = NULL,
algids = 'all',
par_name = NULL,
scale.xlog = F,
scale.ylog = F,
show.mean = T,
show.median = F,
show.CI = F)
UseMethod("Plot.FV.Parameters", dsList)
#' Plot the aggregated empirical cumulative distriburtion as a function of the running times of
#' a DataSetList. Aggregated over multiple functions or dimensions.
#'
#' @param dsList A DataSetList.
#' @param targets The target function values. Specified in a data.frame, as can be generated
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' by the function 'get_ECDF_targets'
#'
#' @return A plot of the empirical cumulative distriburtion as a function of
#' the running times of the DataSetList
#' @export
#' @examples
#' \dontshow{data.table::setDTthreads(1)}
#' Plot.RT.ECDF_Multi_Func(dsl)
Plot.RT.ECDF_Multi_Func <-
function(dsList,
targets = NULL,
scale.xlog = F)
UseMethod("Plot.RT.ECDF_Multi_Func", dsList)
#' Plot ERT-plots for multiple functions or dimensions
#'
#' @param dsList A DataSetList (should consist of only one function OR dimension).
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param scale.reverse Wheter or not to reverse the x-axis (when using minimization)
#' @param backend Which plotting library to use. Either 'plotly' or 'ggplot2'.
#'
#' @return A plot of ERT-values of the DataSetList
#' @export
#' @examples
#' Plot.RT.Multi_Func(dsl)
Plot.RT.Multi_Func <-
function(dsList,
scale.xlog = F,
scale.ylog = F,
scale.reverse = F,
backend = NULL)
UseMethod("Plot.RT.Multi_Func", dsList)
#' Plot ERT-based comparison over multiple functions or dimensions
#'
#' @param dsList A DataSetList (should consist of only one function OR dimension).
#' @param plot_mode How the plots should be created. Can be 'line' or 'radar'
#' @param aggr_on Whether to compare on functions ('funcId') or dimensions ('DIM')
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param maximize Wheter or not to the data is of a maximization problem
#' @param targets Custom list of function-value targets, one for each function or dimension.
#' @param use_rank Wheter to use a ranking system. If False, the actual ERT-values will be used.
#' @param erts Pre-calculated ERT-values for the provided targets. Created by the max_ERTs function
#' of DataSetList. Can be provided to prevent needless computation in recalculating ERTs when recreating
#' this plot.
#' @param inf.action How to handle infinite ERTs ('overlap' or 'jitter')
#' @return A plot of ERT-based comparison on the provided functions or dimensions of the DataSetList
#' @export
#' @examples
#' Plot.RT.Aggregated(dsl)
Plot.RT.Aggregated <-
function(dsList,
aggr_on = 'funcId',
targets = NULL,
plot_mode = 'radar',
use_rank = F,
scale.ylog = T,
maximize = T,
erts = NULL,
inf.action = 'overlap')
UseMethod("Plot.RT.Aggregated", dsList)
#' Plot expected function value-based comparison over multiple functions or dimensions
#'
#' @param dsList A DataSetList (should consist of only one function OR dimension).
#' @param plot_mode How the plots should be created. Can be 'line' or 'radar'
#' @param aggr_on Whether to compare on functions ('funcId') or dimensions ('DIM')
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param runtimes Custom list of function-value targets, one for each function or dimension.
#' @param use_rank Wheter to use a ranking system. If False, the actual expected function-
#' values will be used.
#' @param fvs Pre-calculated expected function-values for the provided runtimes Created by the
#' max_ERTs function of DataSetList. Can be provided to prevent needless computation
#' in recalculating ERTs when recreating this plot.
#'
#' @return A plot of expected function value-based comparison on the provided functions
#' or dimensions of the DataSetList
#' @export
#' @examples
#' Plot.FV.Aggregated(dsl)
Plot.FV.Aggregated <-
function(dsList,
aggr_on = 'funcId',
runtimes = NULL,
plot_mode = 'radar',
use_rank = F,
scale.ylog = T,
fvs = NULL)
UseMethod("Plot.FV.Aggregated", dsList)
#' Plot FV-plots for multiple functions or dimensions
#'
#' @param dsList A DataSetList (should consist of only one function OR dimension).
#' @param scale.xlog Whether or not to scale the x-axis logaritmically
#' @param scale.ylog Whether or not to scale the y-axis logaritmically
#' @param backend Which plotting library to use. Either 'plotly' or 'ggplot2'.
#'
#' @return A plot of Function-values of the DataSetList
#' @export
#' @examples
#' Plot.FV.Multi_Func(dsl)
Plot.FV.Multi_Func <-
function(dsList,
scale.xlog = F,
scale.ylog = F,
backend = NULL)
UseMethod("Plot.FV.Multi_Func", dsList)
#' Plot a heatmap showing the statistically different algorithms
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param ftarget The target function value to use
#' @param alpha The cutoff for statistical significance
#' @param bootstrap.size The amound of bootstrapped samples used
#' @param which Whether to use fixed-target ('by_FV') or fixed-budget ('by_RT') perspective
#'
#' @return A heatmap showing the statistical significance between algorithms
#' @export
#' @examples
#' Plot.Stats.Significance_Heatmap(subset(dsl, funcId == 2), 16)
Plot.Stats.Significance_Heatmap <-
function(dsList,
ftarget,
alpha = 0.01,
bootstrap.size = 30,
which = 'by_FV')
UseMethod("Plot.Stats.Significance_Heatmap", dsList)
#' Plot a heatmap according to the specifications from the Nevergrad dashboard
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param target_dt A data-table containing the targets to condider on each function/dimension pair
#' @param which Whether to use fixed-target ('by_FV') or fixed-budget ('by_RT') perspective
#'
#' @return A heatmap showing the fraction of times algorithm A beats algorithm B
#' @export
#' @examples
#' Plot.Comparison.Heatmap(dsl)
Plot.Comparison.Heatmap <-
function(dsList, target_dt, which = 'by_FV')
UseMethod("Plot.Comparison.Heatmap", dsList)
#' Plot a network graph showing the statistically different algorithms
#'
#' @param dsList A DataSetList (should consist of only one function and dimension).
#' @param ftarget The target function value to use
#' @param alpha The cutoff for statistical significance
#' @param bootstrap.size The amound of bootstrapped samples used
#' @param which Whether to use fixed-target ('by_FV') or fixed-budget ('by_RT') perspective
#'
#' @return A graph showing the statistical significance between algorithms
#' @export
#' @examples
#' Plot.Stats.Significance_Graph(subset(dsl, funcId == 2), 16)
Plot.Stats.Significance_Graph <-
function(dsList,
ftarget,
alpha = 0.01,
bootstrap.size = 30,
which = 'by_FV')
UseMethod("Plot.Stats.Significance_Graph", dsList)
#' Create a candlestick plot of Glicko2-rankings
#'
#' @param dsList A DataSetList
#' @param nr_rounds The number of rounds in the tournament
#' @param glicko2_rank_df Optional. Dataframe containing the glicko2 rating to avoid needless recalculation.
#' @param which Whether to use fixed-target ('by_FV') or fixed-budget ('by_RT') perspective
#' @param target_dt Optional: data table containing the targets for each function and dimension
#'
#' @export
#' @examples
#' Plot.Stats.Glicko2_Candlestick(dsl, nr_rounds=2)
Plot.Stats.Glicko2_Candlestick <-
function(dsList,
nr_rounds = 100,
glicko2_rank_df = NULL,
which = 'by_FV',
target_dt = NULL)
UseMethod("Plot.Stats.Glicko2_Candlestick", dsList)
##Implementations
#' @rdname Plot.RT.Single_Func
#' @export
Plot.RT.Single_Func.DataSetList <-
function(dsList,
Fstart = NULL,
Fstop = NULL,
show.ERT = T,
show.CI = T,
show.mean = F,
show.median = F,
backend = NULL,
scale.xlog = F,
scale.ylog = F,
scale.reverse = F,
includeOpts = F,
p = NULL) {
if (is.null(backend))
backend <-
getOption("IOHanalyzer.backend", default = 'plotly')
if (backend == 'plotly') {
data <-
generate_data.Single_Function(dsList, Fstart, Fstop, scale.xlog, 'by_RT', includeOpts)
y_attrs <- c()
if (show.ERT)
y_attrs <- c(y_attrs, 'ERT')
if (show.mean)
y_attrs <- c(y_attrs, 'mean')
if (show.median)
y_attrs <- c(y_attrs, 'median')
show_legend <- T
if (length(y_attrs) > 0) {
p <- plot_general_data(
data,
x_attr = 'target',
y_attr = y_attrs,
type = 'line',
legend_attr = 'ID',
show.legend = show_legend,
scale.ylog = scale.ylog,
p = p,
scale.xlog = scale.xlog,
x_title = "Best-so-far f(x)-value",
y_title = "Function Evaluations",
scale.reverse = scale.reverse
)
show_legend <- F
}
if (show.CI) {
p <- plot_general_data(
data,
x_attr = 'target',
y_attr = 'mean',
type = 'ribbon',
legend_attr = 'ID',
lower_attr = 'lower',
upper_attr = 'upper',
p = p,
show.legend = show_legend,
scale.ylog = scale.ylog,
scale.xlog = scale.xlog,
x_title = "Best-so-far f(x)-value",
y_title = "Function Evaluations",
scale.reverse = scale.reverse
)
}
}
# } else if (backend == 'ggplot2') {
# dt[, 'group' := paste(algId, funcId, DIM, sep = '-')]
# p <- ggplot(data = dt, aes(group = `group`, colour = `group`))
#
# if (show.CI) p <- p + geom_ribbon(aes(target, ymin = lower, ymax = upper, fill = `group`),
# alpha = 0.2, colour = NA)
# if (show.ERT) p <- p + geom_line(aes(target, ERT), size = 1.2)
# if (show.mean) p <- p + geom_line(aes(target, mean), linetype = 'dashed')
# if (show.median) p <- p + geom_line(aes(target, median), linetype = 'dotted')
#
# p <- p +
# scale_color_manual(values = colors) +
# scale_fill_manual(values = colors)
# }
return(p)
}
#' @rdname Plot.FV.Single_Func
#' @export
Plot.FV.Single_Func.DataSetList <-
function(dsList,
RTstart = NULL,
RTstop = NULL,
show.CI = F,
show.mean = T,
show.median = F,
backend = NULL,
scale.xlog = F,
scale.ylog = F,
scale.reverse = F) {
if (is.null(backend))
backend <-
getOption("IOHanalyzer.backend", default = 'plotly')
if (backend == 'plotly') {
data <-
generate_data.Single_Function(dsList, RTstart, RTstop, scale.xlog, 'by_FV')
y_attrs <- c()
if (show.mean)
y_attrs <- c(y_attrs, 'mean')
if (show.median)
y_attrs <- c(y_attrs, 'median')
show_legend <- T
if (length(y_attrs) > 0) {
p <- plot_general_data(
data,
x_attr = 'runtime',
y_attr = y_attrs,
type = 'line',
legend_attr = 'ID',
show.legend = show_legend,
scale.ylog = scale.ylog,
scale.xlog = scale.xlog,
x_title = "Best-so-far f(x)-value",
y_title = "Function Evaluations",
scale.reverse = scale.reverse
)
show_legend <- F
}
else
p <- NULL
if (show.CI) {
p <- plot_general_data(
data,
x_attr = 'runtime',
y_attr = 'mean',
type = 'ribbon',
legend_attr = 'ID',
lower_attr = 'lower',
upper_attr = 'upper',
p = p,
show.legend = show_legend,
scale.ylog = scale.ylog,
scale.xlog = scale.xlog,
x_title = "Best-so-far f(x)-value",
y_title = "Function Evaluations",
scale.reverse = scale.reverse
)
}
}
# } else if (backend == 'ggplot2') {
# fce[, 'group' := paste(algId, funcId, DIM, sep = '-')]
# p <- ggplot(data = fce, aes(group = `group`, colour = `group`))
#
# if (show.mean) p <- p + geom_line(aes(runtime, mean), linetype = 'dashed')
# if (show.median) p <- p + geom_line(aes(runtime, median), linetype = 'dotted')
#
# p <- p +
# scale_color_manual(values = colors) +
# scale_fill_manual(values = colors)
#
# #TODO: add individual run etc
# }
return(p)
}
#' @rdname Plot.RT.PMF
#' @export
Plot.RT.PMF.DataSetList <-
function(dsList,
ftarget,
show.sample = F,
scale.ylog = F,
backend = NULL) {
if (is.null(backend))
backend <-
getOption("IOHanalyzer.backend", default = 'plotly')
data <- generate_data.PMF(dsList, ftarget, 'by_RT')
plot_general_data(
data,
'ID',
'RT',
scale.ylog = scale.ylog,
x_title = "Algorithm",
y_title = "Function Evaluations"
)
}
#' @rdname Plot.RT.Histogram
#' @export
Plot.RT.Histogram.DataSetList <-
function(dsList,
ftarget,
plot_mode = 'overlay',
use.equal.bins = F) {
if (length(get_funcId(dsList)) != 1 ||
length(get_dim(dsList)) != 1) {
warning(
"Invalid dataset uploaded. Please ensure the datasetlist contains data
from only one function and only one dimension."
)
return(NULL)
}
data <-
generate_data.hist(dsList, ftarget, use.equal.bins, 'by_RT')
subplot_attr <- if (plot_mode == 'subplot')
'ID'
else
NULL
plot_general_data(
data,
'x',
'y',
width = 'width',
type = 'hist',
subplot_attr = subplot_attr,
x_title = "Function Evaluations",
y_title = "Runs"
)
}
#' @rdname Plot.RT.ECDF_Per_Target
#' @export
Plot.RT.ECDF_Per_Target.DataSetList <-
function(dsList, ftargets, scale.xlog = F) {
req(length(ftargets) != 0)
data <- generate_data.ECDF(dsList, ftargets, scale.xlog)
plot_general_data(
data,
'x',
'mean',
'line',
x_title = "Function Evaluations",
y_title = "Proportion of runs",
scale.xlog = scale.xlog,
show.legend = T
)
}
#' @rdname Plot.RT.ECDF_Single_Func
#' @export
Plot.RT.ECDF_Single_Func.DataSetList <-
function(dsList,
fstart = NULL,
fstop = NULL,
fstep = NULL,
show.per_target = F,
scale.xlog = F) {
targets <- seq_FV(get_funvals(dsList), fstart, fstop, fstep)
req(targets)
data <- generate_data.ECDF(dsList, targets, scale.xlog)
plot_general_data(
data,
'x',
'mean',
'line',
x_title = "Function Evaluations",
y_title = "Proportion of (run, target) pairs",
scale.xlog = scale.xlog,
show.legend = T
)
}
#' @rdname Plot.RT.ECDF_AUC
#' @export
Plot.RT.ECDF_AUC.DataSetList <- function(dsList,
fstart = NULL,
fstop = NULL,
fstep = NULL,
fval_formatter = as.integer) {
targets <-
seq_FV(get_funvals(dsList), fstart, fstop, fstep, length.out = 10)
req(targets)
data <- generate_data.AUC(dsList, targets, multiple_x = TRUE)
plot_general_data(data, 'x', 'auc', 'radar')
}
#' @rdname Plot.FV.PDF
#' @export
Plot.FV.PDF.DataSetList <-
function(dsList,
runtime,
show.sample = F,
scale.ylog = F) {
data <- generate_data.PMF(dsList, runtime, 'by_FV')
plot_general_data(
data,
'ID',
'f(x)',
scale.ylog = scale.ylog,
x_title = "Algorithm",
y_title = "Target Value"
)
}
#' @rdname Plot.FV.Histogram
#' @export
Plot.FV.Histogram.DataSetList <-
function(dsList,
runtime,
plot_mode = 'overlay',
use.equal.bins = F) {
if (length(get_funcId(dsList)) != 1 ||
length(get_dim(dsList)) != 1) {
warning(
"Invalid dataset uploaded. Please ensure the datasetlist contains data
from only one function and only one dimension."
)
return(NULL)
}
data <-
generate_data.hist(dsList, runtime, use.equal.bins, 'by_FV')
subplot_attr <- if (plot_mode == 'subplot')
'ID'
else
NULL
plot_general_data(
data,
'x',
'y',
width = 'width',
type = 'hist',
subplot_attr = subplot_attr,
x_title = "Target Values",
y_title = "Runs"
)
}
#' @rdname Plot.FV.ECDF_Per_Target
#' @export
Plot.FV.ECDF_Per_Target.DataSetList <-
function(dsList,
runtimes,
scale.xlog = F,
scale.reverse = F) {
#TODO: Fvals in legend need to be formatted properly
runtimes <- runtimes[!is.na(runtimes)]
req(length(runtimes) != 0)
data <-
generate_data.ECDF(dsList, runtimes, scale.xlog, which = 'by_FV')
plot_general_data(
data,
'x',
'mean',
'line',
x_title = "Target Value",
y_title = "Proportion of runs",
scale.xlog = scale.xlog,
show.legend = T,
scale.reverse = scale.reverse
)
}
#' @rdname Plot.FV.ECDF_Single_Func
#' @export
Plot.FV.ECDF_Single_Func.DataSetList <-
function(dsList,
rt_min = NULL,
rt_max = NULL,
rt_step = NULL,
scale.xlog = F,
show.per_target = F,
scale.reverse = F) {
targets <- seq_RT(get_funvals(dsList), rt_min, rt_max, rt_step)
req(targets)
data <-
generate_data.ECDF(dsList, targets, scale.xlog, which = 'by_FV')
plot_general_data(
data,
'x',
'mean',
'line',
x_title = "Target Value",
y_title = "Proportion of (run, target) pairs",
scale.xlog = scale.xlog,
scale.reverse = scale.reverse,
show.legend = T
)
}
#' @rdname Plot.FV.ECDF_AUC
#' @export
Plot.FV.ECDF_AUC.DataSetList <-
function(dsList,
rt_min = NULL,
rt_max = NULL,
rt_step = NULL) {
targets <-
seq_RT(get_runtimes(dsList), rt_min, rt_max, rt_step, length.out = 10)
req(targets)
data <-
generate_data.AUC(dsList, targets, which = 'by_FV', multiple_x = TRUE)
plot_general_data(data, 'x', 'auc', 'radar')
}
#' @rdname Plot.RT.Parameters
#' @export
Plot.RT.Parameters.DataSetList <-
function(dsList,
f_min = NULL,
f_max = NULL,
algids = 'all',
par_name = NULL,
scale.xlog = F,
scale.ylog = F,
show.mean = T,
show.median = F,
show.CI = F) {
data <-
generate_data.Parameters(dsList, scale.xlog, which = 'by_FV')
y_attrs <- c()
if (show.mean)
y_attrs <- c(y_attrs, 'mean')
if (show.median)
y_attrs <- c(y_attrs, 'median')
show_legend <- T
if (length(y_attrs) > 0) {
p <- plot_general_data(
data,
x_attr = 'target',
y_attr = y_attrs,
type = 'line',
legend_attr = 'ID',
show.legend = show_legend,
scale.ylog = scale.ylog,
subplot_attr = 'parId',
scale.xlog = scale.xlog
)
show_legend <- F
}
else
p <- NULL
if (show.CI) {
p <- plot_general_data(
data,
x_attr = 'target',
y_attr = 'mean',
type = 'ribbon',
legend_attr = 'ID',
lower_attr = 'lower',
upper_attr = 'upper',
p = p,
show.legend = show_legend,
scale.ylog = scale.ylog,
subplot_attr = 'parId',
scale.xlog = scale.xlog
)
}
p
}
#' @rdname Plot.FV.Parameters
#' @export
Plot.FV.Parameters.DataSetList <-
function(dsList,
rt_min = NULL,
rt_max = NULL,
algids = 'all',
par_name = NULL,
scale.xlog = F,
scale.ylog = F,
show.mean = T,
show.median = F,
show.CI = F) {
data <-
generate_data.Parameters(dsList, scale.xlog, which = 'by_RT')
y_attrs <- c()
if (show.mean)
y_attrs <- c(y_attrs, 'mean')
if (show.median)
y_attrs <- c(y_attrs, 'median')
show_legend <- T
if (length(y_attrs) > 0) {
p <- plot_general_data(
data,
x_attr = 'runtime',
y_attr = y_attrs,
type = 'line',
legend_attr = 'ID',
show.legend = show_legend,
scale.ylog = scale.ylog,
subplot_attr = 'parId',
scale.xlog = scale.xlog
)
show_legend <- F
}
else
p <- NULL
if (show.CI) {
p <- plot_general_data(
data,
x_attr = 'runtime',
y_attr = 'mean',
type = 'ribbon',
legend_attr = 'ID',
lower_attr = 'lower',
upper_attr = 'upper',
p = p,
show.legend = show_legend,
scale.ylog = scale.ylog,
subplot_attr = 'parId',
scale.xlog = scale.xlog
)
}
p
}
#' @rdname Plot.RT.ECDF_Multi_Func
#' @export
Plot.RT.ECDF_Multi_Func.DataSetList <-
function(dsList,
targets = NULL,
scale.xlog = F) {
if (is.null(targets) || !is.data.table(targets)) {
targets <- get_ECDF_targets(dsList)
}
data <- generate_data.ECDF(dsList, targets, scale.xlog)
plot_general_data(
data,
'x',
'mean',
'line',
scale.xlog = scale.xlog,
x_title = "Function Evaluations",
y_title = "Proportion of (run, target, ...) pairs",
show.legend = T
)
}
#' @rdname Plot.RT.Multi_Func
#' @export
Plot.RT.Multi_Func.DataSetList <- function(dsList,
scale.xlog = F,
scale.ylog = F,
scale.reverse = F,
backend = NULL) {
if (is.null(backend))
backend <- getOption("IOHanalyzer.backend", default = 'plotly')
data <- rbindlist(lapply(get_funcId(dsList), function(fid) {
generate_data.Single_Function(subset(dsList, funcId == fid),
scale_log = scale.xlog,
which = 'by_RT')
}))
plot_general_data(
data,
x_attr = 'target',
y_attr = 'ERT',
subplot_attr = 'funcId',
type = 'line',
scale.xlog = scale.xlog,
scale.ylog = scale.ylog,
x_title = 'Best-so-far f(x)',
y_title = 'ERT',
show.legend = T,
scale.reverse = scale.reverse
)
}
#' @rdname Plot.FV.Multi_Func
#' @export
Plot.FV.Multi_Func.DataSetList <- function(dsList,
scale.xlog = F,
scale.ylog = F,
backend = NULL) {
if (is.null(backend))
backend <- getOption("IOHanalyzer.backend", default = 'plotly')
data <- rbindlist(lapply(get_funcId(dsList), function(fid) {
generate_data.Single_Function(subset(dsList, funcId == fid),
scale_log = scale.xlog,
which = 'by_FV')
}))
plot_general_data(
data,
x_attr = 'runtime',
y_attr = 'mean',
subplot_attr = 'funcId',
type = 'line',
scale.xlog = scale.xlog,
scale.ylog = scale.ylog,
x_title = 'Runtime',
y_title = 'Best-so-far f(x)',
show.legend = T
)
}
#' @rdname Plot.RT.Aggregated
#' @export
Plot.RT.Aggregated.DataSetList <-
function(dsList,
aggr_on = 'funcId',
targets = NULL,
plot_mode = 'radar',
use_rank = F,
scale.ylog = T,
maximize = T,
erts = NULL,
inf.action = 'overlap') {
targets <- get_target_dt(dsList)
data <-
generate_data.Aggr(dsList, aggr_on = aggr_on, targets = targets)
y_attr <- if (use_rank)
'rank'
else
'value'
y_title <- if (use_rank)
'Rank'
else
'ERT'
plot_general_data(
data,
type = plot_mode,
x_attr = 'funcId',
y_attr = y_attr,
x_title = "FuncId",
y_title = y_title,
show.legend = T,
scale.ylog = scale.ylog,
inf.action = inf.action
)
}
#' @rdname Plot.FV.Aggregated
#' @export
Plot.FV.Aggregated.DataSetList <-
function(dsList,
aggr_on = 'funcId',
runtimes = NULL,
plot_mode = 'radar',
use_rank = F,
scale.ylog = T,
fvs = NULL) {
targets <- get_target_dt(dsList, which = 'by_FV')
data <-
generate_data.Aggr(dsList,
aggr_on = aggr_on,
targets = targets,
which = 'by_FV')
y_attr <- if (use_rank)
'rank'
else
'value'
y_title <- if (use_rank)
'Rank'
else
'Best-so-far f(x)'
plot_general_data(
data,
type = plot_mode,
x_attr = 'funcId',
y_attr = y_attr,
x_title = "FuncId",
y_title = y_title,
show.legend = T,
scale.ylog = scale.ylog
)
}
#' @rdname Plot.Stats.Significance_Heatmap
#' @export
Plot.Stats.Significance_Heatmap.DataSetList <-
function(dsList,
ftarget,
alpha = 0.01,
bootstrap.size = 30,
which = 'by_FV') {
if (length(get_dim(dsList)) != 1 ||
length(get_funcId(dsList)) != 1 ||
length(get_id(dsList)) < 2)
return(NULL)
p_matrix <-
pairwise.test(dsList, ftarget, bootstrap.size, which)
y <- p_matrix <= alpha
colorScale <- data.frame(
x = c(-1, -0.33, -0.33, 0.33, 0.33, 1),
col = c('blue', 'blue', 'white', 'white', 'red', 'red')
)
heatmap <- y - t(y)
heatmap[is.na(heatmap)] <- 0
p <-
plot_ly(
x = colnames(y),
y = rownames(y),
z = heatmap,
type = 'heatmap',
xgap = 0.2,
ygap = 0.2,
colorscale = colorScale,
showscale = F
)
p %<>% layout(
yaxis = list(autorange = 'reversed', scaleratio = 1),
xaxis = list(tickangle = 45)
)
p
}
#' @rdname Plot.Comparison.Heatmap
#' @export
Plot.Comparison.Heatmap.DataSetList <-
function(dsList,
target_dt = NULL,
which = 'by_FV') {
matr <- generate_data.Heatmaps(dsList, which, target_dt)
order <- rowMeans(matr) %>% sort(decreasing = T) %>% names
matr <- matr[order[1:min(6, length(order))], order]
p <-
plot_ly(
x = colnames(matr),
y = rownames(matr),
z = matr,
type = 'heatmap',
xgap = 0.2,
ygap = 0.2,
colorscale = 'RdBu',
showscale = F,
zmin = 0,
zmax = 1
)
p %<>% layout(
yaxis = list(autorange = 'reversed', scaleratio = 1),
xaxis = list(tickangle = 45)
)
p
}
#' Helper function for Plot.Stats.Significance_Graph
#'
#' @param x x
#' @param start default is 0
#' @param direction default is 1
#'
#' @noRd
radian.rescale <- function(x,
start = 0,
direction = 1) {
c.rotate <- function(x)
(x + start) %% (2 * pi) * direction
c.rotate((2 * pi * (x - min(x)) / (max(x) - min(x))))
}
#' @rdname Plot.Stats.Significance_Graph
#' @export
Plot.Stats.Significance_Graph.DataSetList <-
function(dsList,
ftarget,
alpha = 0.01,
bootstrap.size = 30,
which = 'by_FV') {
if (!requireNamespace("igraph", quietly = TRUE)) {
stop("Package \"igraph\" needed for this function to work. Please install it.",
call. = FALSE)
}
if (length(get_dim(dsList)) != 1 ||
length(get_funcId(dsList)) != 1 ||
length(get_id(dsList)) < 2) {
return(NULL)
}
p_matrix <-
pairwise.test(dsList, ftarget, bootstrap.size, which)
g <-
igraph::graph_from_adjacency_matrix(p_matrix <= alpha, mode = 'directed', diag = F)
lab.locs <-
radian.rescale(x = 1:nrow(p_matrix),
direction = -1,
start = 0)
igraph::plot.igraph(
g,
layout = igraph::layout.circle(g),
vertex.size = 10,
edge.arrow.size = 1,
vertex.label.color = 'black',
vertex.label.dist = 2,
vertex.label.cex = 1,
vertex.label.degree = lab.locs
)
}
#' @rdname Plot.Stats.Glicko2_Candlestick
#' @export
Plot.Stats.Glicko2_Candlestick.DataSetList <-
function(dsList,
nr_rounds = 100,
glicko2_rank_df = NULL,
which = 'by_FV',
target_dt = NULL) {
df <- glicko2_rank_df
if (is.null(df)) {
df <-
glicko2_ranking(dsList, nr_rounds, which, target_dt = target_dt)$ratings
Ids <- df$Player$ID
}
else{
Ids <- df$ID
}
p <- IOH_plot_ly_default(title = "Glicko2-rating",
x.title = "ID",
y.title = "Rating")
df$Rating %<>% as.numeric
df$Deviation %<>% as.numeric
high <- df$Rating + 3 * df$Deviation
low <- df$Rating - 3 * df$Deviation
open <- df$Rating + df$Deviation
close <- df$Rating - df$Deviation
N <- length(df$Rating)
colors <- get_color_scheme(Ids)
if (length(colors != N)) {
colors <- get_color_scheme(get_id(dsList))
}
for (i in seq(N)) {
# rgba_str <- paste0('rgba(', paste0(col2rgb(colors[i]), collapse = ','), ',0.52)')
color <- list(line = list(color = colors[[i]]))
p %<>% add_trace(
type = "candlestick",
x = Ids[[i]],
open = open[[i]],
close = close[[i]],
high = high[[i]],
low = low[[i]],
legendgroup = Ids[[i]],
name = Ids[[i]],
increasing = color,
decreasing = color,
hovertext = paste0(
format(df$Rating[[i]], digits = 3),
'+-',
format(df$Deviation[[i]], digits = 3)
),
hoverinfo = "text"
)
}
p %<>% layout(xaxis = list(rangeslider = list(visible = F)))
p
}
### _______________________ Rewritten plotting function ____________________ ###
#' Add transparancy to named list of colors
#'
#' @param colors Named list of colors (in hex-notation)
#' @param percentage The percentage of opacity. 0 is fully transparant, 1 is fully opaque
#'
#' @noRd
add_transparancy <- function(colors, percentage) {
hex_val <-
format(as.hexmode(as.integer(255 * percentage)),
upper.case = T,
width = 2)
sapply(colors, function(col) {
col <- paste0('#', substr(col, 2, 7), hex_val)
})
}
#' General function for plotting within IOHanalyzer
#'
#' @param df The dataframe containing the data to plot. It should contain at least two columns:
#' 'x_attr' and 'y_attr'
#' @param x_attr The column to specify the x_axis. Default is 'algId'
#' @param legend_attr Default is 'algId' This is also used for the selection of colorschemes
#' @param y_attr The column to specify the y_axis
#' @param type The type of plot to use. Currently available: 'violin', 'line', 'radar',
#' 'bar', hist' and 'ribbon'
#' @param upper_attr When using ribbon-plot, this can be used to create a shaded area.
#' Only works in combination with`lower_attr` and `type` == 'ribbon'
#' @param lower_attr When using ribbon-plot, this can be used to create a shaded area.
#' Only works in combination with`upper_attr` and `type` == 'ribbon'
#' @param subplot_attr Which attribute of the dataframe to use for creating subplots
#' @param subplot_shareX Whether or not to share X-axis when using subplots
#' @param scale.xlog Logarithmic scaling of x-axis
#' @param scale.ylog Logarithmic scaling of y-axis
#' @param scale.reverse Decreasing or increasing x-axis
#' @param x_title Title of x-axis. Defaults to x_attr
#' @param y_title Title of x-axis. Defaults to x_attr
#' @param plot_title Title of x-axis. Defaults to no title
#' @param p A previously existing plot on which to add traces. If NULL, a new canvas is created
#' @param show.legend Whether or not to include a legend
#' @param inf.action How to deal with infinite values. Can be 'none', 'overlap' or 'jitter'
#' @param violin.showpoints Wheteher or not to show individual points when making a violinplot
#' @param frame_attr Which attribute of the dataframe to use for the time element of the animation
#' @param symbol_attr Which attribute of the dataframe to use for the scatter symbol
#' @param line.step Whether to plot lines as a step-function (T) or as linear interpolation (F, default)
#' @param ... Additional parameters for the add_trace function
#'
#'
#' @export
plot_general_data <-
function(df,
x_attr = 'ID',
y_attr = 'vals',
type = 'violin',
legend_attr = 'ID',
scale.xlog = F,
scale.ylog = F,
scale.reverse = F,
p = NULL,
x_title = NULL,
y_title = NULL,
plot_title = NULL,
upper_attr = NULL,
lower_attr = NULL,
subplot_attr = NULL,
show.legend = F,
inf.action = 'none',
violin.showpoints = F,
frame_attr = 'frame',
symbol_attr = 'run_nr',
subplot_shareX = F,
line.step = F,
...) {
l <-
x <-
isinf <-
y <-
text <-
l_orig <- frame <- NULL #Set local binding to remove warnings
#Only allow valid plot types
if (!(
type %in% c(
'violin',
'line',
'radar',
'hist',
'ribbon',
'line+ribbon',
'bar',
'anim-scatter',
'scatter'
)
)) {
stop(paste0("Provided plot type ('", type, "') is not supported"))
}
#And valid number of y-attributes
if (length(y_attr) == 0) {
stop("At least one y-attribute is needed to plot")
}
#Deal with subplots
if (!is.null(subplot_attr)) {
if (!subplot_attr %in% colnames(df)) {
stop("Provided subplot-attribut is not a colname of the selected data.table.")
}
colnames(df)[colnames(df) == subplot_attr] <- "subplot_attr"
attrs <- unique(df[, subplot_attr])
if (length(attrs) == 0)
stop(
"Attempting to create subplots with fewer than 2 unique values of
`subplot_attrs`-column"
)
if (length(attrs) == 1)
return(
plot_general_data(
df,
x_attr,
y_attr,
type,
legend_attr,
scale.xlog,
scale.ylog,
scale.reverse,
p,
x_title,
y_title,
attrs,
upper_attr,
lower_attr,
show.legend = show.legend,
subplot_attr = NULL,
...
)
)
if (subplot_attr == legend_attr) {
df[, l := subplot_attr]
}
#Only need one legend for the whole plot
legends_show <- rep(F, length(attrs))
legends_show[[1]] <- show.legend
names(legends_show) <- as.character(attrs)
#Get some number of rows and columns
n_cols <- 1 + ceiling(length(attrs) / 10)
n_rows <- ceiling(length(attrs) / n_cols)
p <- lapply(seq(length(attrs)), function(idx) {
attr_val <- attrs[[idx]]
df_sub <- df[subplot_attr == attr_val]
disp_y <- idx %% n_cols == 1
disp_x <- idx > (length(attrs) - n_cols)
x.title = if (disp_x)
x_title
else
""
y.title = if (disp_y)
y_title
else
""
#Generate title for the subplots
if (stri_detect_regex(subplot_attr, "(?i)fun"))
sub_title <- paste0('F', attr_val)
else if (stri_detect_regex(subplot_attr, "(?i)dim"))
sub_title <- paste0('D', attr_val)
else
sub_title <- paste0(attr_val)
p <- NULL
if (stri_detect_fixed(type, '+')) {
type1 <-
substr(type, 0, stri_locate_all(type, fixed = '+')[[1]][[1]] - 1)
p <-
plot_general_data(
df_sub,
x_attr,
y_attr,
type1,
legend_attr,
scale.xlog,
scale.ylog,
scale.reverse,
NULL,
x.title,
y.title,
plot_title,
upper_attr,
lower_attr,
show.legend = legends_show[[as.character(attr_val)]],
subplot_attr = NULL,
...
)
type <-
substr(type,
stri_locate_all(type, fixed = '+')[[1]][[1]] + 1,
nchar(type))
}
p <-
plot_general_data(
df_sub,
x_attr,
y_attr,
type,
legend_attr,
scale.xlog,
scale.ylog,
scale.reverse,
p,
x.title,
y.title,
plot_title,
upper_attr,
lower_attr,
show.legend = legends_show[[as.character(attr_val)]],
subplot_attr = NULL,
...
)
if (getOption("IOHanalyzer.annotation_x", 0.5) >= 0 &
getOption("IOHanalyzer.annotation_y", 1) >= 0) {
p %<>% layout(
annotations = list(
text = sub_title,
font = f2,
showarrow = FALSE,
xref = "paper",
yref = "paper",
x = getOption("IOHanalyzer.annotation_x", 0.5),
y = getOption("IOHanalyzer.annotation_y", 1)
)
)
p
}
})
p <- subplot(
p,
nrows = n_rows,
titleX = T,
titleY = T,
margin = c(
getOption("IOHanalyzer.margin_horizontal", 0.02),
getOption("IOHanalyzer.margin_vertical", 0.02),
getOption("IOHanalyzer.margin_horizontal", 0.02),
getOption("IOHanalyzer.margin_vertical", 0.02)
),
shareX = subplot_shareX
) %>%
layout(title = plot_title)
return(p)
}
# Replace colnames to have easier matching
if (!x_attr %in% colnames(df) ||
!all(y_attr %in% colnames(df))) {
stop("Not all provided attributes are colnames of the selected data.table.")
}
colnames(df)[colnames(df) == x_attr] <- "x"
if (length(y_attr) == 1 && type != 'line')
colnames(df)[colnames(df) == y_attr] <- "y"
else if (type != 'line')
stop("Multiple y-attrs is currently only supported for line-plots")
if (!is.null(upper_attr) && !is.null(lower_attr)) {
if (!upper_attr %in% colnames(df) ||
!lower_attr %in% colnames(df)) {
stop("Provided upper and lower attributes are not colnames of the selected data.table.")
}
colnames(df)[colnames(df) == upper_attr] <- "upper"
colnames(df)[colnames(df) == lower_attr] <- "lower"
}
if (x_attr != legend_attr) {
colnames(df)[colnames(df) == legend_attr] <- "l"
xs <- unique(df[['l']])
}
else{
xs <- unique(df[['x']])
}
#Get color and based on legend-attribute
colors <- get_color_scheme(xs)
if (is.null(names(colors)) ||
!all(names(colors) %in% xs))
names(colors) <- xs
xscale <- if (scale.xlog)
'log'
else
'linear'
yscale <- if (scale.ylog)
'log'
else
'linear'
#If new plot is needed, create one. Store in bool to decide if axis scaling is needed.
is_new_plot <- F
if (is.null(p)) {
p <-
IOH_plot_ly_default(
x.title = ifelse(is.null(x_title), x_attr, x_title),
y.title = ifelse(is.null(y_title), y_attr, y_title),
title = plot_title
)
is_new_plot <- T
}
switch(
type,
'violin' = {
if (legend_attr != x_attr) {
warning("Inconsistent attribute selected for x-axis and legend. Using x_attr as name")
}
#Update names to aviod numerical legend
if (is.numeric(df[['x']])) {
if (stri_detect_regex(x_attr, "(?i)fun"))
df <- df[, x := paste0('F', sprintf("%02d", x))]
else if (stri_detect_regex(x_attr, "(?i)dim"))
df <- df[, x := paste0('D', as.character(x))]
else
df <- df[, x := as.character(x)]
}
#Update color names as well, since the value changed
names(colors) <- unique(df[['x']])
p %<>%
add_trace(
data = df,
x = ~ x,
y = ~ y,
type = 'violin',
hoveron = "points+kde",
points = violin.showpoints,
pointpos = 1.5,
jitter = 0,
scalemode = 'count',
meanline = list(visible = F),
name = ~ x,
colors = colors,
color = ~ x,
split = ~ x,
line = list(color = 'black', width = 1.1),
box = list(visible = T),
spanmode = 'hard',
showlegend = show.legend,
...
)
if (is_new_plot) {
p %<>% layout(yaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3
))
}
},
'line' = {
if (legend_attr == x_attr) {
stop("Duplicated attribute selected for x-axis and legend.")
}
# Force legend to be categorical
df[, l_orig := l]
if (is.numeric(df[['l']])) {
df[, l := paste0('A', l)]
names(colors) <- paste0('A', names(colors))
}
#Use linestyles to differentiate traces if only one attribute is selected to be plotted
#TODO: Combine these two options more elegantly
if (length(y_attr) == 1) {
dashes <- get_line_style(xs)
names(dashes) <- xs
colnames(df)[colnames(df) == y_attr] <- "y"
df[, isinf := is.infinite(y)]
df[, text := as.character(round(y, getOption("IOHanalyzer.precision", 2)))]
if (inf.action == 'overlap') {
maxval <- max(df[isinf == F, 'y'])
df[['y']][df[['isinf']]] <-
10 ** (ceiling(log10(maxval)) + 1)
}
else if (inf.action == 'jitter') {
#TODO: Faster way to compute this
maxval <- max(df[isinf == F, 'y'])
for (xval in unique(df[['x']])) {
tempval <- 10 ** (ceiling(log10(maxval)) + 1)
for (lval in unique(df[['l']])) {
temp <- df[l == lval][x == xval]
if (nrow(temp) > 0 &&
df[l == lval][x == xval][['isinf']]) {
df[l == lval][x == xval][['y']] <- tempval
tempval <- 1.2 * tempval
}
}
}
}
suppressWarnings(
p %<>%
add_trace(
data = df,
x = ~ x,
y = ~ y,
color = ~ l,
legendgroup = ~ l_orig,
name = ~ l_orig,
type = 'scatter',
mode = 'lines+markers',
linetype = ~ l_orig,
marker = list(size = getOption('IOHanalyzer.markersize', 4)),
linetypes = dashes,
colors = colors,
showlegend = show.legend,
text = ~ text,
line = list(
width = getOption('IOHanalyzer.linewidth', 2),
shape = ifelse(line.step, "hv", "linear")
),
hovertemplate = '%{text}',
...
)
)
if (inf.action != 'none') {
p %<>% add_trace(
data = df[isinf == T],
x = ~ x,
y = ~ y,
legendgroup = ~ l_orig,
name = ~ l_orig,
type = 'scatter',
mode = 'markers',
color = ~ l,
marker = list(
symbol = 'circle-open',
size = 8 + getOption('IOHanalyzer.markersize', 4)
),
colors = colors,
showlegend = F,
text = 'Inf',
hoverinfo = 'none',
...
)
}
}
else {
if (inf.action != 'none') {
warning("inf.action is not yet supported for multiple y-attributes")
}
dashes_full <-
rep(
c(
"solid",
"dot",
"dash",
"longdash",
"dashdot",
"longdashdot"
),
ceiling(length(y_attr) / 3)
)[1:length(y_attr)]
names(dashes_full) <- y_attr
for (y_atr in y_attr) {
colnames(df)[colnames(df) == y_atr] <- "y"
#TODO: Figure out how to supress warning about 6 linetypes
dashstyle <- dashes_full[[y_atr]]
suppressWarnings(
p %<>%
add_trace(
data = df,
x = ~ x,
y = ~ y,
color = ~ l,
legendgroup = ~ l_orig,
name = ~ l_orig,
type = 'scatter',
mode = 'lines+markers',
marker = list(size = getOption('IOHanalyzer.markersize', 4)),
linetype = dashstyle,
colors = colors,
showlegend = show.legend,
name = ~ l,
text = y_atr,
line = list(
width = getOption('IOHanalyzer.linewidth', 2),
shape = ifelse(line.step, "hv", "linear")
),
...
)
)
colnames(df)[colnames(df) == "y"] <- y_atr
show.legend <- F
}
}
if (is_new_plot) {
if (is.numeric(df[['x']]))
p %<>% layout(
xaxis = list(
type = xscale,
tickfont = f3(),
ticklen = 3,
autorange = ifelse(scale.reverse, "reversed", T)
),
yaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3
)
)
else
p %<>% layout(
xaxis = list(
type = 'category',
tickfont = f3(),
ticklen = 3
),
yaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3
)
)
}
},
'ribbon' = {
if (legend_attr == x_attr) {
stop("Duplicated attribute selected for x-axis and legend.")
}
if (is.null(upper_attr) || is.null(lower_attr)) {
stop("No upper or lower attribute provided for ribbon-plot")
}
for (name in xs) {
df_small <- df[l == name]
legend_name <- as.character(name)
rgba_str <-
paste0('rgba(', paste0(col2rgb(colors[[name]]), collapse = ','), ',0.2)')
p %<>%
add_trace(
data = df_small,
x = ~ x,
y = ~ upper,
type = 'scatter',
mode = 'lines',
line = list(color = rgba_str, width = 0),
legendgroup = legend_name,
showlegend = F,
name = 'upper',
...
) %>%
add_trace(
x = ~ x,
y = ~ lower,
type = 'scatter',
mode = 'lines',
fill = 'tonexty',
line = list(color = 'transparent'),
legendgroup = legend_name,
fillcolor = rgba_str,
showlegend = F,
name = 'lower',
...
)
}
if (is_new_plot) {
p %<>% layout(
xaxis = list(
type = xscale,
tickfont = f3(),
ticklen = 3,
autorange = ifelse(scale.reverse, "reversed", T)
),
yaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3
)
)
}
},
'radar' = {
if (legend_attr == x_attr) {
stop("Duplicated attribute selected for x-axis and legend.")
}
if (is.numeric(df[['x']])) {
if (stri_detect_regex(x_attr, "(?i)fun"))
df <- df[, x := paste0('F', sprintf("%02d", x))]
else if (stri_detect_regex(x_attr, "(?i)dim"))
df <- df[, x := paste0('D', as.character(x))]
else
df <- df[, x := as.character(x)]
}
df <- df[, col := add_transparancy(colors, 0.4)[l]]
p %<>%
add_trace(
data = df,
type = 'scatterpolar',
r = ~ y,
theta = ~ x,
mode = 'markers',
#marker = list(color = 'lightgrey', size=0),
fill = 'toself',
connectgaps = T,
fillcolor = ~ col,
color = ~ l,
colors = colors,
name = ~ l,
legendgroup = ~ l,
...
)
if (is_new_plot) {
p %<>% layout(polar = list(
radialaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3,
autorange = ifelse(scale.reverse, "reversed", T)
)
))
}
},
'hist' = {
if (legend_attr == x_attr) {
stop("Duplicated attribute selected for x-axis and legend.")
}
if (!'width' %in% colnames(df)) {
stop(
"No 'width'-column included in the provided dataframe. This is required for a histogram-plot"
)
}
p %<>%
add_trace(
data = df,
x = ~ x,
y = ~ y,
width = ~ width,
type = 'bar',
name = ~ l,
text = ~ text,
hoverinfo = 'text',
colors = add_transparancy(colors, 0.6),
color = ~ l,
marker = list(line = list(color = 'rgb(8,48,107)')),
...
)
if (is_new_plot) {
p %<>% layout(
xaxis = list(
type = xscale,
tickfont = f3(),
ticklen = 3,
autorange = ifelse(scale.reverse, "reversed", T)
),
yaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3
)
)
}
},
'bar' = {
if (legend_attr != x_attr) {
warning("Inconsistent attribute selected for x-axis and legend. Using x_attr as name")
}
colors = add_transparancy(colors, 0.6)
for (xv in xs) {
p %<>%
add_trace(
x = xv,
y = df[x == xv, y],
type = 'bar',
name = xv,
color = colors[xv],
marker = list(line = list(color = 'rgb(8,48,107)')),
...
)
}
if (is_new_plot) {
p %<>% layout(
xaxis = list(tickfont = f3(), ticklen = 3),
yaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3
)
)
}
},
'anim-scatter' = {
colnames(df)[colnames(df) == frame_attr] <- "frame"
colnames(df)[colnames(df) == symbol_attr] <- "s"
colors = add_transparancy(colors, 0.9)
df = df[order(frame), ]
for (xv in xs) {
df_sub = df[l == xv,]
p %<>% add_trace(
data = df_sub,
x = ~ x,
y = ~ y,
type = 'scatter',
mode = 'markers',
marker = list(color = colors[xv],
symbol = ~
s),
legendgroup = xv,
frame = ~ frame,
showlegend = F,
name = xv
)
}
p %<>% animation_opts(transition = 0)
},
'scatter' = {
colnames(df)[colnames(df) == symbol_attr] <- "s"
colors = add_transparancy(colors, 0.9)
df = df[order(frame), ]
for (xv in xs) {
df_sub = df[l == xv,]
p %<>% add_trace(
data = df_sub,
x = ~ x,
y = ~ y,
type = 'scatter',
mode = 'markers',
marker = list(color = colors[xv],
symbol = ~
s),
legendgroup = xv,
showlegend = F,
name = xv
)
}
}
)
return(p)
}
#' Create the PerformViz plot
#'
#' From the paper:
#'
#' @param DSC_rank_result The result from a call to DSCtool rank service (`get_dsc_rank`)
#'
#' @return A performviz plot
#' @export
#' @examples
#' \dontrun{
#' Plot.Performviz(get_dsc_rank(dsl))
#' }
Plot.Performviz <- function(DSC_rank_result) {
if (!requireNamespace("ComplexHeatmap", quietly = TRUE)) {
stop(
"Package \"ComplexHeatmap\" needed for this function to work. Please install it.",
call. = FALSE
)
}
if (!requireNamespace("reshape2", quietly = TRUE)) {
stop("Package \"reshape2\" needed for this function to work. Please install it.",
call. = FALSE)
}
if (!requireNamespace("grid", quietly = TRUE)) {
stop("Package \"grid\" needed for this function to work. Please install it.",
call. = FALSE)
}
mlist <- DSC_rank_result$ranked_matrix
problem <- NULL #Assign variable to remove warnings
# df_temp <- rbindlist(lapply(mlist[[problem_idx]]$result,
# function(x) {
# list(algorithm = x$algorithm, rank = x$rank)
# }))
# df_temp[, problem := mlist[[problem_idx]]$problem]
df <- rbindlist(lapply(seq(length(mlist)), function(problem_idx) {
df_temp <- rbindlist(lapply(mlist[[problem_idx]]$result,
function(x) {
list(algorithm = x$algorithm, rank = x$rank)
}))
df_temp[, problem := mlist[[problem_idx]]$problem]
}))
rank_matrix <-
reshape2::acast(df, algorithm ~ problem, value.var = 'rank')
df <- rank_matrix
# colnames(df)<-index
# rownames(df)<-vector
# Define some graphics to display the distribution of columns
# library(ComplexHeatmap)
.hist = ComplexHeatmap::anno_histogram(df, gp = grid::gpar(fill = "lightblue"))
.density = ComplexHeatmap::anno_density(df, type = "line", gp = grid::gpar(col = "blue"))
ha_mix_top = ComplexHeatmap::HeatmapAnnotation(hist = .hist, density = .density)
# Define some graphics to display the distribution of rows
.violin = ComplexHeatmap::anno_density(
df,
type = "violin",
gp = grid::gpar(fill = "lightblue"),
which = "row"
)
.boxplot = ComplexHeatmap::anno_boxplot(df, which = "row")
ha_mix_right = ComplexHeatmap::HeatmapAnnotation(
violin = .violin,
bxplt = .boxplot,
which = "row",
width = grid::unit(4, "cm")
)
# Combine annotation with heatmap
heatmap_main <- ComplexHeatmap::Heatmap(
df,
name = "Ranking",
column_names_gp = grid::gpar(fontsize = 8),
top_annotation = ha_mix_top,
top_annotation_height = grid::unit(3.8, "cm")
)
return(ComplexHeatmap::draw(
ComplexHeatmap::`+.AdditiveUnit`(heatmap_main, ha_mix_right)
))
}
#' Plot the cumulative difference plot given a DataSetList.
#'
#' @param dsList A DataSetList (should consist of only one function and dimension and two algorithms).
#' @param runtime_or_target_value The target runtime or the target value
#' @param isFixedBudget Should be TRUE when target runtime is used. False otherwise.
#' @param alpha 1 minus the confidence level of the confidence band.
#' @param EPSILON If abs(x-y) < EPSILON, then we assume that x = y.
#' @param nOfBootstrapSamples The number of bootstrap samples used in the estimation.
#' @param dataAlreadyComputed If false, `generate_data.CDP` will be called to process the data.
#' @param precomputedData only needed when dataAlreadyComputed=TRUE. The result of `generate_data.CDP`.
#' @return A cumulative difference plot.
#' @export
#' @examples
#' dsl
#' dsl_sub <- subset(dsl, funcId == 1)
#' target <- 15
#'
#' Plot.cumulative_difference_plot(dsl_sub, target, FALSE)
Plot.cumulative_difference_plot <-
function(dsList,
runtime_or_target_value,
isFixedBudget,
alpha = 0.05,
EPSILON = 1e-80,
nOfBootstrapSamples = 1e3,
dataAlreadyComputed = FALSE,
precomputedData = NULL)
{
if (!requireNamespace("RVCompare", quietly = TRUE)) {
stop("Package \"RVCompare\" needed for this function to work. Please install it.",
call. = FALSE)
}
if (dataAlreadyComputed)
{
if (is.null(precomputedData))
{
return(NULL)
}
data <- precomputedData
}
else
{
data <-
generate_data.CDP(
dsList,
runtime_or_target_value,
isFixedBudget,
alpha,
EPSILON,
nOfBootstrapSamples
)
}
if (isFixedBudget)
{
subds <-
get_FV_sample(dsList, runtime_or_target_value, output = 'long')
algorithms <- unique(subds$ID)
}
else
{
subds <-
get_RT_sample(dsList, runtime_or_target_value, output = 'long')
algorithms <- unique(subds$ID)
}
# Convert back to list
plot_data <- list()
for (i in 1:ncol(data)) {
plot_data[[i]] <- data[, i]
}
names(plot_data) <- colnames(data)
# Confidence band
trace1 <-
list(
x = plot_data$p,
y = plot_data$diff_upper,
line = list(color = "rgba(0, 0, 40, 0)"),
mode = "lines",
name = "Upper bound of the confidence band",
type = "scatter"
)
trace3 <-
list(
x = plot_data$p,
y = plot_data$diff_lower,
connectgaps = TRUE,
line = list(color = "rgba(0, 0, 40, 0)"),
mode = "lines",
name = "Lower bound of the confidence band",
type = "scatter"
)
# Area in which the cumulative diference can be.
trace4 <-
list(
x = c(0, 0.5, 1),
y = c(0, 1, 0),
line = list(color = "rgba(0, 0, 40, 0)"),
mode = "lines",
name = "",
type = "scatter"
)
trace6 <- list(
x = c(0, 0.5, 1),
y = c(0, -1, 0),
connectgaps = TRUE,
line = list(color = "rgba(0, 0, 40, 0)"),
mode = "lines",
name = "",
type = "scatter"
)
fig <- plotly::plot_ly() %>%
plotly::add_lines(
x = plot_data$p,
y = plot_data$diff_estimation,
color = I("black"),
name = "Estimated cumulative diference"
) %>%
plotly::add_lines(
x = trace1$x,
y = trace1$y,
line = trace1$line,
mode = trace1$mode,
name = trace1$name,
type = trace1$type,
uid = trace1$uid,
xsrc = trace1$xsrc,
ysrc = trace1$ysrc
) %>%
plotly::add_trace(
x = trace3$x,
y = trace3$y,
connectgaps = trace3$connectgaps,
line = trace3$line,
mode = trace3$mode,
name = trace3$name,
type = trace3$type,
uid = trace3$uid,
xsrc = trace3$xsrc,
ysrc = trace3$ysrc,
fillcolor = "rgba(0,40,100,0.2)",
fill = 'tonexty'
) %>%
plotly::add_lines(
x = trace4$x,
y = trace4$y,
line = trace4$line,
mode = trace4$mode,
name = trace4$name,
type = trace4$type,
uid = trace4$uid,
xsrc = trace4$xsrc,
ysrc = trace4$ysrc
) %>%
plotly::add_trace(
x = trace6$x,
y = trace6$y,
connectgaps = trace6$connectgaps,
line = trace6$line,
mode = trace6$mode,
name = trace6$name,
type = trace6$type,
uid = trace6$uid,
xsrc = trace6$xsrc,
ysrc = trace6$ysrc,
fillcolor = "rgba(51,204,255,0.2)",
fill = 'tonexty'
) %>%
plotly::layout(
xaxis = list(range = c(0, 1)),
yaxis = list(range = c(-1, 1)),
showlegend = FALSE
) %>%
plotly::add_annotations(
x = 0.02,
y = 0.85,
xref = "x",
yref = "y",
text = algorithms[1],
xanchor = 'left',
showarrow = F
) %>%
plotly::add_annotations(
x = 0.02,
y = -0.85,
xref = "x",
yref = "y",
text = algorithms[2],
xanchor = 'left',
showarrow = F
)
return(fig)
}
#' Create EAF-based polygon plots
#'
#'
#'
#' @param df The dataframe containing the data to plot. This should come from `generate_data.EAF`
#' @param subplot_attr Which attribute of the dataframe to use for creating subplots
#' @param subplot_shareX Whether or not to share X-axis when using subplots
#' @param scale.xlog Logarithmic scaling of x-axis
#' @param scale.ylog Logarithmic scaling of y-axis
#' @param xmin Minimum value for the x-axis
#' @param xmax Maximum value for the x-axis
#' @param ymin Minimum value for the y-axis
#' @param ymax Maximum value for the y-axis
#' @param maximization Whether the data comes from maximization or minimization
#' @param scale.reverse Decreasing or increasing x-axis
#' @param x_title Title of x-axis. Defaults to x_attr
#' @param y_title Title of x-axis. Defaults to x_attr
#' @param plot_title Title of x-axis. Defaults to no title
#' @param p A previously existing plot on which to add traces. If NULL, a new canvas is created
#' @param show.colorbar Whether or not to include a colorbar
#' @param dt_overlay Dataframe containing additional data (e.g. quantiles) to plot
#' on top of the EAF. This should have a column labeled 'runtime'. The other columsn will
#' all be plotted as function values.
#' @param ... Additional parameters for the add_trace function
#'
#' @return An EAF plot
#' @export
#' @examples
#' \dontrun{
#' plot_eaf_data(generate_data.EAF(subset(dsl, ID==get_id(dsl)[[1]])), maximization=T)
#' }
plot_eaf_data <-
function(df,
maximization = F,
scale.xlog = F,
scale.ylog = F,
scale.reverse = F,
p = NULL,
x_title = NULL,
xmin = NULL,
xmax = NULL,
ymin = NULL,
ymax = NULL,
y_title = NULL,
plot_title = NULL,
subplot_attr = NULL,
show.colorbar = F,
subplot_shareX = F,
dt_overlay = NULL,
...) {
l <-
x <-
isinf <-
y <-
text <-
l_orig <- frame <- NULL #Set local binding to remove warnings
#Deal with subplots
if (!is.null(subplot_attr)) {
if (!subplot_attr %in% colnames(df)) {
stop("Provided subplot-attribut is not a colname of the selected data.table.")
}
colnames(df)[colnames(df) == subplot_attr] <- "subplot_attr"
if (!is.null(dt_overlay)) {
colnames(dt_overlay)[colnames(dt_overlay) == subplot_attr] <-
"subplot_attr"
}
attrs <- unique(df[, subplot_attr])
if (length(attrs) == 0)
stop(
"Attempting to create subplots with fewer than 2 unique values of
`subplot_attrs`-column"
)
if (length(attrs) == 1)
return(
plot_eaf_data(
df,
maximization = maximization,
scale.xlog = scale.xlog,
scale.ylog = scale.ylog,
scale.reverse = scale.reverse,
p = p,
x_title = x_title,
xmin = xmin,
xmax = xmax,
ymin = ymin,
ymax = ymax,
y_title = y_title,
show.colorbar = show.colorbar,
subplot_attr = NULL,
dt_overlay = dt_overlay,
...
)
)
#Get some number of rows and columns
n_cols <- 1 + ceiling(length(attrs) / 10)
n_rows <- ceiling(length(attrs) / n_cols)
p <- lapply(seq(length(attrs)), function(idx) {
attr_val <- attrs[[idx]]
df_sub <- df[subplot_attr == attr_val]
dt_overlay_sub <- dt_overlay[subplot_attr == attr_val]
disp_y <- idx %% n_cols == 1
disp_x <- idx > (length(attrs) - n_cols)
x.title = if (disp_x)
x_title
else
""
y.title = if (disp_y)
y_title
else
""
#Generate title for the subplots
if (stri_detect_regex(subplot_attr, "(?i)fun"))
sub_title <- paste0('F', attr_val)
else if (stri_detect_regex(subplot_attr, "(?i)dim"))
sub_title <- paste0('D', attr_val)
else
sub_title <- paste0(attr_val)
p <- NULL
p <-
plot_eaf_data(
df_sub,
maximization = maximization,
scale.xlog = scale.xlog,
scale.ylog = scale.ylog,
scale.reverse = scale.reverse,
p = p,
x_title = x_title,
xmin = xmin,
xmax = xmax,
ymin = ymin,
ymax = ymax,
y_title = y_title,
show.colorbar = F,
subplot_attr = NULL,
dt_overlay = dt_overlay_sub,
...
)
if (getOption("IOHanalyzer.annotation_x", 0.5) >= 0 &
getOption("IOHanalyzer.annotation_y", 1) >= 0) {
p %<>% layout(
annotations = list(
text = sub_title,
font = f2,
showarrow = FALSE,
xref = "paper",
yref = "paper",
x = getOption("IOHanalyzer.annotation_x", 0.5),
y = getOption("IOHanalyzer.annotation_y", 1)
)
)
p
}
})
p <- subplot(
p,
nrows = n_rows,
titleX = T,
titleY = T,
margin = c(
getOption("IOHanalyzer.margin_horizontal", 0.02),
getOption("IOHanalyzer.margin_vertical", 0.02),
getOption("IOHanalyzer.margin_horizontal", 0.02),
getOption("IOHanalyzer.margin_vertical", 0.02)
),
shareX = subplot_shareX
) %>%
layout(title = plot_title)
return(p)
}
xscale <- if (scale.xlog)
'log'
else
'linear'
yscale <- if (scale.ylog)
'log'
else
'linear'
#If new plot is needed, create one. Store in bool to decide if axis scaling is needed.
is_new_plot <- F
if (is.null(p)) {
p <- IOH_plot_ly_default(x.title = x_title,
y.title = y_title,
title = plot_title)
is_new_plot <- T
}
eaf_sets <- df$`percentage`
uniq_eaf_sets <- unique(eaf_sets)
att_surfs <- split.data.frame(df[, .(`runtime`, `f(x)`)],
factor(eaf_sets,
levels = uniq_eaf_sets,
labels = uniq_eaf_sets))
cols <- rev(viridis(length(att_surfs)))
if (maximization)
extreme = as.matrix(df[, .(runtime = max(`runtime`), `f(x)` = min(`f(x)`))])
else
extreme = as.matrix(df[, .(runtime = max(`runtime`), `f(x)` = max(`f(x)`))])
for (i in seq_along(att_surfs)) {
poli <-
add.extremes(points.steps(as.matrix(att_surfs[[i]])),
as.matrix(extreme),
c(F, maximization))
poli <- rbind(poli, extreme)
p %<>% add_polygons(
poli[, 'runtime'],
poli[, 'f(x)'],
alpha = 1,
fillcolor = cols[i],
line = list(width = 0),
name = names(att_surfs)[i],
showlegend = F
)
}
# Set axis ranges
xmin <-
ifelse((is.null(xmin) ||
xmin == ""), min(df$`runtime`), as.numeric(xmin))
xmax <-
ifelse((is.null(xmax) ||
xmax == ""), max(df$`runtime`), as.numeric(xmax))
if (scale.xlog) {
xmin <- log10(xmin)
xmax <- log10(xmax)
}
ymin <-
ifelse((is.null(ymin) ||
ymin == ""), min(df$`f(x)`), as.numeric(ymin))
ymax <-
ifelse((is.null(ymax) ||
ymax == ""), max(df$`f(x)`), as.numeric(ymax))
if (scale.ylog) {
ymin <- log10(ymin)
ymax <- log10(ymax)
}
yrange <- c(ymin, ymax)
if (scale.reverse)
yrange <- rev(yrange)
p %<>% layout(
xaxis = list(
type = xscale,
tickfont = f3(),
ticklen = 3,
range = c(xmin, xmax)
),
yaxis = list(
type = yscale,
tickfont = f3(),
ticklen = 3,
range = yrange
)
)
if (!is.null(dt_overlay)) {
cnames <- colnames(dt_overlay)
if (!('runtime' %in% cnames)) {
warning('dt_overlay needs to contain a columns labeled `runtime` to be used.')
} else {
for (cname in cnames[!(cnames %in% c('runtime', 'subplot_attr', 'ID'))]) {
p %<>% add_trace(
x = dt_overlay[['runtime']],
y = dt_overlay[[cname]],
type = 'scatter',
mode = 'lines',
name = cname,
showlegend = F,
line = list(
width = getOption('IOHanalyzer.linewidth', 2),
color = 'black',
shape = 'hv'
)
)
}
}
}
if (show.colorbar) {
p %<>% add_contour(
z = matrix(-0.1, 1.1),
zmin = -0.1,
zmax = 1.1,
colorscale = 'Viridis',
contours = list(coloring = 'fill'),
reversescale = T
)
p %<>% colorbar(
cmin = -0,
cmax = 1,
thickness = 0.03,
thicknessmode = 'fraction',
len = 1,
tickvals = c(0, 0.5, 1),
tickmode = 'array',
outlinewidth = 1,
title = 'Fraction'
)
}
p
return(p)
}
#' Create EAF-difference contour plots
#'
#'
#'
#' @param matrices The dataframes containing the data to plot. This should come from `generate_data.EAF_diff_Approximate`
#' @param scale.xlog Logarithmic scaling of x-axis
#' @param scale.ylog Logarithmic scaling of y-axis
#' @param zero_transparant Whether values of 0 should be made transparant or not
#' @param show_negatives Whether to also show negative values or not
#'
#' @return EAF difference plots
#' @export
#' @examples
#' \dontrun{
#' plot_eaf_differences(generate_data.EAF_diff_Approximate(subset(dsl, funcId == 1), 1, 50, 1, 16))
#' }
plot_eaf_differences <-
function(matrices,
scale.xlog = T,
scale.ylog = F,
zero_transparant = F,
show_negatives = F) {
xscale <- if (scale.xlog)
'log'
else
'linear'
yscale <- if (scale.ylog)
'log'
else
'linear'
show_colorbar <- T
ids <- names(matrices)
ps <- lapply(seq(length(ids)), function(idx) {
diff <- matrices[[idx]]
if (!show_negatives)
diff[diff < 0] = 0
id <- ids[[idx]]
x <- as.numeric(colnames(diff))
y <- as.numeric(rownames(diff))
p <- IOH_plot_ly_default('', 'Function Evaluations', 'f(x)')
if (zero_transparant)
diff[diff == 0] = NaN
if (all(is.na(diff))) {
p %<>% add_trace(
z = 0,
type = "contour",
x = x,
y = y,
line = list(smoothing = 0),
contours = list(
start = ifelse(show_negatives, -1, 0),
end = 1,
coloring = 'fill',
showlines = F
),
colorscale = ifelse(show_negatives, 'BuRd_r' , 'Viridis'),
reversescale = show_negatives,
name = id
)
} else {
p %<>% add_trace(
z = diff,
type = "contour",
x = x,
y = y,
line = list(smoothing = 0),
contours = list(
start = ifelse(show_negatives, -1, 0),
end = 1,
coloring = 'fill',
showlines = F
),
colorscale = ifelse(show_negatives, 'BuRd_r' , 'Viridis'),
reversescale = show_negatives,
name = id
)
}
p %<>% layout(yaxis = list(type = yscale, ticklen = 3))
p %<>% layout(xaxis = list(type = xscale, ticklen = 3))
if (show_colorbar) {
show_colorbar <<- F
} else {
p %<>% hide_colorbar()
}
if (getOption("IOHanalyzer.annotation_x", 0.5) >= 0 &
getOption("IOHanalyzer.annotation_y", 1) >= 0) {
p %<>% layout(
annotations = list(
text = id,
font = f2,
showarrow = FALSE,
xref = "paper",
yref = "paper",
x = getOption("IOHanalyzer.annotation_x", 0.5),
y = getOption("IOHanalyzer.annotation_y", 1)
)
)
}
# p %<>% add_trace(x=x, y=fv_sum[ , .(max = max(max)), by = runtime]$max, color='white', type = "scatter", mode = "line", showlegend=F, alpha=0.4, name='max')
# p %<>% add_trace(x=x, y=fv_sum[ , .(min = min(min)), by = runtime]$min, color='white', type = "scatter", mode = "line", showlegend=F, alpha=0.4, name='min')
p
})
n_cols <- 1 + ceiling(length(matrices) / 10)
n_rows <- ceiling(length(matrices) / n_cols)
p <- subplot(
ps,
nrows = n_rows,
titleX = T,
titleY = T,
margin = c(
getOption("IOHanalyzer.margin_horizontal", 0.02),
getOption("IOHanalyzer.margin_vertical", 0.02),
getOption("IOHanalyzer.margin_horizontal", 0.02),
getOption("IOHanalyzer.margin_vertical", 0.02)
),
shareX = T,
shareY = T
)
p
return(p)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.