# shared reactive variables
folderList <- reactiveValues(data = list())
DataList <- reactiveValues(data = DataSetList())
observe({
repo_dir <- get_repo_location()
dirs <- list.dirs(repo_dir, full.names = F)
if (length(dirs) == 0) {
shinyjs::alert("No repository directory found. To make use of the IOHProfiler-repository,
please create a folder called 'repository' in your home directory
and make sure it contains at least one '.rds'-file of a DataSetList-object,
such as the ones provided on the IOHProfiler github-page.")
}
else
updateSelectInput(session, 'repository.type', choices = dirs, selected = dirs[[1]])
})
# set up list of datasets (scan the repository, looking for .rds files)
observe({
req(input$repository.type)
repo_dir <- get_repo_location()
dir <- file.path(repo_dir, input$repository.type)
rds_files <- list.files(dir, pattern = '.rds$') %>% sub('\\.rds$', '', .)
if (length(rds_files) != 0) {
updateSelectInput(session, 'repository.dataset', choices = rds_files, selected = rds_files[[1]])
} else {# TODO: the alert msg should be updated
shinyjs::alert("No repository file found. To make use of the IOHProfiler-repository,
please create a folder called 'repository' in your home directory
and make sure it contains at least one '.rds'-file of a DataSetList-object,
such as the ones provided on the IOHProfiler github-page.")
updateSelectInput(session, 'repository.dataset', choices = NULL, selected = NULL)
}
})
# load repository that is selected
observeEvent(input$repository.dataset, {
req(input$repository.dataset)
repo_dir <- get_repo_location()
algs <- c()
dims <- c()
funcs <- c()
for (f in input$repository.dataset) {
rds_file <- file.path(repo_dir, input$repository.type, paste0(f, ".rds"))
if (file.exists(paste0(rds_file, '_info'))) {
info <- readRDS(paste0(rds_file, '_info'))
}
else {
dsl <- readRDS(rds_file)
info = list(algId = get_algId(dsl), funcId = get_funcId(dsl), DIM = get_dim(dsl))
}
algs <- c(algs, info$algId)
dims <- c(dims, info$DIM)
funcs <- c(funcs, info$funcId)
}
algs <- unique(algs)
dims <- unique(dims)
funcs <- unique(funcs)
updateSelectInput(session, 'repository.ID', choices = algs, selected = algs)
updateSelectInput(session, 'repository.dim', choices = dims, selected = dims)
updateSelectInput(session, 'repository.funcId', choices = funcs, selected = funcs)
shinyjs::enable('repository.load_button')
})
# add the data from repository
observeEvent(input$repository.load_button, {
data <- DataSetList()
repo_dir <- get_repo_location()
for (f in input$repository.dataset) {
rds_file <- file.path(repo_dir, input$repository.type, paste0(f, ".rds"))
data <- c(data, readRDS(rds_file))
}
data <- subset(data, funcId %in% input$repository.funcId)
data <- subset(data, DIM %in% input$repository.dim)
data <- subset(data, algId %in% input$repository.ID)
if (length(DataList$data) > 0 && attr(data, 'maximization') != attr(DataList$data, 'maximization')) {
shinyjs::alert(paste0("Attempting to add data from a different optimization type to the currently",
" loaded data.\nPlease either remove the currently loaded data or",
" choose a different dataset to load."))
return(NULL)
}
if (length(DataList$data) > 0 &&
!all(attr(DataList$data, 'ID_attributes') %in% get_static_attributes(data))) {
shinyjs::alert(paste0("Attempting to add data with different ID-attributes.
Please check that the attributes to create the ID
are present in the data you are loading."))
return(NULL) }
if (length(DataList$data) > 0) {
data <- change_id(data, attr(DataList$data, 'ID_attributes'))
temp_data <- c(DataList$data, data)
temp_data <- clean_DataSetList(temp_data)
} else {
temp_data <- change_id(data, 'algId')
}
if (getOption('IOHanalyzer.function_representation', 'funcId') == 'funcName') {
for (ds in temp_data){
attr(ds, 'funcId') <- attr(ds, 'funcName')
}
}
# DataList$data <- change_id(DataList$data, getOption("IOHanalyzer.ID_vars", c("algId")))
update_menu_visibility(attr(temp_data, 'suite'))
# set_format_func(attr(DataList$data, 'suite'))
IDs <- get_id(temp_data)
if (!all(IDs %in% get_color_scheme_dt()[['ids']])) {
set_color_scheme("Default", IDs)
}
DataList$data <- temp_data
})
# decompress zip files recursively and return the root directory of extracted files
unzip_fct_recursive <- function(zipfile, exdir, print_fun = print, alert_fun = print, depth = 0) {
filetype <- basename(zipfile) %>%
strsplit('\\.') %>% `[[`(1) %>%
rev %>%
`[`(1)
folders <- list()
if (filetype == 'zip')
unzip_fct <- unzip
else if (filetype %in% c('bz2', 'bz', 'gz', 'tar', 'tgz', 'tar.gz', 'xz'))
unzip_fct <- untar
files <- unzip_fct(zipfile, list = FALSE, exdir = file.path(exdir, rand_strings(1)))
if (length(files) == 0) {
alert_fun("An error occured while unzipping the provided files.\n
Please ensure no archives are corrupted and the filenames are
in base-64.")
return(NULL)
}
print_fun(paste0('<p style="color:blue;">Succesfully unzipped ', basename(zipfile), '.<br>'))
folders <- grep('*.info|csv|txt|json', files, value = T) %>%
dirname %>%
unique %>%
grep('__MACOSX', ., value = T, invert = T) %>% # to get rid of __MACOSX folder on MAC..
c(folders)
zip_files <- grep('.*\\.zip|\\.bz2|\\.bz|\\.gz|\\.tar|\\.tgz|\\.tar\\.gz|\\.xz', files, value = T, perl = T) %>%
grep('__MACOSX', ., value = T, invert = T)
if (depth <= 3) { # only allow for 4 levels of recursions
for (zipfile in zip_files) {
.folders <- unzip_fct_recursive(zipfile, dirname(zipfile), alert_fun,
print_fun, depth + 1)
folders <- c(folders, .folders)
}
}
unique(folders)
}
# upload the compressed the data file and uncompress them
selected_folders <- reactive({
if (is.null(input$upload.add_zip)) return(NULL)
tryCatch({
datapath <- input$upload.add_zip$datapath
folders <- c()
for (i in seq(datapath)) {
filetype <- basename(datapath[i]) %>%
strsplit('\\.') %>% `[[`(1) %>%
rev %>%
`[`(1)
print_html(paste0('<p style="color:blue;">Handling ', filetype, '-data.<br>'))
if (filetype == 'csv' || filetype == 'rds') {
# add the data path to the folders list direct
folders <- c(folders, datapath[[i]])
next
}
.folders <- unzip_fct_recursive(datapath[i], exdir, print_html) %>% unique
folders %<>% c(.folders)
}
unique(folders)
}, error = function(e) shinyjs::alert(paste0("The following error occured when processing the uploaded data: ", e))
)
})
# load, process the data folders, and update DataSetList
observeEvent(selected_folders(), {
withProgress({
folders <- selected_folders()
req(length(folders) != 0)
# format_selected <- input$upload.data_format
# maximization <- input$upload.maximization
# if (maximization == "AUTOMATIC") maximization <- NULL
if (length(folderList$data) == 0)
folder_new <- folders
else
folder_new <- setdiff(folders, intersect(folderList$data, folders))
req(length(folder_new) != 0)
tryCatch(
format_detected <- lapply(folder_new, check_format) %>% unique
, error = function(e) {
print_html(paste('<p style="color:red;">The data verification
failed, please check that the uploaded files are complete
and not corrupted.</p>'))
})
if (length(format_detected) > 1)
print_html(paste('<p style="color:red;">more than one format: <br>',
format_detected,
'is detected in the uploaded data set... skip the uploaded data'))
else
format_detected <- format_detected[[1]]
print_html(paste0('<p style="color:blue;">Data processing of source type:', format_detected, ' <br>'))
for (folder in folder_new) {
indexFiles <- scan_index_file(folder)
if (length(indexFiles) == 0 && !(format_detected %in% c(NEVERGRAD, "SOS", "RDS")))
print_html(paste('<p style="color:red;">No .info-files detected in the
uploaded folder, while they were expected:</p>', folder))
else {
folderList$data <- c(folderList$data, folder)
if (format_detected == "RDS") {
new_data <- readRDS(folder)
if (!("DataSetList" %in% class(new_data)))
DataSetList()
}
else {
# read the data set and handle potential errors
new_data <- tryCatch({
DataSetList(folder, print_fun = print_html,
maximization = NULL,
format = format_detected,
subsampling = F)},
error = function(e) {
print_html(paste('<p style="color:red;">The following error happened
when processing the data set:</p>'))
print_html(paste('<p style="color:red;">', e, '</p>'))
DataSetList()
}
)
}
tryCatch(
DataList$data <- c(DataList$data, new_data),
error = function(e) {
print_html(paste('<p style="color:red;">The following error happened',
'when adding the uploaded data set:</p>'))
print_html(paste('<p style="color:red;">', e,
'\nRemoving the old data.</p>'))
DataList$data <- new_data
}
)
shinyjs::html("upload_data_promt",
sprintf('%d: %s\n', length(folderList$data), folder),
add = TRUE)
}
}
DataList$data <- clean_DataSetList(DataList$data)
# DataList$data <- change_id(DataList$data, getOption("IOHanalyzer.ID_vars", c("algId")))
if (is.null(DataList$data)) {
shinyjs::alert("An error occurred when processing the uploaded data.
Please ensure the data is not corrupted.")
return(NULL)
}
update_menu_visibility(attr(DataList$data, 'suite'))
# set_format_func(attr(DataList$data, 'suite'))
IDs <- get_id(DataList$data)
if (!all(IDs %in% get_color_scheme_dt()[['ids']])) {
set_color_scheme("Default", IDs)
}
}, message = "Processing data, this might take some time")
})
#Load data from custom csv
observeEvent(input$upload.custom_csv, {
tryCatch({
datapath <- input$upload.custom_csv$datapath
found_columns <- colnames(fread(datapath, nrows=0))
options <- c(found_columns, 'None')
if (length(found_columns) == 1)
selected <- c('None', found_columns[[1]], 'None', 'None', 'None', 'None')
else
selected <- c(found_columns, 'None', 'None', 'None', 'None')
updateSelectInput(session, 'upload.neval_name', choices = options, selected = selected[[1]])
updateSelectInput(session, 'upload.fval_name', choices = options, selected = selected[[2]])
updateSelectInput(session, 'upload.fname_name', choices = options, selected = selected[[3]])
updateSelectInput(session, 'upload.algname_name', choices = options, selected = selected[[4]])
updateSelectInput(session, 'upload.dim_name', choices = options, selected = selected[[5]])
updateSelectInput(session, 'upload.run_name', choices = options, selected = selected[[6]])
datapath
}, error = function(e) shinyjs::alert(paste0("The following error occured when processing the uploaded data: ", e))
)
})
# load, process the data folders, and update DataSetList
observeEvent(input$upload.process_csv, {
file_name <- input$upload.custom_csv$datapath
if (is.null(file_name)) { return(NULL)}
neval_name <- input$upload.neval_name
fval_name <- input$upload.fval_name
fname_name <- input$upload.fname_name
algname_name <- input$upload.algname_name
dim_name <- input$upload.dim_name
run_name <- input$upload.run_name
static_attrs <- list()
if (neval_name == 'None') neval_name <- NULL
if (run_name == 'None') run_name <- NULL
if (fname_name == 'None') {
fname_name <- NULL
static_attrs$fname <- input$upload.fname_static
}
if (algname_name == 'None') {
algname_name <- NULL
static_attrs$algname <- input$upload.algname_static
}
if (dim_name == 'None') {
dim_name <- NULL
static_attrs$dim <- input$upload.dim_static
}
data <- read_pure_csv(file_name, neval_name, fval_name,
fname_name, algname_name, dim_name,
run_name, maximization = input$upload.maximization,
static_attrs = static_attrs)
if (length(DataList$data) > 0 && attr(data, 'maximization') != attr(DataList$data, 'maximization')) {
shinyjs::alert(paste0("Attempting to add data from a different optimization type to the currently",
" loaded data.\nPlease either remove the currently loaded data or",
" choose a different dataset to load."))
return(NULL)
}
if (length(DataList$data) > 0 &&
!all(attr(DataList$data, 'ID_attributes') %in% get_static_attributes(data))) {
shinyjs::alert(paste0("Attempting to add data with different ID-attributes.
Please check that the attributes to create the ID
are present in the data you are loading."))
return(NULL) }
if (length(DataList$data) > 0) {
data <- change_id(data, attr(DataList$data, 'ID_attributes'))
temp_data <- c(DataList$data, data)
temp_data <- clean_DataSetList(temp_data)
} else {
temp_data <- change_id(data, 'algId')
}
# DataList$data <- change_id(DataList$data, getOption("IOHanalyzer.ID_vars", c("algId")))
update_menu_visibility(attr(temp_data, 'suite'))
# set_format_func(attr(DataList$data, 'suite'))
IDs <- get_id(temp_data)
if (!all(IDs %in% get_color_scheme_dt()[['ids']])) {
set_color_scheme("Default", IDs)
}
DataList$data <- temp_data
})
update_menu_visibility <- function(suite){
if (all(suite == NEVERGRAD)) {
#TODO: Better way of doing this such that these pages are not even populated with data instead of just being hidden
session$sendCustomMessage(type = "manipulateMenuItem", message = list(action = "hide", tabName = "#shiny-tab-ERT"))
}
else{
session$sendCustomMessage(type = "manipulateMenuItem", message = list(action = "show", tabName = "#shiny-tab-ERT"))
}
if (all(suite == "PBO")) {
session$sendCustomMessage(type = "manipulateMenuItem", message = list(action = "hide", tabName = "FCE_ECDF"))
}
else {
session$sendCustomMessage(type = "manipulateMenuItem", message = list(action = "show", tabName = "FCE_ECDF"))
}
if (any(suite == "SOS")) {
session$sendCustomMessage(type = "manipulateMenuItem", message = list(action = "show", tabName = "Positions"))
}
else {
session$sendCustomMessage(type = "manipulateMenuItem", message = list(action = "hide", tabName = "Positions"))
}
}
observeEvent(input$Upload.Add_to_repo, {
data <- DATA_RAW()
repo_dir <- get_repo_location()
if (!file.exists(file.path(repo_dir, "public_repo"))) return(NULL)
nr_skipped <- 0
public_dir <- file.path(repo_dir, "public_repo")
for (algname in get_algId(data)) {
filename <- file.path(public_dir, paste0(algname, '.rds'))
if (file.exists(filename)) {
nr_skipped <- nr_skipped + 1
next
}
dsl <- subset(data, algId == algname)
saveRDS(dsl, file = filename)
}
nr_success <- length(get_algId(data)) - nr_skipped
shinyjs::alert(paste0("Successfully added ", nr_success, " algorithms to the public repository.",
"A total of ", nr_skipped, " algorithms were not uploaded because an algorithm",
"of the same name already exists, and overwriting data in the public repository is not yet",
"supported."))
})
# remove all uploaded data set
observeEvent(input$upload.remove_data, {
if (length(DataList$data) != 0) {
DataList$data <- DataSetList() # NOTE: this must be a `DataSetList` object
unlink(folderList$data, T)
folderList$data <- list()
updateSelectInput(session, 'Overall.Dim', choices = c(), selected = '')
updateSelectInput(session, 'Overall.Funcid', choices = c(), selected = '')
updateSelectInput(session, 'Overall.ID', choices = c(), selected = '')
print_html('<p style="color:red;">all data are removed!</p>')
print_html('', 'upload_data_promt')
}
})
# show the detailed information on DataSetList
output$data_info <- renderDataTable({
datasets <- DataList$data
if (length(datasets) != 0)
summary(datasets)
else
data.frame()
}, options = list(pageLength = 10, scrollX = F, autoWidth = TRUE,
columnDefs = list(list(width = '20px', targets = c(0, 1)))))
# update the list of dimensionality, funcId and algId and parameter list
observe({
data <- DataList$data
if (length(data) == 0)
return()
# TODO: create reactive values for them
IDs <- get_id(data)
# algIds <- c(IDs, 'all')
parIds_ <- get_parId(data)
parIds <- c(parIds_, 'all')
parIds_RT_ <- get_parId(data, which = 'by_RT')
funcIds <- get_funcId(data)
DIMs <- get_dim(data)
algIds <- get_algId(data)
runtimes <- get_runtimes(data)
fvals <- get_funvals(data)
selected_ds <- data[[1]]
selected_f <- attr(selected_ds,'funcId')
selected_dim <- attr(selected_ds, 'DIM')
selected_alg <- attr(selected_ds, 'algId')
selected_ID <- get_id(selected_ds)
updateSelectInput(session, 'Overall.Dim', choices = DIMs, selected = selected_dim)
updateSelectInput(session, 'Overall.Funcid', choices = funcIds, selected = selected_f)
if ('algId' %in% input$Settings.ID.Variables)
updateSelectInput(session, 'Overall.ID', choices = NULL, selected = NULL)
else
updateSelectInput(session, 'Overall.ID', choices = algIds, selected = selected_alg)
updateSelectInput(session, 'ERTPlot.Aggr.Funcs', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'Overview.Single.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTportfolio.Shapley.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTportfolio.Shapley.Funcs', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'RTportfolio.Shapley.Dims', choices = DIMs, selected = DIMs)
updateNumericInput(session, 'RTportfolio.Shapley.Permsize', min = 2, max = length(IDs),
value = min(10, length(IDs)))
if(length(IDs) >= 2)
{
updateSelectInput(session, 'RTPMF.CDP.Algs', choices = IDs, selected = c(IDs[1], IDs[2]))
updateSelectInput(session, 'FCEPDF.CDP.Algs', choices = IDs, selected = c(IDs[1], IDs[2]))
}
updateSelectInput(session, 'RT.MultiERT.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT.MultiERT.FuncId', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'RT.MultiERT.DIM', choices = DIMs, selected = selected_dim)
updateSelectInput(session, 'RT.Multisample.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT.Multisample.FuncId', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'RT.Multisample.DIM', choices = DIMs, selected = selected_dim)
updateSelectInput(session, 'ERTPlot.Multi.Funcs', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'FCEPlot.Multi.Funcs', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'RTECDF.Aggr.FuncIds', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'RTECDF.Aggr.DIMS', choices = DIMs, selected = DIMs)
updateSelectInput(session, 'FV.MultiFV.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV.MultiFV.FuncId', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'FV.MultiFV.DIM', choices = DIMs, selected = selected_dim)
updateSelectInput(session, 'FV.Multisample.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV.Multisample.FuncId', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'FV.Multisample.DIM', choices = DIMs, selected = selected_dim)
updateSelectInput(session, 'RT_Stats.Glicko.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT_Stats.Glicko.Funcid', choices = funcIds, selected = selected_f)
updateSelectInput(session, 'RT_Stats.Glicko.Dim', choices = DIMs, selected = selected_dim)
updateSelectInput(session, 'RT_NG.Heatmap.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT_NG.Heatmap.Funcid', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'RT_NG.Heatmap.Dim', choices = DIMs, selected = DIMs)
updateSelectInput(session, 'FV_NG.Heatmap.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_NG.Heatmap.Funcid', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'FV_NG.Heatmap.Dim', choices = DIMs, selected = DIMs)
updateSelectInput(session, 'RT_Stats.DSC.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT_Stats.DSC.Funcid', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'RT_Stats.DSC.Dim', choices = DIMs, selected = DIMs)
updateSelectInput(session, 'FV_Stats.DSC.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_Stats.DSC.Funcid', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'FV_Stats.DSC.Dim', choices = DIMs, selected = DIMs)
updateSelectInput(session, 'RT_Stats.Overview.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_Stats.Glicko.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_Stats.Glicko.Funcid', choices = funcIds, selected = selected_f)
updateSelectInput(session, 'FV_Stats.Glicko.Dim', choices = DIMs, selected = selected_dim)
updateSelectInput(session, 'EAF.Multi.FuncIds', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'EAF.MultiCDF.FuncIds', choices = funcIds, selected = funcIds)
updateSelectInput(session, 'FV_Stats.Overview.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTSummary.Statistics.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTSummary.Overview.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCESummary.Overview.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTSummary.Sample.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_PAR.Plot.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_PAR.CorrPlot.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT_PAR.Plot.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCESummary.Statistics.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCESummary.Sample.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_PAR.Summary.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_PAR.Sample.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT_PAR.Summary.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'RT_PAR.Sample.ID', choices = IDs, selected = IDs)
updateSelectInput(session, 'ERTPlot.Multi.Algs', choices = IDs, selected = selected_ID)
updateSelectInput(session, 'ERTPlot.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'ERTPlot.Aggr.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'ERTPlot.Aggr_Dim.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCEPlot.Multi.Algs', choices = IDs, selected = selected_ID)
updateSelectInput(session, 'FCEPlot.Aggr.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCEPlot.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCEPDF.Bar.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCEPDF.Hist.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTPMF.Bar.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTPMF.Hist.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FV_PAR.Summary.Param', choices = parIds, selected = 'all')
updateSelectInput(session, 'FV_PAR.Sample.Param', choices = parIds, selected = 'all')
updateSelectInput(session, 'RT_PAR.Summary.Param', choices = parIds, selected = 'all')
updateSelectInput(session, 'RT_PAR.Sample.Param', choices = parIds, selected = 'all')
updateSelectInput(session, 'RTECDF.Single.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTECDF.Aggr.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTECDF.AUC.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'RTECDF.Multi.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCEECDF.Single.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCEECDF.Mult.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'FCEECDF.AUC.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'EAF.Single.Algs', choices = IDs, selected = IDs[[1]])
updateSelectInput(session, 'EAF.CDF.Algs', choices = IDs, selected = IDs[[1]])
updateSelectInput(session, 'EAF.Multi.Algs', choices = IDs, selected = IDs[[1]])
updateSelectInput(session, 'EAF.MultiCDF.Algs', choices = IDs, selected = IDs[[1]])
updateSelectInput(session, 'EAF.Diff.Algs', choices = IDs, selected = IDs)
updateSelectInput(session, 'ParCoordPlot.Algs', choices = IDs, selected = IDs[[1]])
updateSelectInput(session, 'FV_PAR.CorrPlot.Param1', choices = c(parIds_RT_, 'f(x)'), selected = 'f(x)')
if (length(parIds_RT_) == 0)
updateSelectInput(session, 'FV_PAR.CorrPlot.Param2', choices = c(parIds_RT_, 'f(x)'), selected = 'f(x)')
else
updateSelectInput(session, 'FV_PAR.CorrPlot.Param2', choices = c(parIds_RT_, 'f(x)'), selected = parIds_RT_[[1]])
updateSelectInput(session, 'FV_PAR.Plot.Params', choices = parIds_RT_, selected = parIds_RT_)
updateSelectInput(session, 'RT_PAR.Plot.Params', choices = parIds_, selected = parIds_)
updateTextInput(session, 'FCEPlot.Multi.Min', value = min(runtimes))
updateTextInput(session, 'FCEPlot.Multi.Max', value = max(runtimes))
attr_choices <- get_static_attributes(data)
invalid_choices <- c('funcId', 'DIM', 'ID')
updateSelectInput(session, 'Settings.ID.Variables', choices = attr_choices[!attr_choices %in% invalid_choices],
selected = attr(data, 'ID_attributes'))
updateTextInput(session, 'EAF.MultiCDF.yMin', value = min(fvals, na.rm = T))
updateTextInput(session, 'EAF.MultiCDF.yMax', value = max(fvals, na.rm = T))
if (isTRUE(attr(data, 'constrained'))) {
shinyjs::show(id = "Settings.Constrained")
shinyjs::alert("The data you loaded seems to come from a constrained optimization problem.
We have added support for these types of problems by allowing for post-hoc
analysis of different penalization techniques (see the 'settings' page).")
} else {shinyjs::hide(id = "Settings.Constrained")}
})
# update (filter) according to users selection DataSets
DATA <- reactive({
dim <- input$Overall.Dim
req(dim)
d <- subset(DataList$data, DIM == dim)
if (!'algId' %in% input$Settings.ID.Variables) {
algid <- input$Overall.ID
if (!is.null(algid)) d <- subset(d, algId == algid)
}
fid <- input$Overall.Funcid
if (!is.null(fid)) d <- subset(d, funcId == fid)
if (length(DataList$data) == 0) return(NULL)
if (length(d) == 0 && dim != "") {
showNotification("There is no data available for this (dimension,function)-pair")
}
d
})
# TODO: give a different name for DATA and DATA_RAW
DATA_RAW <- reactive({
DataList$data
})
MAX_ERTS_FUNC <- reactive({
dim <- input$Overall.Dim
data <- subset(DataList$data, DIM == dim)
max_ERTs(data, aggr_on = 'funcId', maximize = attr(data, 'maximization'))
})
MAX_ERTS_DIM <- reactive({
func <- input$Overall.Funcid
data <- subset(DataList$data, funcId == func)
max_ERTs(data, aggr_on = 'DIM', maximize = attr(data, 'maximization'))
})
MEAN_FVALS_FUNC <- reactive({
dim <- input$Overall.Dim
data <- subset(DataList$data, DIM == dim)
mean_FVs(data, aggr_on = 'funcId')
})
MEAN_FVALS_DIM <- reactive({
func <- input$Overall.Funcid
data <- subset(DataList$data, funcId == func)
mean_FVs(data, aggr_on = 'DIM')
})
# TODO: make this urgely snippet look better...
# register the TextInput and restore them when switching funcID and DIM
observeEvent(eval(eventExpr), {
data <- DATA()
name <- get_data_id(data)
if (is.null(name))
return()
for (id in widget_id) {
REG[[id]][[name]] <<- input[[id]]
}
})
# update the values for the grid of target values
observe({
data <- DATA()
v <- get_funvals(data)
name <- get_data_id(data)
req(v)
# choose proper scaling for the function value
# v <- trans_funeval(v) # Do the scaling in seq_FV instead
q <- quantile(v, probs = c(.25, .5, .75), names = F)
# TODO: we need to fix this for the general case!!!
length.out <- 10
fseq <- seq_FV(v, length.out = length.out)
start <- fseq[1]
stop <- fseq[length.out]
if (length(fseq) < 4) {
step <- 0
} else {
#TODO: Make more general
if (abs(2 * fseq[3] - fseq[2] - fseq[4]) < 1e-12) #arbitrary precision
step <- fseq[3] - fseq[2]
else
step <- log10(fseq[3]) - log10(fseq[2])
}
setTextInput(session, 'RTSummary.Statistics.Min', name, alternative = format_FV(start))
setTextInput(session, 'RTSummary.Statistics.Max', name, alternative = format_FV(stop))
setTextInput(session, 'RTSummary.Statistics.Step', name, alternative = format_FV(step))
setTextInput(session, 'RTSummary.Sample.Min', name, alternative = format_FV(start))
setTextInput(session, 'RTSummary.Sample.Max', name, alternative = format_FV(stop))
setTextInput(session, 'RTSummary.Sample.Step', name, alternative = format_FV(step))
setTextInput(session, 'RTECDF.Multi.Min', name, alternative = format_FV(start))
setTextInput(session, 'RTECDF.Multi.Max', name, alternative = format_FV(stop))
setTextInput(session, 'RTECDF.Multi.Step', name, alternative = format_FV(step))
setTextInput(session, 'RTPMF.Bar.Target', name, alternative = format_FV(median(v)))
setTextInput(session, 'RTPMF.Hist.Target', name, alternative = format_FV(median(v)))
setTextInput(session, 'RTPMF.CDP.Target', name, alternative = format_FV(median(v)))
setTextInput(session, 'ERTPlot.Min', name, alternative = format_FV(start))
setTextInput(session, 'ERTPlot.Max', name, alternative = format_FV(stop))
setTextInput(session, 'ERTPlot.Aggr.Targets', name, alternative = "")
setTextInput(session, 'FCEPlot.Aggr.Targets', name, alternative = "")
setTextInput(session, 'RTECDF.Single.Target', name, alternative = format_FV(q[2]))
setTextInput(session, 'RTECDF.AUC.Min', name, alternative = format_FV(start))
setTextInput(session, 'RTECDF.AUC.Max', name, alternative = format_FV(stop))
setTextInput(session, 'RTECDF.AUC.Step', name, alternative = format_FV(step))
setTextInput(session, 'RT_PAR.Plot.Min', name, alternative = format_FV(start))
setTextInput(session, 'RT_PAR.Plot.Max', name, alternative = format_FV(stop))
setTextInput(session, 'RT_PAR.Summary.Min', name, alternative = format_FV(start))
setTextInput(session, 'RT_PAR.Summary.Max', name, alternative = format_FV(stop))
setTextInput(session, 'RT_PAR.Summary.Step', name, alternative = format_FV(step))
setTextInput(session, 'RT_PAR.Sample.Min', name, alternative = format_FV(start))
setTextInput(session, 'RT_PAR.Sample.Max', name, alternative = format_FV(stop))
setTextInput(session, 'RT_PAR.Sample.Step', name, alternative = format_FV(step))
setTextInput(session, 'RT_Stats.Overview.Target', name, alternative = format_FV(stop))
setTextInput(session, 'RT.Multisample.Target', name, alternative = format_FV(median(v)))
setTextInput(session, 'RT.MultiERT.Target', name, alternative = format_FV(median(v)))
setTextInput(session, 'EAF.Single.yMin', name, alternative = format_FV(start))
setTextInput(session, 'EAF.Single.yMax', name, alternative = format_FV(stop))
setTextInput(session, 'EAF.CDF.yMin', name, alternative = format_FV(start))
setTextInput(session, 'EAF.CDF.yMax', name, alternative = format_FV(stop))
setTextInput(session, 'EAF.Diff.yMin', name, alternative = format_FV(start))
setTextInput(session, 'EAF.Diff.yMax', name, alternative = format_FV(stop))
setTextInput(session, 'RT.MultiERT.Target', name, alternative = format_FV(median(v)))
setTextInput(session, 'RT.MultiERT.Target', name, alternative = format_FV(median(v)))
})
# update the values for the grid of running times
observe({
data <- DATA()
v <- get_runtimes(data)
name <- get_data_id(data)
if (length(v) == 0) return()
# TODO: this part should be made generic!!!
q <- quantile(v, probs = c(.25, .5, .75), names = F, type = 3)
grid <- seq(min(v), max(v), length.out = 10)
step <- max(1, min(grid[-1] - grid[-length(grid)]))
start <- min(v)
stop <- max(v)
setTextInput(session, 'FV.Multisample.Target', name, alternative = max(v))
setTextInput(session, 'FV.MultiFV.Target', name, alternative = max(v))
setTextInput(session, 'FCESummary.Statistics.Min', name, alternative = min(v))
setTextInput(session, 'FCESummary.Statistics.Max', name, alternative = max(v))
setTextInput(session, 'FCESummary.Statistics.Step', name, alternative = step)
setTextInput(session, 'FCESummary.Sample.Min', name, alternative = min(v))
setTextInput(session, 'FCESummary.Sample.Max', name, alternative = max(v))
setTextInput(session, 'FCESummary.Sample.Step', name, alternative = step)
setTextInput(session, 'FCEPDF.Hist.Runtime', name, alternative = median(v))
setTextInput(session, 'FCEPDF.Bar.Runtime', name, alternative = median(v))
setTextInput(session, 'FCEPDF.CDP.Runtime', name, alternative = median(v))
setTextInput(session, 'FCEPlot.Min', name, alternative = start)
setTextInput(session, 'FCEPlot.Max', name, alternative = stop)
setTextInput(session, 'FCEECDF.Mult.Min', name, alternative = min(v))
setTextInput(session, 'FCEECDF.Mult.Max', name, alternative = max(v))
setTextInput(session, 'FCEECDF.Mult.Step', name, alternative = step)
setTextInput(session, 'FCEECDF.AUC.Min', name, alternative = min(v))
setTextInput(session, 'FCEECDF.AUC.Max', name, alternative = max(v))
setTextInput(session, 'FCEECDF.AUC.Step', name, alternative = step)
setTextInput(session, 'FV_PAR.Plot.Min', name, alternative = min(v))
setTextInput(session, 'FV_PAR.Plot.Max', name, alternative = max(v))
setTextInput(session, 'FV_PAR.Summary.Min', name, alternative = min(v))
setTextInput(session, 'FV_PAR.Summary.Max', name, alternative = max(v))
setTextInput(session, 'FV_PAR.Summary.Step', name, alternative = step)
setTextInput(session, 'FV_PAR.Sample.Min', name, alternative = min(v))
setTextInput(session, 'FV_PAR.Sample.Max', name, alternative = max(v))
setTextInput(session, 'FV_PAR.Sample.Step', name, alternative = step)
setTextInput(session, 'FV_Stats.Overview.Target', name, alternative = max(v))
setTextInput(session, 'EAF.Single.Min', name, alternative = min(v))
setTextInput(session, 'EAF.Single.Max', name, alternative = max(v))
setTextInput(session, 'EAF.Diff.Min', name, alternative = min(v))
setTextInput(session, 'EAF.Diff.Max', name, alternative = max(v))
#TODO: remove q and replace by single number
setTextInput(session, 'FCEECDF.Single.Target', name, alternative = q[2])
})
output$upload.Download_processed <- downloadHandler(
filename = "DataSetList.rds",
content = function(file) {
saveRDS(DATA_RAW(), file = file)
}
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.