nspace <- NS(id)

material_tab_content(

tab_id = id,

material_row(

material_column( # left: input and design parameters

width = 3,

material_card("Choose design",

# tagList("Read about the library ", a("here", href="https://declaredesign.org/library/")),

div(style="text-align: center;",

# add a selectbox to choose the design from DesignLibrary

uiOutput(nspace("import_design_lib_id")),

actionButton(nspace("import_from_design_lib"),

label = "Load",

disabled = "disabled"),

actionButton(inputId='learn_more', label= NULL,

icon = icon("question-circle"),

style = "text-align: center; padding-left: 8px; padding-right: 8px;",

'_blank')")

)

),

# show designer parameters if a design was loaded

hidden(div(id = nspace('design_params_panel_wrapper'),

material_card("Set design parameters",

uiOutput(nspace('design_vignette')),

br(),

textInput(nspace('design_arg_design_name'), 'Design name'),

conditionalPanel(paste0("output['", nspace('design_supports_fixed_arg'), "'] != ''"),

div(style="text-align: right;", uiOutput(nspace('fix_toggle_btn')))

),

uiOutput(nspace("design_parameters")) # display *all* arguments of an imported design

)

))

),

material_column( # center: design output

width = 9,

uiOutput(nspace("load_design_info")),

material_card("Download",

downloadButton(nspace('download_r_script'), label = 'R code', disabled = 'disabled'),

downloadButton(nspace('download_rds_obj'), label = 'Design as RDS file', disabled = 'disabled')),

bsCollapse(id=nspace('sections_container'), multiple = TRUE,

bsCollapsePanel('Warnings or errors', uiOutput(nspace("section_messages"))),

bsCollapsePanel('Summary', uiOutput(nspace("section_summary"))),

bsCollapsePanel('Code output', uiOutput(nspace('section_design_code'))),

bsCollapsePanel('Simulated data',

p("The following table shows a single draw of the data."),

actionButton(nspace("simdata_redraw"), label = "Redraw data", disabled = "disabled"),

downloadButton(nspace("simdata_download"), label = "Download data", disabled = "disabled"),

dataTableOutput(nspace("section_simdata_table"))),

bsCollapsePanel("About DeclareDesign Wizard",

p(" This project is generously supported by a grant from the Laura and John Arnold Foundation and seed funding from Evidence in Governance and Politics (EGAP)."),

tagList(" This software is in beta release. We welcome your feedback! Please report any issues ", a("here.", href="https://github.com/DeclareDesign/DDWizard/issues")))

)

)

)

)

options(warn = 1) # always directly print warnings

# -------------- reactive values definition --------------

react <- reactiveValues(

design = NULL, # parametric designer object (a closure)

design_id = NULL, # identifier for current design instance *after* being instantiated

design_code = '',

design_argdefinitions = NULL, # argument definitions for current design instance

design_name_once_changed = FALSE, # records whether design name was changed after import

fix_toggle = 'fix', # toggle for fixing/unfixing all design parameters. must be either "fix" or "unfix"

simdata = NULL, # a single draw of the data to be shown in the "simulated data" panel

captured_stdout = NULL, # captured output of print(design_instance). used in design summary

captured_errors = NULL, # captured errors and warnings during design creation

error_occurred = NULL, # detect whether error occurred in design_instance

warning_occurred = NULL, # detect whether warning occurred in design_instance

input_errors = NULL, # errors related to invalid inputs

captured_msgs = NULL, # captured messages during design creation

custom_state = list() # additional state values for bookmarking

)

# -------------- helper functions --------------

# Load the designer with the name `designer` (char string).

# For mysterious reasons, it is necessary to pass a namespace function `nspace` (created with `NS(<id>)`)

# *whenever this function is called for restoring a bookmark.*

load_designer <- function(designer, nspace = function(x) { x }) {

print(paste('loading designer', designer))

shinyjs::show(nspace('design_params_panel_wrapper'))

react$design_id <- designer

react$design <- getFromNamespace(react$design_id, 'DesignLibrary')

react$design_argdefinitions <- attr(react$design, 'definitions') # get the designer's argument definitions

react$design_name_once_changed <- FALSE

react$fix_toggle <- 'fix'

shinyjs::enable(nspace('download_r_script'))

shinyjs::enable(nspace('download_rds_obj'))

shinyjs::enable(nspace('simdata_redraw'))

shinyjs::enable(nspace('simdata_download'))

# replace xx_designer as xx_design

updateTextInput(session, nspace('design_arg_design_name'), value = gsub("designer","design", react$design_id))

# simulation data would react once new design is loaded

isolate({

d <- req(design_instance())

if (!is.null(react$custom_state$simdata)) {

simdata <- react$custom_state$simdata

react$custom_state$simdata <- NULL

} else {

simdata <- draw_data(d)

}

})

react$simdata <- simdata

# save this to state because it is not automatically restored from bookmark

react$custom_state$designer <- react$design_id

}

# -------------- reactive functions --------------

# arguments/parameters for react$design and their values taken from the inputs

design_args <- reactive({

output_args <- list()

if (!is.null(react$design)) { # return empty list if no designer given

switching <- isolate({ input$switching_designer })

if (is.null(switching)) { # happens on bookmark restore

switching <- TRUE

}

args <- get_designer_args(react$design)

args_eval <- evaluate_designer_args(args, attr(react$design, 'definitions'))

arg_defs <- react$design_argdefinitions # is NULL on first run, otherwise data frame of argument definitions (class, min/max)

if (is.null(arg_defs)) {

return(output_args) # empty list

}

fixed_args <- NULL

all_default <- TRUE

for (argname in names(args)) {

skip_specifc_args <- args_control_skip_specific_designer_args[[react$design_id]]

if (argname %in% args_control_skip_design_args || (!is.null(skip_specifc_args) && argname %in% skip_specifc_args))

next()

argdefault <- args_eval[[argname]]

argdefinition <- as.list(arg_defs[arg_defs$names == argname,])

inp_value <- input[[paste0('design_arg_', argname)]]

if (switching) { # if the designer was just changed, use its default values

# because the inputs still hold values from the prev. designer which might be incompatible

output_args[[argname]] <- design_arg_value_from_input(argdefault, argdefault, argdefinition, class(argdefault), typeof(argdefault))

} else { # otherwise use the inputs as usual

# convert an input value to a argument value of correct class

if (length(argdefinition) != 0) {

argvalue <- design_arg_value_from_input(inp_value, argdefault, argdefinition, class(argdefault), typeof(argdefault))

has_NAs <- !is.null(argvalue) && any(is.na(argvalue)) # may contain NAs where invalid input was supplied

if (!has_NAs && ((!is.null(argvalue) && is.null(argdefault))

|| (!is.null(argvalue) && argvalue != ''

&& (length(argvalue) != length(argdefault) || argvalue != argdefault))))

{

all_default <- FALSE

}

if (has_NAs || !is.null(argvalue)) { # add the value to the list of designer arguments

output_args[[argname]] <- argvalue

}

}

}

# determine whether argument was set in "args_to_fix"

arg_is_fixed_value <- input[[paste0('design_arg_', argname, '_fixed')]]

if (isTruthy(arg_is_fixed_value)) {

fixed_args <- c(fixed_args, argname)

# if at least one arg. is set to fixed, the toggle button is set to "Unfix all"

react$fix_toggle <- 'unfix'

updateActionButton(session, 'fix_toggle', label = 'Unfix all')

}

}

# additional designer arguments: design name and vector of fixed arguments

if (is.null(react$design_argdefinitions)) {

# output_args$design_name <- react$design_id # should always be a valid R object name

updateTextInput(session, 'design_arg_design_name', value = react$design_id)

} else if (!is.null(input$design_arg_design_name) && (!all_default || react$design_name_once_changed)) {

# output_args$design_name <- make_valid_r_object_name(input$design_arg_design_name)

# updateTextInput(session, 'design_arg_design_name', value = output_args$design_name)

react$design_name_once_changed <- TRUE

}

if (design_supports_fixed_arg()) {

output_args$args_to_fix <- fixed_args

}

}

output_args

})

# specific design instance generated from above react$design with specific parameter values `design_args()`

design_instance <- reactive({

d_inst <- NULL # design instance

react$input_errors <- NULL

react$captured_errors <- NULL

react$design_code <- ''

if (!is.null(react$design)) { # return NULL if no designer is given

msgs <- character()

error_occur <- FALSE

warning_occur <- FALSE

d_args <- design_args() # designer arguments

print('creating design instance with arguments:')

print(d_args)

d_args_NAs <- sapply(d_args, function(arg) { any(is.na(arg)) })

if (sum(d_args_NAs) > 0) {

react$input_errors <- paste('Invalid values supplied to the following arguments:',

paste(names(d_args_NAs)[d_args_NAs], collapse = ', '))

react$captured_errors <- 'Please correct the errors in the argument values first.'

} else {

conditions <- tryCatch(

expr = {

capture.output({

d_inst <- do.call(react$design, d_args)

# capture message prints, e.g in block_cluster_two_arm_designer

msgs <- paste0(capture.output(d_inst <- do.call(react$design, d_args)), collapse = "\n")

print(d_inst)

}, type = 'message')

}, error = function(e){

error_occur <<- TRUE

msgs <<- e

},warning = function(w){

warning_occur <<- TRUE

msgs <<- w

})

# create a design instance from the designer using the current arguments `d_args`

if (!error_occur) {

if (is.null(d_inst)) { # try again if we only got warnings (not errors)

d_inst <- do.call(react$design, d_args)

}

react$captured_stdout <- capture.output({ # capture output of `print(d_inst)`

print(d_inst) # to create summary output if and only if there is no error in d_inst

}, type = 'output')

} else {

react$captured_stdout <- ''

}

react$captured_errors <- conditions

react$captured_msgs <- msgs

react$error_occurred <- error_occur

react$warning_occurred <- warning_occur

if (!error_occur && !is.null(d_inst)){

# also update simulated data

react$simdata <- draw_data(d_inst)

# update design code

code_text <- paste(attr(d_inst, 'code'), collapse = "\n")

default_designer_name <- gsub("designer","design", react$design_id)

react$design_code <- gsub(default_designer_name,

make_valid_r_object_name(input$design_arg_design_name),

code_text)

}else{

react$simdata <- NULL

}

}

print('design instance changed')

}

d_inst

})

# return TRUE if designer supports "args_to_fix" argument, else FALSE

design_supports_fixed_arg <- reactive({

req(react$design)

#return(FALSE) # for testing

'args_to_fix' %in% names(formals(react$design))

})

# return a character vector that lists the arguments set in "args_to_fix"

get_fixed_design_args <- reactive({

req(react$design)

if (!design_supports_fixed_arg()) {

return(character()) # empty char vector

}

args <- get_designer_args(react$design)

args_fixed <- sapply(names(args), function(argname) {

inp_elem_name_fixed <- paste0('design_arg_', argname, '_fixed')

if (!is.null(input[[inp_elem_name_fixed]])) {

input[[inp_elem_name_fixed]]

} else {

NA

}

})

args_fixed <- args_fixed[!is.na(args_fixed)]

names(args_fixed)[args_fixed]

})

# returns TRUE if at least one designer argument was set in "args_to_fix", otherwise FALSE

at_least_one_design_arg_fixed <- reactive({

length(get_fixed_design_args()) > 0

})

# returns TRUE if all design arguments were set to fixed, otherwise FALSE

all_design_args_fixed <- reactive({

all_args <- get_designer_args(react$design)

args_fixed <- get_fixed_design_args()

length(args_fixed) == length(all_args)

})

# observer for the error message to unfold the message panel

# reactive expression returns true when there is no error or warning

message_close <- reactive({

req(react$warning_occurred)

req(react$error_occurred)

if (!isTRUE(react$warning_occurred) && !isTRUE(react$error_occurred)) {

return(TRUE)

} else {

return(NULL)

}

})

# reactive expression returns true when there is any error or warning

message_open <- reactive({

if (is.null(design_instance()) || isTRUE(react$warning_occurred) || isTRUE(react$error_occurred)){

return(TRUE)

} else {

return(NULL)

}

})

# -------------- event observers --------------

# input observer for click on design import

observeEvent(input$import_from_design_lib, {

# loads a pre-defined designer from the library

if (!is.null(input$import_design_library)) {

load_designer(input$import_design_library)

}

})

# input observer for click on "Fix/Unfix all" button

observeEvent(input$fix_toggle_click, {

args <- get_designer_args(react$design)

checkbox_val <- react$fix_toggle == 'fix'

for (argname in names(args)) {

inp_elem_name_fixed <- paste0('design_arg_', argname, '_fixed')

if (!is.null(input[[inp_elem_name_fixed]])) {

updateCheckboxInput(session, inp_elem_name_fixed, value = checkbox_val)

}

}

})

# input observer for click on "redraw data" button in "simulated data" section

observeEvent(input$simdata_redraw, {

isolate({

d <- req(design_instance())

if (!is.null(react$custom_state$simdata)) {

simdata <- react$custom_state$simdata

react$custom_state$simdata <- NULL

} else {

if (react$warning_occurred || react$error_occurred) {

simdata <- NULL

} else {

simdata <- draw_data(d)

}

}

})

react$simdata <- simdata

})

# unfold the message panel

observeEvent(message_open(),ignoreInit = TRUE,{

updateCollapse(session, "sections_container", open = 'Warnings or errors')

})

# fold back the message panel

observeEvent(message_close(),ignoreInit = TRUE,{

updateCollapse(session, "sections_container", close = 'Warnings or errors')

})

# -------------- output elements: hidden --------------

# hidden (for conditional panel)

output$design_supports_fixed_arg <- design_supports_fixed_arg

outputOptions(output, 'design_supports_fixed_arg', suspendWhenHidden = FALSE)

# -------------- output elements: left side --------------

# left side: designer description

output$design_description <- renderUI({

req(react$design)

HTML(attr(react$design, 'description'))

})

# create link to vignette based on design input from the library

output$design_vignette <- renderUI({

url <- paste0("window.open('https://declaredesign.org/r/designlibrary/articles/", gsub("_designer","",react$design_id), ".html', '_blank')")

actionButton(inputId='vignette', label=" Read more",

icon = icon("book"),

>