####################################### ## Simulate data ####################################### #### Try putting all input$sim_... and input$rep_... into a list #### so you can have multiple simulations in the state file and #### can restore them in the GUI #### This should be similar to the dtree setup #### #### Also checkout https://github.com/daattali/advanced-shiny/tree/master/update-input0 sim_types <- list( `Probability distributions` = setNames( c("binom", "discrete", "lnorm", "norm", "pois", "unif"), c( i18n$t("Binomial"), i18n$t("Discrete"), i18n$t("Log normal"), i18n$t("Normal"), i18n$t("Poisson"), i18n$t("Uniform") ) ), `Deterministic` = setNames( c("const", "data", "grid", "sequ"), c( i18n$t("Constant"), i18n$t("Data"), i18n$t("Grid search"), i18n$t("Sequence") ) ) ) sim_types_vec <- c(sim_types[[1]], sim_types[[2]]) sim_args <- as.list(formals(simulater)) ## list of function inputs selected by user sim_inputs <- reactive({ ## loop needed because reactive values don't allow single bracket indexing for (i in names(sim_args)) { sim_args[[i]] <- input[[paste0("sim_", i)]] } for (i in sim_types_vec) { if (!i %in% input$sim_types) sim_args[[i]] <- "" } if (!isTRUE(input$sim_add_functions)) { sim_args[["funcs"]] <- "" } sim_args }) rep_args <- as.list(formals(repeater)) ## list of function inputs selected by user rep_inputs <- reactive({ ## loop needed because reactive values don't allow single bracket indexing rep_args$dataset <- input$sim_name for (i in r_drop(names(rep_args))) { rep_args[[i]] <- input[[paste0("rep_", i)]] } if (is.empty(input$rep_fun)) rep_args$fun <- "none" rep_args }) rep_sum_args <- as.list(if (exists("summary.repeater")) { formals(summary.repeater) } else { formals(radiant.model:::summary.repeater) }) ## list of function inputs selected by user rep_sum_inputs <- reactive({ ## loop needed because reactive values don't allow single bracket indexing for (i in names(rep_sum_args)) { rep_sum_args[[i]] <- input[[paste0("rep_", i)]] } rep_sum_args }) rep_plot_args <- as.list(if (exists("plot.repeater")) { formals(plot.repeater) } else { formals(radiant.model:::plot.repeater) }) ## list of function inputs selected by user rep_plot_inputs <- reactive({ ## loop needed because reactive values don't allow single bracket indexing for (i in names(rep_plot_args)) { rep_plot_args[[i]] <- input[[paste0("rep_", i)]] } rep_plot_args }) textinput_maker <- function(id = "const", lab = i18n$t("Constant"), rows = 3, pre = "sim_", placeholder = i18n$t("Provide values in the input boxes above and then press the + symbol"), allow_tab = TRUE) { if (allow_tab) { onkeydown <- "" } else { onkeydown <- "if(event.keyCode===9){var v=this.value,s=this.selectionStart,e=this.selectionEnd;this.value=v.substring(0, s)+'\t'+v.substring(e);this.selectionStart=this.selectionEnd=s+1;return false;}" } ## avoid all sorts of 'helpful' behavior from your browser ## based on https://stackoverflow.com/a/35514029/1974918 id <- paste0(pre, id) tags$textarea( state_init(id), id = id, type = "text", rows = rows, placeholder = placeholder, autocomplete = "off", autocorrect = "off", autocapitalize = "off", spellcheck = "false", class = "form-control", onkeydown = onkeydown ) } output$ui_sim_types <- renderUI({ selectizeInput( "sim_types", label = i18n$t("Select types:"), choices = sim_types, multiple = TRUE, selected = state_multiple("sim_types", sim_types_vec), options = list(placeholder = i18n$t("Select types"), plugins = list("remove_button")) ) }) output$ui_sim_data <- renderUI({ choices <- c("None" = "none", r_info[["datasetlist"]]) selectizeInput( inputId = "sim_data", label = i18n$t("Input data for calculations:"), choices = choices, selected = state_single("sim_data", choices, isolate(input$sim_data)), multiple = FALSE ) }) sim_vars <- reactive({ input$sim_run if (is.empty(input$sim_name)) { character(0) } else { if (is.null(r_data[[input$sim_name]])) { character(0) } else { colnames(r_data[[input$sim_name]]) } } }) output$ui_rep_vars <- renderUI({ vars <- sim_vars() req(vars) form <- input$sim_form %>% sim_cleaner() if (!is.empty(form)) { s <- gsub(" ", "", form) %>% sim_splitter("=") svars <- c() for (i in 1:length(s)) { if (grepl("^\\s*#", s[[i]][1])) next if (grepl("\\s*<-\\s*function\\s*\\(", s[[i]][1])) next if (grepl(s[[i]][1], s[[i]][2])) next svars <- c(svars, s[[i]][1]) } if (length(svars) > 0) vars <- base::setdiff(vars, svars) } selectizeInput( "rep_vars", label = i18n$t("Variables to re-simulate:"), choices = vars, multiple = TRUE, selected = state_multiple("rep_vars", vars, isolate(input$rep_vars)), options = list(placeholder = i18n$t("Select variables"), plugins = list("remove_button")) ) }) output$ui_rep_sum_vars <- renderUI({ vars <- sim_vars() req(!is.empty(vars)) selectizeInput( "rep_sum_vars", label = i18n$t("Output variables:"), choices = vars, multiple = TRUE, selected = state_multiple("rep_sum_vars", vars, isolate(input$rep_sum_vars)), options = list( placeholder = i18n$t("Select variables"), plugins = list("remove_button", "drag_drop") ) ) }) output$ui_rep_grid_vars <- renderUI({ const <- input$sim_const %>% sim_cleaner() if (const != "") { s <- const %>% sim_splitter() vars <- c() for (i in 1:length(s)) { vars <- c(vars, s[[i]][1]) } } req(!is.empty(vars)) selectizeInput( "rep_grid_vars", label = i18n$t("Name:"), choices = vars, multiple = FALSE, selected = state_single("rep_grid_vars", vars) ) }) output$ui_rep_byvar <- renderUI({ vars <- setNames( c(".sim", ".rep"), c(i18n$t("Simulation"), i18n$t("Repeat")) ) selectizeInput( "rep_byvar", label = i18n$t("Group by:"), choices = vars, selected = state_single("rep_byvar", vars), multiple = FALSE, options = list(placeholder = i18n$t("Select group-by variable")) ) }) output$ui_rep_fun <- renderUI({ choices <- setNames( c( "sum", "mean", "median", "min", "max", "sd", "var", "sdprop", "varprop", "p01", "p025", "p05", "p10", "p25", "p75", "p90", "p95", "p975", "p99", "first", "last" ), c( i18n$t("sum"), i18n$t("mean"), i18n$t("median"), i18n$t("min"), i18n$t("max"), i18n$t("sd"), i18n$t("var"), i18n$t("sdprop"), i18n$t("varprop"), i18n$t("p01"), i18n$t("p025"), i18n$t("p05"), i18n$t("p10"), i18n$t("p25"), i18n$t("p75"), i18n$t("p90"), i18n$t("p95"), i18n$t("p975"), i18n$t("p99"), i18n$t("first"), i18n$t("last") ) ) selectizeInput( inputId = "rep_fun", label = i18n$t("Apply function:"), choices = choices, selected = state_multiple("rep_fun", choices, isolate(input$rep_fun)), multiple = TRUE, options = list(placeholder = i18n$t("None"), plugins = list("remove_button")) ) }) var_updater <- function(variable, var_str, var_name, var_inputs, fix = TRUE) { if (is.null(variable) || variable == 0) { return() } if (is.empty(var_inputs[1]) || any(is.na(var_inputs[-1]))) { showModal( modalDialog( title = i18n$t("Inputs required"), span("Please provide all required inputs"), footer = modalButton("OK"), size = "s", easyClose = TRUE ) ) } else { if (fix) { var_name <- fix_names(var_name) } inp <- paste(c(var_name, var_inputs), collapse = " ") if (is.empty(input[[var_str]])) { val <- paste0(inp, ";") } else { val <- paste0(input[[var_str]], "\n", inp, ";") } updateTextInput(session = session, var_str, value = val) } } var_remover <- function(variable) { input[[variable]] %>% strsplit("\n") %>% unlist() %>% head(., -1) %>% paste0(collapse = "\n") %>% updateTextInput(session = session, variable, value = .) } observeEvent(input$sim_binom_add, { var_updater( input$sim_binom_add, "sim_binom", input$sim_binom_name, c(input$sim_binom_n, input$sim_binom_p) ) }) observeEvent(input$sim_discrete_add, { v <- input$sim_discrete_val p <- input$sim_discrete_prob v <- gsub(",", " ", v) %>% strsplit("\\s+") %>% unlist() p <- gsub(",", " ", p) %>% strsplit("\\s+") %>% unlist() lp <- length(p) lv <- length(v) if (lv != lp && lv %% lp == 0) p <- rep(p, lv / lp) var_updater( input$sim_discrete_add, "sim_discrete", input$sim_discrete_name, paste0(c(v, p), collapse = " ") ) }) observeEvent(input$sim_lnorm_add, { var_updater(input$sim_lnorm_add, "sim_lnorm", input$sim_lnorm_name, c(input$sim_lnorm_mean, input$sim_lnorm_sd)) }) observeEvent(input$sim_norm_add, { var_updater(input$sim_norm_add, "sim_norm", input$sim_norm_name, c(input$sim_norm_mean, input$sim_norm_sd)) }) observeEvent(input$sim_pois_add, { var_updater(input$sim_pois_add, "sim_pois", input$sim_pois_name, input$sim_pois_lambda) }) observeEvent(input$sim_unif_add, { var_updater(input$sim_unif_add, "sim_unif", input$sim_unif_name, c(input$sim_unif_min, input$sim_unif_max)) }) observeEvent(input$sim_const_add, { var_updater(input$sim_const_add, "sim_const", input$sim_const_name, input$sim_const_nr) }) observeEvent(input$sim_sequ_add, { var_updater(input$sim_sequ_add, "sim_sequ", input$sim_sequ_name, c(input$sim_sequ_min, input$sim_sequ_max)) }) observeEvent(input$rep_grid_add, { var_updater( input$rep_grid_add, "rep_grid", input$rep_grid_name, c(input$rep_grid_min, input$rep_grid_max, input$rep_grid_step) ) updateNumericInput(session = session, "rep_nr", value = NA) }) observeEvent(input$sim_grid_add, { var_updater( input$sim_grid_add, "sim_grid", input$sim_grid_name, c(input$sim_grid_min, input$sim_grid_max, input$sim_grid_step) ) }) observeEvent(c(input$sim_grid, input$sim_types), { if ("grid" %in% input$sim_types && !is.empty(input$sim_grid)) { updateNumericInput(session = session, "sim_nr", value = NA) } else { val <- ifelse(is.empty(r_state$sim_nr), 1000, r_state$sim_nr) updateNumericInput(session = session, "sim_nr", value = val) } }) observeEvent(c(input$rep_grid, input$rep_byvar), { if (isTRUE(input$rep_byvar %in% c(".rep", "rep")) && !is.empty(input$rep_grid)) { updateNumericInput(session = session, "rep_nr", value = NA) } else { val <- ifelse(is.empty(r_state$rep_nr), 12, r_state$rep_nr) updateNumericInput(session = session, "rep_nr", value = val) } }) observeEvent(input$sim_binom_del, { var_remover("sim_binom") }) observeEvent(input$sim_discrete_del, { var_remover("sim_discrete") }) observeEvent(input$sim_norm_del, { var_remover("sim_norm") }) observeEvent(input$sim_lnorm_del, { var_remover("sim_lnorm") }) observeEvent(input$sim_pois_del, { var_remover("sim_pois") }) observeEvent(input$sim_unif_del, { var_remover("sim_unif") }) observeEvent(input$sim_const_del, { var_remover("sim_const") }) observeEvent(input$rep_grid_del, { var_remover("rep_grid") }) observeEvent(input$sim_sequ_del, { var_remover("sim_sequ") }) observeEvent(input$sim_grid_del, { var_remover("sim_grid") }) ## add a spinning refresh icon if the simulation needs to be (re)run run_refresh(sim_args, "sim", init = "types", label = i18n$t("Run simulation"), relabel = i18n$t("Re-run simulation"), data = FALSE) ## add a spinning refresh icon if the repeated simulation needs to be (re)run run_refresh(rep_args, "rep", init = "sum_vars", label = i18n$t("Repeat simulation"), data = FALSE) output$ui_simulater <- renderUI({ tagList( conditionalPanel( condition = "input.tabs_simulate == 'Simulate'", wellPanel( actionButton("sim_run", i18n$t("Run simulation"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success") ), wellPanel( uiOutput("ui_sim_types") ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('binom') >= 0", wellPanel( HTML( paste0( "" ) ), with(tags, table( td(textInput("sim_binom_name", i18n$t("Name:"), value = state_init("sim_binom_name", ""))), td(numericInput("sim_binom_n", i18n$t("n:"), value = state_init("sim_binom_n"), min = 1)), td(numericInput("sim_binom_p", i18n$t("p:"), value = state_init("sim_binom_p"), min = 0)) )), textinput_maker("binom", i18n$t("Binomial")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('const') >= 0", wellPanel( HTML(paste0( "" )), with(tags, table( td(textInput("sim_const_name", i18n$t("Name:"), value = state_init("sim_const_name", ""))), td(numericInput("sim_const_nr", i18n$t("Value:"), value = state_init("sim_const_nr"))) )), textinput_maker("const", i18n$t("Constant")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('discrete') >= 0", wellPanel( HTML(paste0( "" )), with(tags, table( td(textInput("sim_discrete_name", i18n$t("Name:"), value = state_init("sim_discrete_name", ""))), td(textInput("sim_discrete_val", i18n$t("Values:"), value = state_init("sim_discrete_val"))), td(textInput("sim_discrete_prob", i18n$t("Prob.:"), value = state_init("sim_discrete_prob"))) )), textinput_maker("discrete", i18n$t("Discrete")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('lnorm') >= 0", wellPanel( HTML(paste0( "" )), with(tags, table( td(textInput("sim_lnorm_name", i18n$t("Name:"), value = state_init("sim_lnorm_name", ""))), td(numericInput("sim_lnorm_mean", i18n$t("Mean:"), value = state_init("sim_lnorm_mean"))), td(numericInput("sim_lnorm_sd", i18n$t("St.dev.:"), value = state_init("sim_lnorm_sd"), min = 1)) )), textinput_maker("lnorm", i18n$t("Log normal")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('norm') >= 0", wellPanel( HTML(paste0( "" )), with(tags, table( td(textInput("sim_norm_name", i18n$t("Name:"), value = state_init("sim_norm_name", ""))), td(numericInput("sim_norm_mean", i18n$t("Mean:"), value = state_init("sim_norm_mean"))), td(numericInput("sim_norm_sd", i18n$t("St.dev.:"), value = state_init("sim_norm_sd"), min = 0)) )), textinput_maker("norm", i18n$t("Normal")), checkboxInput("sim_nexact", i18n$t("Use exact specifications"), state_init("sim_nexact", FALSE)), textInput("sim_ncorr", i18n$t("Correlations:"), value = state_init("sim_ncorr")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('pois') >= 0", wellPanel( HTML(paste0( "" )), with(tags, table( td(textInput("sim_pois_name", i18n$t("Name:"), value = state_init("sim_pois_name", ""))), td(numericInput("sim_pois_lambda", i18n$t("Lambda:"), value = state_init("sim_pois_lambda"))) )), textinput_maker("pois", i18n$t("Poisson")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('unif') >= 0", wellPanel( HTML(paste0( "" )), with(tags, table( td(textInput("sim_unif_name", i18n$t("Name:"), value = state_init("sim_unif_name", ""))), td(numericInput("sim_unif_min", i18n$t("Min:"), value = state_init("sim_unif_min"))), td(numericInput("sim_unif_max", i18n$t("Max:"), value = state_init("sim_unif_max"))) )), textinput_maker("unif", i18n$t("Uniform")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('sequ') >= 0", wellPanel( HTML(paste0( "" )), with(tags, table( td(textInput("sim_sequ_name", i18n$t("Name:"), value = state_init("sim_sequ_name", ""))), td(numericInput("sim_sequ_min", i18n$t("Min:"), value = state_init("sim_sequ_min"))), td(numericInput("sim_sequ_max", i18n$t("Max:"), value = state_init("sim_sequ_max"))) )), textinput_maker("sequ", i18n$t("Sequence")) ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('grid') >= 0", wellPanel( HTML( paste0( "" ) ), with(tags, table( td(textInput("sim_grid_name", i18n$t("Name:"), value = state_init("sim_grid_name", ""))), td(numericInput("sim_grid_min", i18n$t("Min:"), value = state_init("sim_grid_min"))), td(numericInput("sim_grid_max", i18n$t("Max:"), value = state_init("sim_grid_max"))), td(numericInput("sim_grid_step", i18n$t("Step:"), value = state_init("sim_grid_step"))) )), textinput_maker("grid") ) ), conditionalPanel( "input.sim_types && input.sim_types.indexOf('data') >= 0", wellPanel( uiOutput("ui_sim_data") ) ), wellPanel( with(tags, table( td(numericInput( "sim_seed", i18n$t("Set random seed:"), value = state_init("sim_seed", 1234), )), td(numericInput( "sim_nr", i18n$t("# sims:"), min = 1, max = 10^6, value = state_init("sim_nr", 1000), width = "95px" )) )), with(tags, table( td(textInput("sim_name", i18n$t("Simulated data:"), state_init("sim_name", "simdat"))), td(numericInput("sim_dec", label = i18n$t("Decimals:"), value = state_init("sim_dec", 4), min = 0, width = "95px")) )), with(tags, table( td(checkboxInput("sim_add_functions", i18n$t("Add functions"), state_init("sim_add_functions", FALSE))), td(HTML("   ")), td(checkboxInput("sim_show_plots", i18n$t("Show plots"), state_init("sim_show_plots", FALSE))) )) ), help_and_report( modal_title = i18n$t("Simulate"), fun_name = "simulater", help_file = inclMD(file.path(getOption("radiant.path.model"), "app/tools/help/simulater.md")) ) ), conditionalPanel( condition = "input.tabs_simulate == 'Repeat'", wellPanel( actionButton("rep_run", i18n$t("Repeat simulation"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success") ), wellPanel( uiOutput("ui_rep_vars"), uiOutput("ui_rep_sum_vars") ), wellPanel( uiOutput("ui_rep_byvar"), conditionalPanel( condition = "input.rep_byvar == '.rep'", HTML(paste0( "" )), with(tags, table( td(textInput("rep_grid_name", i18n$t("Name:"), value = state_init("rep_grid_name", ""))), td(numericInput("rep_grid_min", i18n$t("Min:"), value = state_init("rep_grid_min"))), td(numericInput("rep_grid_max", i18n$t("Max:"), value = state_init("rep_grid_max"))), td(numericInput("rep_grid_step", i18n$t("Step:"), value = state_init("rep_grid_step"))) )), textinput_maker("grid", "", pre = "rep_") ), uiOutput("ui_rep_fun") ), wellPanel( with(tags, table( td(numericInput( "rep_seed", i18n$t("Set random seed:"), value = state_init("rep_seed", 1234) )), td(numericInput( "rep_nr", i18n$t("# reps:"), min = 1, max = 10^6, value = state_init("rep_nr", 12), width = "95px" )) )), with(tags, table( td(textInput("rep_name", i18n$t("Repeat data:"), state_init("rep_name", "repdat"))), td(numericInput("rep_dec", label = i18n$t("Decimals:"), value = state_init("rep_dec", 4), min = 0, max = 10, width = "95px")) )), with(tags, table( # td(checkboxInput("rep_add_functions", "Add functions", state_init("rep_add_functions", FALSE))), # td(HTML("   ")), td(checkboxInput("rep_show_plots", i18n$t("Show plots"), state_init("rep_show_plots", FALSE))) )) ), help_and_report( modal_title = i18n$t("Repeat simulation"), fun_name = "repeater", help_file = inclMD(file.path(getOption("radiant.path.model"), "app/tools/help/simulater.md")) ) ) ) }) ## output is called from the main radiant ui.R output$simulater <- renderUI({ register_print_output("summary_simulate", ".summary_simulate") register_plot_output( "plot_simulate", ".plot_simulate", width_fun = "sim_plot_width", height_fun = "sim_plot_height" ) register_print_output("summary_repeat", ".summary_repeat") register_plot_output( "plot_repeat", ".plot_repeat", width_fun = "rep_plot_width", height_fun = "rep_plot_height" ) ## mulitple tabs with components stacked sim_output_panels <- tabsetPanel( id = "tabs_simulate", tabPanel( i18n$t("Simulate"), value = "Simulate", HTML(i18n$t("")), shinyAce::aceEditor( "sim_form", mode = "r", theme = getOption("radiant.ace_theme", default = "tomorrow"), wordWrap = TRUE, debounce = -1, height = "120px", value = state_init("sim_form", "") %>% fix_smart(), placeholder = i18n$t("Use formulas to perform calculations on simulated variables\n(e.g., demand = 5 * price). Press the Run simulation button\nto run the simulation. Click the ? icon on the bottom left\nof your screen for help and examples"), vimKeyBinding = getOption("radiant.ace_vim.keys", default = FALSE), tabSize = getOption("radiant.ace_tabSize", 2), useSoftTabs = getOption("radiant.ace_useSoftTabs", TRUE), showInvisibles = getOption("radiant.ace_showInvisibles", FALSE), autoScrollEditorIntoView = TRUE, minLines = 7, maxLines = 20 ), conditionalPanel( "input.sim_add_functions == true", HTML(i18n$t("
")), shinyAce::aceEditor( "sim_funcs", mode = "r", theme = getOption("radiant.ace_theme", default = "tomorrow"), wordWrap = TRUE, debounce = -1, height = "120px", value = state_init("sim_funcs", "") %>% fix_smart(), placeholder = i18n$t("Create your own R functions (e.g., add = function(x, y) {x + y}).\nCall these functions from the 'formula' input and press the Run\nsimulation button to run the simulation. Click the ? icon on the\nbottom left of your screen for help and examples"), vimKeyBinding = getOption("radiant.ace_vim.keys", default = FALSE), tabSize = getOption("radiant.ace_tabSize", 2), useSoftTabs = getOption("radiant.ace_useSoftTabs", TRUE), showInvisibles = getOption("radiant.ace_showInvisibles", FALSE), autoScrollEditorIntoView = TRUE, minLines = 7, maxLines = 20, autoComplete = "live", autoCompleters = c("static", "text"), autoCompleteList = isolate(radiant_sim_auto()) ) ), HTML(i18n$t("
")), verbatimTextOutput("summary_simulate"), conditionalPanel( condition = "input.sim_show_plots == true", HTML(i18n$t("
")), download_link("dlp_simulate"), plotOutput("plot_simulate", height = "100%") ) ), tabPanel( i18n$t("Repeat"), value = "Repeat", HTML(i18n$t("")), shinyAce::aceEditor( "rep_form", mode = "r", theme = getOption("radiant.ace_theme", default = "tomorrow"), wordWrap = TRUE, debounce = -1, height = "120px", value = state_init("rep_form", "") %>% fix_smart(), placeholder = i18n$t("Press the Repeat simulation button to repeat the simulation specified in the\nSimulate tab. Use formulas to perform additional calculations on the repeated\nsimulation data. Click the ? icon on the bottom left of your screen for help\nand examples"), vimKeyBinding = getOption("radiant.ace_vim.keys", default = FALSE), tabSize = getOption("radiant.ace_tabSize", 2), useSoftTabs = getOption("radiant.ace_useSoftTabs", TRUE), showInvisibles = getOption("radiant.ace_showInvisibles", FALSE), autoScrollEditorIntoView = TRUE, minLines = 7, maxLines = 20 ), conditionalPanel( "input.rep_add_functions == true", HTML(i18n$t("
")), shinyAce::aceEditor( "rep_funcs", mode = "r", theme = getOption("radiant.ace_theme", default = "tomorrow"), wordWrap = TRUE, debounce = -1, height = "120px", value = state_init("rep_funcs", "") %>% fix_smart(), placeholder = i18n$t("Create your own R functions (e.g., add = function(x, y) {x + y}).\nCall these functions from the 'formula' input and press the Run\nsimulation button to run the simulation. Click the ? icon on the\nbottom left of your screen for help and examples"), vimKeyBinding = getOption("radiant.ace_vim.keys", default = FALSE), tabSize = getOption("radiant.ace_tabSize", 2), useSoftTabs = getOption("radiant.ace_useSoftTabs", TRUE), showInvisibles = getOption("radiant.ace_showInvisibles", FALSE), autoScrollEditorIntoView = TRUE, minLines = 7, maxLines = 20 ) ), HTML(i18n$t("
")), verbatimTextOutput("summary_repeat"), conditionalPanel( condition = "input.rep_show_plots == true", HTML(i18n$t("
")), download_link("dlp_repeat"), plotOutput("plot_repeat", height = "100%") ) ) ) stat_tab_panel( menu = i18n$t("Model > Decide"), tool = i18n$t("Simulate"), data = NULL, tool_ui = "ui_simulater", output_panels = sim_output_panels ) }) ## creating autocomplete list for simuate - function editor radiant_sim_auto <- reactive({ pkgs <- c("stats", "base", "radiant.data") %>% sapply(function(x) grep("^[A-Za-z]", getNamespaceExports(x), value = TRUE)) %>% set_names(., paste0("{", names(.), "}")) inp <- clean_args(sim_inputs(), sim_args) %>% lapply(report_cleaner) nms <- base::intersect(c(sim_types_vec, "form"), names(inp)) auto_nms <- list() for (i in nms) { auto_nms[[paste0("{sim ", i, "}")]] <- strsplit(inp[[i]], ";\\s*")[[1]] %>% strsplit(., "(\\s+|=)") %>% base::Filter(length, .) %>% sapply(., `[[`, 1) } c(pkgs, auto_nms) }) ## auto completion for r-functions and defined variables observe({ req(isTRUE(input$sim_add_functions)) shinyAce::updateAceEditor( session, "sim_funcs", autoCompleters = c("static", "text"), autoCompleteList = radiant_sim_auto() ) }) .simulater <- eventReactive(input$sim_run, { validate( need( !is.empty(input$sim_types) || !is.empty(input$sim_form), i18n$t("No formulas or simulated variables specified") ) ) fixed <- fix_names(input$sim_name) updateTextInput(session, "sim_name", value = fixed) withProgress(message = i18n$t("Running simulation"), value = 0.5, { inp <- sim_inputs() inp$name <- fixed inp$envir <- r_data sim <- do.call(simulater, inp) if (is.data.frame(sim)) { r_data[[fixed]] <- sim register(fixed) } sim }) }) .summary_simulate <- eventReactive( { c(input$sim_run, input$sim_dec) }, { if (not_pressed(input$sim_run)) { i18n$t("** Press the Run simulation button to simulate data **") } else { summary(.simulater(), dec = input$sim_dec) } } ) sim_plot_width <- function() 650 sim_plot_height <- function() { sim <- .simulater() if (is.character(sim)) { 300 } else { if (dim(sim)[1] == 0) { 300 } else { ceiling(sum(sapply(sim, does_vary)) / 2) * 300 } } } .plot_simulate <- eventReactive(input$sim_run, { req(input$sim_show_plots) withProgress(message = i18n$t("Generating simulation plots"), value = 1, { .simulater() %>% { if (is.empty(.)) invisible() else plot(., shiny = TRUE) } }) }) .repeater <- eventReactive(input$rep_run, { fixed <- fix_names(input$rep_name) updateTextInput(session, "rep_name", value = fixed) withProgress(message = i18n$t("Repeated simulation"), value = 0.5, { inp <- rep_inputs() inp$name <- fixed inp$envir <- r_data rep <- do.call(repeater, inp) if (is.data.frame(rep)) { r_data[[fixed]] <- rep register(fixed) } rep }) }) .summary_repeat <- eventReactive( { c(input$rep_run, input$rep_dec) }, { if (not_pressed(input$rep_run)) { i18n$t("** Press the Repeat simulation button **") } else if (length(input$rep_sum_vars) == 0) { i18n$t("Select at least one Output variable") } else if (input$rep_byvar == ".sim" && is.empty(input$rep_nr)) { i18n$t("Please specify the number of repetitions in '# reps'") } else { summary(.repeater(), dec = input$rep_dec) } } ) rep_plot_width <- function() 650 rep_plot_height <- function() { if (length(input$rep_sum_vars) == 0) { return(300) } rp <- .repeater() if (is.character(rp)) { 300 } else { if (dim(rp)[1] == 0) { 300 } else { ceiling(sum(sapply(select(rp, -1), does_vary)) / 2) * 300 } } } .plot_repeat <- eventReactive(input$rep_run, { req(input$rep_show_plots) req(length(input$rep_sum_vars) > 0) if (input$rep_byvar == ".sim" && is.empty(input$rep_nr)) { return(invisible()) } # else if (input$rep_byvar == "rep" && is.empty(input$rep_grid)) { # return(invisible()) # } object <- .repeater() if (is.null(object)) { return(invisible()) } withProgress(message = i18n$t("Generating repeated simulation plots"), value = 1, { inp <- rep_plot_inputs() inp$shiny <- TRUE inp$x <- object do.call(plot, inp) }) }) report_cleaner <- function(x) { x %>% gsub("\n", ";", .) %>% gsub("[;]{2,}", ";", .) } simulater_report <- function() { sim_dec <- input$sim_dec %>% ifelse(is.empty(.), 3, .) outputs <- "summary" inp_out <- list(list(dec = sim_dec), "") figs <- FALSE if (isTRUE(input$sim_show_plots)) { outputs <- c("summary", "plot") inp_out[[2]] <- list(custom = FALSE) figs <- TRUE } ## report cleaner turns seed and nr into strings inp <- clean_args(sim_inputs(), sim_args) %>% lapply(report_cleaner) sim_name <- fix_names(input$sim_name) updateTextInput(session, "sim_name", value = sim_name) if (!is.empty(inp$seed)) inp$seed <- as_numeric(inp$seed) if (!is.empty(inp$nr)) inp$nr <- as_numeric(inp$nr) if (!"norm" %in% names(inp)) { inp$ncorr <- inp$nexact <- NULL } else { if (is.empty(inp$ncorr)) inp$ncorr <- NULL if (!is.empty(inp$nexact)) inp$nexact <- as.logical(inp$nexact) } for (i in c(sim_types_vec, "form")) { if (i %in% names(inp)) { inp[[i]] <- strsplit(inp[[i]], ";\\s*")[[1]] } } if (length(inp[["form"]]) == 1 && grepl("^#", inp[["form"]])) { inp[["form"]] <- NULL } if (is.empty(inp$data)) { inp$data <- NULL } else { inp$data <- as.symbol(inp$data) } pre_cmd <- paste0(sim_name, " <- ") if (!is.empty(input$sim_funcs)) { ## dealing with user defined functions in simulate tab pre_cmd <- gsub(" ", " ", input$sim_funcs) %>% gsub("\t", " ", .) %>% paste0("\n\n", pre_cmd) funcs <- parse(text = input$sim_funcs) lfuncs <- list() for (i in seq_len(length(funcs))) { tmp <- strsplit(as.character(funcs[i]), "(\\s*=|\\s*<-)")[[1]][1] lfuncs[[tmp]] <- as.symbol(tmp) } if (length(lfuncs) == 0) { pre_cmd <- paste0(sim_name, " <- ") inp$funcs <- NULL } else { inp$funcs <- lfuncs } } inp$name <- NULL update_report( inp_main = inp, fun_name = "simulater", inp_out = inp_out, pre_cmd = pre_cmd, xcmd = paste0("register(\"", sim_name, "\")"), outputs = outputs, inp = sim_name, figs = figs, fig.width = sim_plot_width(), fig.height = sim_plot_height() ) } observeEvent(input$repeater_report, { rep_dec <- input$rep_dec %>% ifelse(is.empty(.), 3, .) outputs <- "summary" inp_out <- list(list(dec = rep_dec), "") figs <- FALSE if (isTRUE(input$rep_show_plots)) { outputs <- c("summary", "plot") inp_out[[2]] <- list(custom = FALSE) figs <- TRUE } ## report cleaner turns seed and nr into strings inp <- clean_args(rep_inputs(), rep_args) %>% lapply(report_cleaner) rep_name <- fix_names(input$rep_name) updateTextInput(session, "rep_name", value = rep_name) inp$dataset <- fix_names(input$sim_name) updateTextInput(session, "sim_name", value = inp$dataset) if (!is.empty(inp$seed)) inp$seed <- as_numeric(inp$seed) if (!is.empty(inp$nr)) inp$nr <- as_numeric(inp$nr) if (input$rep_byvar == ".sim") inp$grid <- NULL if (!is.empty(inp[["form"]])) { inp[["form"]] <- strsplit(inp[["form"]], ";\\s*")[[1]] if (length(inp[["form"]]) == 1 && grepl("^#", inp[["form"]])) { inp[["form"]] <- NULL } } if (!is.empty(inp[["grid"]])) { inp[["grid"]] <- strsplit(inp[["grid"]], ";\\s*")[[1]] } inp$name <- NULL update_report( inp_main = inp, fun_name = "repeater", inp_out = inp_out, pre_cmd = paste0(rep_name, " <- "), xcmd = paste0("register(\"", rep_name, "\")"), outputs = outputs, inp = rep_name, figs = figs, fig.width = rep_plot_width(), fig.height = rep_plot_height() ) }) download_handler( id = "dlp_simulate", fun = download_handler_plot, fn = function() paste0(input$sim_name, "_sim"), type = "png", caption = i18n$t("Save simulation plots"), plot = .plot_simulate, width = sim_plot_width, height = sim_plot_height ) download_handler( id = "dlp_repeat", fun = download_handler_plot, fn = function() paste0(input$rep_name, "_rep"), type = "png", caption = i18n$t("Save repeated simulation plots"), plot = .plot_repeat, width = rep_plot_width, height = rep_plot_height ) observeEvent(input$simulater_report, { r_info[["latest_screenshot"]] <- NULL simulater_report() }) observeEvent(input$simulater_screenshot, { r_info[["latest_screenshot"]] <- NULL radiant_screenshot_modal("modal_simulater_screenshot") }) observeEvent(input$modal_simulater_screenshot, { simulater_report() removeModal() ## remove shiny modal after save })