Nothing
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, 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, 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,
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)
}
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.