├── .Rprofile ├── .cache └── .gitignore ├── .gitattributes ├── .gitignore ├── DDWizard.Rproj ├── Makefile ├── NEWS.md ├── README.md ├── _docs ├── app_structure.Rmd ├── app_structure.html ├── ddnotes.Rmd ├── ddnotes.html ├── modules.png ├── modules.svg └── test_checklist.md ├── app.R ├── common.R ├── conf.R ├── inspect_helpers.R ├── inspect_plot_template.txt ├── renv.lock ├── renv ├── .gitignore ├── activate.R └── settings.dcf ├── tab_design.R ├── tab_inspect.R ├── tests ├── startup-expected │ ├── 001.json │ └── 001.png └── startup.R ├── tests_RUnit ├── .cache │ └── .gitignore ├── runit_common.R ├── runit_designers.R └── runit_inspect_helpers.R ├── uihelpers.R └── www ├── brand.png ├── custom.css ├── custom.js ├── data_protection_policy.html ├── get_started.html └── legal_notice.html /.Rprofile: -------------------------------------------------------------------------------- 1 | source("renv/activate.R") 2 | -------------------------------------------------------------------------------- /.cache/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore everything in this directory 2 | * 3 | # Except this file 4 | !.gitignore 5 | 6 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | _docs/*.html linguist-generated=true 2 | 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | _tmp/ 4 | .DS_Store 5 | .Rapp.history 6 | www/piwik.txt 7 | tests/load_all_designs-current/ 8 | shiny_bookmarks/ 9 | .rsyncexclude 10 | Makefile_server 11 | _docs/server* 12 | -------------------------------------------------------------------------------- /DDWizard.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 4 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Makefile 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | run_tests: run_tests_common run_tests_designers run_tests_inspect_helpers 2 | 3 | run_tests_common: 4 | cd tests_RUnit; rm .cache/*.RDS; echo "library(RUnit); runTestSuite(defineTestSuite('common', '.', 'runit_common.R'))" | R -q --vanilla; cd .. 5 | 6 | run_tests_designers: 7 | cd tests_RUnit; echo "library(RUnit); runTestSuite(defineTestSuite('designers', '.', 'runit_designers.R'))" | R -q --vanilla; cd .. 8 | 9 | run_tests_inspect_helpers: 10 | cd tests_RUnit; echo "library(RUnit); runTestSuite(defineTestSuite('inspect_helpers', '.', 'runit_inspect_helpers.R'))" | R -q --vanilla; cd .. 11 | 12 | run_shinytests: 13 | echo "library(shinytest); testApp()" | R -q --vanilla 14 | 15 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # DDWizard 0.1.0 2 | 3 | * Enables status cacheing/restoring: "SHARE" button creates a link that caches/restores app status (inputs and outputs) for easy sharing/saving. 4 | * Unfolds Warnings/messages automatically when the latter are captured by design 5 | * Displays link to vignette of selected designer 6 | * Displays descripton of loaded design at the top and values of fixed arguments 7 | * Allows selection of estimands to display in graph 8 | * Includes option to reshape downloaded diagnosis table from wide to long (with standard errors in square brackets). 9 | * Enables graphing parameters (x-axis, color, faceting) according to number of arguments being varied and with reactive options (selection removed from subsequent parameters) 10 | * Enables download of plot code (code to reproduce data included) 11 | * Input values react to changes in inputs in the DESIGN tab unless they were manually modified in the DIAGNOSIS tab. 12 | * Several enhancements and fixes to stability 13 | 14 | # DDWizard 0.0.99 15 | 16 | * First development version (March 2019) 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DeclareDesign Wizard 2 | 3 | A [Shiny app](http://shiny.rstudio.com/) for creating, editing and diagnosing research designs. 4 | 5 | Authors: 6 | 7 | - Clara Bicalho 8 | - Sisi Huang 9 | - Markus Konrad 10 | 11 | 12 | ## Dependencies 13 | 14 | ### Installing dependencies using *renv* 15 | 16 | DDWizard employs [renv](https://blog.rstudio.com/2019/11/06/renv-project-environments-for-r/) and we recommend using it, when you want to run DDWizard on your computer. If you haven't installed renv yet, please do so by running `install.packages('renv')`. After that, open the DDWizard RStudio project and run: 17 | 18 | ``` 19 | renv::restore() 20 | ``` 21 | 22 | This will install all required packages in an isolated package environment for DDWizard, i.e. it will not mess with your existing R package versions. Every time you open the DDWizard RStudio project, this package environment will be used. 23 | 24 | ### List of dependencies 25 | 26 | All dependencies are listed in the file `renv.lock`. 27 | 28 | 29 | ## Overview of files 30 | 31 | This shiny app displays several tabs, each of which is a separate shiny module (http://shiny.rstudio.com/articles/modules.html) implemented in the respective "tab_ ... .R" file. Hence `app.R` only implements the "skeleton" of the application. 32 | 33 | - `app.R`: Shiny application skeleton 34 | - `tab_design.R`: "Design" tab for loading and manipulating existing designs 35 | - `tab_inspect.R`: "Diagnose" tab for visual design inspection 36 | - `common.R`: Common utility functions 37 | - `inspect_helpers.R`: Utility functions for design inspection 38 | - `uihelpers.R`: UI related utility functions 39 | - `conf.R`: Configuration options 40 | 41 | 42 | ## Documentation 43 | 44 | The `_docs` folder contains the following documentation files that provide an overview: 45 | 46 | - `ddnotes.Rmd`: introduces designers from the DesignLibrary package from a DDWizard development perspective; read this first 47 | - `app_structure.Rmd`: gives and overview about the source code structure for DDWizard and some details that are quite specific for this app such as use of namespaces, use of Shiny UI extension packages as well as some notes on reactivity and running diagnoses 48 | 49 | 50 | ## Tests 51 | 52 | ### Unit tests 53 | 54 | Unit tests are implemented in the *tests* folder with [RUnit](https://cran.r-project.org/web/packages/RUnit/index.html). 55 | 56 | A shortcut to run all tests was added to the Makefile so you can run in the console: 57 | 58 | ``` 59 | make run_tests 60 | ``` 61 | 62 | ### Functional tests with shinytest 63 | 64 | We tried to setup [shinytest](https://rstudio.github.io/shinytest/) for DDWizard to record app states and then replay them to check automatically if (and where) the app doesn't provide the expected output if we changed the source or updated one of its dependency packages. Unfortunately, shinytest doesn't work well with our app and will fail with [an already reported error](https://github.com/rstudio/shinytest/issues/144) for all but the very simplest test, which is available in `tests/startup.R`. 65 | 66 | Once the shinytest package works with our package, we should generate more test cases like this: 67 | 68 | ```R 69 | library(shinytest) 70 | recordTest(seed = 1234) # setting a seed is important since simulations need to be the same 71 | ``` 72 | 73 | And test them via: 74 | 75 | ```R 76 | library(shinytest) 77 | testApp() # optionally provide `testnames = ...` 78 | ``` 79 | -------------------------------------------------------------------------------- /_docs/app_structure.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "DDWizard source code structure" 3 | author: "Markus Konrad " 4 | date: "July 29, 2019" 5 | output: 6 | html_document: 7 | toc: yes 8 | --- 9 | 10 | 11 | ## Introduction 12 | 13 | DDWizard is an [R shiny app](https://shiny.rstudio.com/). Since it is a fairly large shiny app we divided it into two [modules](https://shiny.rstudio.com/articles/modules.html) which reflect the (currently) two main uses of the app: 14 | 15 | - design: load a design*er* from the DesignLibrary, specify design parameters, simulate design, get its code, etc.; implemented in `tab_design.R` 16 | - diagnose (aka "inspect"): vary design parameters and investigate their effects on different diagnostic properties; implemented in `tab_inspect.R` 17 | 18 | UI-wise, these modules are represented as two tabs, "Design" and "Diagnose". 19 | 20 | The main Shiny app file `app.R` defines the overall layout, "global" input elements and actions (e.g. showing the help text or the bookmark feature) and calls both modules as depicted below: 21 | 22 | ![Module structure](modules.png) 23 | 24 | The design module exports several functions and objects (this is done in the final `return` statement in the last lines of `tab_design.R`) so that the diagnosis module can get access to specific parts of the design module. For example, the design module exports a function to get the current design instance. For more information on communication between R shiny modules see [this article](https://shiny.rstudio.com/articles/communicate-bet-modules.html). 25 | 26 | ### Namespaces 27 | 28 | Each module has its own *namespace* for UI inputs/outputs, named `tab_design` and `tab_inspect` respectively. A namespace function is generated per module via `nspace <- NS(id)` where `id` is the module ID (`tab_design` or `tab_inspect`). Two general main rules apply when working with namespaces in Shiny: 29 | 30 | 1. When **creating** an UI element (either dynamically during runtime or statically as defined in a UI function of the module) or when **updating** an UI element's value (e.g. `updateTextInput()`), **you must wrap the element ID in a namespace function**, e.g. `checkboxInput(nspace('my_checkbox'), label = 'On')`. 31 | 2. When **reading** the value of an UI element using the `input` object within a module's server definition, **you shall not use a namespace function** (e.g. you can use `input$my_checkbox` as usual). 32 | 33 | ## UI Design 34 | 35 | We use the following extension packages for Shiny for specific UI components: 36 | 37 | - [shinymaterial](https://ericrayanderson.github.io/shinymaterial/) for pages, tabs and "cards" (boxes of content) 38 | - [shinyBS](https://ebailey78.github.io/shinyBS/) ("Twitter Bootstrap components for Shiny") for collapsible panels and help texts in "popover" boxes 39 | - [shinyalert](https://cran.r-project.org/web/packages/shinyalert/index.html) for popup messages (modals) 40 | - [shinyjs](https://deanattali.com/shinyjs/) mostly for enabling / disabling buttons interactively 41 | 42 | The whole app is a `material_page` with two tabs, each defined in a separate module as `material_tab_content`. In both tabs, there is one `material_row` defined with two (design tab) or three (diagnose tab) `material_column`s. In each column, the UI components are placed inside boxes (`material_card`s). 43 | 44 | 45 | ## Reactivity 46 | 47 | ### "Design" tab 48 | 49 | Once a designer is loaded, UI elements with inputs for each parameter are created dynamically in the "Design" tab on the left side. The UI elements depend on the parameters (their type, range, etc.) that the designer excepts. For example, when the designer excepts a parameter "assignment probability" of type numeric in range [0, 1], then a numeric input with minimum 0 and maximum 1 is created for that parameter. All these parameter inputs are reactive, i.e. whenever the user changes one of these values, everything that depends on such a value gets updated. This includes: 50 | 51 | - messages, summary, code output and simulated data in the "Design" tab 52 | - default values for parameters in the "Diagnose" tab **that were not changed before by the user** 53 | 54 | In the background, each parameter value change triggers the creation of a new design instance from the designer given the parameters the user entered. Design instance creation may fail, e.g. when the user enters invalid values. This in turn triggers messages that are displayed in the output. 55 | 56 | ### "Diagnose" tab 57 | 58 | The UI in the "Diagnose" tab is a bit more complex. In the left side, varying parameter values can be specified as list of elements like "1, 2, 3" or sequences with step size like "10, 20, ..., 50" which will create the sequence 10, 20, 30, 40, 50. **Since all parameters can be potentially a sequence of numbers, each input is a text input, no matter what the actual type of the parameter is.** Some parameters except (or even require) vector inputs. For these parameters, users can enter a sequence of vectors in a text area field, e.g.: 59 | 60 | ``` 61 | (1, 2, 3), 62 | (5, 5, 5), 63 | (3, 2, 1, -10), 64 | (10, 20, ..., 100) 65 | ``` 66 | 67 | As you can see, sequences of vectors don't require the individual vectors to have the same length (however, a specific designer may have this requirement). Furthermore, sequences with step sizes as shown in the last row can be defined. 68 | 69 | The values entered by the user are parsed in `get_args_for_inspection()` (see `inspect_helpers.R`) and are converted to the expected type. Again, this may fail and raise error messages, e.g. when the user enters invalid values. 70 | 71 | The inputs for the parameters are parsed directly when the user changes a value (they are reactive), but they only come into effect once the user clicks "Run diagnoses / update plot" because of the potentially long running diagnosis process. The plot configuration on the right side behaves the same. Diagnoses will only be re-run if a parameter value or the simulation configuration changed, otherwise only the plot gets updated with the same data but different visual properties as defined in the plot configuration. 72 | 73 | 74 | ## Running diagnoses 75 | 76 | Running diagnoses for a given designer and a given set of varying parameters is done in `run_diagnoses()` in `common.R`. For each combination of the parameters, a design instance is created using `expand_design()` from DeclareDesign. For example, this will create two designs from the designer `two_arm_designer` included in DesignLibrary, one with $N = 10$, the other with $N = 20$ (won't show the full output of the designs here because it is too long): 77 | 78 | ```{r, message=FALSE} 79 | library(DeclareDesign) 80 | library(DesignLibrary) 81 | 82 | 83 | all_designs <- expand_design(two_arm_designer, expand = TRUE, N = c(10, 20)) 84 | length(all_designs) 85 | ``` 86 | 87 | In order to generate designs from an arbitrary list of (varying) parameters that come from the user input, we can use rlang's `eval_bare()` as below: 88 | 89 | ```{r} 90 | library(rlang) 91 | 92 | params <- list( 93 | 'N' = c(10, 20, 30, 40), 94 | 'assignment_prob' = c(0.5, 0.7), 95 | 'ate' = c(0.1, 1, 2), 96 | 'control_sd' = 0.1 # this is constant across all designs 97 | ) 98 | 99 | all_designs <- eval_bare(expr(expand_design(designer = two_arm_designer, expand = TRUE, !!!params))) 100 | length(all_designs) 101 | ``` 102 | 103 | As a result of the combination of all parameter values, this created $4 \cdot 2 \cdot 3 \cdot 1 = 24$ designs. 104 | 105 | After that, simulations can be run for all designs using `simulate_designs()` from DeclareDesign. Here, we run a very low number of simulations (10) for each of the 24 designs because it takes quite some time: 106 | 107 | ```{r, warning=FALSE} 108 | simdata <- simulate_designs(all_designs, sims = 10) 109 | head(simdata) 110 | ``` 111 | 112 | The final step is to run the diagnoses. Again, we use a very small number of bootstrap simulations: 113 | 114 | ```{r} 115 | diag_results <- diagnose_designs(simdata, bootstrap_sims = 10) 116 | head(diag_results$diagnosands_df) 117 | ``` 118 | 119 | As already mentioned, these steps take quite some time to compute. We employ parallel processing and caching to reduce the runtime as explained below. 120 | 121 | ### Parallel processing 122 | 123 | Simulation and diagnoses are implemented to run in parallel in DeclareDesign when the packages "future" and "future.apply" are installed and a parallel processing "plan" is created using `plan()`. Currently, this is done using the "multicore" strategy which spawns R child processes. 124 | 125 | ### Caching 126 | 127 | Both of the above steps are cached. This means, with the exact same input (designer and the user defined parameter space) we will load a file from disk that contains the already calculated results and return these results instead of running the computations. If such a cache file doesn't exist, the computations are run and the results are stored to disk so that they can be retrieved the next time when a diagnosis should be run with the exact same input arguments. 128 | 129 | In order to check if a cache file exists for the same input arguments, a unique code string (an MD5 hash) is generated for the given parameter set, the simulation configuration (num. of simulations and bootstraps), the **source code of the designer** and a cache version (see `get_diagnosis_cache_filename()` in `common.R`). Whenever one of these elements changes only a little bit, the MD5 hash is completely different. 130 | 131 | The cache is stored in the `.cache` folder. 132 | 133 | 134 | ## Share / bookmark feature 135 | 136 | We use Shiny's [bookmarking feature](https://shiny.rstudio.com/articles/bookmarking-state.html) (see also ["Bookmarking and modules"](https://shiny.rstudio.com/articles/bookmarking-modules.html)) to let users share a state of the app via a generated URL. This means the user can work with DDWizard, e.g. create a diagnosis for a design, and then press the "Share" button in the top left corner which will generate an URL that the user can share. When someone else visits that URL, the same state of the app will be restored, e.g. it will show the same diagnosis results with the same inputs, settings, etc. as entered by the user before that shared the URL. 137 | 138 | Custom bookmarking code is implemented at "global" level in `app.R` and at module level in `tab_design.R` and `tab_inspect.R` in the respective `onBookmark()` / `onRestore()` functions. 139 | 140 | -------------------------------------------------------------------------------- /_docs/ddnotes.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Notes on DeclareDesign *designers*" 3 | author: "Markus Konrad" 4 | date: "July 29, 2019" 5 | output: html_document 6 | --- 7 | 8 | This document is a set of notes about DeclareDesign and the *designers* in its DesignLibrary package from a DDWizard development perspective. 9 | 10 | 11 | ```{r, message=FALSE} 12 | library(DeclareDesign) 13 | packageVersion('DeclareDesign') 14 | ``` 15 | 16 | ```{r} 17 | library(DesignLibrary) 18 | packageVersion('DesignLibrary') 19 | ``` 20 | 21 | ## Designers 22 | 23 | *Designers* are parametric "templates" for specific *designs*. So the the distinction between design*er* and design is important. The latter is a specific instance of a designer given a set of parameters. 24 | 25 | A designer is a function, e.g. the `two_arm_designer`: 26 | 27 | ```{r} 28 | class(two_arm_designer) 29 | ``` 30 | 31 | It has some attributes that provide meta-data for the designer: 32 | 33 | ```{r} 34 | attributes(two_arm_designer) 35 | ``` 36 | 37 | ```{r} 38 | attr(two_arm_designer, 'description') 39 | ``` 40 | 41 | These attributes are important for DDWizard. For example, the `definitions` attribute specifies the designer's arguments, their type, range and whether they except a vector as input. These metadata are an addition to what is returned by `formals()` as explained in the next section. 42 | 43 | ### Designer parameters 44 | 45 | You can get a designer's arguments and their default values as list with `formals()`: 46 | 47 | ```{r} 48 | formals(two_arm_designer) 49 | ``` 50 | 51 | As you can see, parameters can also accept R syntax (like the default values for `treatment_mean` and `control_sd`) which is evaluated inside the designer function. 52 | 53 | 54 | ## A specific design instance 55 | 56 | Calling a designer function with some specific parameters generates a specific design instance: 57 | 58 | ```{r} 59 | two_arm_N10 <- two_arm_designer(N = 10) 60 | two_arm_N10 61 | ``` 62 | 63 | This instance contains all the steps of the designer, but with specific parameters set. It's a special list of classes "design" and "dd": 64 | 65 | ```{r} 66 | class(two_arm_N10) 67 | ``` 68 | 69 | ```{r} 70 | typeof(two_arm_N10) 71 | ``` 72 | 73 | All steps can be accessed by name: 74 | 75 | ```{r} 76 | names(two_arm_N10) 77 | ``` 78 | 79 | ```{r} 80 | two_arm_N10$population 81 | ``` 82 | 83 | Generate a random population with the parameters specified by the designer: 84 | 85 | ```{r} 86 | two_arm_N10$population() 87 | ``` 88 | 89 | 90 | Parameters cannot be changed here any more: 91 | 92 | ```{r, eval=FALSE} 93 | two_arm_N10$population(N = 20) 94 | ## Error in two_arm_N10$population(N = 20) : unused argument (N = 20) 95 | ``` 96 | 97 | There are more attributes to the design instance: 98 | 99 | ```{r} 100 | attributes(two_arm_N10) 101 | ``` 102 | 103 | Attribute "code" reproduces the design instance: 104 | 105 | ```{r} 106 | attr(two_arm_N10, 'code') 107 | ``` 108 | 109 | -------------------------------------------------------------------------------- /_docs/modules.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DeclareDesign/DDWizard/ba0320b6931cf3328cc1872e86af3ef103ea7a7e/_docs/modules.png -------------------------------------------------------------------------------- /_docs/modules.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 29 | 34 | 35 | 36 | 54 | 57 | 58 | 60 | 61 | 63 | image/svg+xml 64 | 66 | 67 | 68 | 69 | 70 | 74 | 83 | 88 | 95 | design moduletab_design.R 111 | 112 | 117 | 124 | diagnose moduletab_inspect.R 140 | 141 | 148 | provide access 161 | 170 | global functionality: save bookmark, restore bookmark, help, etc. 183 | Main shiny app / app.R 198 | 199 | 200 | -------------------------------------------------------------------------------- /_docs/test_checklist.md: -------------------------------------------------------------------------------- 1 | # Checklist for testing the app 2 | 3 | Since automatted testing (of the interface) doesn't really work (see details in `README.md`), I propose the following checklist that should be used before committing major changes: 4 | 5 | 6 | - [ ] load all designers in design tab, open at least the "source" box and switch to inspect tab one by one 7 | - [ ] for random designers, change values in design tab 8 | - make sure to include vector inputs 9 | - also try input errors (e.g. "1, foo, 2" in a numeric vector input) 10 | - randomly fix/unfix an argument 11 | - check "read more" button 12 | - [ ] for random designers, change values in inspect tab 13 | - make sure to include lists of vectors 14 | - also try input errors (e.g. "1, foo, 2" in a numeric vector input) 15 | - randomly fix/unfix an argument 16 | - [ ] for a random designer and random inputs: 17 | - download the R code and the RDS file 18 | - redraw the simulated data and download it 19 | - [ ] for a random designer and random inputs, diagnose a design 20 | - randomly change plot config. 21 | - download plot 22 | - download plot code 23 | - show diagnosis box 24 | - download reduced and full diagnosis results 25 | - [ ] for random designer and random inputs create a bookmark and restore it in a different browser window 26 | - [ ] help, legal notice, data protection policy buttons 27 | -------------------------------------------------------------------------------- /app.R: -------------------------------------------------------------------------------- 1 | # DeclareDesign Wizard shiny app. 2 | # 3 | # This shiny app displays several tabs, each of which is a separate shiny module (http://shiny.rstudio.com/articles/modules.html) 4 | # implemented in the respective "tab_ ... .R" file. Hence this file only implements the "skeleton" of the application. 5 | # 6 | # Clara Bicalho 7 | # Markus Konrad 8 | # Sisi Huang 9 | # 10 | # Dec. 2018 11 | # 12 | 13 | library(DesignLibrary) 14 | library(shiny) 15 | library(shinymaterial) 16 | library(shinyalert) 17 | library(shinyBS) 18 | library(shinyjs) 19 | library(stringr) 20 | library(stringi) 21 | library(dplyr) 22 | library(MASS) 23 | 24 | source('conf.R') 25 | source('common.R') 26 | source('uihelpers.R') 27 | source('tab_design.R') 28 | source('tab_inspect.R') 29 | 30 | 31 | # -------------- Frontend: User interface definition -------------- 32 | 33 | piwik_code_file <- 'www/piwik.txt' 34 | if (file.exists(piwik_code_file)) { 35 | piwik_code <- readChar(piwik_code_file, file.info(piwik_code_file)$size) 36 | print('using PiWik code') 37 | } else { 38 | piwik_code <- '' 39 | } 40 | 41 | ui <- function(request) { 42 | material_page( 43 | # title 44 | nav_bar_fixed = TRUE, 45 | nav_bar_color = "white", 46 | title = tags$img(src="brand.png", height = 52.5, width = 300), 47 | 48 | 49 | # additional JS / CSS libraries 50 | bootstrapLib(), 51 | withMathJax(), 52 | tags$head( 53 | tags$link(rel = "stylesheet", type = "text/css", href = "custom.css"), 54 | HTML(piwik_code), 55 | tags$title(app_title) 56 | ), 57 | shinyjs::useShinyjs(), 58 | shinyjs::extendShinyjs(script = 'www/custom.js', functions = c("registerBookmarkModalClickHandler", 59 | "unregisterBookmarkModalClickHandler")), 60 | 61 | div( 62 | HTML(sprintf(' 63 | Give feedback', feedback_form_url)), 64 | bookmarkButton("Share", 65 | title = "Share the status of your design and diagnoses", 66 | class = "btn btn-sm", 67 | icon = NULL), 68 | id = "top_button_row" 69 | ), 70 | 71 | # tabs 72 | material_tabs( 73 | tabs = c( 74 | "Design" = "tab_design", 75 | "Diagnose" = "tab_inspect" 76 | ), 77 | color = "blue" 78 | 79 | ), 80 | 81 | # "Design" tab 82 | useShinyalert(), 83 | designTabUI('tab_design'), 84 | 85 | # "Inspect" tab 86 | inspectTabUI('tab_inspect'), 87 | 88 | #Footer 89 | tags$footer( 90 | actionLink("show_help_text", "Help"), 91 | span(' | '), 92 | actionLink('show_legal_notice', 'Legal notice'), 93 | span(' | '), 94 | actionLink('show_data_protection_policy', 'Data protection policy'), 95 | 96 | align = "center", style = " 97 | bottom:0; 98 | width:100%; 99 | color: black; 100 | padding: 10px; 101 | background-color: #F5F5F5; 102 | z-index: 1000;" 103 | ) 104 | ) 105 | } 106 | 107 | # -------------- Backend: Input handling and output generation on server -------------- 108 | 109 | server <- function(input, output, session) { 110 | insp_changed_args <- character() 111 | 112 | design_tab_proxy <- callModule(designTab, 'tab_design') 113 | inspect_tab_proxy <- callModule(inspectTab, 'tab_inspect', design_tab_proxy) 114 | 115 | # -------------- observers for global events -------------- 116 | 117 | # get started button clicked 118 | observeEvent(input$show_help_text,{ 119 | alert_with_content_from_html_file('Welcome to DDWizard', 'www/get_started.html', 'Get started') 120 | }) 121 | 122 | # legal notice button clicked 123 | observeEvent(input$show_legal_notice, { 124 | alert_with_content_from_html_file('Legal notice', 'www/legal_notice.html', className = 'wide') 125 | }) 126 | 127 | # data protection button clicked 128 | observeEvent(input$show_data_protection_policy, { 129 | alert_with_content_from_html_file('Data protection policy', 'www/data_protection_policy.html', className = 'wide') 130 | }) 131 | 132 | # observe changes between tabs 133 | observe({ 134 | if (!is.null(input$current_tab)) { # initially, currentTab is NULL; it only gets a value after the first tab change 135 | if (input$current_tab == 'tab_inspect') { # check if change to "inspect" tab occurred 136 | # when switching from design to inspect tab, pass the recorded arguments from below (i.e. those that the 137 | # user changed previously in the inspect tab). we will not override these arguments' values with values 138 | # from the design tab. 139 | inspect_tab_proxy$set_changed_args(insp_changed_args) 140 | } else if (input$current_tab == 'tab_design') { # check if change to "design" tab occurred 141 | # when switching from inspect to design tab, record which arguments the user changed in the inspect tab, 142 | # i.e. which of the values in the inspect tab differ from those in the design tab. 143 | # when switching back to the inspect tab, we will not override these with values from the design tab. 144 | isolate({ 145 | insp_changed_args <<- inspect_tab_proxy$get_changed_args() 146 | }) 147 | } 148 | } 149 | }) 150 | 151 | # observe show intro event which is triggered on start from custom.js when no bookmark is restored 152 | observe({ 153 | req(input$show_intro_modal) 154 | alert_with_content_from_html_file('Welcome to DDWizard', 'www/get_started.html', 'Get started') 155 | }) 156 | 157 | # -------------- bookmarking -------------- 158 | 159 | # handling of bookmarking via "SHARE" button on top right 160 | 161 | onBookmark(function(state) { 162 | print('BOOKMARKING IN APP:') 163 | state$values$current_tab <- input$current_tab 164 | print(state$values$current_tab) 165 | }) 166 | 167 | onBookmarked(function(url) { 168 | shinyalert( 169 | title = 'Save and share', 170 | text = sprintf('

You can save and share the current state of your design and diagnosis with the following link:

171 | 172 |
Copy to clipboard', url), 173 | closeOnEsc = TRUE, 174 | closeOnClickOutside = TRUE, 175 | html = TRUE, 176 | showConfirmButton = TRUE, 177 | showCancelButton = FALSE, 178 | confirmButtonText = "OK", 179 | timer = 0, 180 | imageUrl = "", 181 | confirmButtonCol = "light-blue darken-3", 182 | animation = TRUE, 183 | callbackR = function(x) { shinyjs::js$unregisterBookmarkModalClickHandler(); } 184 | ) 185 | shinyjs::js$registerBookmarkModalClickHandler(); 186 | }) 187 | 188 | onRestore(function(state) { 189 | # open the bookmarked tab 190 | shinymaterial::select_material_tab(session, state$values$current_tab) 191 | }) 192 | } 193 | 194 | # Run the application 195 | shinyApp(ui = ui, server = server, enableBookmarking = 'server') 196 | -------------------------------------------------------------------------------- /common.R: -------------------------------------------------------------------------------- 1 | # Common utility functions. 2 | # 3 | # Markus Konrad 4 | # Clara Bicalho 5 | # Sisi Huang 6 | # 7 | # Oct. 2018 8 | # 9 | 10 | library(shiny) 11 | library(stringr) 12 | library(future) 13 | library(rlang) 14 | library(digest) 15 | library(DeclareDesign) 16 | 17 | 18 | # Append `v` to list `l` and return the resulting list. Appending is slow, don't use that often! 19 | list_append <- function(l, v) { 20 | l[[length(l)+1]] <- v 21 | l 22 | } 23 | 24 | # Merge list `l1` with `l2` and return combined list. If the same key exists in both lists, the 25 | # value in `l2` will overwrite the value in `l1`. 26 | list_merge <- function(l1, l2) { 27 | l_out <- list() 28 | keys1 <- names(l1) 29 | keys2 <- names(l2) 30 | 31 | for (k in keys1) { l_out[[k]] <- l1[[k]] } 32 | for (k in keys2) { l_out[[k]] <- l2[[k]] } 33 | 34 | stopifnot(setequal(union(keys1, keys2), names(l_out))) 35 | 36 | l_out 37 | } 38 | 39 | # Get "tips" from `definitions` attribute of designer 40 | get_tips <- function(designer){ 41 | def <- attr(designer, "definitions") 42 | split(def$tips, def$names) 43 | } 44 | 45 | # Check if lists `a` and `b` have equal elements in a "shallow" way, i.e. *not* traversing recursively 46 | # through nested lists. 47 | lists_equal_shallow <- function(a, b, na.rm = FALSE) { 48 | if (na.rm) { 49 | a <- a[!is.na(a)] 50 | b <- b[!is.na(b)] 51 | } 52 | 53 | if (!setequal(names(a), names(b))) { 54 | return(FALSE) 55 | } 56 | 57 | all(sapply(names(a), function (e) { 58 | a_elem <- a[[e]] 59 | b_elem <- b[[e]] 60 | 61 | if (na.rm) { # doing this here already because we need to remove NAs before checking length() 62 | a_elem <- a_elem[!is.na(a_elem)] 63 | b_elem <- b_elem[!is.na(b_elem)] 64 | } 65 | 66 | is.numeric(a_elem) && is.numeric(b_elem) && length(a_elem) == length(b_elem) && all(a_elem == b_elem) 67 | })) 68 | } 69 | 70 | 71 | # Round numeric values in a data frame to `digits`. 72 | # Copied from "wizard_shiny" repository. 73 | round_df <- function(df, digits){ 74 | i <- vapply(df, is.numeric, TRUE) 75 | df[i] <- lapply(df[i], round, digits) 76 | df 77 | } 78 | 79 | # Parse a sequence string `s` in the form of "n, n+s, ..., m", e.g. "1, 2, ..., 5" or "0, 0.25, ..., 1", etc. 80 | # Convert the result to a vector of class `cls`. 81 | # Finds the step `s` and generates the sequence using `seq()`. 82 | # If a sequence without ellipsis that indicate range is passed, then the sequence is used as is. So 83 | # a string of "1, 3, 8, 2" will just be split and converted depending on `cls`. 84 | # Is fault tolerant to commas, so "1, 2 ... 5" is also accepted. 85 | # 86 | # If you want to react on input errors, this function should be wrapped inside a tryCatch expression. 87 | parse_sequence_string <- function(s, cls = 'numeric') { 88 | if (cls %in% c('numeric', 'integer') && grepl('...', s, fixed = TRUE)) { # int/num sequences with range like 1, 2, ..., 10 89 | start_end <- str_split(s, "\\.\\.\\.")[[1]] 90 | start <- str_trim(str_split(start_end[1], ',')[[1]]) 91 | startnums <- as.numeric(start[start != '']) 92 | 93 | end <- str_trim(str_replace_all(start_end[[2]], ',', '')) 94 | endnum <- as.numeric(end) 95 | 96 | if (length(startnums) > 1) { 97 | step <- startnums[2] - startnums[1] 98 | } else { 99 | step <- ifelse(startnums[1] <= endnum, 1, -1) 100 | } 101 | 102 | return(seq(from = startnums[1], to = endnum, by = step)) 103 | } else { # character list or int/num scalar or int/num sequence like 1, 3, 8, 2 104 | elems <- str_trim(str_split(s, ',')[[1]]) 105 | elems <- elems[nchar(elems) > 0] 106 | if (cls %in% c('numeric', 'integer')) { 107 | if (length(elems) == 1 && elems == '') { 108 | return(numeric()) 109 | } else { 110 | return(as.numeric(elems)) 111 | } 112 | } else { 113 | if (length(elems) == 1 && elems == '') { 114 | return(character()) 115 | } else { 116 | return(elems) 117 | } 118 | } 119 | } 120 | } 121 | 122 | # Parse a string `s` that denotes a sequence of sequences of class `cls` such as: 123 | # 124 | # '(1, 2, 3), (4, 5, 6), (7,8, 9)' 125 | # or 126 | # '(1, 2, 3), 127 | # (4, 5, 6), 128 | # (7,8, 9)' 129 | # or 130 | # (1, 2) (3) (4, 5 ,6) 131 | # 132 | # Note the inner sequences must be denoted as "(a, b, ... z)", i.e. there must be a comma to 133 | # split the values. However, to split the sequences themselves no comma is needed. 134 | # 135 | # If `require_rectangular` is TRUE, all sequences in `s` must be of the same length, i.e. they 136 | # must form a regular, rectangular matrix (like the first two examples). The output will then 137 | # be a matrix of size NxM, where N is the number of sequences and M is the number of items in 138 | # each sequence. If `s` does not form a regular matrix, NULL will be returned. 139 | # If `require_rectangular` is TRUE, the sequences in `s` can be of any length > 0. The output will 140 | # then be a list of length N, where N is the number of sequences. Each list item is then a numeric 141 | # vector of variable length. 142 | # 143 | # If you want to react on input errors, this function should be wrapped inside a tryCatch expression. 144 | # 145 | # If the input cannot be parsed, NULL will be returned. 146 | parse_sequence_of_sequences_string <- function(s, cls = 'numeric', require_rectangular = FALSE) { 147 | if (str_trim(s) == '') return(list()) 148 | 149 | m <- gregexpr('\\(([^\\(\\)]*)\\)', s) 150 | vecs <- regmatches(s, m) 151 | 152 | if (length(vecs[[1]]) == 0) { 153 | return(NULL) 154 | } 155 | 156 | parsed <- sapply(vecs[[1]], function(v) { 157 | v <- gsub('[\\(\\)]', '', v) 158 | if (cls == 'character') { 159 | v <- gsub('["\']', '', v) 160 | } 161 | parse_sequence_string(v, cls = cls) 162 | }, USE.NAMES = FALSE, simplify = require_rectangular) 163 | 164 | if (require_rectangular) { 165 | if (class(parsed) != 'list') { 166 | return(t(parsed)) 167 | } else { 168 | return(NULL) 169 | } 170 | } else { 171 | return(parsed) 172 | } 173 | } 174 | 175 | 176 | # Turn a string `s` into a valid R object name. 177 | make_valid_r_object_name <- function(s) { 178 | # Identifiers consist of a sequence of letters, digits, the period (‘.’) and the underscore. 179 | # They must not start with a digit or an underscore, or with a period followed by a digit. 180 | # — R Language Definition 181 | s <- str_replace_all(s, '[^A-Za-z0-9\\._]', '_') 182 | s <- str_replace(s, '^[\\d_]+', '') 183 | str_replace(s, '^\\.\\d+', '') 184 | } 185 | 186 | 187 | # Return a list of valid designer parameters 188 | get_designer_args <- function(designer) { 189 | formals(designer) 190 | } 191 | 192 | # Take a argument value `arg_val` from a designer with class `arg_class` and `arg_is_vector` indicating if 193 | # the designer expects this argument to be a vector. Convert the argument to fractions for numbers with many repeating digits 194 | # (like 0.333... will become 1/3). 195 | # If `to_char` is TRUE, additionally convert the result to a character vector as formatted for an input box (e.g. 196 | # "(1/3, 1/3, 1/3)" for a vector input with fractions). 197 | designer_arg_value_to_fraction <- function(arg_val, arg_class, arg_is_vector, to_char = FALSE) { 198 | # try to convert to fractions if there is a number with many repeating digits after the decimal point like "0.3333333333" 199 | if (arg_class == "numeric" && any(grepl(sprintf('\\.(%s)$', paste(sprintf('%s{10,}', 1:9), collapse = '|')), as.character(arg_val)))) { 200 | arg_val <- MASS::fractions(arg_val) 201 | } 202 | 203 | if (to_char) { 204 | arg_val <- as.character(arg_val) 205 | 206 | if (arg_is_vector) { # vector of vectors input 207 | return(sprintf('(%s)', paste(arg_val, collapse = ', '))) 208 | } else { 209 | return(arg_val) 210 | } 211 | } else { 212 | arg_val 213 | } 214 | } 215 | 216 | 217 | # evaluate argument defaults of designers in separate environment (because they might be "language" constructs) 218 | # return evaluated argument defaults 219 | # `args` is a list of arguments with defaults as returned from `formals()` 220 | evaluate_designer_args <- function(args, definition) { 221 | eval_envir <- new.env() 222 | 223 | args_eval <- lapply(1:length(args), function(a) { 224 | argdef <- definition[a,] 225 | 226 | # convert the value to fraction if necessary 227 | evaluated_arg <- designer_arg_value_to_fraction(invisible(eval(args[[a]], envir = eval_envir)), argdef$class, argdef$vector) 228 | 229 | invisible(assign(x = names(args)[a], value = evaluated_arg, envir = eval_envir)) 230 | hold <- invisible(get(names(args)[a], envir = eval_envir)) 231 | if(length(hold) > 1) hold <- paste0(hold, collapse = ", ") 232 | return(hold) 233 | }) 234 | 235 | names(args_eval) <- names(args) 236 | args_eval 237 | } 238 | 239 | # get cache file name unique to cache type `cachetype` (designs, simulation or diagnosis results), 240 | # parameter space `args`, number of (bootstrap) simulations `sims`, designer object `designer` 241 | get_diagnosis_cache_filename <- function(cachetype, args, sims, bs_sims, designer) { 242 | fingerprint_args <- args 243 | fingerprint_args$sims <- sims 244 | fingerprint_args$bs_sims <- bs_sims 245 | fingerprint_args$designer_src <- deparse(designer) 246 | fingerprint_args$cache_version <- 1 # increment whenever the simulated data in cache is not compatible anymore (i.e. DD upgrade) 247 | fingerprint <- digest(fingerprint_args) # uses MD5 248 | 249 | # print('CACHE FINGERPRINT ARGS/') 250 | # print(fingerprint_args) 251 | # print('/CACHE FINGERPRINT ARGS') 252 | 253 | sprintf('.cache/%s_%s.RDS', cachetype, fingerprint) 254 | } 255 | 256 | 257 | # Run diagnoses on designer `designer` and parameter space `args`. Run `sims` simulations and `bootstrap_sims` bootstraps. 258 | # `diagnosands_call` is a closure to calculate the diagnosands 259 | # If `use_cache` is TRUE, check if simulated data already exists for this designer / parameter combinations and use cached 260 | # data or create newly simulated data for running diagnoses. 261 | # The simulations are run in parallel if packages `future` and `future.apply` are installed. 262 | run_diagnoses <- function(designer, args, sims, bootstrap_sims, diagnosands_call, use_cache = TRUE, 263 | advance_progressbar = 0, n_diagnosis_workers = 1) { 264 | if (n_diagnosis_workers > 1) { 265 | # set up to run in parallel 266 | plan('multicore', workers = n_diagnosis_workers) 267 | } 268 | 269 | all_designs <- NULL 270 | if (use_cache) { 271 | # cache fingerprint generated from designer object, simulation config. and parameter space 272 | designs_cache_file <- get_diagnosis_cache_filename('designs', args, NULL, NULL, designer) 273 | 274 | if (file.exists(designs_cache_file)) { # read and return result object from cache 275 | if (advance_progressbar) incProgress(advance_progressbar) 276 | all_designs <- readRDS(designs_cache_file) 277 | print('loaded generated designs from cache') 278 | } 279 | } else { 280 | designs_cache_file <- NULL 281 | } 282 | 283 | if (is.null(all_designs)) { # generate designs 284 | # generate designs from designer with arguments `args` 285 | all_designs <- eval_bare(expr(expand_design(designer = designer, expand = TRUE, !!!args))) 286 | if (advance_progressbar) incProgress(advance_progressbar) 287 | 288 | # save designs to cache if requested 289 | if (!is.null(all_designs) && !is.null(designs_cache_file)) { 290 | saveRDS(all_designs, designs_cache_file) 291 | } 292 | } 293 | 294 | from_cache <- FALSE # records if some data was loaded from cache 295 | simdata <- NULL 296 | if (use_cache) { 297 | # cache fingerprint generated from designer object, simulation config. and parameter space 298 | cache_file <- get_diagnosis_cache_filename('simdata', args, sims, NULL, designer) 299 | 300 | if (file.exists(cache_file)) { # read and return result object from cache 301 | if (advance_progressbar) incProgress(advance_progressbar) 302 | simdata <- readRDS(cache_file) 303 | print('loaded simulation data from cache') 304 | from_cache <- TRUE 305 | } 306 | } else { 307 | cache_file <- NULL 308 | } 309 | 310 | 311 | if (is.null(simdata)) { # generate simulations 312 | # simulate data 313 | simdata <- simulate_designs(all_designs, sims = sims) 314 | if (advance_progressbar) incProgress(advance_progressbar) 315 | 316 | # save simulations to cache if requested 317 | if (!is.null(simdata) && !is.null(cache_file)) { 318 | saveRDS(simdata, cache_file) 319 | } 320 | } 321 | 322 | diag_res <- NULL 323 | if (use_cache) { 324 | stopifnot(!is.null(cache_file)) 325 | # make the cache fingerprint dependent on simulated data's fingerprint and on parameters for diagnosands 326 | diag_call_src <- deparse(diagnosands_call) 327 | diag_call_env <- environment(diagnosands_call) 328 | if (is.null(diag_call_env)) { 329 | diag_call_objnames <- NULL 330 | diag_call_objvals <- NULL 331 | } else { 332 | diag_call_objnames <- ls(diag_call_env) 333 | diag_call_objvals <- get(diag_call_objnames, diag_call_env) 334 | } 335 | 336 | args <- list( 337 | 'diag_call_src' = diag_call_src, 338 | 'diag_call_objnames' = diag_call_objnames, 339 | 'diag_call_objvals' = diag_call_objvals, 340 | 'from_simdata' = cache_file 341 | ) 342 | 343 | diag_cache_file <- get_diagnosis_cache_filename('diagresult', args, sims, bootstrap_sims, designer) 344 | 345 | if (file.exists(diag_cache_file)) { # read and return result object from cache 346 | if (advance_progressbar) incProgress(advance_progressbar) 347 | diag_res <- readRDS(diag_cache_file) 348 | print('loaded diagnosis results from cache') 349 | from_cache <- TRUE 350 | } 351 | } else { 352 | diag_cache_file <- NULL 353 | } 354 | 355 | if (is.null(diag_res)) { # run diagnoses using the simulated data 356 | diag_res <- diagnose_designs(simdata, diagnosands = diagnosands_call, bootstrap_sims = bootstrap_sims) 357 | if (advance_progressbar) incProgress(advance_progressbar) 358 | 359 | # save diagnosis results to cache if requested 360 | if (!is.null(diag_res) && !is.null(diag_cache_file)) { 361 | saveRDS(diag_res, diag_cache_file) 362 | } 363 | } 364 | 365 | list(results = diag_res, from_cache = from_cache) 366 | } 367 | 368 | # Show a shinyalert message box with title `title` and content loaded from `html_file`. 369 | # Set label of the confirmation button to `confirm_btn_label`. 370 | alert_with_content_from_html_file <- function(title, html_file, confirm_btn_label = 'OK', className = '') { 371 | shinyalert( 372 | title = title, 373 | text = readChar(html_file, file.info(html_file)$size), 374 | closeOnEsc = TRUE, 375 | closeOnClickOutside = TRUE, 376 | html = TRUE, 377 | showConfirmButton = TRUE, 378 | showCancelButton = FALSE, 379 | confirmButtonText = confirm_btn_label, 380 | timer = 0, 381 | imageUrl = "", 382 | confirmButtonCol = "light-blue darken-3", 383 | animation = FALSE, 384 | className = className 385 | ) 386 | } 387 | -------------------------------------------------------------------------------- /conf.R: -------------------------------------------------------------------------------- 1 | # Configuration options 2 | # 3 | # Sisi Huang 4 | # Markus Konrad 5 | # Clara Bicalho 6 | # 7 | # Oct. 2018 8 | # 9 | 10 | library(future) 11 | 12 | options(future.fork.enable = TRUE) # see ?future::supportsMulticore 13 | 14 | app_title <- "DeclareDesign Wizard" 15 | nav_bar_color <- " light-blue darken-3" 16 | feedback_form_url <- "https://docs.google.com/forms/d/e/1FAIpQLSfH8_zy14p1OgvA4Kpx1OSuqx3Kihb5f3OrxA6W_KwDFPqijA/viewform" 17 | 18 | args_control_skip_design_args <- c('design_name', 'args_to_fix') # for all designers 19 | args_control_skip_specific_designer_args <- list( # for specific designers 20 | 'block_cluster_two_arm_designer' = c('treatment_mean'), 21 | 'two_arm_designer' = c('treatment_mean'), 22 | 'two_arm_covariate_designer' = c('treatment_mean'), 23 | 'two_by_two_designer' = c('outcome_means') 24 | ) 25 | 26 | n_diagnosis_workers <- availableCores() - 1 # number of parallel processes when running diagnoses 27 | 28 | default_diag_sims <- 100 29 | default_diag_bootstrap_sims <- 30 30 | 31 | -------------------------------------------------------------------------------- /inspect_helpers.R: -------------------------------------------------------------------------------- 1 | # Inspect tab related utility functions. 2 | # 3 | # Clara Bicalho 4 | # Sisi Huang 5 | # Markus Konrad 6 | # 7 | # March 2019 8 | # 9 | 10 | # get defaults for inputs in inspect tab: use value from design args `d_args` in design tab unless the argument 11 | # is in the set of previously changed arguments `insp_changed_args`, a sequence of values for arg comparison was 12 | # defined in inspect tab (`input` is the input object for the inspect tab) or the input is invalid and needs to 13 | # be fixed by the user. 14 | # `defs` is the argument definitions table for the current designer 15 | # if `use_only_d_args` is TRUE, use only the values from `d_args` (used when initially creating the UI after a 16 | # designer was changed) 17 | get_inspect_input_defaults <- function(d_args, defs, input, insp_changed_args, use_only_d_args = FALSE) { 18 | first_arg <- names(d_args)[1] 19 | if (first_arg == 'N' && is.null(d_args['N'])) first_arg <- names(d_args)[2] 20 | 21 | sapply(names(d_args), function(argname) { 22 | arg_inspect_input <- input[[paste0('inspect_arg_', argname)]] 23 | arg_design_val <- d_args[[argname]] 24 | argdef <- as.list(defs[defs$names == argname,]) 25 | 26 | parsed_arg_inspect_input <- tryCatch(parse_sequence_string(arg_inspect_input), 27 | warning = function(cond) { NA }, 28 | error = function(cond) { NA }) 29 | 30 | if (is.null(arg_inspect_input) || use_only_d_args) { # initial state: no inputs in the "inspect" tab on the left side 31 | # set a default value for "N" the first time 32 | # but there are some design without N argument 33 | if (argname == first_arg) { 34 | if (first_arg == 'N') { 35 | n_int <- as.integer(d_args[[first_arg]]) 36 | return(sprintf('%d, %d ... %d', n_int, n_int + 10, n_int + 100)) 37 | } else { 38 | min_int <- argdef$inspector_min 39 | step_int <- argdef$inspector_step 40 | max_int <- min_int + 4*step_int 41 | return(sprintf('%d, %d ... %d', min_int, min_int + step_int, max_int)) 42 | } 43 | } else { # set a default for all other arguments 44 | return(designer_arg_value_to_fraction(arg_design_val, argdef$class, argdef$vector, to_char = TRUE)) 45 | } 46 | } else { # "inspect" tab on the left side has inputs 47 | # if it is in the set of previously changed arguments or if it is varying (user has entered a sequence), 48 | # or if the user has entered an invalid value, return this value as set by the user 49 | 50 | seq_input <- tryCatch(parse_sequence_string(arg_inspect_input), 51 | warning = function(cond) { NA }, 52 | error = function(cond) { NA }) 53 | 54 | seqofseq_input <- tryCatch(parse_sequence_of_sequences_string(arg_inspect_input), 55 | warning = function(cond) { NA }, 56 | error = function(cond) { NA }) 57 | 58 | if (argname %in% insp_changed_args || (argdef$vector && !is.null(seqofseq_input) && length(seqofseq_input) > 1) 59 | || (!argdef$vector && any(is.na(seq_input)))) 60 | { 61 | return(arg_inspect_input) 62 | } else { # else return the argument value from the design tab. this overwrites values set by the user in this tab 63 | return(designer_arg_value_to_fraction(arg_design_val, argdef$class, argdef$vector, to_char = TRUE)) 64 | } 65 | } 66 | }, simplify = FALSE) 67 | } 68 | 69 | 70 | # For a given designer `design`, its argument definitions `d_argdefs`, the inspector tab input values object `inspect_input`, 71 | # a character vector of fixed design arguments `fixed_args`, and the design tab input values object `design_input`, 72 | # parse the sequence string for each designer argument and generate a list of arguments used for inspection. 73 | # These argument values will define the parameter space for inspection. 74 | get_args_for_inspection <- function(design, design_id, d_argdefs, inspect_input, fixed_args, design_input) { 75 | d_args <- get_designer_args(design) 76 | 77 | insp_args <- list() 78 | 79 | for (d_argname in names(d_args)) { 80 | # skip specific args as defined in config 81 | skip_specifc_args <- args_control_skip_specific_designer_args[[design_id]] 82 | if (d_argname %in% args_control_skip_design_args || (!is.null(skip_specifc_args) && d_argname %in% skip_specifc_args)) 83 | next() 84 | 85 | inp_name_design <- paste0('design_arg_', d_argname) 86 | inp_name_inspect <- paste0('inspect_arg_', d_argname) 87 | 88 | # for a fixed argument or if no input is given in the inspect tab (character arguments), 89 | # use the design tab input value 90 | if (d_argname %in% fixed_args) { 91 | inp_value <- design_input[[inp_name_design]] 92 | } else { # else use the value from the inspect tab 93 | inp_value <- inspect_input[[inp_name_inspect]] 94 | } 95 | 96 | d_argdef <- as.list(d_argdefs[d_argdefs$names == d_argname,]) 97 | d_argclass <- d_argdef$class 98 | # if a value was entered, try to parse it as sequence string and add the result to the list of arguments to compare 99 | inp_elem_name_fixed <- paste0('design_arg_', d_argname, '_fixed') 100 | if (isTruthy(inp_value) && !isTruthy(inspect_input[[inp_elem_name_fixed]])) { 101 | insp_args[[d_argname]] <- tryCatch({ 102 | if (d_argdef$vector) { 103 | # split the possible "vector of vectors" into a list of character vectors 104 | if (d_argname %in% fixed_args) { 105 | # the format of inp_value depends on whether it is as fixed_arg, if fixed, then without brackets around the value 106 | split_strings <- list(parse_sequence_string(inp_value, cls = 'character')) # for vector it must be converted as a list 107 | } else { 108 | split_strings <- parse_sequence_of_sequences_string(inp_value, cls = 'character') 109 | } 110 | 111 | if (d_argclass != 'character') { # convert strings to numbers 112 | # eval() is evil, so make sure to include only characters that can make up integer, real or rational number: 113 | # all digits, dots, slashes and minus 114 | split_strings <- lapply(split_strings, function(s) { 115 | gsub('[^\\d\\.\\/\\-]', '', s, perl = TRUE) 116 | }) 117 | 118 | lapply(split_strings, function(s) { # outer lapply: list of vectors like ("1.3", "1/5", "-2") -> s 119 | unname(sapply(s, function(x) { # inner sapply: parse each element in s to produce a numeric (this also handles fractions, otherwise we could use "as.numeric") 120 | eval(parse(text=x)) 121 | })) 122 | }) 123 | } else { # return the strings as they are 124 | split_strings 125 | } 126 | } else { 127 | parse_sequence_string(inp_value, d_argclass) 128 | } 129 | }, warning = function(cond) { 130 | NA 131 | }, error = function(cond) { 132 | NA 133 | }) 134 | } 135 | } 136 | 137 | insp_args 138 | } 139 | 140 | 141 | # get diagnosands call closure and vector of available diagnosands for `designer` 142 | # returns a list with: 143 | # $diagnosands_call -- a closure that generates a diagnosands function depending on parameter "alpha" 144 | # $available_diagnosands -- a character vector of available diagnosand labels 145 | get_diagnosands_info <- function(designer) { 146 | diag_call <- attr(designer, 'diagnosands') 147 | 148 | res <- list() 149 | 150 | if (is.null(diag_call)) { 151 | res$diagnosands_call <- function(diag_param_alpha) { # here we can pass alpha 152 | function(data) { 153 | DeclareDesign:::default_diagnosands(data, alpha = diag_param_alpha) 154 | } 155 | } 156 | 157 | res$available_diagnosands <- DeclareDesign:::default_diagnosands(NULL)$diagnosand_label 158 | } else { 159 | res$diagnosands_call <- function(diag_param_alpha) { # here we ignore alpha 160 | attr(diag_call, 'call') 161 | } 162 | 163 | quick_diagnosis <- suppressWarnings(diagnose_design(designer, sims = 2, bootstrap_sims = 0)$diagnosands_df) 164 | res$available_diagnosands <- setdiff(names(quick_diagnosis), c("design_label", "estimand_label", "estimator_label", 165 | "term", "n_sims")) 166 | res$available_diagnosands <- grep("se(", res$available_diagnosands, fixed = TRUE, invert = TRUE, value = TRUE) 167 | } 168 | 169 | res 170 | } 171 | 172 | # clean and capitalize string 173 | str_cap <- function(str, hard_code = c("rmse" = "RMSE", 174 | "type_s_rate" = "Type S rate", 175 | "mean_se" = "Mean SE", 176 | "sd_estimate" = "SD estimate")){ #can hardcode specific capitalizations 177 | if(str %in% names(hard_code)) 178 | hard_code[[str]] 179 | else { 180 | str_ret <- rm_usc(str) 181 | paste0(toupper(substr(str_ret, 1, 1)), 182 | substr(str_ret, 2, nchar(str_ret))) 183 | } 184 | 185 | } 186 | 187 | # round function of diagnosands data table 188 | round_df <- function(df, digits) { 189 | nums <- vapply(df, is.numeric, FUN.VALUE = logical(1)) 190 | df[,nums] <- round(df[,nums], digits = digits) 191 | return(df) 192 | } 193 | 194 | # generate plot code 195 | generate_plot_code <- function(plotdf, design_name, diag_param, x_param, color_param, facets_param, plot_ci) { 196 | code <- readLines('inspect_plot_template.txt') 197 | plot_color <- isTruthy(color_param) && color_param != '(none)' 198 | plot_facets <- isTruthy(facets_param) && facets_param != '(none)' 199 | 200 | if (plot_color) { 201 | plotdf[[color_param]] <- factor(plotdf[[color_param]]) 202 | } 203 | 204 | if (plot_facets) { 205 | plotdf[[facets_param]] <- factor(plotdf[[facets_param]]) 206 | } 207 | 208 | aes_args <- list( 209 | 'x' = x_param, 210 | 'y' = diag_param, 211 | 'ymin' = paste0(diag_param, '_min'), 212 | 'ymax' = paste0(diag_param, '_max') 213 | ) 214 | 215 | # if the "color" parameter is set, add it to the aeshetics definition 216 | if (plot_color) { 217 | aes_args$color <- color_param 218 | aes_args$fill <- color_param 219 | aes_args$group <- color_param 220 | } else { 221 | aes_args$group <- 1 222 | } 223 | 224 | vars <- list() 225 | vars$CREATION_DATE <- Sys.Date() 226 | # using dput instead of datapasta::df_paste b/c of https://github.com/DeclareDesign/DDWizard/issues/197 227 | # datapasta::df_paste(plotdf, # nicely format data frame. ugly alternative: dput 228 | # output_context = datapasta::console_context()) 229 | vars$CREATE_DATA <- paste(capture.output(dput(plotdf)), collapse = '\n') 230 | vars$DIAG_PARAM <- diag_param 231 | vars$X_PARAM <- x_param 232 | vars$DESIGN_NAME <- design_name 233 | vars$PLOT_AES <- paste(paste(names(aes_args), '=', as.character(aes_args)), collapse = ', ') 234 | 235 | if (plot_ci) { 236 | vars$PLOT_RIBBON <- "\n geom_ribbon(alpha = 0.25, color = 'white') +" 237 | } else { 238 | vars$PLOT_RIBBON <- '' 239 | } 240 | 241 | if (plot_facets) { 242 | vars$PLOT_FACETS <- sprintf("+\n facet_wrap(~%s, ncol = 2, labeller = label_both)", facets_param) 243 | } else { 244 | vars$PLOT_FACETS <- '' 245 | } 246 | 247 | for (varname in names(vars)) { 248 | code <- gsub(paste0('%', varname, '%'), vars[[varname]], code, fixed = TRUE) 249 | } 250 | 251 | code 252 | } 253 | 254 | # Function to enclose string within parameters 255 | inpar <- function(vector){ 256 | sapply(vector, function(v) 257 | ifelse(is.na(v) || v == "", "", paste0("[", v , "]"))) 258 | } 259 | 260 | # Function that weaves two matrices (first row of first matrix) 261 | weave <- function(mat1, mat2, inpar_mat2 = TRUE, rnames = NULL, excl_0 = TRUE, within_col = TRUE){ 262 | if(!identical(dim(mat1), dim(mat2))) stop("Input matrices should be the same length") 263 | if(is.vector(mat1)){ 264 | if(within_col){ 265 | mat1 <- matrix(mat1, ncol = 1) 266 | mat2 <- matrix(mat2, ncol = 1) 267 | }else{ 268 | mat1 <- matrix(mat1, nrow = 1) 269 | mat2 <- matrix(mat2, nrow = 1) 270 | } 271 | } 272 | if(!is.matrix(mat1)) mat1 <- as.matrix(mat1) 273 | if(!is.matrix(mat2)) mat2 <- as.matrix(mat2) 274 | 275 | matout <- matrix(NA, nrow(mat1)*2, ncol(mat1)) 276 | for(i in 1:nrow(mat1)){ 277 | matout[(2*i-1),] <- mat1[i,] 278 | if(inpar_mat2) 279 | matout[(2*i),] <- inpar(mat2[i,]) 280 | else 281 | matout[(2*i),] <- mat2[i,] 282 | } 283 | 284 | if(!is.null(rnames)){ 285 | rnames <- rep(rnames, each = 2) 286 | rmn <- 1:length(rnames)%%2 == 0 287 | rnames[rmn] <- "" 288 | } 289 | 290 | if(!is.null(colnames(mat1))) colnames(matout) <- colnames(mat1) 291 | matout <- cbind(rnames, matout) 292 | matout <- gsub("NaN", "", matout, fixed = TRUE) 293 | if(excl_0) matout <- gsub("(0)", "", matout, fixed = TRUE) 294 | 295 | return(matout) 296 | } 297 | 298 | # Make diagnositic table long (used in download long option of diagnosis tab) 299 | 300 | make_diagnosis_long <- function(tab, diagnosand_labels, within_col = FALSE){ 301 | mains <- diagnosand_labels 302 | ses <- paste0('se(', mains, ')') 303 | 304 | tab_args <- tab[, !names(tab) %in% c(mains, ses)] 305 | tab_means <- tab[,names(tab) %in% mains] 306 | tab_ses <- tab[,names(tab) %in% ses] 307 | 308 | to_export <- cbind(weave(tab_args, matrix("", nrow(tab_args), ncol(tab_args))), 309 | weave(round(tab_means, 3), round(tab_ses, 3), within_col = within_col)) 310 | colnames(to_export) <- c(names(tab_args), mains) 311 | return(to_export) 312 | } 313 | -------------------------------------------------------------------------------- /inspect_plot_template.txt: -------------------------------------------------------------------------------- 1 | # 2 | # Automatically generated code for design inspection. 3 | # Created by Declare Design Wizard on %CREATION_DATE%. 4 | # https://declaredesign.org/ 5 | # 6 | 7 | library(ggplot2) 8 | 9 | # diagnosis data 10 | 11 | diagnosis <- %CREATE_DATA% 12 | 13 | diagnosis$%DIAG_PARAM%_min <- diagnosis$%DIAG_PARAM% - diagnosis$`se(%DIAG_PARAM%)` * 1.96 14 | diagnosis$%DIAG_PARAM%_max <- diagnosis$%DIAG_PARAM% + diagnosis$`se(%DIAG_PARAM%)` * 1.96 15 | 16 | # create plot 17 | 18 | ggplot(diagnosis, aes(%PLOT_AES%)) + 19 | geom_line() + 20 | geom_point() + %PLOT_RIBBON% 21 | labs(x = '%X_PARAM%', y = '%DIAG_PARAM%') + 22 | ggtitle("%DESIGN_NAME%") %PLOT_FACETS% 23 | -------------------------------------------------------------------------------- /renv.lock: -------------------------------------------------------------------------------- 1 | { 2 | "R": { 3 | "Version": "3.4.4", 4 | "Repositories": [ 5 | { 6 | "Name": "CRAN", 7 | "URL": "https://cloud.r-project.org" 8 | } 9 | ] 10 | }, 11 | "Packages": { 12 | "BH": { 13 | "Package": "BH", 14 | "Version": "1.69.0-1", 15 | "Source": "Repository", 16 | "Repository": "CRAN", 17 | "Hash": "b10526cc28739a55b4e96c1d3f75288d" 18 | }, 19 | "DeclareDesign": { 20 | "Package": "DeclareDesign", 21 | "Version": "0.18.0", 22 | "Source": "Repository", 23 | "Repository": "CRAN", 24 | "Hash": "9f586737e4c1f7176100690dfe6749a5" 25 | }, 26 | "DesignLibrary": { 27 | "Package": "DesignLibrary", 28 | "Version": "0.1.4", 29 | "Source": "Repository", 30 | "Repository": "CRAN", 31 | "Hash": "f405f5216fd17260d3feedbad2b96db1" 32 | }, 33 | "Formula": { 34 | "Package": "Formula", 35 | "Version": "1.2-3", 36 | "Source": "Repository", 37 | "Repository": "CRAN", 38 | "Hash": "0e79568bd760956b9678f61dfffebf8a" 39 | }, 40 | "MASS": { 41 | "Package": "MASS", 42 | "Version": "7.3-51.4", 43 | "Source": "Repository", 44 | "Repository": "CRAN", 45 | "Hash": "3a482055a6ff3a2ccb346252468dcd83" 46 | }, 47 | "Matrix": { 48 | "Package": "Matrix", 49 | "Version": "1.2-12", 50 | "Source": "Repository", 51 | "Repository": "CRAN", 52 | "Hash": "ae711e32db797eb48d461115cadb4ef4" 53 | }, 54 | "R6": { 55 | "Package": "R6", 56 | "Version": "2.4.0", 57 | "Source": "Repository", 58 | "Repository": "CRAN", 59 | "Hash": "40680773613ca924d3d9d2d9d0d85b8f" 60 | }, 61 | "RColorBrewer": { 62 | "Package": "RColorBrewer", 63 | "Version": "1.1-2", 64 | "Source": "Repository", 65 | "Repository": "CRAN", 66 | "Hash": "813da90cb05b5f6705319bfc6cd75dac" 67 | }, 68 | "RUnit": { 69 | "Package": "RUnit", 70 | "Version": "0.4.32", 71 | "Source": "Repository", 72 | "Repository": "CRAN", 73 | "Hash": "54c359dfa8e8c7c892f0bdf929cb8e27" 74 | }, 75 | "Rcpp": { 76 | "Package": "Rcpp", 77 | "Version": "1.0.3", 78 | "Source": "Repository", 79 | "Repository": "CRAN", 80 | "Hash": "36ea605f53923e0c166e9a53bef04f46" 81 | }, 82 | "RcppEigen": { 83 | "Package": "RcppEigen", 84 | "Version": "0.3.3.5.0", 85 | "Source": "Repository", 86 | "Repository": "CRAN", 87 | "Hash": "13578339992f94ac8416bf946610b527" 88 | }, 89 | "assertthat": { 90 | "Package": "assertthat", 91 | "Version": "0.2.1", 92 | "Source": "Repository", 93 | "Repository": "CRAN", 94 | "Hash": "87318c127c936afe4da4d066d1fd01c3" 95 | }, 96 | "backports": { 97 | "Package": "backports", 98 | "Version": "1.1.5", 99 | "Source": "Repository", 100 | "Repository": "CRAN", 101 | "Hash": "f6363d57a19f88c82028828e8b3e8250" 102 | }, 103 | "base64enc": { 104 | "Package": "base64enc", 105 | "Version": "0.1-3", 106 | "Source": "Repository", 107 | "Repository": "CRAN", 108 | "Hash": "c37ae531f7ec4e391620c4f1d18adbb1" 109 | }, 110 | "cli": { 111 | "Package": "cli", 112 | "Version": "1.1.0", 113 | "Source": "Repository", 114 | "Repository": "CRAN", 115 | "Hash": "d824893c21c5333664e7d59347569aff" 116 | }, 117 | "codetools": { 118 | "Package": "codetools", 119 | "Version": "0.2-15", 120 | "Source": "Repository", 121 | "Repository": "CRAN", 122 | "Hash": "a08e7d3f7ff0ec1a7205a86665265302" 123 | }, 124 | "colorspace": { 125 | "Package": "colorspace", 126 | "Version": "1.4-1", 127 | "Source": "Repository", 128 | "Repository": "CRAN", 129 | "Hash": "7461a33b765d4f020547dd0fa4b3a68e" 130 | }, 131 | "crayon": { 132 | "Package": "crayon", 133 | "Version": "1.3.4", 134 | "Source": "Repository", 135 | "Repository": "CRAN", 136 | "Hash": "7a8cbdc75f41e9a4b846be963155176e" 137 | }, 138 | "digest": { 139 | "Package": "digest", 140 | "Version": "0.6.22", 141 | "Source": "Repository", 142 | "Repository": "CRAN", 143 | "Hash": "1e260c370751e4176595226ada8e6f26" 144 | }, 145 | "dplyr": { 146 | "Package": "dplyr", 147 | "Version": "0.8.1", 148 | "Source": "Repository", 149 | "Repository": "CRAN", 150 | "Hash": "2c8c97e2b506ae7e74ca4722c2f5e492" 151 | }, 152 | "estimatr": { 153 | "Package": "estimatr", 154 | "Version": "0.18.0", 155 | "Source": "Repository", 156 | "Repository": "CRAN", 157 | "Hash": "b58feeccbac357a999c335b50496b92d" 158 | }, 159 | "evaluate": { 160 | "Package": "evaluate", 161 | "Version": "0.14", 162 | "Source": "Repository", 163 | "Repository": "CRAN", 164 | "Hash": "d13155ef954e5bda6a9aeca4d96e9492" 165 | }, 166 | "fabricatr": { 167 | "Package": "fabricatr", 168 | "Version": "0.8.0", 169 | "Source": "Repository", 170 | "Repository": "CRAN", 171 | "Hash": "d4ae7c62fd25601c2c7be8822ef3b542" 172 | }, 173 | "fansi": { 174 | "Package": "fansi", 175 | "Version": "0.4.0", 176 | "Source": "Repository", 177 | "Repository": "CRAN", 178 | "Hash": "8973437b0225fd5e419213605c8b0c45" 179 | }, 180 | "future": { 181 | "Package": "future", 182 | "Version": "1.15.1", 183 | "Source": "Repository", 184 | "Repository": "CRAN", 185 | "Hash": "68221d07934a9ed4a25ca7f074e01632" 186 | }, 187 | "generics": { 188 | "Package": "generics", 189 | "Version": "0.0.2", 190 | "Source": "Repository", 191 | "Repository": "CRAN", 192 | "Hash": "ed43c833f2acd2f94b04981cbceec0dd" 193 | }, 194 | "ggplot2": { 195 | "Package": "ggplot2", 196 | "Version": "3.2.1", 197 | "Source": "Repository", 198 | "Repository": "CRAN", 199 | "Hash": "d22cb65dfe6d6a94e85b3223d2f19bd1" 200 | }, 201 | "globals": { 202 | "Package": "globals", 203 | "Version": "0.12.4", 204 | "Source": "Repository", 205 | "Repository": "CRAN", 206 | "Hash": "aac3035afb1dd190f559bd565fd95c2b" 207 | }, 208 | "glue": { 209 | "Package": "glue", 210 | "Version": "1.3.1", 211 | "Source": "Repository", 212 | "Repository": "CRAN", 213 | "Hash": "83eab558c4b636c7e062817783a22522" 214 | }, 215 | "gtable": { 216 | "Package": "gtable", 217 | "Version": "0.3.0", 218 | "Source": "Repository", 219 | "Repository": "CRAN", 220 | "Hash": "e56b6898b9d6cc13c8ab37387962fc59" 221 | }, 222 | "highr": { 223 | "Package": "highr", 224 | "Version": "0.8", 225 | "Source": "Repository", 226 | "Repository": "CRAN", 227 | "Hash": "5b37141c85a01e8a23278f8225127e2d" 228 | }, 229 | "htmltools": { 230 | "Package": "htmltools", 231 | "Version": "0.3.6", 232 | "Source": "Repository", 233 | "Repository": "CRAN", 234 | "Hash": "de92bd2e77bcbe626ae7a3a5793b5952" 235 | }, 236 | "httpuv": { 237 | "Package": "httpuv", 238 | "Version": "1.5.2", 239 | "Source": "Repository", 240 | "Repository": "CRAN", 241 | "Hash": "e8946fe2a8efb71a8a67646db9d51206" 242 | }, 243 | "jsonlite": { 244 | "Package": "jsonlite", 245 | "Version": "1.6", 246 | "Source": "Repository", 247 | "Repository": "CRAN", 248 | "Hash": "5bafd42ac282de7e181c4bcf566e0b35" 249 | }, 250 | "knitr": { 251 | "Package": "knitr", 252 | "Version": "1.25", 253 | "Source": "Repository", 254 | "Repository": "CRAN", 255 | "Hash": "9843436dbfe2efe6a6b3519eec5df085" 256 | }, 257 | "labeling": { 258 | "Package": "labeling", 259 | "Version": "0.3", 260 | "Source": "Repository", 261 | "Repository": "CRAN", 262 | "Hash": "923c552a5aadd2051124fecb7721c4c9" 263 | }, 264 | "later": { 265 | "Package": "later", 266 | "Version": "1.0.0", 267 | "Source": "Repository", 268 | "Repository": "CRAN", 269 | "Hash": "1a43fd366bd6775cef42826708545dfb" 270 | }, 271 | "lattice": { 272 | "Package": "lattice", 273 | "Version": "0.20-35", 274 | "Source": "Repository", 275 | "Repository": "CRAN", 276 | "Hash": "15e79001ea698d00695ea9a2295ad6fb" 277 | }, 278 | "lazyeval": { 279 | "Package": "lazyeval", 280 | "Version": "0.2.2", 281 | "Source": "Repository", 282 | "Repository": "CRAN", 283 | "Hash": "f0987a9a9653a078b8c1ce05df4cd37e" 284 | }, 285 | "listenv": { 286 | "Package": "listenv", 287 | "Version": "0.7.0", 288 | "Source": "Repository", 289 | "Repository": "CRAN", 290 | "Hash": "be3d3528bac1517c6d4bd45460c10dac" 291 | }, 292 | "magrittr": { 293 | "Package": "magrittr", 294 | "Version": "1.5", 295 | "Source": "Repository", 296 | "Repository": "CRAN", 297 | "Hash": "50e0083e3cfe11ce8d21705b51312506" 298 | }, 299 | "markdown": { 300 | "Package": "markdown", 301 | "Version": "1.1", 302 | "Source": "Repository", 303 | "Repository": "CRAN", 304 | "Hash": "cc3d34f5d6490caf09fa82464def2c01" 305 | }, 306 | "mgcv": { 307 | "Package": "mgcv", 308 | "Version": "1.8-23", 309 | "Source": "Repository", 310 | "Repository": "CRAN", 311 | "Hash": "419787953dfc526c154327c4c48915cc" 312 | }, 313 | "mime": { 314 | "Package": "mime", 315 | "Version": "0.7", 316 | "Source": "Repository", 317 | "Repository": "CRAN", 318 | "Hash": "1d04d9bb732f6f97cfb9edb4ab938618" 319 | }, 320 | "munsell": { 321 | "Package": "munsell", 322 | "Version": "0.5.0", 323 | "Source": "Repository", 324 | "Repository": "CRAN", 325 | "Hash": "bf4ab9cebdba2d26d8cd5d6231a10266" 326 | }, 327 | "nlme": { 328 | "Package": "nlme", 329 | "Version": "3.1-131", 330 | "Source": "Repository", 331 | "Repository": "CRAN", 332 | "Hash": "84a58393afd90fd067ccf3cc2f77b38e" 333 | }, 334 | "pillar": { 335 | "Package": "pillar", 336 | "Version": "1.4.2", 337 | "Source": "Repository", 338 | "Repository": "CRAN", 339 | "Hash": "9cfc7736ebcfd366a84158ecbe3e7fb6" 340 | }, 341 | "pkgconfig": { 342 | "Package": "pkgconfig", 343 | "Version": "2.0.3", 344 | "Source": "Repository", 345 | "Repository": "CRAN", 346 | "Hash": "5b0ae02436098f2aeb5885d6b1593cc8" 347 | }, 348 | "plogr": { 349 | "Package": "plogr", 350 | "Version": "0.2.0", 351 | "Source": "Repository", 352 | "Repository": "CRAN", 353 | "Hash": "c7bec940f6fc272b56f442469e2056fb" 354 | }, 355 | "plyr": { 356 | "Package": "plyr", 357 | "Version": "1.8.4", 358 | "Source": "Repository", 359 | "Repository": "CRAN", 360 | "Hash": "a5e093c4e492b469f73a72d00614429c" 361 | }, 362 | "promises": { 363 | "Package": "promises", 364 | "Version": "1.1.0", 365 | "Source": "Repository", 366 | "Repository": "CRAN", 367 | "Hash": "35772062d52b4e9515e488afda4672f6" 368 | }, 369 | "purrr": { 370 | "Package": "purrr", 371 | "Version": "0.3.3", 372 | "Source": "Repository", 373 | "Repository": "CRAN", 374 | "Hash": "6993556d02e6a6d8cb6bade9f29f529b" 375 | }, 376 | "randomizr": { 377 | "Package": "randomizr", 378 | "Version": "0.18.0", 379 | "Source": "Repository", 380 | "Repository": "CRAN", 381 | "Hash": "7222e5a614991342dc34c03f49bdf7cb" 382 | }, 383 | "renv": { 384 | "Package": "renv", 385 | "Version": "0.8.3", 386 | "Source": "Repository", 387 | "Repository": "CRAN", 388 | "Hash": "bf0b67f70a9f271c01e868a5043c45d7" 389 | }, 390 | "reshape2": { 391 | "Package": "reshape2", 392 | "Version": "1.4.3", 393 | "Source": "Repository", 394 | "Repository": "CRAN", 395 | "Hash": "f094a1746435a6a16524d3d845d40e0a" 396 | }, 397 | "rlang": { 398 | "Package": "rlang", 399 | "Version": "0.3.4", 400 | "Source": "Repository", 401 | "Repository": "CRAN", 402 | "Hash": "865049a63db1d7855b7d46297b0f64ba" 403 | }, 404 | "rmarkdown": { 405 | "Package": "rmarkdown", 406 | "Version": "1.16", 407 | "Source": "Repository", 408 | "Repository": "CRAN", 409 | "Hash": "fcd7358295cd6537bd54cb82e85d8b03" 410 | }, 411 | "scales": { 412 | "Package": "scales", 413 | "Version": "1.0.0", 414 | "Source": "Repository", 415 | "Repository": "CRAN", 416 | "Hash": "acfa966acab894eb419dd5be991a4730" 417 | }, 418 | "shiny": { 419 | "Package": "shiny", 420 | "Version": "1.3.2", 421 | "Source": "Repository", 422 | "Repository": "CRAN", 423 | "Hash": "d43b88c1095de34bfd4501f42201c695" 424 | }, 425 | "shinyBS": { 426 | "Package": "shinyBS", 427 | "Version": "0.61", 428 | "Source": "Repository", 429 | "Repository": "CRAN", 430 | "Hash": "a4ad852a22f2e26d55520e5cbc2092f5" 431 | }, 432 | "shinyalert": { 433 | "Package": "shinyalert", 434 | "Version": "1.0", 435 | "Source": "Repository", 436 | "Repository": "CRAN", 437 | "Hash": "0160c1dffc7a299aefec24c22da353d8" 438 | }, 439 | "shinyjs": { 440 | "Package": "shinyjs", 441 | "Version": "1.0", 442 | "Source": "Repository", 443 | "Repository": "CRAN", 444 | "Hash": "38bcb4b910ed40f5af9fd2cf6bc2c9bb" 445 | }, 446 | "shinymaterial": { 447 | "Package": "shinymaterial", 448 | "Version": "0.5.5.9000", 449 | "Source": "GitHub", 450 | "RemoteType": "github", 451 | "RemoteHost": "api.github.com", 452 | "RemoteRepo": "shinymaterial", 453 | "RemoteUsername": "ericrayanderson", 454 | "RemoteRef": "master", 455 | "RemoteSha": "94c19c7950525ab3a4945bc82354fb24d6e80fa9", 456 | "Hash": "f4f0d3bae5cfb54f18b3a1b25f003142" 457 | }, 458 | "sourcetools": { 459 | "Package": "sourcetools", 460 | "Version": "0.1.7", 461 | "Source": "Repository", 462 | "Repository": "CRAN", 463 | "Hash": "c7d54a8bbd904135132a46c2d7199578" 464 | }, 465 | "stringi": { 466 | "Package": "stringi", 467 | "Version": "1.4.3", 468 | "Source": "Repository", 469 | "Repository": "CRAN", 470 | "Hash": "e9bb22c87f9b1b4d33c3ea8b67536a86" 471 | }, 472 | "stringr": { 473 | "Package": "stringr", 474 | "Version": "1.4.0", 475 | "Source": "Repository", 476 | "Repository": "CRAN", 477 | "Hash": "097c393a12f22945ccea00deac0b5b8b" 478 | }, 479 | "tibble": { 480 | "Package": "tibble", 481 | "Version": "2.1.3", 482 | "Source": "Repository", 483 | "Repository": "CRAN", 484 | "Hash": "0561cf2a62e7265533414b7c847a34de" 485 | }, 486 | "tidyselect": { 487 | "Package": "tidyselect", 488 | "Version": "0.2.5", 489 | "Source": "Repository", 490 | "Repository": "CRAN", 491 | "Hash": "e7f0c2054cc4ff87a82a019d77fd5a1f" 492 | }, 493 | "tinytex": { 494 | "Package": "tinytex", 495 | "Version": "0.17", 496 | "Source": "Repository", 497 | "Repository": "CRAN", 498 | "Hash": "8a66f6f51b160fabff9aa15d6dd14c40" 499 | }, 500 | "utf8": { 501 | "Package": "utf8", 502 | "Version": "1.1.4", 503 | "Source": "Repository", 504 | "Repository": "CRAN", 505 | "Hash": "83d28efd0b1c38e4cd55958267a969aa" 506 | }, 507 | "vctrs": { 508 | "Package": "vctrs", 509 | "Version": "0.1.0", 510 | "Source": "Repository", 511 | "Repository": "CRAN", 512 | "Hash": "d5d4ca9e293b89e0a1b2ab88c52ab44b" 513 | }, 514 | "viridisLite": { 515 | "Package": "viridisLite", 516 | "Version": "0.3.0", 517 | "Source": "Repository", 518 | "Repository": "CRAN", 519 | "Hash": "810edc02cd91d05024cdab3e53fb2dca" 520 | }, 521 | "withr": { 522 | "Package": "withr", 523 | "Version": "2.1.2", 524 | "Source": "Repository", 525 | "Repository": "CRAN", 526 | "Hash": "98f2d2df7f048140171d10dd425beeb9" 527 | }, 528 | "xfun": { 529 | "Package": "xfun", 530 | "Version": "0.10", 531 | "Source": "Repository", 532 | "Repository": "CRAN", 533 | "Hash": "b312ba64a299a8274a000b16e13913a1" 534 | }, 535 | "xtable": { 536 | "Package": "xtable", 537 | "Version": "1.8-4", 538 | "Source": "Repository", 539 | "Repository": "CRAN", 540 | "Hash": "7dabb0b0673b0462b1cde716dd089343" 541 | }, 542 | "yaml": { 543 | "Package": "yaml", 544 | "Version": "2.2.0", 545 | "Source": "Repository", 546 | "Repository": "CRAN", 547 | "Hash": "d73b7d8bb61f5cfadb9ec2c0fbf98172" 548 | }, 549 | "zeallot": { 550 | "Package": "zeallot", 551 | "Version": "0.1.0", 552 | "Source": "Repository", 553 | "Repository": "CRAN", 554 | "Hash": "825480f004fb14e704e421df9e56ca28" 555 | } 556 | } 557 | } 558 | -------------------------------------------------------------------------------- /renv/.gitignore: -------------------------------------------------------------------------------- 1 | library/ 2 | python/ 3 | staging/ 4 | -------------------------------------------------------------------------------- /renv/activate.R: -------------------------------------------------------------------------------- 1 | 2 | local({ 3 | 4 | # the requested version of renv 5 | version <- "0.8.3" 6 | 7 | # avoid recursion 8 | if (!is.na(Sys.getenv("RENV_R_INITIALIZING", unset = NA))) 9 | return(invisible(TRUE)) 10 | 11 | # signal that we're loading renv during R startup 12 | Sys.setenv("RENV_R_INITIALIZING" = "true") 13 | on.exit(Sys.unsetenv("RENV_R_INITIALIZING"), add = TRUE) 14 | 15 | # signal that we've consented to use renv 16 | options(renv.consent = TRUE) 17 | 18 | # load the 'utils' package eagerly -- this ensures that renv shims, which 19 | # mask 'utils' packages, will come first on the search path 20 | library(utils, lib.loc = .Library) 21 | 22 | # check to see if renv has already been loaded 23 | if ("renv" %in% loadedNamespaces()) { 24 | 25 | # if renv has already been loaded, and it's the requested version of renv, 26 | # nothing to do 27 | spec <- .getNamespaceInfo(.getNamespace("renv"), "spec") 28 | if (identical(spec[["version"]], version)) 29 | return(invisible(TRUE)) 30 | 31 | # otherwise, unload and attempt to load the correct version of renv 32 | unloadNamespace("renv") 33 | 34 | } 35 | 36 | # construct path to renv in library 37 | libpath <- local({ 38 | 39 | root <- Sys.getenv("RENV_PATHS_LIBRARY", unset = "renv/library") 40 | prefix <- paste("R", getRversion()[1, 1:2], sep = "-") 41 | 42 | # include SVN revision for development versions of R 43 | # (to avoid sharing platform-specific artefacts with released versions of R) 44 | devel <- 45 | identical(R.version[["status"]], "Under development (unstable)") || 46 | identical(R.version[["nickname"]], "Unsuffered Consequences") 47 | 48 | if (devel) 49 | prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") 50 | 51 | file.path(root, prefix, R.version$platform) 52 | 53 | }) 54 | 55 | # try to load renv from the project library 56 | if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) 57 | return(renv::load()) 58 | 59 | # failed to find renv locally; we'll try to install from GitHub. 60 | # first, set up download options as appropriate (try to use GITHUB_PAT) 61 | install_renv <- function() { 62 | 63 | message("Failed to find installation of renv -- attempting to bootstrap...") 64 | 65 | # ensure .Rprofile doesn't get executed 66 | rpu <- Sys.getenv("R_PROFILE_USER", unset = NA) 67 | Sys.setenv(R_PROFILE_USER = "") 68 | on.exit({ 69 | if (is.na(rpu)) 70 | Sys.unsetenv("R_PROFILE_USER") 71 | else 72 | Sys.setenv(R_PROFILE_USER = rpu) 73 | }, add = TRUE) 74 | 75 | # prepare download options 76 | pat <- Sys.getenv("GITHUB_PAT") 77 | if (nzchar(Sys.which("curl")) && nzchar(pat)) { 78 | fmt <- "--location --fail --header \"Authorization: token %s\"" 79 | extra <- sprintf(fmt, pat) 80 | saved <- options("download.file.method", "download.file.extra") 81 | options(download.file.method = "curl", download.file.extra = extra) 82 | on.exit(do.call(base::options, saved), add = TRUE) 83 | } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { 84 | fmt <- "--header=\"Authorization: token %s\"" 85 | extra <- sprintf(fmt, pat) 86 | saved <- options("download.file.method", "download.file.extra") 87 | options(download.file.method = "wget", download.file.extra = extra) 88 | on.exit(do.call(base::options, saved), add = TRUE) 89 | } 90 | 91 | # fix up repos 92 | repos <- getOption("repos") 93 | on.exit(options(repos = repos), add = TRUE) 94 | repos[repos == "@CRAN@"] <- "https://cloud.r-project.org" 95 | options(repos = repos) 96 | 97 | # check for renv on CRAN matching this version 98 | db <- as.data.frame(available.packages(), stringsAsFactors = FALSE) 99 | if ("renv" %in% rownames(db)) { 100 | entry <- db["renv", ] 101 | if (identical(entry$Version, version)) { 102 | message("* Installing renv ", version, " ... ", appendLF = FALSE) 103 | dir.create(libpath, showWarnings = FALSE, recursive = TRUE) 104 | utils::install.packages("renv", lib = libpath, quiet = TRUE) 105 | message("Done!") 106 | return(TRUE) 107 | } 108 | } 109 | 110 | # try to download renv 111 | message("* Downloading renv ", version, " ... ", appendLF = FALSE) 112 | prefix <- "https://api.github.com" 113 | url <- file.path(prefix, "repos/rstudio/renv/tarball", version) 114 | destfile <- tempfile("renv-", fileext = ".tar.gz") 115 | on.exit(unlink(destfile), add = TRUE) 116 | utils::download.file(url, destfile = destfile, mode = "wb", quiet = TRUE) 117 | message("Done!") 118 | 119 | # attempt to install it into project library 120 | message("* Installing renv ", version, " ... ", appendLF = FALSE) 121 | dir.create(libpath, showWarnings = FALSE, recursive = TRUE) 122 | 123 | # invoke using system2 so we can capture and report output 124 | bin <- R.home("bin") 125 | exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" 126 | r <- file.path(bin, exe) 127 | args <- c("--vanilla", "CMD", "INSTALL", "-l", shQuote(libpath), shQuote(destfile)) 128 | output <- system2(r, args, stdout = TRUE, stderr = TRUE) 129 | message("Done!") 130 | 131 | # check for successful install 132 | status <- attr(output, "status") 133 | if (is.numeric(status) && !identical(status, 0L)) { 134 | text <- c("Error installing renv", "=====================", output) 135 | writeLines(text, con = stderr()) 136 | } 137 | 138 | 139 | } 140 | 141 | try(install_renv()) 142 | 143 | # try again to load 144 | if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { 145 | message("Successfully installed and loaded renv ", version, ".") 146 | return(renv::load()) 147 | } 148 | 149 | # failed to download or load renv; warn the user 150 | msg <- c( 151 | "Failed to find an renv installation: the project will not be loaded.", 152 | "Use `renv::activate()` to re-initialize the project." 153 | ) 154 | 155 | warning(paste(msg, collapse = "\n"), call. = FALSE) 156 | 157 | }) 158 | -------------------------------------------------------------------------------- /renv/settings.dcf: -------------------------------------------------------------------------------- 1 | external.libraries: 2 | ignored.packages: 3 | snapshot.type: packrat 4 | use.cache: TRUE 5 | vcs.ignore.library: TRUE 6 | -------------------------------------------------------------------------------- /tab_design.R: -------------------------------------------------------------------------------- 1 | # UI and server module for "Design" tab. 2 | # 3 | # designTab function returns a list of objects that allow to access its reactive values and some functions (see end of file). 4 | # 5 | # Markus Konrad 6 | # Clara Bicalho 7 | # Sisi Huang 8 | # 9 | # Dec. 2018 10 | # 11 | 12 | # -------------- UI -------------- 13 | 14 | designTabUI <- function(id, label = 'Design') { 15 | 16 | nspace <- NS(id) 17 | 18 | material_tab_content( 19 | tab_id = id, 20 | material_row( 21 | material_column( # left: input and design parameters 22 | width = 3, 23 | material_card("Choose design", 24 | # tagList("Read about the library ", a("here", href="https://declaredesign.org/library/")), 25 | div(style="text-align: center;", 26 | # add a selectbox to choose the design from DesignLibrary 27 | uiOutput(nspace("import_design_lib_id")), 28 | actionButton(nspace("import_from_design_lib"), 29 | label = "Load", 30 | disabled = "disabled"), 31 | actionButton(inputId='learn_more', label= NULL, 32 | icon = icon("question-circle"), 33 | style = "text-align: center; padding-left: 8px; padding-right: 8px;", 34 | onclick = "window.open('https://declaredesign.org/r/designlibrary/', '_blank')") 35 | ) 36 | ), 37 | # show designer parameters if a design was loaded 38 | hidden(div(id = nspace('design_params_panel_wrapper'), 39 | material_card("Set design parameters", 40 | uiOutput(nspace('design_vignette')), 41 | br(), 42 | textInput(nspace('design_arg_design_name'), 'Design name'), 43 | conditionalPanel(paste0("output['", nspace('design_supports_fixed_arg'), "'] != ''"), 44 | div(style="text-align: right;", uiOutput(nspace('fix_toggle_btn'))) 45 | ), 46 | uiOutput(nspace("design_parameters")) # display *all* arguments of an imported design 47 | ) 48 | )) 49 | ), 50 | material_column( # center: design output 51 | width = 9, 52 | uiOutput(nspace("load_design_info")), 53 | material_card("Download", 54 | downloadButton(nspace('download_r_script'), label = 'R code', disabled = 'disabled'), 55 | downloadButton(nspace('download_rds_obj'), label = 'Design as RDS file', disabled = 'disabled')), 56 | bsCollapse(id=nspace('sections_container'), multiple = TRUE, 57 | bsCollapsePanel('Warnings or errors', uiOutput(nspace("section_messages"))), 58 | bsCollapsePanel('Summary', uiOutput(nspace("section_summary"))), 59 | bsCollapsePanel('Code output', uiOutput(nspace('section_design_code'))), 60 | bsCollapsePanel('Simulated data', 61 | p("The following table shows a single draw of the data."), 62 | actionButton(nspace("simdata_redraw"), label = "Redraw data", disabled = "disabled"), 63 | downloadButton(nspace("simdata_download"), label = "Download data", disabled = "disabled"), 64 | dataTableOutput(nspace("section_simdata_table"))), 65 | bsCollapsePanel("About DeclareDesign Wizard", 66 | 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)."), 67 | tagList(" This software is in beta release. We welcome your feedback! Please report any issues ", a("here.", href="https://github.com/DeclareDesign/DDWizard/issues"))) 68 | ) 69 | ) 70 | ) 71 | ) 72 | } 73 | 74 | # -------------- server -------------- 75 | 76 | designTab <- function(input, output, session) { 77 | options(warn = 1) # always directly print warnings 78 | 79 | # -------------- reactive values definition -------------- 80 | 81 | react <- reactiveValues( 82 | design = NULL, # parametric designer object (a closure) 83 | design_id = NULL, # identifier for current design instance *after* being instantiated 84 | design_code = '', 85 | design_argdefinitions = NULL, # argument definitions for current design instance 86 | design_name_once_changed = FALSE, # records whether design name was changed after import 87 | fix_toggle = 'fix', # toggle for fixing/unfixing all design parameters. must be either "fix" or "unfix" 88 | simdata = NULL, # a single draw of the data to be shown in the "simulated data" panel 89 | captured_stdout = NULL, # captured output of print(design_instance). used in design summary 90 | captured_errors = NULL, # captured errors and warnings during design creation 91 | error_occurred = NULL, # detect whether error occurred in design_instance 92 | warning_occurred = NULL, # detect whether warning occurred in design_instance 93 | input_errors = NULL, # errors related to invalid inputs 94 | captured_msgs = NULL, # captured messages during design creation 95 | custom_state = list() # additional state values for bookmarking 96 | ) 97 | 98 | # -------------- helper functions -------------- 99 | 100 | # Load the designer with the name `designer` (char string). 101 | # For mysterious reasons, it is necessary to pass a namespace function `nspace` (created with `NS()`) 102 | # *whenever this function is called for restoring a bookmark.* 103 | load_designer <- function(designer, nspace = function(x) { x }) { 104 | print(paste('loading designer', designer)) 105 | 106 | shinyjs::show(nspace('design_params_panel_wrapper')) 107 | 108 | react$design_id <- designer 109 | react$design <- getFromNamespace(react$design_id, 'DesignLibrary') 110 | react$design_argdefinitions <- attr(react$design, 'definitions') # get the designer's argument definitions 111 | react$design_name_once_changed <- FALSE 112 | react$fix_toggle <- 'fix' 113 | 114 | shinyjs::enable(nspace('download_r_script')) 115 | shinyjs::enable(nspace('download_rds_obj')) 116 | shinyjs::enable(nspace('simdata_redraw')) 117 | shinyjs::enable(nspace('simdata_download')) 118 | 119 | # replace xx_designer as xx_design 120 | updateTextInput(session, nspace('design_arg_design_name'), value = gsub("designer","design", react$design_id)) 121 | 122 | # simulation data would react once new design is loaded 123 | isolate({ 124 | d <- req(design_instance()) 125 | if (!is.null(react$custom_state$simdata)) { 126 | simdata <- react$custom_state$simdata 127 | react$custom_state$simdata <- NULL 128 | } else { 129 | simdata <- draw_data(d) 130 | } 131 | }) 132 | 133 | react$simdata <- simdata 134 | 135 | # save this to state because it is not automatically restored from bookmark 136 | react$custom_state$designer <- react$design_id 137 | } 138 | 139 | # -------------- reactive functions -------------- 140 | 141 | # arguments/parameters for react$design and their values taken from the inputs 142 | design_args <- reactive({ 143 | output_args <- list() 144 | 145 | if (!is.null(react$design)) { # return empty list if no designer given 146 | switching <- isolate({ input$switching_designer }) 147 | if (is.null(switching)) { # happens on bookmark restore 148 | switching <- TRUE 149 | } 150 | 151 | args <- get_designer_args(react$design) 152 | args_eval <- evaluate_designer_args(args, attr(react$design, 'definitions')) 153 | arg_defs <- react$design_argdefinitions # is NULL on first run, otherwise data frame of argument definitions (class, min/max) 154 | 155 | if (is.null(arg_defs)) { 156 | return(output_args) # empty list 157 | } 158 | 159 | fixed_args <- NULL 160 | 161 | all_default <- TRUE 162 | 163 | for (argname in names(args)) { 164 | skip_specifc_args <- args_control_skip_specific_designer_args[[react$design_id]] 165 | if (argname %in% args_control_skip_design_args || (!is.null(skip_specifc_args) && argname %in% skip_specifc_args)) 166 | next() 167 | 168 | argdefault <- args_eval[[argname]] 169 | argdefinition <- as.list(arg_defs[arg_defs$names == argname,]) 170 | inp_value <- input[[paste0('design_arg_', argname)]] 171 | 172 | if (switching) { # if the designer was just changed, use its default values 173 | # because the inputs still hold values from the prev. designer which might be incompatible 174 | output_args[[argname]] <- design_arg_value_from_input(argdefault, argdefault, argdefinition, class(argdefault), typeof(argdefault)) 175 | } else { # otherwise use the inputs as usual 176 | # convert an input value to a argument value of correct class 177 | if (length(argdefinition) != 0) { 178 | argvalue <- design_arg_value_from_input(inp_value, argdefault, argdefinition, class(argdefault), typeof(argdefault)) 179 | has_NAs <- !is.null(argvalue) && any(is.na(argvalue)) # may contain NAs where invalid input was supplied 180 | if (!has_NAs && ((!is.null(argvalue) && is.null(argdefault)) 181 | || (!is.null(argvalue) && argvalue != '' 182 | && (length(argvalue) != length(argdefault) || argvalue != argdefault)))) 183 | { 184 | all_default <- FALSE 185 | } 186 | 187 | if (has_NAs || !is.null(argvalue)) { # add the value to the list of designer arguments 188 | output_args[[argname]] <- argvalue 189 | } 190 | } 191 | } 192 | 193 | # determine whether argument was set in "args_to_fix" 194 | arg_is_fixed_value <- input[[paste0('design_arg_', argname, '_fixed')]] 195 | if (isTruthy(arg_is_fixed_value)) { 196 | fixed_args <- c(fixed_args, argname) 197 | 198 | # if at least one arg. is set to fixed, the toggle button is set to "Unfix all" 199 | react$fix_toggle <- 'unfix' 200 | updateActionButton(session, 'fix_toggle', label = 'Unfix all') 201 | } 202 | } 203 | 204 | # additional designer arguments: design name and vector of fixed arguments 205 | if (is.null(react$design_argdefinitions)) { 206 | # output_args$design_name <- react$design_id # should always be a valid R object name 207 | updateTextInput(session, 'design_arg_design_name', value = react$design_id) 208 | } else if (!is.null(input$design_arg_design_name) && (!all_default || react$design_name_once_changed)) { 209 | # output_args$design_name <- make_valid_r_object_name(input$design_arg_design_name) 210 | # updateTextInput(session, 'design_arg_design_name', value = output_args$design_name) 211 | react$design_name_once_changed <- TRUE 212 | } 213 | 214 | if (design_supports_fixed_arg()) { 215 | output_args$args_to_fix <- fixed_args 216 | } 217 | } 218 | 219 | output_args 220 | }) 221 | 222 | 223 | # specific design instance generated from above react$design with specific parameter values `design_args()` 224 | design_instance <- reactive({ 225 | d_inst <- NULL # design instance 226 | react$input_errors <- NULL 227 | react$captured_errors <- NULL 228 | react$design_code <- '' 229 | 230 | if (!is.null(react$design)) { # return NULL if no designer is given 231 | msgs <- character() 232 | error_occur <- FALSE 233 | warning_occur <- FALSE 234 | d_args <- design_args() # designer arguments 235 | 236 | print('creating design instance with arguments:') 237 | print(d_args) 238 | 239 | d_args_NAs <- sapply(d_args, function(arg) { any(is.na(arg)) }) 240 | if (sum(d_args_NAs) > 0) { 241 | react$input_errors <- paste('Invalid values supplied to the following arguments:', 242 | paste(names(d_args_NAs)[d_args_NAs], collapse = ', ')) 243 | react$captured_errors <- 'Please correct the errors in the argument values first.' 244 | } else { 245 | conditions <- tryCatch( 246 | expr = { 247 | capture.output({ 248 | d_inst <- do.call(react$design, d_args) 249 | # capture message prints, e.g in block_cluster_two_arm_designer 250 | msgs <- paste0(capture.output(d_inst <- do.call(react$design, d_args)), collapse = "\n") 251 | print(d_inst) 252 | }, type = 'message') 253 | }, error = function(e){ 254 | error_occur <<- TRUE 255 | msgs <<- e 256 | },warning = function(w){ 257 | warning_occur <<- TRUE 258 | msgs <<- w 259 | }) 260 | 261 | # create a design instance from the designer using the current arguments `d_args` 262 | if (!error_occur) { 263 | if (is.null(d_inst)) { # try again if we only got warnings (not errors) 264 | d_inst <- do.call(react$design, d_args) 265 | } 266 | 267 | react$captured_stdout <- capture.output({ # capture output of `print(d_inst)` 268 | print(d_inst) # to create summary output if and only if there is no error in d_inst 269 | }, type = 'output') 270 | } else { 271 | react$captured_stdout <- '' 272 | } 273 | 274 | react$captured_errors <- conditions 275 | react$captured_msgs <- msgs 276 | react$error_occurred <- error_occur 277 | react$warning_occurred <- warning_occur 278 | 279 | if (!error_occur && !is.null(d_inst)){ 280 | # also update simulated data 281 | react$simdata <- draw_data(d_inst) 282 | 283 | # update design code 284 | code_text <- paste(attr(d_inst, 'code'), collapse = "\n") 285 | default_designer_name <- gsub("designer","design", react$design_id) 286 | react$design_code <- gsub(default_designer_name, 287 | make_valid_r_object_name(input$design_arg_design_name), 288 | code_text) 289 | 290 | }else{ 291 | react$simdata <- NULL 292 | } 293 | 294 | } 295 | 296 | print('design instance changed') 297 | } 298 | 299 | d_inst 300 | }) 301 | 302 | # return TRUE if designer supports "args_to_fix" argument, else FALSE 303 | design_supports_fixed_arg <- reactive({ 304 | req(react$design) 305 | #return(FALSE) # for testing 306 | 'args_to_fix' %in% names(formals(react$design)) 307 | }) 308 | 309 | # return a character vector that lists the arguments set in "args_to_fix" 310 | get_fixed_design_args <- reactive({ 311 | req(react$design) 312 | 313 | if (!design_supports_fixed_arg()) { 314 | return(character()) # empty char vector 315 | } 316 | 317 | args <- get_designer_args(react$design) 318 | 319 | args_fixed <- sapply(names(args), function(argname) { 320 | inp_elem_name_fixed <- paste0('design_arg_', argname, '_fixed') 321 | if (!is.null(input[[inp_elem_name_fixed]])) { 322 | input[[inp_elem_name_fixed]] 323 | } else { 324 | NA 325 | } 326 | }) 327 | 328 | args_fixed <- args_fixed[!is.na(args_fixed)] 329 | names(args_fixed)[args_fixed] 330 | }) 331 | 332 | # returns TRUE if at least one designer argument was set in "args_to_fix", otherwise FALSE 333 | at_least_one_design_arg_fixed <- reactive({ 334 | length(get_fixed_design_args()) > 0 335 | }) 336 | 337 | # returns TRUE if all design arguments were set to fixed, otherwise FALSE 338 | all_design_args_fixed <- reactive({ 339 | all_args <- get_designer_args(react$design) 340 | args_fixed <- get_fixed_design_args() 341 | length(args_fixed) == length(all_args) 342 | }) 343 | 344 | # observer for the error message to unfold the message panel 345 | # reactive expression returns true when there is no error or warning 346 | message_close <- reactive({ 347 | req(react$warning_occurred) 348 | req(react$error_occurred) 349 | if (!isTRUE(react$warning_occurred) && !isTRUE(react$error_occurred)) { 350 | return(TRUE) 351 | } else { 352 | return(NULL) 353 | } 354 | }) 355 | 356 | # reactive expression returns true when there is any error or warning 357 | message_open <- reactive({ 358 | if (is.null(design_instance()) || isTRUE(react$warning_occurred) || isTRUE(react$error_occurred)){ 359 | return(TRUE) 360 | } else { 361 | return(NULL) 362 | } 363 | }) 364 | 365 | # -------------- event observers -------------- 366 | 367 | # input observer for click on design import 368 | observeEvent(input$import_from_design_lib, { 369 | # loads a pre-defined designer from the library 370 | if (!is.null(input$import_design_library)) { 371 | load_designer(input$import_design_library) 372 | } 373 | }) 374 | 375 | # input observer for click on "Fix/Unfix all" button 376 | observeEvent(input$fix_toggle_click, { 377 | args <- get_designer_args(react$design) 378 | 379 | checkbox_val <- react$fix_toggle == 'fix' 380 | 381 | for (argname in names(args)) { 382 | inp_elem_name_fixed <- paste0('design_arg_', argname, '_fixed') 383 | if (!is.null(input[[inp_elem_name_fixed]])) { 384 | updateCheckboxInput(session, inp_elem_name_fixed, value = checkbox_val) 385 | } 386 | } 387 | }) 388 | 389 | # input observer for click on "redraw data" button in "simulated data" section 390 | observeEvent(input$simdata_redraw, { 391 | isolate({ 392 | d <- req(design_instance()) 393 | if (!is.null(react$custom_state$simdata)) { 394 | simdata <- react$custom_state$simdata 395 | react$custom_state$simdata <- NULL 396 | } else { 397 | if (react$warning_occurred || react$error_occurred) { 398 | simdata <- NULL 399 | } else { 400 | simdata <- draw_data(d) 401 | } 402 | } 403 | }) 404 | 405 | react$simdata <- simdata 406 | }) 407 | 408 | # unfold the message panel 409 | observeEvent(message_open(),ignoreInit = TRUE,{ 410 | updateCollapse(session, "sections_container", open = 'Warnings or errors') 411 | }) 412 | 413 | # fold back the message panel 414 | observeEvent(message_close(),ignoreInit = TRUE,{ 415 | updateCollapse(session, "sections_container", close = 'Warnings or errors') 416 | }) 417 | 418 | # -------------- output elements: hidden -------------- 419 | 420 | # hidden (for conditional panel) 421 | output$design_supports_fixed_arg <- design_supports_fixed_arg 422 | outputOptions(output, 'design_supports_fixed_arg', suspendWhenHidden = FALSE) 423 | 424 | # -------------- output elements: left side -------------- 425 | 426 | # left side: designer description 427 | output$design_description <- renderUI({ 428 | req(react$design) 429 | HTML(attr(react$design, 'description')) 430 | }) 431 | 432 | # create link to vignette based on design input from the library 433 | output$design_vignette <- renderUI({ 434 | url <- paste0("window.open('https://declaredesign.org/r/designlibrary/articles/", gsub("_designer","",react$design_id), ".html', '_blank')") 435 | actionButton(inputId='vignette', label=" Read more", 436 | icon = icon("book"), 437 | onclick = url) 438 | }) 439 | 440 | # left side: designer parameters 441 | output$design_parameters <- renderUI({ 442 | req(react$design) 443 | 444 | nspace <- NS('tab_design') 445 | 446 | isolate({ 447 | defaults <- design_args() 448 | param_boxes <- create_design_parameter_ui(type = 'design', react = react, nspace = nspace, 449 | input = input, defaults = defaults, 450 | create_fixed_checkboxes = design_supports_fixed_arg(), 451 | use_only_argdefaults = input$switching_designer) 452 | }) 453 | 454 | if (!is.null(react$input_errors) && length(react$input_errors) > 0) { 455 | list(tags$div(class = 'error_msgs', paste(react$input_errors, collapse = "\n")), tags$div(param_boxes)) 456 | } else { 457 | list(tags$div(param_boxes)) 458 | } 459 | }) 460 | 461 | # left side: "Fix/Unfix all" button 462 | output$fix_toggle_btn <- renderUI({ 463 | nspace <- NS('tab_design') 464 | 465 | if (at_least_one_design_arg_fixed()) { 466 | fix_toggle_label <- 'Unfix all' 467 | react$fix_toggle <- 'unfix' 468 | } else { 469 | fix_toggle_label <- 'Fix all' 470 | react$fix_toggle <- 'fix' 471 | } 472 | 473 | actionButton(nspace('fix_toggle_click'), fix_toggle_label) 474 | }) 475 | 476 | # left side: choose designers 477 | output$import_design_lib_id <- renderUI({ 478 | nspace <- NS('tab_design') 479 | 480 | cached <- str_replace(grep("designer$", ls(as.environment("package:DesignLibrary")), value = TRUE), "_designer", "") 481 | option <- c() 482 | for (i in 1:length(cached)){ 483 | if (is.null(attr(getFromNamespace(paste(cached[i], sep = "_", "designer"), 'DesignLibrary'), "shiny"))){ 484 | next() 485 | }else{ 486 | option[i] <- paste(cached[i], sep = "_", "designer") 487 | } 488 | } 489 | 490 | test <- gsub("_", " ",gsub("_designer","", option[!is.na(option)])) 491 | options_data <- data.frame(names = option[!is.na(option)],abbr = stri_trans_totitle(test), stringsAsFactors = FALSE) 492 | if (any(options_data$names == 'binary_iv_designer')) options_data[options_data$names == 'binary_iv_designer',]$abbr = "Binary IV" 493 | option_list <- as.list(options_data$names) 494 | names(option_list) <- options_data$abbr 495 | 496 | shinyjs::enable("import_from_design_lib") 497 | selectInput(nspace("import_design_library"), 498 | label = "", 499 | selected = "two_arm_designer", choices = option_list, 500 | multiple = FALSE) 501 | 502 | 503 | 504 | }) 505 | 506 | # -------------- output elements: center -------------- 507 | 508 | # center: info about the name of loaded design 509 | output$load_design_info <- renderUI({ 510 | req(react$design_id) 511 | title = str_cap(react$design_id) 512 | if (title == "Binary iv designer") title <- "Binary IV designer" 513 | material_card(title = title, HTML(attr(react$design, 'description'))) 514 | }) 515 | 516 | # center: design code 517 | output$section_design_code <- renderUI({ 518 | req(design_instance()) 519 | tags$pre(react$design_code) 520 | }) 521 | 522 | # center: design summary 523 | output$section_summary <- renderUI({ 524 | if(!is.null(react$captured_stdout)) { 525 | # show captured print() output 526 | txt <- paste(react$captured_stdout, collapse = "\n") 527 | } else { 528 | txt <- 'No summary.' 529 | } 530 | 531 | tags$pre(txt) 532 | }) 533 | 534 | # center: design messages 535 | output$section_messages <- renderUI({ 536 | got_errors <- !is.null(react$captured_errors) && length(react$captured_errors) > 0 537 | 538 | if(!is.null(react$captured_msgs) && react$captured_msgs != '') { 539 | # show captured messages 540 | txt <- paste(react$captured_msgs, collapse = "\n") 541 | 542 | if (got_errors) { 543 | txt <- tags$div(class = 'error_msgs', txt) 544 | } 545 | } else { 546 | txt <- 'No warnings/errors.' 547 | } 548 | 549 | tags$pre(txt) 550 | }) 551 | 552 | # center: simulated data table 553 | output$section_simdata_table <- renderDataTable({ 554 | req(react$simdata) 555 | round_df(react$simdata, 4) 556 | }, options = list(searching = FALSE, 557 | ordering = FALSE, 558 | paging = TRUE, 559 | pageLength = 10, 560 | info = FALSE, 561 | lengthChange = FALSE, 562 | scrollX = TRUE)) 563 | 564 | 565 | 566 | # -------------- download handlers -------------- 567 | 568 | # download design as R script 569 | output$download_r_script <- downloadHandler( 570 | filename = function() { # note that this seems to work only in a "real" browser, not in RStudio's browser 571 | design_name <- input$design_arg_design_name 572 | 573 | if (!isTruthy(design_name)) { 574 | design_name <- paste0("design-", Sys.Date()) 575 | } 576 | 577 | paste0(design_name, '.R') 578 | }, 579 | content = function(file) { 580 | d <- design_instance() 581 | if(!is.null(d) && !is.null(attr(d, 'code'))) { 582 | # use the "code" attribute of a design instance and write it to `file` 583 | code_lines <- c(paste('# code generated with DDWizard and DesignLibrary on', Sys.time()), 584 | '# see https://declaredesign.org/', 585 | '', 586 | 'library(DeclareDesign)', 587 | '', 588 | attr(d, 'code')) 589 | writeLines(code_lines, file) 590 | } 591 | } 592 | ) 593 | 594 | # download design as RDS file 595 | output$download_rds_obj <- downloadHandler( 596 | filename = function() { # note that this seems to work only in a "real" browser, not in RStudio's browser 597 | design_name <- input$design_arg_design_name 598 | 599 | if (!isTruthy(design_name)) { 600 | design_name <- paste0("design-", Sys.Date()) 601 | } 602 | 603 | paste0(design_name, '.RDS') 604 | }, 605 | content = function(file) { 606 | d <- design_instance() 607 | if(!is.null(d)) { # save design instance 608 | saveRDS(d, file = file) 609 | } 610 | } 611 | ) 612 | 613 | # download simulated data 614 | output$simdata_download <- downloadHandler( 615 | filename = function() { # note that this seems to work only in a "real" browser, not in RStudio's browser 616 | design_name <- input$design_arg_design_name 617 | 618 | if (!isTruthy(design_name)) { 619 | design_name <- paste0("design-", Sys.Date()) 620 | } 621 | 622 | paste0(design_name, '_simulated_data.csv') 623 | }, 624 | content = function(file) { 625 | req(react$simdata) 626 | write.csv(react$simdata, file = file, row.names = FALSE) 627 | } 628 | ) 629 | 630 | 631 | # -------------- bookmarking -------------- 632 | 633 | # customize bookmarking process: add additional data to bookmarked state 634 | onBookmark(function(state) { 635 | print('BOOKMARKING IN DESIGN TAB:') 636 | 637 | # add open panels, because they're not restored automatically 638 | react$custom_state$panels_state <- input$sections_container 639 | 640 | # store simulated data 641 | react$custom_state$simdata <- react$simdata 642 | 643 | print(react$custom_state) 644 | state$values$custom_state <- react$custom_state 645 | }) 646 | 647 | # customize restoring process 648 | onRestore(function(state) { 649 | print('RESTORING IN DESIGN TAB:') 650 | react$custom_state <- state$values$custom_state 651 | 652 | print(react$custom_state) 653 | 654 | # design is not loaded automatically on restore (probably because list of available designers 655 | # is not loaded yet) so do it here 656 | # also, a namespace function must be passed when doing a restore (reason unknown) 657 | load_designer(react$custom_state$designer, NS('tab_design')) 658 | 659 | # re-open the panels 660 | updateCollapse(session, 'sections_container', open = react$custom_state$panels_state) 661 | }) 662 | 663 | # -------------- return values of this module -------------- 664 | 665 | # return reactive values and some functions to be accessed from other modules 666 | return(list( 667 | react = react, 668 | design_args = design_args, 669 | design_instance = design_instance, 670 | input = input, 671 | all_design_args_fixed = all_design_args_fixed, 672 | get_fixed_design_args = get_fixed_design_args 673 | )) 674 | } 675 | 676 | 677 | -------------------------------------------------------------------------------- /tab_inspect.R: -------------------------------------------------------------------------------- 1 | # UI and server module for "Inspect" tab. 2 | # 3 | # Sisi Huang 4 | # Markus Konrad 5 | # Clara Bicalho 6 | # 7 | # Dec. 2018 8 | # 9 | 10 | source('inspect_helpers.R') 11 | 12 | 13 | # -------------- config -------------- 14 | 15 | diagnosis_table_opts <- list(searching = FALSE, 16 | ordering = FALSE, 17 | paging = TRUE, 18 | pageLength = 10, 19 | info = FALSE, 20 | lengthChange = FALSE, 21 | scrollX = TRUE) 22 | 23 | # -------------- UI -------------- 24 | 25 | inspectTabUI <- function(id, label = 'Inspect') { 26 | nspace <- NS(id) 27 | nspace_design <- NS('tab_design') 28 | 29 | # "Inspect" tab 30 | material_tab_content( 31 | tab_id = id, 32 | material_row( 33 | material_column( # left: design parameters for comparison 34 | width = 3, 35 | material_card("Compare design parameters", 36 | conditionalPanel(paste0("output['", nspace_design('design_loaded'), "'] != ''"), 37 | uiOutput(nspace("param_input_messages")), 38 | uiOutput(nspace("compare_design_parameters")) # display not-fixed parameters of a design / allow to define sequences 39 | ), 40 | conditionalPanel(paste0("output['", nspace_design('design_loaded'), "'] == ''"), 41 | p('Load a design first') 42 | ) 43 | ) 44 | ), 45 | material_column( # center: inspection output 46 | width = 6, 47 | bsCollapse(id = nspace('inspect_sections_simconf_container'), 48 | bsCollapsePanel('Configure simulations', 49 | checkboxInput(nspace('simconf_force_rerun'), label = 'Always re-run simulations (disable cache)'), 50 | numericInput(nspace("simconf_sim_num"), label = "Num. of simulations", 51 | value = default_diag_sims, 52 | min = 1, max = 1000, step = 1), 53 | numericInput(nspace("simconf_bootstrap_num"), label = "Num. of bootstraps", 54 | value = default_diag_bootstrap_sims, 55 | min = 1, max = 1000, step = 1))), 56 | uiOutput(nspace("plot_info")), 57 | conditionalPanel(paste0("output['", nspace('all_design_args_fixed'), "'] === false"), 58 | material_card("Diagnostic plots", 59 | uiOutput(nspace('plot_message')), 60 | div(actionButton(nspace('update_plot'), 'Run diagnoses'), style = "margin-bottom:10px"), 61 | uiOutput(nspace('plot_output')), 62 | downloadButton(nspace("download_plot"), label = "Download plot", disabled = "disabled"), 63 | downloadButton(nspace("download_plot_code"), label = "Download plot code", disabled = "disabled") 64 | ), 65 | bsCollapse(id = nspace('inspect_sections_container'), 66 | bsCollapsePanel('Diagnosis', 67 | uiOutput(nspace("section_diagnosands_message")), 68 | dataTableOutput(nspace("section_diagnosands_table")), 69 | checkboxInput(nspace("reshape_diagnosands"), 70 | label = "Convert to unformatted table"), 71 | downloadButton(nspace("section_diagnosands_download_subset"), 72 | label = "Download above table", disabled = "disabled"), 73 | downloadButton(nspace("section_diagnosands_download_full"), 74 | label = "Download full diagnosands table", disabled = "disabled")) 75 | ) 76 | ), 77 | conditionalPanel(paste0("output['", nspace('all_design_args_fixed'), "'] === true"), 78 | material_card("Diagnostic plots", 79 | HTML('

Diagnosis plot not available since all parameters were set to fixed.

'), 80 | actionButton(nspace('update_plot_all_fixed'), 'Run single design diagnosis'), 81 | uiOutput(nspace("single_diagnosands_message")), 82 | dataTableOutput(nspace("single_diagnosands_table")) 83 | ) 84 | ) 85 | ), 86 | material_column( # right: plot configuration 87 | width = 3, 88 | uiOutput(nspace("plot_conf")) 89 | ) 90 | ) 91 | ) 92 | } 93 | 94 | # -------------- server -------------- 95 | 96 | bookmark_store_react_objects <- c('cur_design_id', 97 | 'diagnosands', 98 | 'diagnosands_cached', 99 | 'diagnosands_call', 100 | 'insp_args_used_in_plot', 101 | 'captured_errors') 102 | 103 | inspectTab <- function(input, output, session, design_tab_proxy) { 104 | 105 | # -------------- reactive values definition -------------- 106 | 107 | react <- reactiveValues( 108 | cur_design_id = NULL, # current design name used in inspection (coming from design tab) 109 | diagnosands = NULL, # diagnosands for current plot in "inspect" tab 110 | diagnosands_cached = FALSE, # records whether current diagnosand results came from cache 111 | diagnosands_call = NULL, # a closure that actually calculates the diagnosands, valid for current design 112 | insp_args_used_in_plot = NULL, # last used design parameters used in plot 113 | insp_args_varying = character(), # arguments that are varying 114 | insp_args_changed = character(), # arguments that were changed in the inspector by the user 115 | insp_args_set_after_tab_switch = FALSE, # records if the the above vector was just set after switching to this tab again 116 | captured_errors = NULL, # errors to display 117 | custom_state = list(), # additional state values for bookmarking 118 | restoring_state = NULL # while restoring from bookmark, this holds the saved input values 119 | ) 120 | 121 | # -------------- helper functions -------------- 122 | 123 | # Run diagnoses using inspection arguments `insp_args` 124 | run_diagnoses_using_inspection_args <- function(insp_args, advance_progressbar = 0) { 125 | isolate({ 126 | if (length(input$plot_conf_diag_param_param) == 0) { 127 | diag_param_alpha <- 0.05 128 | } else { 129 | diag_param_alpha <- input$plot_conf_diag_param_param 130 | } 131 | 132 | # run diagnoses. if errors occur, write them to "error_msg" element in result list 133 | diag_res <- tryCatch({ 134 | res <- run_diagnoses(design_tab_proxy$react$design, insp_args, 135 | sims = input$simconf_sim_num, 136 | bootstrap_sims = input$simconf_bootstrap_num, 137 | diagnosands_call = react$diagnosands_call(diag_param_alpha), 138 | use_cache = !input$simconf_force_rerun, 139 | advance_progressbar = advance_progressbar, 140 | n_diagnosis_workers = n_diagnosis_workers) 141 | res$error_msg <- NULL 142 | res 143 | }, warning = function(exc) { 144 | list(error_msg = conditionMessage(exc)) 145 | }, error = function(exc) { 146 | list(error_msg = conditionMessage(exc)) 147 | }) 148 | }) 149 | 150 | diag_res 151 | } 152 | 153 | # set the names of arguments which were changed by the user. 154 | # this is evoked from "outside" from app.R once the user switches from design to inspect tab 155 | set_changed_args <- function(changed_args) { 156 | react$insp_args_changed <- changed_args 157 | react$insp_args_set_after_tab_switch <- TRUE 158 | } 159 | 160 | # -------------- reactive functions -------------- 161 | 162 | # reactive function to run diagnoses and return the results once "Update plot" is clicked 163 | get_diagnoses_for_plot <- eventReactive(input$update_plot, { 164 | req(design_tab_proxy$react$design, design_tab_proxy$react$design_argdefinitions) 165 | 166 | # in case re-running the diagnoses is not required, directly return the result from the 167 | # previous diagnoses saved to "react" 168 | if (!rerun_diagnoses_required()) { 169 | return(list( 170 | results = list( 171 | diagnosands_df_for_plot = react$diagnosands 172 | ), 173 | from_cache = react$diagnosands_cached 174 | )) 175 | } 176 | 177 | # get all arguments from the left side pane in the "Inspect" tab 178 | d_args <- design_tab_proxy$design_args() 179 | 180 | insp_args <- get_args_for_inspection(design_tab_proxy$react$design, 181 | design_tab_proxy$react$design_id, 182 | design_tab_proxy$react$design_argdefinitions, 183 | input, 184 | design_tab_proxy$get_fixed_design_args(), 185 | design_tab_proxy$input) 186 | 187 | if (max(sapply(insp_args, length)) == 0) { 188 | # only if at least one argument is a sequence (i.e. its length is > 1) for comparison, 189 | # run the diagnoses and return a result 190 | return(NULL) 191 | } 192 | 193 | print('will run diagnoses with arguments:') 194 | print(insp_args) 195 | 196 | # save the current state of the inspection parameters 197 | react$insp_args_used_in_plot <- insp_args 198 | react$insp_args_used_in_plot$simconf_sim_num <- input$simconf_sim_num 199 | react$insp_args_used_in_plot$simconf_bootstrap_num <- input$simconf_bootstrap_num 200 | 201 | # run diagnoses and get results 202 | diag_results <- run_diagnoses_using_inspection_args(insp_args, advance_progressbar = 1/6) 203 | 204 | if (!is.null(diag_results$error_msg)) { # if errors occurred, don't try to generate a plot and directly return NULL 205 | react$captured_errors <- c(react$captured_errors, diag_results$error_msg) 206 | return(NULL) 207 | } 208 | 209 | react$diagnosands_cached <- diag_results$from_cache 210 | react$diagnosands_full <- diag_results$results$diagnosands_df 211 | plotdf <- diag_results$results$diagnosands_df 212 | react$diagnosands <- plotdf 213 | diag_results$results$diagnosands_df_for_plot <- plotdf 214 | 215 | diag_results 216 | }) 217 | 218 | # reactive function to run diagnoses and return the results once "Run single design diagnosis" is clicked 219 | get_diagnosis_for_single_design <- eventReactive(input$update_plot_all_fixed, { 220 | req(design_tab_proxy$react$design, design_tab_proxy$react$design_argdefinitions) 221 | 222 | args <- design_tab_proxy$design_args() 223 | argnames <- names(args) 224 | argnames <- setdiff(argnames, 'fixed') 225 | insp_args <- args[argnames] 226 | 227 | run_diagnoses_using_inspection_args(insp_args) 228 | }) 229 | 230 | # get subset data frame of diagnosands for display and download once "Update plot" is clicked 231 | get_diagnosands_for_display <- reactive({ 232 | req(react$diagnosands) 233 | req(input$plot_conf_color_param) 234 | req(input$plot_conf_facets_param) 235 | req(input$plot_conf_diag_param) 236 | 237 | # assign a new dataframe, then subset this dataframe by estimand or estimator variable 238 | plotdf <- react$diagnosands 239 | 240 | if (isTruthy(input$plot_conf_estimand) && isTruthy(input$plot_conf_estimator)) { 241 | plotdf <- plotdf[plotdf$estimator_label == input$plot_conf_estimator & plotdf$estimand_label == input$plot_conf_estimand,] 242 | } 243 | 244 | # set columns to show 245 | if (input$plot_conf_x_param != "") { 246 | cols <- c(input$plot_conf_x_param) 247 | } else { 248 | cols <- character() 249 | } 250 | 251 | if (isTruthy(input$plot_conf_color_param) && input$plot_conf_color_param != '(none)') { 252 | cols <- c(cols, input$plot_conf_color_param) 253 | } 254 | if (isTruthy(input$plot_conf_facets_param) && input$plot_conf_facets_param != '(none)') { 255 | cols <- c(cols, input$plot_conf_facets_param) 256 | } 257 | 258 | if ("term" %in% colnames(react$diagnosands)){ 259 | cols <- c(cols, 'estimand_label','estimator_label', 'term', input$plot_conf_diag_param, paste0('se(', input$plot_conf_diag_param, ')')) 260 | } else { 261 | cols <- c(cols, 'estimand_label', 'estimator_label', input$plot_conf_diag_param, paste0('se(', input$plot_conf_diag_param, ')')) 262 | } 263 | 264 | # return data frame subset 265 | plotdf[cols] 266 | }) 267 | 268 | # determines whether it is necessary to re-run the diagnoses (i.e. when also the comparison parameters 269 | # on the left have been changed and not only the plot config. parameters) 270 | rerun_diagnoses_required <- reactive({ 271 | if (is.null(react$insp_args_used_in_plot)) { 272 | return(TRUE) 273 | } else { 274 | d_args <- design_tab_proxy$design_args() 275 | 276 | insp_args <- get_args_for_inspection(design_tab_proxy$react$design, 277 | design_tab_proxy$react$design_id, 278 | design_tab_proxy$react$design_argdefinitions, 279 | input, 280 | design_tab_proxy$get_fixed_design_args(), 281 | design_tab_proxy$input) 282 | 283 | insp_args$simconf_sim_num <- input$simconf_sim_num 284 | insp_args$simconf_bootstrap_num <- input$simconf_bootstrap_num 285 | return(!lists_equal_shallow(react$insp_args_used_in_plot, insp_args, na.rm = TRUE)) 286 | } 287 | }) 288 | 289 | # return a character vector with names of arguments that the user changed in the inspect tab, i.e. 290 | # those arguments where the values differ from those in the design tab. 291 | get_changed_args <- reactive({ 292 | # get current designer arguments and argument definitions 293 | d_args <- design_tab_proxy$design_args() 294 | defs <- defs <- design_tab_proxy$react$design_argdefinitions 295 | 296 | # record changed arguments 297 | changed_args <- character() 298 | for (argname in names(d_args)) { 299 | # get input names for respective tabs 300 | inp_name_design <- paste0('design_arg_', argname) 301 | inp_name_inspect <- paste0('inspect_arg_', argname) 302 | 303 | argdef <- as.list(defs[defs$names == argname,]) 304 | 305 | insp_inp_value <- input[[inp_name_inspect]] 306 | 307 | # skip on initial NULL values 308 | if (!is.null(insp_inp_value)) { 309 | # get input value from design tab and convert it to a string as it would be used in the inspect tab 310 | design_inp_value <- design_tab_proxy$input[[inp_name_design]] 311 | design_inp_value_str <- designer_arg_value_to_fraction(design_inp_value, argdef$class, argdef$vector, to_char = TRUE) 312 | 313 | if (insp_inp_value != design_inp_value_str) { # record if values differ 314 | changed_args <- c(changed_args, argname) 315 | } 316 | } 317 | } 318 | 319 | return(changed_args) 320 | }) 321 | 322 | # message to be displayed if results were loaded from cache 323 | results_cached_message <- reactive({ 324 | if (react$diagnosands_cached) { 325 | return(p('Results loaded from cached diagnoses. You can disable caching in the top panel "Configure simulations".')) 326 | } else { 327 | return('') 328 | } 329 | }) 330 | 331 | # message to be displayed if not all varying parameters are used in plot as visual properties 332 | plot_config_warning <- reactive({ 333 | inp_prefix <- 'plot_conf_' 334 | inp_plotconf <- c('x_param', 'color_param', 'facets_param') 335 | 336 | # single-bracket indexing of reactivevalues object is not allowed 337 | input_values <- sapply(paste0(inp_prefix, inp_plotconf), function(inp_id) { 338 | val <- input[[inp_id]] 339 | ifelse(val == '(none)', NA, val) 340 | }) 341 | input_values <- input_values[!is.na(input_values)] 342 | names(input_values) <- NULL 343 | 344 | unused_args <- setdiff(react$insp_args_varying, input_values) 345 | if (length(unused_args) > 0) { 346 | arglabels <- rm_usc(unused_args) 347 | return(paste('

The following designer parameters are varying, but are not bound to visual 348 | properties in the plot: ', paste(arglabels, collapse = ', '), '

You should 349 | bind them by adjusting the plot configuration on the right panel to make sure 350 | that a valid plot is constructed and to make this message disappear.

')) 351 | } 352 | 353 | return('') 354 | }) 355 | 356 | # reactive plot generation function 357 | generate_plot <- reactive({ 358 | n_steps = 6 359 | withProgress(message = 'Simulating data and generating plot...', value = 0, { 360 | incProgress(1/n_steps) 361 | diag_res <- get_diagnoses_for_plot() 362 | 363 | if (is.null(diag_res)) { 364 | return(NULL) 365 | } 366 | 367 | p <- NULL 368 | plotdf <- diag_res$results$diagnosands_df_for_plot 369 | 370 | isolate({ # isolate all other parameters used to configure the plot so that the "Update plot" button has to be clicked 371 | if (length(react$insp_args_varying) > 0) { 372 | diag_colnames <- colnames(plotdf) 373 | req(input$plot_conf_x_param, input$plot_conf_diag_param) 374 | req(input$plot_conf_x_param %in% diag_colnames) 375 | req(input$plot_conf_diag_param %in% diag_colnames) 376 | 377 | # the bound value of confidence interval: diagnosand values +/-SE*1.96 378 | plotdf$diagnosand_min <- plotdf[[input$plot_conf_diag_param]] - plotdf[[paste0("se(", input$plot_conf_diag_param, ")")]] * 1.96 379 | plotdf$diagnosand_max <- plotdf[[input$plot_conf_diag_param]] + plotdf[[paste0("se(", input$plot_conf_diag_param, ")")]] * 1.96 380 | 381 | # base aesthetics for line plot 382 | aes_args <- list( 383 | 'x' = input$plot_conf_x_param, 384 | 'y' = input$plot_conf_diag_param, 385 | 'ymin' = 'diagnosand_min', 386 | 'ymax' = 'diagnosand_max' 387 | 388 | ) 389 | 390 | # subset the plotdf by estimand or estimator variable 391 | if (isTruthy(input$plot_conf_estimand) && isTruthy(input$plot_conf_estimator)) { 392 | plotdf <- plotdf[plotdf$estimator_label == input$plot_conf_estimator & plotdf$estimand_label == input$plot_conf_estimand,] 393 | } 394 | # if the "color" parameter is set, add it to the aeshetics definition 395 | if (isTruthy(input$plot_conf_color_param) && input$plot_conf_color_param != '(none)') { 396 | plotdf[[input$plot_conf_color_param]] <- factor(plotdf[[input$plot_conf_color_param]]) 397 | aes_args$color <- input$plot_conf_color_param 398 | aes_args$fill <- input$plot_conf_color_param 399 | aes_args$group <- input$plot_conf_color_param 400 | } else { 401 | aes_args$group <- 1 402 | } 403 | 404 | # if the "facets" parameter is set, add it to the aeshetics definition 405 | if (isTruthy(input$plot_conf_facets_param) && input$plot_conf_facets_param != '(none)') { 406 | plotdf$facets_param <- as.factor(plotdf[[input$plot_conf_facets_param]]) 407 | } 408 | 409 | # create aesthetics definition 410 | aes_definition <- do.call(aes_string, aes_args) 411 | 412 | incProgress(1/n_steps) 413 | 414 | # create base line plot 415 | 416 | p <- ggplot(plotdf, aes_definition) + 417 | geom_line() + 418 | geom_point() + 419 | scale_y_continuous(name = str_cap(input$plot_conf_diag_param)) + 420 | dd_theme() + 421 | labs(x = input$plot_conf_x_param) 422 | 423 | # add confidence interval if requested 424 | if (isTruthy(input$plot_conf_confi_int_id)) { 425 | p <- p + geom_ribbon(alpha = 0.25, color = 'white') 426 | } 427 | 428 | # add facets if necessary 429 | if (isTruthy(input$plot_conf_facets_param) && input$plot_conf_facets_param != '(none)') { 430 | p <- p + facet_wrap(input$plot_conf_facets_param, ncol = 2, labeller = label_both) 431 | } 432 | 433 | incProgress(1/n_steps) 434 | } 435 | 436 | shinyjs::enable('reshape_diagnosands') 437 | shinyjs::enable('section_diagnosands_download_subset') 438 | shinyjs::enable('section_diagnosands_download_full') 439 | shinyjs::enable('convert_format_table') 440 | 441 | p 442 | }) 443 | }) 444 | }) 445 | 446 | # reactive button label 447 | btn_label <- reactive({ 448 | if (rerun_diagnoses_required()) { 449 | return('Run diagnoses and update plot') 450 | } else { 451 | return('Update plot') 452 | } 453 | }) 454 | 455 | 456 | # -------------- event observers -------------- 457 | 458 | # "reset values" button on left side: set inputs to defaults 459 | observeEvent(input$reset_inputs, { 460 | d_args <- design_tab_proxy$design_args() 461 | defs <- design_tab_proxy$react$design_argdefinitions 462 | 463 | defaults <- get_inspect_input_defaults(d_args, defs, list()) # pass empty input list 464 | 465 | for (argname in names(defaults)) { 466 | updateTextInput(session, paste0('inspect_arg_', argname), value = defaults[[argname]]) 467 | } 468 | }) 469 | 470 | # Action button label gets updated only when reactive inspector values don't change 471 | observeEvent(btn_label(), { updateActionButton(session, 'update_plot', btn_label()) }) 472 | 473 | 474 | # -------------- output elements: hidden -------------- 475 | 476 | # hidden (for conditional panel): return TRUE when all designer arguments were fixed, otherwise FALSE 477 | output$all_design_args_fixed <- reactive({ 478 | req(design_tab_proxy$react$design) 479 | design_tab_proxy$all_design_args_fixed() 480 | }) 481 | outputOptions(output, 'all_design_args_fixed', suspendWhenHidden = FALSE) 482 | 483 | # hidden output that records current design ID (i.e. designer name) in order to detect changes of the 484 | # designer and then reset the state of the inspect tab 485 | output$cur_design_id <- reactive({ 486 | if (!is.null(react$cur_design_id) && react$cur_design_id != design_tab_proxy$react$design_id) { 487 | # if the designer was changed, reset the reactive values 488 | react$diagnosands <- NULL 489 | react$diagnosands_full <- NULL 490 | react$diagnosands_cached <- FALSE 491 | react$diagnosands_call <- NULL 492 | react$available_diagnosands <- NULL 493 | react$design_params_used_in_plot <- NULL 494 | shinyjs::disable('update_plot') 495 | shinyjs::disable('reshape_diagnosands') 496 | shinyjs::disable('section_diagnosands_download_subset') 497 | shinyjs::disable('section_diagnosands_download_full') 498 | shinyjs::disable('convert_format_table') 499 | } 500 | 501 | react$cur_design_id <- design_tab_proxy$react$design_id 502 | react$cur_design_id 503 | }) 504 | outputOptions(output, 'cur_design_id', suspendWhenHidden = FALSE) 505 | 506 | # -------------- output elements: left side -------------- 507 | 508 | # left: show error messages if there are some (e.g. for invalid inputs) 509 | output$param_input_messages <- renderUI({ 510 | req(react$captured_errors) 511 | 512 | tags$div(class = 'error_msgs', paste(react$captured_errors, collapse = "\n")) 513 | }) 514 | 515 | # left: design parameters to inspect 516 | output$compare_design_parameters <- renderUI({ 517 | req(design_tab_proxy$react$design) 518 | 519 | if (design_tab_proxy$all_design_args_fixed()) { 520 | return(HTML('

No comparisons available since all parameters were set to fixed.

')) 521 | } 522 | 523 | d_args <- design_tab_proxy$design_args() 524 | defs <- design_tab_proxy$react$design_argdefinitions 525 | isolate({ 526 | if (!is.null(react$restoring_state)) { 527 | defaults <- react$restoring_state[startsWith(names(react$restoring_state), 'inspect_arg_')] 528 | names(defaults) <- substring(names(defaults), 13) # remove prefix 'inspect_arg_' 529 | } else { 530 | # set defaults: use value from design args in design tab unless the value was changed in the inspector tab 531 | if (react$insp_args_set_after_tab_switch) { 532 | # if we just switched over from the design tab, take over the values from there as long as they were 533 | # not recorded as "changed" before switching 534 | insp_args_changed <- react$insp_args_changed 535 | react$insp_args_set_after_tab_switch <- FALSE # reset 536 | } else { 537 | # otherwise respect the changes at the point where we switched to this tab *and* the changes done since then 538 | insp_args_changed <- union(react$insp_args_changed, get_changed_args()) 539 | } 540 | 541 | # get defaults for inspect inputs; react$design_params_used_in_plot is NULL when switching 542 | # from "design" tab for the first time after a designer was loaded 543 | defaults <- get_inspect_input_defaults(d_args, defs, input, insp_args_changed, 544 | use_only_d_args = is.null(react$design_params_used_in_plot)) 545 | } 546 | 547 | nspace <- NS('tab_inspect') 548 | param_boxes <- create_design_parameter_ui('inspect', design_tab_proxy$react, nspace, 549 | input = design_tab_proxy$input, 550 | defaults = defaults) 551 | reset_btn <- actionButton(nspace('reset_inputs'), 'Reset values') 552 | }) 553 | 554 | list(tags$div(reset_btn, param_boxes)) 555 | }) 556 | 557 | # -------------- output elements: center -------------- 558 | 559 | # center: messages for plot 560 | output$plot_message <- renderUI({ 561 | if (is.null(react$diagnosands)) { 562 | res <- HTML(inpector_help_text) 563 | } else { 564 | res <- results_cached_message() 565 | 566 | plot_conf_warn <- plot_config_warning() 567 | 568 | if (length(react$insp_args_varying) == 0) { 569 | res <- list(res, HTML('

No varying arguments were set on the left side, hence not plot can be 570 | generated. You can still access the diagnosis for the single generated design 571 | in the box below.

')) 572 | } else if (plot_conf_warn != '') { 573 | res <- list(res, HTML(plot_conf_warn)) 574 | } 575 | 576 | res <- div(res, class = 'alert alert-warning') 577 | } 578 | 579 | res 580 | }) 581 | 582 | # center: plot output 583 | # all the following hassle because Shiny would neither: 584 | # - accept "auto" as plot height 585 | # - allow to show/hide the plot inside a conditional panel (the "Run diagnoses" button would not work anymore) 586 | # - allow to show/hide the plot using shinyjs (same as above) 587 | output$plot_output <- renderUI({ 588 | if (is.null(react$diagnosands) || length(react$insp_args_varying) == 0) { 589 | h <- 1 590 | } else { 591 | h <- 400 592 | } 593 | 594 | nspace <- NS('tab_inspect') 595 | plotOutput(nspace('actual_plot_output'), height = h) 596 | }) 597 | 598 | output$actual_plot_output <- renderPlot({ 599 | p <- generate_plot() 600 | 601 | if (!is.null(p) && !is.null(react$diagnosands)) { 602 | shinyjs::enable('download_plot') 603 | shinyjs::enable('download_plot_code') 604 | } else { 605 | shinyjs::disable('download_plot') 606 | shinyjs::disable('download_plot_code') 607 | } 608 | 609 | p 610 | }) 611 | 612 | # center above plot: plot information 613 | output$plot_info <- renderUI({ 614 | if (is.null(design_tab_proxy$react$design)) { 615 | return(material_card(title = "No designer loaded", 616 | p('Please load a designer first in the "Design" tab.'))) 617 | } else { 618 | # get the values from the inspect tab 619 | d_args <- design_tab_proxy$design_args() 620 | 621 | insp_args <- get_args_for_inspection(design_tab_proxy$react$design, 622 | design_tab_proxy$react$design_id, 623 | design_tab_proxy$react$design_argdefinitions, 624 | input, 625 | design_tab_proxy$get_fixed_design_args(), 626 | design_tab_proxy$input) 627 | 628 | # show the design name 629 | title <- str_cap(design_tab_proxy$react$design_id) 630 | if (title == "Binary iv designer") title <- "Binary IV designer" 631 | fixed_text <- "" 632 | # show the fixed args 633 | if (length(design_tab_proxy$get_fixed_design_args()) > 0){ 634 | txt1 <- unname(sapply(design_tab_proxy$get_fixed_design_args(), function(x){ 635 | if (length(insp_args[[x]])> 1) insp_args[[x]] <- sprintf('(%s)', paste(insp_args[[x]], collapse = ', ')) 636 | paste(rm_usc(x), "=", insp_args[[x]], collapse = "\n") 637 | })) 638 | fixed_text <- paste("

Fixed arguments (not shown):
", paste0(txt1, collapse = ", ")) 639 | } 640 | req(design_tab_proxy$react$design) 641 | description <- attr(design_tab_proxy$react$design, 'description') 642 | 643 | return(material_card(title = title, 644 | HTML(attr(design_tab_proxy$react$design, 'description')), 645 | HTML(fixed_text))) 646 | } 647 | }) 648 | 649 | # center below plot: diagnosands table message 650 | output$section_diagnosands_message <- renderUI({ 651 | if (is.null(react$diagnosands)) { 652 | return(p('Missing simulations data. Vary design parameters on the left and click "Run diagnoses".')) 653 | } else { 654 | results_cached_message() 655 | } 656 | }) 657 | 658 | output$single_diagnosands_message <- renderUI({ 659 | if (is.null(react$diagnosands)) { 660 | return(p('Not data yet. Set comparison parameters and generate a plot first.')) 661 | } else { 662 | results_cached_message() 663 | } 664 | }) 665 | 666 | # center below plot: diagnosands table 667 | output$section_diagnosands_table <- renderDataTable({ 668 | if (input$reshape_diagnosands){ 669 | get_diagnosands_for_display() 670 | }else{ 671 | make_diagnosis_long(get_diagnosands_for_display(), input$plot_conf_diag_param, within_col = TRUE) 672 | } 673 | 674 | }, options = diagnosis_table_opts) 675 | 676 | # center below plot: diagnosis table for single design 677 | output$single_diagnosands_table <- renderDataTable({ 678 | diag_res <- get_diagnosis_for_single_design() 679 | react$diagnosands_cached <- diag_res$from_cache 680 | select(diag_res$results$diagnosands_df, -c(design_label, n_sims)) 681 | }, options = list_merge(diagnosis_table_opts, list(paging = FALSE))) 682 | 683 | # -------------- output elements: right side -------------- 684 | 685 | # right: inspection plot configuration 686 | output$plot_conf <- renderUI({ 687 | boxes <- list() 688 | 689 | if (!is.null(design_tab_proxy$react$design) && !is.null(design_tab_proxy$react$design_argdefinitions)) { 690 | # create list of input elements, all with a common prefix 691 | nspace <- NS('tab_inspect') 692 | inp_prefix <- 'plot_conf_' 693 | boxes <- list() 694 | args_fixed <- design_tab_proxy$get_fixed_design_args() 695 | all_fixed <- design_tab_proxy$all_design_args_fixed() 696 | 697 | if (is.null(react$restoring_state)) { 698 | input_defaults <- input 699 | } else { 700 | input_defaults <- react$restoring_state 701 | } 702 | 703 | # get estimates and diagnosis information 704 | # create the design instance and get its estimates 705 | d <- design_tab_proxy$design_instance() 706 | d_estimates <- draw_estimates(d) 707 | diag_info <- get_diagnosands_info(d) 708 | 709 | # get available diagnosands 710 | react$diagnosands_call <- diag_info$diagnosands_call 711 | react$available_diagnosands <- diag_info$available_diagnosands 712 | available_diagnosands <- react$available_diagnosands 713 | names(available_diagnosands) <- sapply(available_diagnosands, str_cap, USE.NAMES = FALSE) 714 | 715 | # 1. estimand 716 | inp_estimand_id <- paste0(inp_prefix, "estimand") 717 | inp_estimand <- selectInput(nspace(inp_estimand_id), "Estimand Label", 718 | choices = unique(d_estimates$estimand_label), 719 | selected = input_defaults[[inp_estimand_id]]) 720 | boxes <- list_append(boxes, inp_estimand) 721 | 722 | # 2. estimator 723 | inp_estimator_id <- paste0(inp_prefix, "estimator") 724 | inp_estimator <- selectInput(nspace(inp_estimator_id), "Estimator Label", 725 | choices = unique(d_estimates$estimator_label[d_estimates$estimand_label == input_defaults[[inp_estimand_id]]]), 726 | selected = input_defaults[[inp_estimator_id]]) 727 | boxes <- list_append(boxes, inp_estimator) 728 | 729 | # 3. coefficient 730 | if ("term" %in% names(d_estimates)) { 731 | coefficients <- d_estimates$term[d_estimates$estimand_label == input_defaults[[inp_estimand_id]] & d_estimates$estimator_label == input_defaults[[inp_estimator_id]]] 732 | inp_coeff_id <- paste0(inp_prefix, "coefficient") 733 | inp_coeff <- selectInput(nspace(inp_coeff_id), "Coefficient", 734 | choices = coefficients, 735 | selected = input_defaults[[inp_coeff_id]]) 736 | boxes <- list_append(boxes, inp_coeff) 737 | } 738 | 739 | # 4. diagnosand (y-axis) 740 | if (!all_fixed) { 741 | inp_diag_param_id <- paste0(inp_prefix, "diag_param") 742 | inp_diag_param <- selectInput(nspace(inp_diag_param_id), "Diagnosand (y-axis)", 743 | choices = available_diagnosands, 744 | selected = input_defaults[[inp_diag_param_id]]) 745 | boxes <- list_append(boxes, inp_diag_param) 746 | } 747 | 748 | # 4b. optional: diagnosand parameter 749 | if (all_fixed || (length(input_defaults[[inp_diag_param_id]]) > 0 && input_defaults[[inp_diag_param_id]] == 'power')) { 750 | inp_diag_param_param_id <- paste0(inp_prefix, "diag_param_param") 751 | if (length(input_defaults[[inp_diag_param_param_id]]) > 0) { 752 | inp_diag_param_param_default <- input_defaults[[inp_diag_param_param_id]] 753 | } else { 754 | inp_diag_param_param_default <- 0.05 755 | } 756 | inp_diag_param_param <- numericInput(nspace(inp_diag_param_param_id), "Alpha for power", 757 | min = 0, max = 1, step = 0.01, 758 | value = inp_diag_param_param_default) 759 | boxes <- list_append(boxes, inp_diag_param_param) 760 | } 761 | 762 | if (!all_fixed) { 763 | # 5. CI check box 764 | inp_con_int_param_id <- paste0(inp_prefix, "confi_int_id") 765 | inp_con_int_param <- checkboxInput(nspace(inp_con_int_param_id), label = "Show confidence interval", value = TRUE) 766 | boxes <- list_append(boxes, inp_con_int_param) 767 | 768 | # 6. main inspection parameter (x-axis) 769 | d_args <- design_tab_proxy$design_args() 770 | 771 | insp_args <- get_args_for_inspection(design_tab_proxy$react$design, 772 | design_tab_proxy$react$design_id, 773 | design_tab_proxy$react$design_argdefinitions, 774 | input_defaults, 775 | design_tab_proxy$get_fixed_design_args(), 776 | design_tab_proxy$input_defaults) 777 | 778 | if (length(insp_args)>0){ # inp_value is empty when we first load the inspect tab 779 | 780 | insp_args_NAs <- sapply(insp_args, function(arg) { any(is.na(arg)) }) 781 | insp_args_is_varying <- sapply(insp_args, function(arg) {any(length(arg) > 1)}) 782 | react$insp_args_varying <- names(insp_args_is_varying)[insp_args_is_varying] 783 | 784 | if (sum(insp_args_NAs) > 0) { 785 | shinyjs::disable('update_plot') 786 | react$captured_errors <- paste('Invalid values supplied to the following arguments:', 787 | paste(names(insp_args_NAs)[insp_args_NAs], collapse = ', ')) 788 | }else{ 789 | react$captured_errors <- NULL 790 | shinyjs::enable('update_plot') 791 | } 792 | 793 | insp_args_lengths <- sapply(insp_args, length) 794 | variable_args <- names(insp_args_lengths[insp_args_lengths > 1]) 795 | variable_args <- setdiff(variable_args, args_fixed) 796 | 797 | inp_x_param_id <- paste0(inp_prefix, "x_param") 798 | inp_x_param <- selectInput(nspace(inp_x_param_id), "Primary parameter (x-axis)", 799 | choices = variable_args, 800 | selected = input_defaults[[inp_x_param_id]]) 801 | 802 | boxes <- list_append(boxes, inp_x_param) 803 | 804 | # 7. secondary inspection parameter (color) 805 | variable_args_optional <- c('(none)',variable_args[variable_args != input_defaults[[inp_x_param_id]]]) 806 | inp_color_param_id <- paste0(inp_prefix, "color_param") 807 | inp_color_param <- selectInput(nspace(inp_color_param_id), "Secondary parameter (color)", 808 | choices = variable_args_optional, 809 | selected = input_defaults[[inp_color_param_id]]) 810 | boxes <- list_append(boxes, inp_color_param) 811 | 812 | # 8. tertiary inspection parameter (small multiples) 813 | if (length(variable_args_optional) <= 2) { 814 | variable_args_options <- variable_args_optional 815 | }else{ 816 | variable_args_options <- variable_args_optional[variable_args_optional != input_defaults[[inp_color_param_id]]] 817 | } 818 | # variable_args_options <- c('(none)',variable_args_optional[variable_args_optional != input_defaults[[inp_color_param_id]]]) 819 | inp_facets_param_id <- paste0(inp_prefix, "facets_param") 820 | inp_facets_param <- selectInput(nspace(inp_facets_param_id), "Tertiary parameter (small multiples)", 821 | choices = variable_args_options, 822 | selected = input_defaults[[inp_facets_param_id]]) 823 | boxes <- list_append(boxes, inp_facets_param) 824 | } 825 | } 826 | } 827 | 828 | do.call(material_card, c(title="Plot configuration", boxes)) 829 | }) 830 | 831 | # -------------- download handlers -------------- 832 | 833 | output$download_plot <- downloadHandler( 834 | filename = function() { 835 | design_name <- input$design_arg_design_name 836 | 837 | if (!isTruthy(design_name)) { 838 | design_name <- paste0("design-", Sys.Date()) 839 | } 840 | 841 | paste0(design_name, '_diagnostic_plot.png') 842 | }, 843 | content = function(file) { 844 | png(file, width = 1200, height = 900) 845 | print(generate_plot()) 846 | dev.off() 847 | } 848 | ) 849 | 850 | output$download_plot_code <- downloadHandler( 851 | filename = function() { 852 | design_name <- input$design_arg_design_name 853 | 854 | if (!isTruthy(design_name)) { 855 | design_name <- paste0("design-", Sys.Date()) 856 | } 857 | 858 | paste0(design_name, '_inspection_plot.R') 859 | }, 860 | content = function(fname) { 861 | code <- generate_plot_code(get_diagnosands_for_display(), 862 | react$cur_design_id, 863 | input$plot_conf_diag_param, 864 | input$plot_conf_x_param, 865 | input$plot_conf_color_param, 866 | input$plot_conf_facets_param, 867 | isTruthy(input$plot_conf_confi_int_id)) 868 | print(code) 869 | fh <- file(fname, 'w') 870 | writeLines(code, fh) 871 | close(fh) 872 | } 873 | ) 874 | 875 | # diagnosands download 876 | output$section_diagnosands_download_subset <- downloadHandler( 877 | filename = function() { # note that this seems to work only in a "real" browser, not in RStudio's browser 878 | design_name <- input$design_arg_design_name 879 | 880 | if (!isTruthy(design_name)) { 881 | design_name <- paste0("design-", Sys.Date()) 882 | } 883 | 884 | paste0(design_name, '_diagnosands.csv') 885 | }, 886 | content = function(file) { 887 | if (input$reshape_diagnosands) { 888 | download_data <- get_diagnosands_for_display() 889 | } else { 890 | download_data <- make_diagnosis_long(get_diagnosands_for_display(), 891 | input$plot_conf_diag_param, 892 | within_col = TRUE) 893 | } 894 | 895 | write.csv(download_data, file = file, row.names = FALSE) 896 | } 897 | ) 898 | 899 | # diagnosands download (full dataset) 900 | output$section_diagnosands_download_full <- downloadHandler( 901 | filename = function() { # note that this seems to work only in a "real" browser, not in RStudio's browser 902 | design_name <- input$design_arg_design_name 903 | if (!isTruthy(design_name)) { 904 | design_name <- paste0("design-", Sys.Date()) 905 | } 906 | 907 | paste0(design_name, '_diagnosands_full.csv') 908 | }, 909 | content = function(file) { 910 | if (input$reshape_diagnosands) { 911 | download_data <- react$diagnosands 912 | } else { 913 | download_data <- make_diagnosis_long(react$diagnosands, 914 | react$available_diagnosands, 915 | within_col = FALSE) 916 | } 917 | 918 | write.csv(download_data, file = file, row.names = FALSE) 919 | } 920 | ) 921 | 922 | # -------------- bookmarking -------------- 923 | 924 | # customize bookmarking process: add additional data to bookmarked state 925 | onBookmark(function(state) { 926 | print('BOOKMARKING IN INSPECT TAB:') 927 | 928 | # add open panels, because they're not restored automatically 929 | react$custom_state$panel_simconf_state <- input$inspect_sections_simconf_container 930 | react$custom_state$panel_diagnosis_state <- input$inspect_sections_container 931 | 932 | # store additional state objects 933 | for (objname in bookmark_store_react_objects) { 934 | react$custom_state[[objname]] <- react[[objname]] 935 | } 936 | 937 | print(react$custom_state) 938 | state$values$custom_state <- react$custom_state 939 | }) 940 | 941 | # customize restoring process 942 | onRestore(function(state) { 943 | print('RESTORING IN INSPECT TAB:') 944 | react$custom_state <- state$values$custom_state 945 | react$restoring_state <- state$input 946 | print(state) 947 | 948 | # restore additional state objects 949 | for (objname in bookmark_store_react_objects) { 950 | react[[objname]] <- react$custom_state[[objname]] 951 | } 952 | 953 | # re-open the panels 954 | updateCollapse(session, 'inspect_sections_simconf_container', open = react$custom_state$panel_simconf_state) 955 | updateCollapse(session, 'inspect_sections_container', open = react$custom_state$panel_diagnosis_state) 956 | 957 | # update the plot after a small delay when all inputs are ready 958 | shinyjs::delay(3000, { 959 | nspace <- NS('tab_inspect') 960 | react$restoring_state <- NULL 961 | shinyjs::click(nspace('update_plot')) 962 | }) 963 | }) 964 | 965 | # -------------- return values of this module -------------- 966 | 967 | # return reactive values and some functions to be accessed from other modules 968 | return(list( 969 | get_changed_args = get_changed_args, 970 | set_changed_args = set_changed_args 971 | )) 972 | } -------------------------------------------------------------------------------- /tests/startup-expected/001.json: -------------------------------------------------------------------------------- 1 | { 2 | "input": { 3 | "._bookmark_": 0, 4 | "learn_more": 0, 5 | "show_data_protection_policy": 0, 6 | "show_help_text": 0, 7 | "show_legal_notice": 0, 8 | "tab_design-design_arg_design_name": "", 9 | "tab_design-import_design_library": "two_arm_designer", 10 | "tab_design-import_design_library-selectized": "", 11 | "tab_design-import_from_design_lib": 0, 12 | "tab_design-sections_container": null, 13 | "tab_design-simdata_redraw": 0, 14 | "tab_inspect-inspect_sections_container": null, 15 | "tab_inspect-inspect_sections_simconf_container": null, 16 | "tab_inspect-simconf_bootstrap_num": 30, 17 | "tab_inspect-simconf_force_rerun": false, 18 | "tab_inspect-simconf_sim_num": 100, 19 | "tab_inspect-update_plot": 0, 20 | "tab_inspect-update_plot_all_fixed": 0 21 | }, 22 | "output": { 23 | "tab_design-design_supports_fixed_arg": { 24 | "message": "", 25 | "call": "NULL", 26 | "type": [ 27 | "shiny.silent.error", 28 | "validation" 29 | ] 30 | }, 31 | "tab_design-import_design_lib_id": { 32 | "html": "
\n