├── .Rbuildignore ├── .github ├── .gitignore └── workflows │ ├── R-CMD-check.yml │ └── test_coverage.yml ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R ├── answers.R ├── custom_widgets.R ├── formatters.R ├── guidelines.R ├── guidelines_shiny.R ├── labels.R ├── modifiers.R ├── module_dataset_chooser.R ├── package.R ├── question_utitlities.R ├── questions.R ├── renderers.R ├── shiny_server.R ├── shiny_ui.R ├── shiny_ui_methods_table.R ├── shiny_ui_modals.R ├── shiny_ui_options.R ├── shiny_ui_questions.R └── sysdata.rda ├── README.Rmd ├── README.md ├── clean_history.sh ├── data-raw ├── generate_help_pictures.R ├── generate_trajectory_type_pictures.R └── internal.R ├── dynguidelines.Rproj ├── inst ├── CITATION ├── NEWS ├── css │ ├── balancing-sliders.css │ ├── indeterminate-checkbox.css │ └── style.css ├── deploy │ ├── .gitignore │ ├── Dockerfile │ ├── common_commands.md │ ├── deploy.sh │ ├── dynguidelines-service.yaml │ └── server │ │ ├── server.R │ │ ├── shiny-server.conf │ │ ├── shiny-server.sh │ │ └── ui.R ├── img │ ├── complex_tree_example.png │ ├── cyclic_example.png │ ├── disconnected_example.png │ ├── favicon_16.png │ ├── logo_dynverse.png │ ├── logo_horizontal.png │ └── trajectory_types │ │ ├── acyclic_graph.png │ │ ├── bifurcation.png │ │ ├── convergence.png │ │ ├── cycle.png │ │ ├── disconnected_graph.png │ │ ├── graph.png │ │ ├── linear.png │ │ ├── multifurcation.png │ │ └── tree.png └── js │ ├── balancing-sliders.js │ ├── google-analytics.js │ ├── indeterminate-checkbox.js │ └── tooltips.js ├── man ├── answer_questions.Rd ├── dynguidelines.Rd ├── figures │ ├── demo.gif │ ├── dependencies.png │ ├── favicon.svg │ ├── favicon_16.png │ ├── favicon_32.png │ ├── favicon_96.png │ ├── logo.png │ ├── logo.svg │ ├── logo_horizontal.png │ └── logo_horizontal.svg ├── get_answers_code.Rd ├── get_questions.Rd ├── guidelines.Rd ├── shiny_server.Rd └── shiny_ui.Rd └── tests ├── testthat.R └── testthat ├── test-answers.R ├── test-formatters.R ├── test-guidelines.R ├── test-guidelines_shiny.R └── test-renderers.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^data-raw 4 | ^\.travis 5 | ^deploy 6 | clean_history.sh 7 | .git 8 | ^README\.Rmd$ 9 | ^LICENSE\.md$ 10 | ^LICENSE\.md$ 11 | ^\.github$ 12 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | - devel 6 | pull_request: 7 | branches: 8 | - master 9 | schedule: 10 | - cron: "0 0 * * 1" 11 | 12 | name: R-CMD-check 13 | 14 | jobs: 15 | R-CMD-check: 16 | runs-on: ${{ matrix.config.os }} 17 | 18 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 19 | 20 | strategy: 21 | fail-fast: false 22 | matrix: 23 | config: 24 | - {os: windows-latest, r: 'release'} 25 | - {os: macos-latest, r: 'release'} 26 | - {os: ubuntu-16.04, r: '3.6', rspm: "https://demo.rstudiopm.com/all/__linux__/xenial/latest"} 27 | - {os: ubuntu-16.04, r: 'release', rspm: "https://demo.rstudiopm.com/all/__linux__/xenial/latest"} 28 | 29 | env: 30 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 31 | RSPM: ${{ matrix.config.rspm }} 32 | 33 | steps: 34 | - uses: actions/checkout@v2 35 | 36 | - uses: r-lib/actions/setup-r@master 37 | with: 38 | r-version: ${{ matrix.config.r }} 39 | 40 | - uses: r-lib/actions/setup-pandoc@master 41 | 42 | - name: Query dependencies 43 | run: | 44 | install.packages('remotes') 45 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 46 | shell: Rscript {0} 47 | 48 | - name: Cache R packages 49 | if: runner.os != 'Windows' 50 | uses: actions/cache@v1 51 | with: 52 | path: ${{ env.R_LIBS_USER }} 53 | key: ${{ runner.os }}-r-${{ matrix.config.r }}-${{ hashFiles('.github/depends.Rds') }} 54 | restore-keys: ${{ runner.os }}-r-${{ matrix.config.r }}- 55 | 56 | - name: Install system dependencies 57 | if: runner.os == 'Linux' 58 | env: 59 | RHUB_PLATFORM: linux-x86_64-ubuntu-gcc 60 | run: | 61 | Rscript -e "remotes::install_github('r-hub/sysreqs')" 62 | sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))") 63 | sudo -s eval "$sysreqs" 64 | 65 | - name: Install dependencies 66 | run: | 67 | remotes::install_deps(dependencies = TRUE) 68 | remotes::install_cran("rcmdcheck") 69 | shell: Rscript {0} 70 | 71 | - name: Check 72 | env: 73 | _R_CHECK_CRAN_INCOMING_REMOTE_: false 74 | run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") 75 | shell: Rscript {0} 76 | 77 | - name: Upload check results 78 | if: failure() 79 | uses: actions/upload-artifact@master 80 | with: 81 | name: ${{ runner.os }}-r${{ matrix.config.r }}-results 82 | path: check 83 | 84 | -------------------------------------------------------------------------------- /.github/workflows/test_coverage.yml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | - devel 6 | pull_request: 7 | branches: 8 | - master 9 | 10 | name: test-coverage 11 | 12 | jobs: 13 | test-coverage: 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v2 17 | 18 | - uses: r-lib/actions/setup-r@master 19 | 20 | - uses: r-lib/actions/setup-pandoc@master 21 | 22 | - name: Query dependencies 23 | run: | 24 | install.packages('remotes') 25 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), "depends.Rds", version = 2) 26 | shell: Rscript {0} 27 | 28 | - name: Cache R packages 29 | uses: actions/cache@v1 30 | with: 31 | path: ${{ env.R_LIBS_USER }} 32 | key: ubuntu-r-release-${{ hashFiles('depends.Rds') }} 33 | restore-keys: ubuntu-r-release- 34 | 35 | - name: Install system dependencies 36 | if: runner.os == 'Linux' 37 | env: 38 | RHUB_PLATFORM: linux-x86_64-ubuntu-gcc 39 | run: | 40 | Rscript -e "remotes::install_github('rcannood/sysreqs')" 41 | sysreqs=$(Rscript -e "cat(sysreqs:::sysreq_commands_pkgs(sysreqs:::get_cran_sysreqs(sysreqs:::get_cran_deps('covr'))))") 42 | sudo -s eval "$sysreqs" 43 | 44 | - name: Install dependencies 45 | run: | 46 | install.packages(c("remotes")) 47 | remotes::install_deps(dependencies = TRUE) 48 | remotes::install_cran("covr") 49 | shell: Rscript {0} 50 | 51 | - name: Test coverage 52 | run: covr::codecov() 53 | shell: Rscript {0} 54 | 55 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | .DS_Store 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # parts of this travis yaml are based on https://gist.github.com/mjackson/5887963e7d8b8fb0615416c510ae8857 2 | language: r 3 | dist: trusty 4 | warnings_are_errors: true 5 | cache: 6 | directories: 7 | - $HOME/R/Library 8 | - $HOME/google-cloud-sdk 9 | - $HOME/.cache # phantomjs 10 | services: 11 | - docker 12 | env: 13 | global: 14 | # Do not prompt for user input when using any SDK methods. 15 | - CLOUDSDK_CORE_DISABLE_PROMPTS=1 16 | 17 | before_install: 18 | - source <(curl -sSL https://raw.githubusercontent.com/dynverse/travis_scripts/master/helper.sh) 19 | - install_phantomjs 20 | install: 21 | - install_cran devtools covr 22 | - install_cran covr 23 | - use_dynverse_devel 24 | - install_withdeps 25 | before_deploy: 26 | - if [ ! -d "$HOME/google-cloud-sdk/bin" ]; then rm -rf $HOME/google-cloud-sdk; export CLOUDSDK_CORE_DISABLE_PROMPTS=1; curl https://sdk.cloud.google.com | bash; fi 27 | - source /home/travis/google-cloud-sdk/path.bash.inc 28 | - gcloud --quiet version 29 | - gcloud --quiet components update 30 | - gcloud --quiet components update kubectl 31 | deploy: 32 | - provider: script 33 | script: ./inst/deploy/deploy.sh 34 | skip_cleanup: true 35 | on: 36 | branch: master 37 | after_success: 38 | - R -e 'covr::codecov()' 39 | 40 | jobs: 41 | include: 42 | - stage: prepare cache 43 | script: 44 | - echo Skip 45 | after_success: 46 | - echo Skip 47 | deplor: 48 | - echo Skip 49 | - stage: test 50 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Type: Package 2 | Package: dynguidelines 3 | Title: User guidelines for trajectory inference 4 | Version: 1.0.1 5 | Authors@R: 6 | c(person(given = "Wouter", 7 | family = "Saelens", 8 | role = "aut", 9 | email = "wouter.saelens@gmail.com", 10 | comment = c(ORCID = "0000-0002-7114-6248")), 11 | person(given = "Robrecht", 12 | family = "Cannoodt", 13 | role = c("aut", "cre"), 14 | email = "rcannood@gmail.com", 15 | comment = c(ORCID = "0000-0003-3641-729X"))) 16 | Description: A shiny app which lets you select the most optimal 17 | TI method based on a number of user-dependent and dataset-dependent 18 | parameters. After using the GUI, a user can copy the code necessary 19 | to reproduce the guidelines to their script. 20 | License: MIT + file LICENSE 21 | URL: https://github.com/dynverse/dynguidelines 22 | BugReports: https://github.com/dynverse/dynguidelines/issues 23 | Depends: 24 | R (>= 3.3) 25 | Imports: 26 | akima, 27 | colorspace, 28 | crayon, 29 | dplyr, 30 | dynutils (>= 1.0.2), 31 | dynwrap (>= 1.0.0), 32 | glue, 33 | grDevices, 34 | htmltools, 35 | knitr, 36 | purrr, 37 | shiny (>= 1.2.0), 38 | shinyjs, 39 | shinyWidgets, 40 | stringr, 41 | tibble, 42 | tidyr, 43 | utils, 44 | VGAM, 45 | viridis 46 | Suggests: 47 | shinytest, 48 | testthat 49 | Remotes: 50 | dynverse/dynutils, 51 | dynverse/dynwrap 52 | Encoding: UTF-8 53 | LazyData: true 54 | Roxygen: list(markdown = TRUE) 55 | RoxygenNote: 7.1.1 56 | Collate: 57 | 'formatters.R' 58 | 'labels.R' 59 | 'modifiers.R' 60 | 'questions.R' 61 | 'answers.R' 62 | 'custom_widgets.R' 63 | 'guidelines.R' 64 | 'guidelines_shiny.R' 65 | 'module_dataset_chooser.R' 66 | 'package.R' 67 | 'question_utitlities.R' 68 | 'renderers.R' 69 | 'shiny_server.R' 70 | 'shiny_ui.R' 71 | 'shiny_ui_methods_table.R' 72 | 'shiny_ui_modals.R' 73 | 'shiny_ui_options.R' 74 | 'shiny_ui_questions.R' 75 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2014-2020 2 | COPYRIGHT HOLDER: Robrecht Cannoodt, Wouter Saelens 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2014-2020 Robrecht Cannoodt, Wouter Saelens 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(answer_questions) 4 | export(get_answers_code) 5 | export(guidelines) 6 | export(guidelines_shiny) 7 | export(shiny_server) 8 | export(shiny_ui) 9 | import(dplyr) 10 | import(purrr) 11 | import(shiny) 12 | import(stringr) 13 | import(tibble) 14 | importFrom(dynutils,add_class) 15 | importFrom(dynutils,calculate_geometric_mean) 16 | importFrom(dynutils,extract_row_to_list) 17 | importFrom(grDevices,col2rgb) 18 | importFrom(utils,data) 19 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # dynguidelines 1.0.1 (29-06-2020) 2 | 3 | ## Fixes 4 | * Fix `get_questions()`: Remove accidental reliance on list name 5 | autocompletion, which has been removed from R. 6 | 7 | ## Minor changes 8 | * Migrate from Travis CI to Github Actions for CMD check and codecov, not yet for automated deployment. 9 | 10 | # dynguidelines 1.0 (29-03-2019) 11 | 12 | ## Minor changes 13 | * Remove dyneval dependency 14 | * Minor changes due to changes in dynwrap v1.0 15 | 16 | # dynguidelines 0.3.2 (17-12-2018) 17 | 18 | ## New features 19 | 20 | * Enable automatic deployment via travis-ci 21 | 22 | ## Fixes 23 | 24 | * Justify lens buttons 25 | * Use master branch of dynwrap instead of devel 26 | 27 | 28 | # dynguidelines 0.3.1 (16-11-2018) 29 | 30 | ## New features 31 | 32 | * Time and memory are now formatted relative to the limits in the questions (fixes #46) 33 | * If time and memory exceed the limit, they are clipped 34 | 35 | ## Fixes 36 | 37 | * Remove debug javascript messages 38 | * Fix javascript error for lenses which activated wrong columns 39 | * Fix bug when no n_cells or n_features is entered 40 | * Clean stability column names 41 | * Clean scalability column names 42 | * Add tooltips to priors 43 | * Small fixes for default columns 44 | * Cleanup of exported function and documentation 45 | 46 | # dynguidelines 0.3.0 (15-11-2018) 47 | 48 | ## New features 49 | 50 | * Add category headers, just like figure 2/3 51 | * Columns are now sorted within each category, categories are sorted according to figure 2/3 52 | * New columns: overall scores within each category, wrapper type, prior information 53 | * New lens: Summary (Fig. 2) 54 | * Show lenses by default 55 | 56 | ## Fixes 57 | 58 | * Several small cosmetic changes 59 | * Code and doi links are opened in a new tab 60 | * Not knowing the explicit topology will now filter on multifurcations as well 61 | 62 | # dynguidelines 0.2.1 (14-11-2018) 63 | 64 | * Add warning column for when a method errors too often 65 | * Several fixes for more readable columns (such as usability) 66 | * Update deployment instructions 67 | * Rename scaling to scalability 68 | 69 | # dynguidelines 0.2.0 (14-11-2018) 70 | 71 | * Update for new dynbenchmark results 72 | * Add new coloring scheme 73 | * Add stability, shown by default as a warning that a method produces an unstable result 74 | 75 | # dynguidelines 0.1.0 (16-04-2018) 76 | 77 | * INITIAL RELEASE: dynguidelines, user guidelines for trajectory inference 78 | - A shiny app which lets you select the most optimal trajectory inference method based on a number of user-dependent and dataset-dependent parameters 79 | -------------------------------------------------------------------------------- /R/answers.R: -------------------------------------------------------------------------------- 1 | ## Answer questions 2 | # get default answers based on questions 3 | get_defaults <- function(question_ids = names(get_questions())) { 4 | questions <- get_questions()[question_ids] 5 | map(questions, ~if(is.function(.$default)) {.$default()} else {.$default}) %>% set_names(names(questions)) 6 | } 7 | 8 | get_default <- function(question_id, questions = get_questions()) { 9 | default <- questions[[question_id]][["default"]] 10 | 11 | default 12 | } 13 | 14 | # function which generates the documentation for the answers function based on all the questions 15 | answer_questions_docs <- function() { 16 | questions <- get_questions() 17 | parameters <- paste0( 18 | "@param ... Answers to questions: \n", 19 | glue::glue( 20 | " - {names(questions)}: {map_chr(questions, 'label')} defaults to `{get_defaults(names(questions)) %>% as.character()}`: " 21 | ) %>% glue::glue_collapse("\n") 22 | ) 23 | 24 | parameters 25 | } 26 | 27 | #' Provide answers to questions 28 | #' 29 | #' @include questions.R 30 | #' @param dataset The dynwrap dataset object from which the answers will be computed 31 | #' @eval answer_questions_docs() 32 | #' 33 | #' @export 34 | answer_questions <- function(dataset = NULL, ...) { 35 | questions <- get_questions() 36 | 37 | # get either the defaults or the arguments given by the user 38 | given_answers <- list(...) 39 | default_answers <- get_defaults(names(questions)) 40 | default_answers <- default_answers[setdiff(names(default_answers), names(given_answers))] 41 | answers <- c(given_answers, default_answers) 42 | 43 | # get computed answers from dataset 44 | computed_question_ids <- character() 45 | if (!is.null(dataset)) { 46 | for (question_id in setdiff(names(questions), names(given_answers))) { 47 | if (is.function(questions[[question_id]]$default_dataset)) { 48 | new_default <- questions[[question_id]]$default_dataset(dataset, answers[[question_id]]) 49 | new_default <- list(new_default) # use list here to avoid xxx <- NULL removing the element 50 | answers[question_id] <- new_default 51 | computed_question_ids <- c(computed_question_ids, question_id) 52 | } 53 | } 54 | } 55 | 56 | for (question_id in setdiff(names(questions), names(given_answers))) { 57 | if (is.function(questions[[question_id]]$default)) { 58 | computed_question_ids <- c(computed_question_ids, question_id) 59 | } 60 | } 61 | 62 | tibble( 63 | question_id = names(answers), 64 | answer = answers, 65 | source = case_when( 66 | question_id %in% names(given_answers) ~ "adapted", 67 | question_id %in% computed_question_ids ~ "computed", 68 | TRUE ~ "default" 69 | ) 70 | ) 71 | } 72 | 73 | #' Produces the code necessary to reproduce guidelines given a set of answers 74 | #' 75 | #' @param answers An answers tibble as generated by [answer_questions()] 76 | #' 77 | #' @export 78 | get_answers_code <- function(answers = answer_questions()) { 79 | params <- c() 80 | 81 | adapted_answers <- answers %>% filter(source %in% c("computed", "adapted")) 82 | params <- 83 | map2_chr(adapted_answers$question_id, adapted_answers$answer, function(question_id, answer) { 84 | glue::glue("{question_id} = {glue::glue_collapse(deparse(answer, width.cutoff = 80L))}") 85 | }) 86 | 87 | if (length(params) == 0) { 88 | code <- "answers <- dynguidelines::answer_questions()" 89 | } else { 90 | code <- glue::glue( 91 | "answers <- dynguidelines::answer_questions(", 92 | glue::glue_collapse(paste0(" ", params), ", \n"), 93 | ")", 94 | .sep = "\n", 95 | .trim = FALSE 96 | ) 97 | } 98 | 99 | code <- paste( 100 | "# Reproduces the guidelines as created in the shiny app", 101 | code, 102 | "guidelines <- dynguidelines::guidelines(answers = answers)", 103 | sep = "\n" 104 | ) 105 | 106 | code 107 | } -------------------------------------------------------------------------------- /R/custom_widgets.R: -------------------------------------------------------------------------------- 1 | collapsePanel <- function(..., header = "", show_on_start = FALSE, id = "") { 2 | collapse_id <- paste0("collapse", sample(1:100000000, 1)) 3 | div( 4 | class = "panel panel-default", 5 | div( 6 | class = paste0("panel-heading", ifelse(show_on_start, "", " collapsed")), 7 | `data-target` = paste0("#", collapse_id), 8 | `data-toggle` = "collapse", 9 | span(icon("caret-down"), header) 10 | ), 11 | div( 12 | id = collapse_id, 13 | class = paste0("panel-collapse collapse", ifelse(show_on_start, " in", "")), 14 | div( 15 | ... 16 | ) 17 | ), 18 | id = id 19 | ) 20 | } 21 | 22 | dropNulls <- function(x) { 23 | x[!vapply(x, is.null, FUN.VALUE = logical(1))] 24 | } 25 | 26 | balancingSliders <- function( 27 | inputId, 28 | label, 29 | labels, 30 | ids, 31 | values, 32 | min = 0, 33 | max = 1, 34 | sum = 1, 35 | step = 0.01, 36 | tooltips = TRUE, 37 | ticks = FALSE 38 | ) { 39 | sliderTags <- pmap(lst(label = labels, id = ids, value = values), function(label, id, value) { 40 | sliderProps <- dropNulls(list( 41 | id = id, 42 | class = "js-range-slider", 43 | `data-type` = "single", 44 | `data-from` = value, 45 | `data-min` = min, 46 | `data-max` = max, 47 | `data-step` = step, 48 | `data-grid` = ticks 49 | )) 50 | 51 | sliderTag <- div( 52 | class = "form-group shiny-input-container", 53 | style = paste0("width: 100%;"), 54 | `data-sum` = 1, 55 | tags$button(id = id, class = "lock btn btn-xs", icon("lock")), 56 | tags$label(shiny::HTML(label)), 57 | do.call(tags$input, sliderProps) 58 | ) 59 | }) 60 | 61 | tags$div( 62 | class = "form-group shiny-input-container balancing-sliders", 63 | id = inputId, 64 | singleton(tags$head(includeScript(system.file("js/balancing-sliders.js", package = "dynguidelines")))), 65 | singleton(tags$head(includeCSS(system.file("css/balancing-sliders.css", package = "dynguidelines")))), 66 | tags$label( 67 | class = "control-label", 68 | `for` = inputId, 69 | label 70 | ), 71 | sliderTags 72 | ) 73 | } 74 | 75 | 76 | 77 | 78 | indeterminateCheckbox <- function( 79 | inputId, 80 | label, 81 | value, 82 | ... 83 | ) { 84 | tags$span( 85 | singleton(tags$head(includeScript(system.file("js/indeterminate-checkbox.js", package = "dynguidelines")))), 86 | singleton(tags$head(includeCSS(system.file("css/indeterminate-checkbox.css", package = "dynguidelines")))), 87 | class = "indeterminate-checkbox", 88 | id = inputId, 89 | tags$label( 90 | tags$input( 91 | type = "checkbox", 92 | value = "", 93 | `data-initial` = value 94 | ), 95 | label 96 | ) 97 | ) 98 | } 99 | 100 | updateIndeterminateCheckboxInput <- function(session, inputId, value) { 101 | message <- list(value=value) 102 | session$sendInputMessage(inputId, message) 103 | } 104 | -------------------------------------------------------------------------------- /R/formatters.R: -------------------------------------------------------------------------------- 1 | format_100 <- function(y) { 2 | round(y * 100) 3 | } 4 | 5 | 6 | format_time <- function(x, min = 1, max = 60*60*24*10) { 7 | map_chr(x, function(x) { 8 | if (is.na(x)) { 9 | NA 10 | } else if (x < min) { 11 | paste0("<", format_time(min)) 12 | } else if (x > max) { 13 | paste0(">", format_time(max)) 14 | } else if(x < 60) { 15 | paste0(round(x), "s") 16 | } else if (x < (60*60)) { 17 | paste0(round(x/60), "m") 18 | } else if (x < (60*60*24)) { 19 | paste0(round(x/60/60), "h") 20 | } else { 21 | paste0(round(x/60/60/24), "d") 22 | } 23 | }) 24 | } 25 | process_time <- function(x) { 26 | map_dbl(x, function(x) { 27 | if (is.na(x)) { 28 | NA 29 | } else if (x == "\U221E") { 30 | Inf 31 | } else if (str_detect(x, "([0-9]*)[smhd]")) { 32 | number <- as.numeric(gsub("([0-9]*)[smhd]", "\\1", x)) 33 | if (endsWith(x, "s")) { 34 | number 35 | } else if (endsWith(x, "m")) { 36 | number * 60 37 | } else if (endsWith(x, "h")) { 38 | number * 60 * 60 39 | } else if (endsWith(x, "d")) { 40 | number * 60 * 60 * 24 41 | } 42 | } else { 43 | stop("Invalid time: ", x) 44 | } 45 | }) 46 | } 47 | 48 | format_memory <- function(x, min = 1000, max = 10**20) { 49 | map_chr(x, function(x) { 50 | if (is.na(x)) { 51 | NA 52 | } else if (x < min) { 53 | paste0("<", format_memory(min)) 54 | } else if (x > max) { 55 | paste0(">", format_memory(max)) 56 | } else if (x < 10^3) { 57 | paste0(round(x), "B") 58 | } else if (x < 10^6) { 59 | paste0(round(x/10^3), "kB") 60 | } else if (x < 10^9) { 61 | paste0(round(x/10^6), "MB") 62 | } else if (x < 10^12) { 63 | paste0(round(x/10^9), "GB") 64 | } else { 65 | paste0(round(x/10^12), "TB") 66 | } 67 | }) 68 | } 69 | process_memory <- function(x) { 70 | map_dbl(x, function(x) { 71 | if (is.na(x)) { 72 | NA 73 | } else if (x == "\U221E") { 74 | Inf 75 | } else { 76 | number <- as.numeric(gsub("([0-9]*)[kMGT]?B", "\\1", x)) 77 | unit <- gsub("[0-9]*([kMGT]?B)", "\\1", x) 78 | if (unit == "B") { 79 | number 80 | } else if (unit == "kB") { 81 | number * 10^3 82 | } else if (unit == "MB") { 83 | number * 10^6 84 | } else if (unit == "GB") { 85 | number * 10^9 86 | } else if (unit == "TB") { 87 | number * 10^12 88 | } else { 89 | stop("Invalid memory: ", x) 90 | } 91 | } 92 | }) 93 | } -------------------------------------------------------------------------------- /R/guidelines.R: -------------------------------------------------------------------------------- 1 | #' Provide guidelines on which methods to use, optionally based on a given dataset 2 | #' 3 | #' `guidelines()` immediately returns a set of guidelines. Use the `answers` arguments to provide answers 4 | #' `guidelines_shiny()` opens the shiny app 5 | #' 6 | #' @param dataset The dynwrap dataset object from which some of the answers will be precomputed 7 | #' @param answers A set answers generated by [answer_questions()] 8 | #' 9 | #' @return Returns a dynguidelines::guidelines object, containing 10 | #' - `methods`: Ordered tibble containing information about the selected methods 11 | #' - `method_columns`: Information about what columns in methods are given and whether the were used for filtering or ordering 12 | #' - `methods_aggr`: Same columns as `methods`, but includes filtered methods 13 | #' - `answers`: An answers tibble, can be provided again to this function to reproduce the guidelines 14 | #' - `methods_selected`: Ids for all selected methods, can be given to [dynwrap::infer_trajectory()] 15 | #' 16 | #' @export 17 | guidelines <- function( 18 | dataset = NULL, 19 | answers = answer_questions(dataset = dataset) 20 | ) { 21 | # build data with default order and columns 22 | method_columns <- get_renderers() %>% 23 | filter(!is.na(default)) %>% 24 | select(column_id) %>% 25 | mutate(filter = FALSE, order = ifelse(column_id == "overall_benchmark", TRUE, FALSE)) 26 | 27 | # construct data object 28 | data <- lst(methods_aggr = methods_aggr %>% mutate(selected = FALSE), method_columns, answers) 29 | 30 | # get the answers in a list 31 | question_answers <- answers %>% select(question_id, answer) %>% deframe() 32 | 33 | # process default 34 | data <- default_modifier(data, question_answers) 35 | 36 | # call the modifiers if the question is active 37 | for (question in get_questions()) { 38 | # only modify if question is checkbox/picker (and therefore NULL can be a valid answer) or if answers is not NULL 39 | if(question$type %in% c("checkbox", "picker") || !is.null(question_answers[[question$question_id]])) { 40 | # only modify if question is active 41 | if(question$active_if(question_answers)) { 42 | data <- question$modifier(data, question_answers) 43 | data$methods_aggr %>% select(method_name) 44 | } 45 | } 46 | } 47 | 48 | # filter method_columns based on last 49 | data$method_columns <- data$method_columns %>% 50 | group_by(column_id) %>% 51 | slice(n()) %>% 52 | ungroup() 53 | 54 | # create the methods 55 | data$methods <- data$methods_aggr[match(data$methods_selected, data$methods_aggr$method_id), data$method_columns$column_id] 56 | 57 | data <- add_class(data, "dynguidelines::guidelines") 58 | data 59 | } -------------------------------------------------------------------------------- /R/guidelines_shiny.R: -------------------------------------------------------------------------------- 1 | #' @rdname guidelines 2 | #' @inheritParams shiny::runApp 3 | #' @param ... Other parameters given to [shiny::runApp()] 4 | #' @export 5 | guidelines_shiny <- function( 6 | dataset = NULL, 7 | answers = answer_questions(dataset = dataset), 8 | port = NULL, 9 | launch.browser = TRUE, 10 | host = NULL, 11 | ... 12 | ) { 13 | 14 | app <- shiny::shinyApp( 15 | shiny_ui(), 16 | shiny_server(answers = answers) 17 | ) 18 | 19 | shiny::runApp( 20 | app, 21 | port = port, 22 | launch.browser = launch.browser, 23 | host = host, 24 | ... 25 | ) 26 | } 27 | -------------------------------------------------------------------------------- /R/labels.R: -------------------------------------------------------------------------------- 1 | label_capitalise <- function(x) { 2 | capitalise <- function(string) { 3 | capped <- grep("^[A-Z]", string, invert = TRUE) 4 | substr(string[capped], 1, 1) <- toupper(substr(string[capped], 1, 1)) 5 | string 6 | } 7 | 8 | x %>% str_replace_all("_", " ") %>% capitalise() 9 | } 10 | 11 | label_split <- function(x) { 12 | x %>% str_replace_all("_", " ") 13 | } 14 | 15 | 16 | #' @importFrom grDevices col2rgb 17 | html_color <- function (colors){ 18 | map_chr(colors, function(color) { 19 | if (substr(color, 1, 1) != "#" | nchar(color) != 9) 20 | return(color) 21 | rgba_code <- grDevices::col2rgb(color, alpha = TRUE) 22 | rgba_code[4] <- round(rgba_code[4]/255, 2) 23 | paste0("rgba(", paste(rgba_code, collapse = ", "),")") 24 | }) 25 | } -------------------------------------------------------------------------------- /R/modifiers.R: -------------------------------------------------------------------------------- 1 | default_modifier <- function(data, answers) { 2 | data$methods_aggr <- data$methods_aggr %>% arrange(-benchmark_overall_overall) 3 | 4 | # default benchmark 5 | benchmark_overall_overall <- methods_aggr %>% 6 | select(method_id, benchmark) %>% 7 | filter(!map_lgl(benchmark, is.null)) %>% 8 | tidyr::unnest(benchmark) %>% 9 | calculate_benchmark_score(answers = answers) 10 | data$methods_aggr$benchmark_overall_overall <- benchmark_overall_overall[data$methods_aggr$method_id] 11 | 12 | data$method_columns <- data$method_columns %>% 13 | add_row(column_id = "benchmark_overall_overall", order = TRUE) 14 | 15 | # default order 16 | data$methods_aggr <- data$methods_aggr %>% arrange(-benchmark_overall_overall) 17 | 18 | # add stability and error warning column 19 | scale_clip <- function(x, min, max) { 20 | case_when( 21 | x < min ~ 1, 22 | x < max ~ 1 - (x - min) / (max - min), 23 | TRUE ~ 0 24 | ) 25 | } 26 | 27 | data$methods_aggr <- data$methods_aggr %>% mutate( 28 | stability_warning = scale_clip(stability_overall_overall, 0.5, 0.8), 29 | error_warning = 1 - scale_clip(benchmark_overall_pct_errored, 0.2, 0.5) 30 | ) 31 | data$method_columns <- data$method_columns %>% 32 | add_row(column_id = "stability_warning", order = FALSE) %>% 33 | add_row(column_id = "error_warning", order = FALSE) 34 | 35 | data 36 | } 37 | 38 | 39 | multiple_disconnected_modifier <- function(data, answers) { 40 | if(isTRUE(answers$multiple_disconnected)) { 41 | data$methods_aggr <- data$methods_aggr %>% filter(method_detects_disconnected_graph) 42 | data$method_columns <- data$method_columns %>% 43 | add_row(column_id = "method_detects_disconnected_graph", filter = TRUE, order = FALSE) 44 | } 45 | data 46 | } 47 | 48 | 49 | expect_topology_modifier <- function(data, answers) { 50 | if (!isTRUE(answers$expect_topology)) { 51 | data$methods_aggr <- data$methods_aggr %>% filter(method_detects_linear & method_detects_bifurcation & method_detects_multifurcation & method_detects_tree) 52 | data$method_columns <- data$method_columns %>% 53 | bind_rows( 54 | tibble( 55 | column_id = c("method_detects_linear", "method_detects_bifurcation", "method_detects_multifurcation", "method_detects_tree"), 56 | filter = TRUE, 57 | order = FALSE 58 | ) 59 | ) 60 | } 61 | data 62 | } 63 | 64 | 65 | expected_topology_modifier <- function(data, answers) { 66 | trajectory_type_column <- paste0("method_detects_", answers$expected_topology) 67 | score_column <- paste0("benchmark_tt_", answers$expected_topology) 68 | 69 | trajectory_type_score <- methods_aggr %>% 70 | select(method_id, benchmark) %>% 71 | filter(!map_lgl(benchmark, is.null)) %>% 72 | tidyr::unnest(benchmark) %>% 73 | filter(dataset_trajectory_type == answers$expected_topology) %>% 74 | calculate_benchmark_score(answers = answers) 75 | data$methods_aggr[score_column] <- trajectory_type_score[data$methods_aggr$method_id] 76 | 77 | data$methods_aggr <- data$methods_aggr[data$methods_aggr[[trajectory_type_column]], ] %>% arrange(-.[[score_column]]) 78 | data$method_columns <- data$method_columns %>% 79 | mutate(order = FALSE) %>% 80 | add_row(column_id = score_column, order = TRUE, filter = FALSE) %>% 81 | add_row(column_id = trajectory_type_column, filter = TRUE, order = FALSE) 82 | 83 | data 84 | } 85 | 86 | 87 | expect_cycles_modifier <- function(data, answers) { 88 | if(isTRUE(answers$expect_cycles)) { 89 | data$methods_aggr <- data$methods_aggr %>% filter(method_detects_graph & method_detects_cycle) 90 | data$method_columns <- data$method_columns %>% 91 | bind_rows( 92 | tibble( 93 | column_id = c("method_detects_graph", "method_detects_cycle"), 94 | filter = TRUE, 95 | order = FALSE 96 | ) 97 | 98 | ) 99 | } 100 | data 101 | } 102 | 103 | 104 | expect_complex_tree_modifier <- function(data, answers) { 105 | if(isTRUE(answers$expect_complex_tree)) { 106 | data$methods_aggr <- data$methods_aggr %>% arrange(-benchmark_tt_tree) 107 | data$method_columns <- data$method_columns %>% 108 | mutate(order = FALSE) %>% 109 | add_row(column_id = "benchmark_tt_tree", filter = FALSE, order = TRUE) 110 | } 111 | data 112 | } 113 | 114 | dynmethods_modifier <- function(data, answers) { 115 | data 116 | } 117 | 118 | 119 | programming_interface_modifier <- function(data, answers) { 120 | if (!isTRUE(answers$programming_interface)) { 121 | data$methods_aggr <- data$methods_aggr %>% filter(gui > 0) 122 | } 123 | 124 | data 125 | } 126 | 127 | 128 | languages_modifier <- function(data, answers) { 129 | data$methods_aggr <- data$methods_aggr %>% filter(method_platform %in% answers$languages) 130 | data$method_columns <- data$method_columns %>% 131 | add_row(column_id = "method_platform", filter = TRUE, order = FALSE) 132 | 133 | data 134 | } 135 | 136 | 137 | user_friendliness_modifier <- function(data, answers) { 138 | data$methods_aggr <- data$methods_aggr %>% filter(qc_app_user_friendly >= as.numeric(answers$user_friendliness)/100) 139 | data$method_columns <- data$method_columns %>% 140 | add_row(column_id = "qc_app_user_friendly", filter = TRUE, order = FALSE) 141 | 142 | data 143 | } 144 | 145 | developer_friendliness_modifier <- function(data, answers) { 146 | data$methods_aggr <- data$methods_aggr %>% filter(qc_app_developer_friendly >= as.numeric(answers$developer_friendliness)/100) 147 | data$method_columns <- data$method_columns %>% 148 | add_row(column_id = "qc_app_developer_friendly", filter = TRUE, order = FALSE) 149 | 150 | data 151 | } 152 | 153 | 154 | 155 | invoke_if_function <- function(func, ...) { 156 | if(!is.null(func)) { 157 | func(...) 158 | } else { 159 | NA 160 | } 161 | } 162 | 163 | 164 | time_modifier <- function(data, answers) { 165 | time_cutoff <- process_time(answers$time) 166 | 167 | if (!is.na(time_cutoff)) { 168 | n_cells <- ifelse(is.na(answers$n_cells), 1, answers$n_cells) 169 | n_features <- ifelse(is.na(answers$n_features), 1, answers$n_features) 170 | 171 | # calculate the time 172 | data$methods_aggr <- data$methods_aggr %>% 173 | mutate( 174 | scaling_predicted_time = map_dbl( 175 | scaling_models_predict_time, 176 | invoke_if_function, 177 | n_cells = n_cells, 178 | n_features = n_features 179 | ) 180 | ) 181 | 182 | # filter on time 183 | data$methods_aggr <- data$methods_aggr %>% 184 | filter(is.na(scaling_predicted_time) | scaling_predicted_time <= time_cutoff) 185 | 186 | # add to method columns 187 | data$method_columns <- data$method_columns %>% 188 | add_row(column_id = "scaling_predicted_time", filter = TRUE, order = FALSE) 189 | } 190 | data 191 | } 192 | 193 | memory_modifier <- function(data, answers) { 194 | memory_cutoff <- process_memory(answers$memory) 195 | if (!is.na(memory_cutoff)) { 196 | n_cells <- ifelse(is.na(answers$n_cells), 1, answers$n_cells) 197 | n_features <- ifelse(is.na(answers$n_features), 1, answers$n_features) 198 | 199 | # calculate the memory 200 | data$methods_aggr <- data$methods_aggr %>% 201 | mutate( 202 | scaling_predicted_mem = map_dbl( 203 | scaling_models_predict_mem, 204 | invoke_if_function, 205 | n_cells = n_cells, 206 | n_features = n_features 207 | ) 208 | ) 209 | 210 | # filter on memory 211 | data$methods_aggr <- data$methods_aggr %>% 212 | filter(is.na(scaling_predicted_mem) | scaling_predicted_mem <= memory_cutoff) 213 | 214 | # add to method columns 215 | data$method_columns <- data$method_columns %>% 216 | add_row(column_id = "scaling_predicted_mem", filter = TRUE, order = FALSE) 217 | } 218 | 219 | data 220 | } 221 | 222 | 223 | prior_information_modifier <- function(data, answers) { 224 | unavailable_priors <- dynwrap::priors %>% filter(!prior_id %in% answers$prior_information) %>% pull(prior_id) 225 | data$methods_aggr <- data$methods_aggr %>% 226 | filter( 227 | map_lgl(method_required_priors, ~!any(. %in% unavailable_priors)) 228 | ) 229 | 230 | data 231 | } 232 | 233 | 234 | method_selection_modifier <- function(data, answers) { 235 | data 236 | } 237 | 238 | 239 | dynamic_n_methods_modifier <- function(data, answers) { 240 | data$methods_aggr <- data$methods_aggr %>% 241 | mutate(selected = row_number() < 5) 242 | data$method_columns <- data$method_columns %>% 243 | add_row(column_id = "selected", filter = FALSE, order = FALSE) 244 | data$methods_selected <- data$methods_aggr %>% filter(selected) %>% pull(method_id) 245 | 246 | data 247 | } 248 | 249 | 250 | fixed_n_methods_modifier <- function(data, answers) { 251 | data$methods_aggr <- data$methods_aggr %>% 252 | mutate(selected = row_number() < answers$fixed_n_methods+1) 253 | data$method_columns <- data$method_columns %>% 254 | add_row(column_id = "selected", filter = FALSE, order = FALSE) 255 | data$methods_selected <- data$methods_aggr %>% filter(selected) %>% pull(method_id) 256 | 257 | data 258 | } 259 | 260 | 261 | n_cells_modifier <- function(data, answers) { 262 | data 263 | } 264 | 265 | 266 | n_features_modifier <- function(data, answers) { 267 | data 268 | } 269 | 270 | 271 | docker_modifier <- function(data, answers) { 272 | data 273 | } 274 | 275 | 276 | metric_importance_modifier <- function(data, answers) { 277 | data 278 | } 279 | 280 | 281 | 282 | 283 | 284 | calculate_benchmark_score <- function(benchmark, answers) { 285 | benchmark %>% 286 | filter(!dataset_id %in% answers$exclude_datasets) %>% 287 | group_by(method_id, dataset_trajectory_type) %>% 288 | summarise_if(is.numeric, mean) %>% 289 | summarise_if(is.numeric, mean) %>% 290 | mutate(score = dynutils::calculate_geometric_mean(.[, benchmark_metrics$metric_id], weights = unlist(answers$metric_importance[benchmark_metrics$metric_id]))) %>% 291 | select(method_id, score) %>% 292 | deframe() 293 | } -------------------------------------------------------------------------------- /R/module_dataset_chooser.R: -------------------------------------------------------------------------------- 1 | dataset_chooser_input <- function(id, data) { 2 | # create namespace of shiny modules 3 | ns <- NS(id) 4 | 5 | # get information on datasets 6 | benchmark_datasets_info <- data$benchmark_datasets_info 7 | 8 | # filter datasets on source 9 | all_sources <- unique(benchmark_datasets_info$source) 10 | source_buttons <- shinyWidgets::checkboxGroupButtons( 11 | inputId = ns("sources"), 12 | label = "Dataset sources", 13 | selected = all_sources, 14 | choices = all_sources, 15 | status = "default" 16 | ) 17 | 18 | # filter datasets on trajectory type 19 | all_trajectory_types <- unique(benchmark_datasets_info$trajectory_type) 20 | choices <- map(all_trajectory_types, function(trajectory_type) { 21 | span( 22 | img(src = str_glue("img/trajectory_types/{trajectory_type}.png"), class = "trajectory_type"), 23 | label_capitalise(trajectory_type) 24 | ) 25 | }) %>% set_names(all_trajectory_types) 26 | 27 | trajectory_type_buttons <- shinyWidgets::checkboxGroupButtons( 28 | inputId = ns("trajectory_types"), 29 | label = "Trajectory types", 30 | selected = all_trajectory_types, 31 | choiceNames = unname(choices), 32 | choiceValues = names(choices), 33 | status = "default" 34 | ) 35 | 36 | # filter dataset individually 37 | dataset_picker <- shinyWidgets::pickerInput( 38 | inputId = ns("ids"), 39 | label = "Select individual datasets", 40 | choices = benchmark_datasets_info$id, 41 | selected = benchmark_datasets_info$id, 42 | multiple = TRUE, 43 | options = list( 44 | `actions-box` = TRUE, 45 | `deselect-all-text` = "None", 46 | `select-all-text` = "All", 47 | `none-selected-text` = "None" 48 | ) 49 | ) 50 | 51 | tagList( 52 | tags$p("Number of datasets: ", textOutput(ns("n_datasets"), container = tags$em), "/", nrow(data$benchmark_datasets)), 53 | 54 | source_buttons, 55 | 56 | trajectory_type_buttons, 57 | 58 | tags$style(" 59 | .dropdown-menu.inner { 60 | max-height: 200px!important; 61 | } 62 | "), 63 | dataset_picker 64 | ) 65 | } 66 | 67 | 68 | dataset_chooser <- function(input, output, session) { 69 | # filter datasets on every aspect 70 | excluded_dataset_ids <- reactive({ 71 | included <- benchmark_datasets_info %>% 72 | filter( 73 | source %in% input$sources, 74 | trajectory_type %in% input$trajectory_types, 75 | id %in% input$ids 76 | ) %>% 77 | pull(id) 78 | 79 | setdiff(benchmark_datasets_info$id, included) 80 | }) 81 | 82 | # change the number of datasets in the ui 83 | output$n_datasets <- renderText(nrow(benchmark_datasets_info) - length(excluded_dataset_ids())) 84 | 85 | # output the excluded dataset ids 86 | excluded_dataset_ids 87 | } -------------------------------------------------------------------------------- /R/package.R: -------------------------------------------------------------------------------- 1 | #' Dynguidelines packages 2 | #' 3 | #' The dynguidelines package can be used to find the most optimal TI methods on a given dataset 4 | #' This can be done both directly in R or through a shiny interface. 5 | #' 6 | #' @import dplyr 7 | #' @import purrr 8 | #' @import tibble 9 | #' @import shiny 10 | #' @import stringr 11 | #' @importFrom dynutils add_class extract_row_to_list calculate_geometric_mean 12 | #' 13 | #' @name dynguidelines 14 | NULL -------------------------------------------------------------------------------- /R/question_utitlities.R: -------------------------------------------------------------------------------- 1 | get_available_memory <- function( 2 | choices = memory_choices 3 | ) { 4 | available_memory <- if(Sys.info()["sysname"] == "Linux") { 5 | system("cat /proc/meminfo | grep MemTotal", intern = TRUE) %>% 6 | gsub("MemTotal:[ ]*([0-9]*) (kB)", "\\1\\2", .) %>% 7 | process_memory() 8 | } else { 9 | process_memory("4GB") 10 | } 11 | 12 | available_memory <- available_memory - process_memory("2GB") 13 | 14 | choices[first(which.min(abs(available_memory - choices)))] %>% format_memory() 15 | } 16 | -------------------------------------------------------------------------------- /R/questions.R: -------------------------------------------------------------------------------- 1 | # convert javascript active if question 2 | generate_r_active_if <- function(question) { 3 | activeIf <- question$activeIf 4 | if(activeIf == "true") { 5 | activeIf <- "TRUE" 6 | } else { 7 | activeIf <- gsub("\\.", "$", activeIf) 8 | } 9 | activeIf <- parse(text = activeIf) 10 | active_if <- function(input) { 11 | active <- eval(activeIf) 12 | length(active) && !is.na(active) && active 13 | } 14 | } 15 | 16 | # memory choices 17 | memory_choices <- c(seq(10^8, 10^9, 10^8), seq(10^9, 10^10, 10^9), seq(10^10, 10^11, 10^10)) 18 | 19 | #' Get the the questions, their modifiers and properties 20 | #' 21 | #' @include modifiers.R 22 | #' @include labels.R 23 | #' @include formatters.R 24 | get_questions <- function() { 25 | priors <- dynwrap::priors %>% 26 | filter(prior_id != "dataset") 27 | 28 | # possible programming languages 29 | all_programming_languages <- c("Python", "R", "C++", "Matlab") 30 | all_free_programming_languages <- intersect(all_programming_languages, c("Python", "R", "C++")) 31 | 32 | # possible trajectory types 33 | trajectory_types <- dynwrap::trajectory_types 34 | all_trajectory_types <- trajectory_types$id 35 | 36 | # benchmark metrics 37 | questions <- list( 38 | list( 39 | question_id = "multiple_disconnected", 40 | modifier = multiple_disconnected_modifier, 41 | type = "radiobuttons", 42 | choices = c("Yes" = TRUE, "I don't know" = TRUE, "No" = FALSE), 43 | modifier = function(data, answer = NULL) {}, 44 | activeIf = "true", 45 | label = "Do you expect multiple disconnected trajectories in the data?", 46 | title = tags$p("Disconnected trajectories are trajectories which are not connected", tags$img(src='img/disconnected_example.png')), 47 | category = "topology", 48 | default = NULL, 49 | default_dataset = function(dataset, default) { 50 | if(dynwrap::is_wrapper_with_trajectory(dataset)) { 51 | FALSE 52 | } else { 53 | default 54 | } 55 | }, 56 | show_on_start = TRUE 57 | ), 58 | list( 59 | question_id = "expect_topology", 60 | modifier = expect_topology_modifier, 61 | type = "radiobuttons", 62 | choices = c("Yes" = TRUE, "No" = FALSE), 63 | activeIf = "input.multiple_disconnected == 'FALSE'", 64 | label = "Do you expect a particular topology in the data?", 65 | title = "Select 'Yes' if you already know the expected topology in the data.", 66 | category = "topology", 67 | default = NULL, 68 | default_dataset = function(dataset, default) { 69 | if(dynwrap::is_wrapper_with_trajectory(dataset)) { 70 | FALSE 71 | } else { 72 | default 73 | } 74 | } 75 | ), 76 | list( 77 | question_id = "expected_topology", 78 | modifier = expected_topology_modifier, 79 | type = "radiobuttons", 80 | choiceValues = all_trajectory_types, 81 | choiceNames = map(all_trajectory_types, function(trajectory_type) { 82 | span( 83 | img(src = str_glue("img/trajectory_types/{trajectory_type}.png"), class = "trajectory_type"), 84 | label_capitalise(trajectory_type) 85 | ) 86 | }), 87 | activeIf = " 88 | input.multiple_disconnected == 'FALSE' && 89 | input.expect_topology == 'TRUE' 90 | ", 91 | label = "What is the expected topology", 92 | title = "Select the expected topology ", 93 | category = "topology", 94 | default = NULL, 95 | default_dataset = function(dataset, default) { 96 | if(dynwrap::is_wrapper_with_trajectory(dataset)) { 97 | dynwrap::classify_milestone_network(dataset$milestone_network)$network_type 98 | } else { 99 | default 100 | } 101 | } 102 | ), 103 | list( 104 | question_id = "expect_cycles", 105 | modifier = expect_cycles_modifier, 106 | type = "radiobuttons", 107 | choices = c("Yes" = TRUE, "I don't know" = TRUE, "No" = FALSE), 108 | activeIf = " 109 | input.multiple_disconnected == 'FALSE' && 110 | input.expect_topology == 'FALSE' 111 | ", 112 | label = "Do you expect cycles in the data?", 113 | title = p( 114 | "Select 'Yes' or 'It's possible' if cyclic could be present in the trajectory.", 115 | tags$br(), 116 | "Cells within a cyclic topology can go back to their original state. A cycle can be part of a larger trajectory topology, for example:", 117 | tags$img(src = "img/cyclic_example.png"), 118 | "Examples of cyclic trajectories can be: cell cycle or cell activation and deactivation" 119 | ), 120 | category = "topology", 121 | default = NULL 122 | ), 123 | list( 124 | question_id = "expect_complex_tree", 125 | modifier = expect_complex_tree_modifier, 126 | type = "radiobuttons", 127 | choices = c("Yes" = TRUE, "I don't know" = FALSE, "No" = FALSE), 128 | activeIf = " 129 | input.multiple_disconnected == 'FALSE' && 130 | input.expect_cycles == 'FALSE' && 131 | input.expect_topology == 'FALSE' 132 | ", 133 | label = "Do you expect a complex tree in the data?", 134 | title = tags$p( 135 | "A complex tree can include two or more bifurcations.", 136 | tags$img(src = "img/complex_tree_example.png") 137 | ), 138 | category = "topology", 139 | default = NULL 140 | ), 141 | list( 142 | question_id = "n_cells", 143 | modifier = n_cells_modifier, 144 | type = "numeric", 145 | label = "Number of cells", 146 | title = "Number of cells in the dataset. Will be extracted from the dataset if provided.", 147 | activeIf = "true", 148 | category = "scalability", 149 | default = 1000, 150 | default_dataset = function(dataset, default) { 151 | if(dynwrap::is_wrapper_with_expression(dataset)) { 152 | nrow(dataset$expression) 153 | } else { 154 | default 155 | } 156 | }, 157 | show_on_start = TRUE 158 | ), 159 | list( 160 | question_id = "n_features", 161 | modifier = n_features_modifier, 162 | type = "numeric", 163 | label = "Number of features (genes)", 164 | title = "Number of features in the dataset. Will be extracted from the dataset if provided.", 165 | activeIf = "true", 166 | category = "scalability", 167 | default = 1000, 168 | default_dataset = function(dataset, default) { 169 | if(dynwrap::is_wrapper_with_expression(dataset)) { 170 | ncol(dataset$expression) 171 | } else { 172 | default 173 | } 174 | } 175 | ), 176 | list( 177 | question_id = "time", 178 | modifier = time_modifier, 179 | type = "textslider", 180 | choices = c(format_time(c(seq(10, 60, 5), seq(5, 60, 5)*60, seq(4, 24, 4) * 60 * 60, seq(2, 4) * 60 * 60 * 24)), "\U221E"), 181 | default = "1h", 182 | category = "scalability", 183 | activeIf = "true", 184 | label = "Time limit", 185 | title = span("Limits the maximal time a method is allowed to run. The running times is estimated based on dataset size and the ", tags$a("scalability assessment of dynbenchmark", href = "https://github.com/dynverse/dynbenchmark_results/tree/master/05-scaling"), ".") 186 | ), 187 | list( 188 | question_id = "memory", 189 | modifier = memory_modifier, 190 | type = "textslider", 191 | choices = c(format_memory(memory_choices), "\U221E"), 192 | default = get_available_memory, 193 | category = "scalability", 194 | category = "scalability", 195 | activeIf = "true", 196 | label = "Memory limit", 197 | title = span("Limits the maximal memory a method is allowed to use. The memory usage is estimated based on dataset size and the ", tags$a("scalability assessment of dynbenchmark", href = "https://github.com/dynverse/dynbenchmark_results/tree/master/05-scaling"), ".") 198 | ), 199 | list( 200 | question_id = "prior_information", 201 | modifier = prior_information_modifier, 202 | type = "picker", 203 | choices = set_names(priors$prior_id, priors$name), 204 | multiple = TRUE, 205 | label = "Are you able to provide the following prior information?", 206 | title = "Some methods require some prior information, such as the start cells, to help with the construction of the trajectory. Although this can help the method with finding the right trajectory, prior information can also bias the trajectory towards what is already known.
Prior information should therefore be given with great care.", 207 | activeIf = "true", 208 | category = "prior_information", 209 | default = dynwrap::priors %>% filter(type == "soft") %>% pull(prior_id), 210 | default_dataset = function(dataset, default) { 211 | if("prior_information" %in% names(dataset) || dynwrap::is_wrapper_with_prior_information(dataset)) { 212 | priors %>% filter(prior_id %in% names(dataset$prior_information)) %>% pull(prior_id) 213 | } else { 214 | default 215 | } 216 | }, 217 | show_on_start = TRUE 218 | ), 219 | list( 220 | question_id = "method_selection", 221 | modifier = method_selection_modifier, 222 | type = "radiobuttons", 223 | choices = c("Dynamic" = "dynamic_n_methods", "Fixed" = "fixed_n_methods"), 224 | label = "How to select the number of methods", 225 | default = "dynamic_n_methods", 226 | activeIf = "true", 227 | category = "method_selection" 228 | ), 229 | list( 230 | question_id = "dynamic_n_methods", 231 | modifier = dynamic_n_methods_modifier, 232 | type = "slider", 233 | min = 1, 234 | max = 100, 235 | default = 80, 236 | label = "Minimal probability of selecting the top model for the task", 237 | activeIf = "input.method_selection == 'dynamic_n_methods'", 238 | category = "method_selection" 239 | ), 240 | list( 241 | question_id = "fixed_n_methods", 242 | modifier = fixed_n_methods_modifier, 243 | type = "slider", 244 | min = 1, 245 | max = 10, 246 | default = 4, 247 | label = "Number of methods", 248 | activeIf = "input.method_selection == 'fixed_n_methods'", 249 | category = "method_selection" 250 | ), 251 | list( 252 | question_id = "metric_importance", 253 | modifier = metric_importance_modifier, 254 | type = "balancing_sliders", 255 | label = "How important are the following aspects of the trajectory?", 256 | title = tags$p( 257 | tags$em("This question is currently not yet implemented"), 258 | tags$br(), 259 | "Within dynbenchmark, we assessed the performance of a TI method by comparing the similarity of its model to a given gold standard. There are several metrics to quantify this similarity, and this question allows to give certain metrics more weights than others: ", 260 | tags$ul( 261 | style = "text-align:left;", 262 | map2(benchmark_metrics$category, benchmark_metrics$description, function(name, description) {tags$li(tags$strong(name), ": ", description)}) 263 | ) 264 | ), 265 | activeIf = "true", 266 | category = "benchmarking_metrics", 267 | labels = glue::glue("{label_split(benchmark_metrics$category)}: {benchmark_metrics$html}"), 268 | ids = benchmark_metrics$metric_id, 269 | default = rep(1/nrow(benchmark_metrics), nrow(benchmark_metrics)) %>% set_names(benchmark_metrics$metric_id) %>% as.list(), 270 | min = 0, 271 | max = 1, 272 | step = 0.01, 273 | sum = 1 274 | ), 275 | 276 | # list( 277 | # activeIf = "true", 278 | # category = "benchmarking_datasets", 279 | # labels = 280 | # ), 281 | 282 | list( 283 | question_id = "user", 284 | modifier = function(data, answers) {data}, 285 | type = "radiobuttons", 286 | choices = c("User" = "user", "Developer" = "developer"), 287 | label = "Are you an end-user or a method developer?", 288 | activeIf = "true", 289 | category = "availability", 290 | default = "user" 291 | ), 292 | list( 293 | question_id = "dynmethods", 294 | modifier = dynmethods_modifier, 295 | type = "radiobuttons", 296 | choices = c("Yes" = TRUE, "No" = FALSE), 297 | label = "Do you use dynmethods to run the methods?", 298 | title = "Dynmethods is an R package which contains wrappers TI methods into a common interface. While we highly recommend the use of this package, as it eases interpretation, some users may prefer to work in other programming languages.", 299 | activeIf = "input.user == 'user'", 300 | category = "availability", 301 | default = TRUE 302 | ), 303 | list( 304 | question_id = "docker", 305 | modifier = docker_modifier, 306 | type = "radiobuttons", 307 | choices = c("Yes" = TRUE, "No" = FALSE), 308 | label = "Is docker installed?", 309 | title = "Docker makes it easy to run each TI method without dependency issues, apart from the installation of docker itself.", 310 | activeIf = "input.user == 'user' && input.dynmethods == 'TRUE'", 311 | category = "availability", 312 | default = function() if(interactive()) {dynwrap::test_docker_installation()} else {TRUE} 313 | ), 314 | list( 315 | question_id = "programming_interface", 316 | modifier = programming_interface_modifier, 317 | type = "radiobuttons", 318 | choices = c("Yes" = TRUE, "No" = FALSE), 319 | label = "Can you work in a programming interface?", 320 | activeIf = "input.user == 'user' && input.dynmethods == 'FALSE'", 321 | category = "availability", 322 | default = TRUE 323 | ), 324 | list( 325 | question_id = "languages", 326 | modifier = languages_modifier, 327 | type = "picker", 328 | choices = all_programming_languages, 329 | special_choices = list(c("All", all_programming_languages), c("Any free", all_free_programming_languages), c("Clear", "[]")), 330 | default = all_free_programming_languages, 331 | label = "Which languages can you work with?", 332 | activeIf = "input.user == 'user' && input.dynmethods == 'FALSE' && input.programming_interface == 'TRUE'", 333 | category = "availability", 334 | default = all_free_programming_languages 335 | ), 336 | list( 337 | question_id = "user_friendliness", 338 | modifier = user_friendliness_modifier, 339 | type = "slider", 340 | min = 0, 341 | max = 100, 342 | step = 10, 343 | default = 60, 344 | label = "Minimal user friendliness score", 345 | activeIf = "input.user == 'user' && input.dynmethods == 'FALSE'", 346 | category = "availability" 347 | ) 348 | , 349 | list( 350 | question_id = "developer_friendliness", 351 | modifier = developer_friendliness_modifier, 352 | type = "slider", 353 | min = 0, 354 | max = 100, 355 | step = 10, 356 | default = 60, 357 | label = "Minimal developer friendliness score", 358 | activeIf = "input.user == 'developer'", 359 | category = "availability" 360 | ), 361 | list( 362 | question_id = "exclude_datasets", 363 | modifier = function(data, answers) {data}, 364 | type = "module", 365 | module_input = dataset_chooser_input, 366 | module_server = dataset_chooser, 367 | data = lst(benchmark_datasets_info), 368 | default = character(), 369 | label = "Which datasets should be excluded", 370 | activeIf = "true", 371 | category = "benchmarking_datasets" 372 | ) 373 | ) %>% {set_names(., map(., "question_id"))} 374 | 375 | # generate R active_if from javascript activeIf 376 | questions <- map(questions, function(question) { 377 | question$active_if <- generate_r_active_if(question) 378 | question 379 | }) 380 | 381 | questions 382 | } -------------------------------------------------------------------------------- /R/renderers.R: -------------------------------------------------------------------------------- 1 | scale_01 <- function(y, lower = min(y, na.rm = TRUE), upper = max(y, na.rm = TRUE)) { 2 | 3 | if (lower == upper) { 4 | lower <- upper - 0.1 5 | } 6 | 7 | y[y < lower] <- lower 8 | y[y > upper] <- upper 9 | 10 | (y - lower) / (upper - lower) 11 | } 12 | 13 | 14 | palettes <- tribble( 15 | ~palette, ~colours, 16 | # blues palette 17 | "overall", grDevices::colorRampPalette(rev(RColorBrewer::brewer.pal(9, "Greys")[-1]))(101), 18 | "accuracy", grDevices::colorRampPalette(rev(RColorBrewer::brewer.pal(9, "Blues") %>% c("#011636")))(101), 19 | "scalability", grDevices::colorRampPalette(rev(RColorBrewer::brewer.pal(9, "Reds")[-8:-9]))(101), 20 | "stability", grDevices::colorRampPalette(rev(RColorBrewer::brewer.pal(9, "YlOrBr")[-7:-9]))(101), 21 | "usability", grDevices::colorRampPalette(rev(RColorBrewer::brewer.pal(9, "Greens")[-1] %>% c("#00250f")))(101), 22 | "column_annotation", c(method = "#555555", overall = "#555555", accuracy = "#4292c6", scalability = "#f6483a", stability = "#fe9929", usability = "#41ab5d") 23 | ) %>% deframe() 24 | 25 | scaled_color <- function(x, palette) { 26 | palette[ceiling(x * (length(palette)-1)) + 1] 27 | } 28 | 29 | color_based_on_background <- function(background) { 30 | map_chr(background, function(background) { 31 | ifelse( 32 | mean(colorspace::hex2RGB(background)@coords) > 0.6, 33 | "black", 34 | "white" 35 | ) 36 | }) 37 | } 38 | 39 | 40 | get_score_renderer <- function(palette = palettes$accuracy) { 41 | function(x, options) { 42 | if (any(is.na(x))) { 43 | # warning("Some NA values in score renderer! ", x) 44 | } 45 | 46 | style <- ifelse(is.null(options$score_visualisation), "bar", options$score_visualisation) 47 | if (style == "bar") { 48 | y <- tibble( 49 | x = x, 50 | normalised = ifelse(is.na(x), 0, scale_01(x, lower = 0)), 51 | rounded = format_100(normalised), 52 | formatted = ifelse(is.na(x), "NA", rounded), 53 | width = paste0(rounded, "px"), 54 | `background-color` = ifelse(is.na(x), "none", html_color(scaled_color(normalised, palette))), 55 | color = case_when(scale_01(normalised, lower = 0) > 0.5 ~ "black", is.na(x) ~ "grey", TRUE ~ "white"), 56 | `text-shadow` = case_when(color == "white" ~ "-1px 0 #000000AA, 0 1px #000000AA, 1px 0 #000000AA, 0 -1px #000000AA", TRUE ~ "none"), 57 | style = pmap(lst(`background-color`, color, width, `text-shadow`), htmltools::css), 58 | class = "score bar" 59 | ) 60 | } else if (style == "circle") { 61 | y <- tibble( 62 | x = x, 63 | normalised = ifelse(is.na(x), 0, scale_01(x, lower = 0)), 64 | rounded = format_100(normalised), 65 | formatted = ifelse(is.na(x), "NA", rounded), 66 | width = paste0(rounded/3, "px"), 67 | `line-height` = paste0(rounded/3, "px"), 68 | `background-color` = ifelse(is.na(x), "none", html_color(scaled_color(normalised, palette))), 69 | color = case_when(scale_01(normalised, lower = 0) > 0.5 ~ "black", is.na(x) ~ "grey", TRUE ~ "white"), 70 | `text-shadow` = case_when(color == "white" ~ "-1px 0 #000000AA, 0 1px #000000AA, 1px 0 #000000AA, 0 -1px #000000AA", TRUE ~ "none"), 71 | style = pmap(lst(`background-color`, color, display = "block", width, `text-shadow`, `line-height`, `text-align` = "center"), htmltools::css), 72 | class = "score circle" 73 | ) 74 | } 75 | 76 | pmap(list(y$formatted, style = y$style, class = y$class), span) 77 | } 78 | } 79 | 80 | render_detects_trajectory_type <- function(x) { 81 | map( 82 | x, 83 | function(trajectory_type) { 84 | if (is.na(trajectory_type)) { 85 | NA 86 | } else { 87 | img(src = str_glue("img/trajectory_types/{trajectory_type}.png"), class = "trajectory_type") 88 | } 89 | } 90 | ) 91 | } 92 | 93 | get_trajectory_type_renderer <- function(trajectory_type) { 94 | if (is.na(trajectory_type)) { 95 | function(x) {NA} 96 | } else { 97 | function(x) { 98 | map( 99 | x, 100 | function(x) { 101 | if(is.na(x)) { 102 | "NA" 103 | } else { 104 | if (isTRUE(x)) { 105 | class <- "trajectory_type" 106 | } else { 107 | class <- "trajectory_type inactive" 108 | } 109 | img(src = str_glue("img/trajectory_types/{gsub('method_detects_', '', trajectory_type)}.png"), class = class) 110 | } 111 | } 112 | ) 113 | } 114 | } 115 | } 116 | 117 | render_selected <- function(x) { 118 | map(x, ~if(.) {icon("check")}) 119 | } 120 | 121 | render_identity <- function(x) {x} 122 | 123 | render_article <- function(x) { 124 | map(x, ~if(!is.na(.)) {tags$a(href = paste0("https://doi.org/", .), icon("paper-plane"), target = "blank")} else {""}) 125 | } 126 | 127 | render_code <- function(x) { 128 | map(x, ~if(!is.na(.)) {tags$a(href = ., icon("code"), target = "blank")} else {""}) 129 | } 130 | 131 | hard_prior_ids <- dynwrap::priors %>% filter(type == "hard") %>% pull(prior_id) # prepopulate 132 | prior_id_to_label <- dynwrap::priors %>% select(prior_id, name) %>% deframe() # prepopulate 133 | 134 | render_required_priors <- function(x) { 135 | map(x, function(prior_ids) { 136 | if (length(prior_ids)) { 137 | symbol <- ifelse(any(prior_ids %in% hard_prior_ids), "\U2716", "\U2715") 138 | tags$span( 139 | symbol, 140 | title = paste(prior_id_to_label[prior_ids], collapse = ", "), 141 | class = "tooltippable", 142 | `data-toggle` = "tooltip", 143 | `data-placement` = "top", 144 | style = "font-size:15px" 145 | ) 146 | } else { 147 | "" 148 | } 149 | }) 150 | } 151 | 152 | wrapper_type_id_to_label <- dynwrap::wrapper_types %>% select(id, short_name) %>% deframe() 153 | render_wrapper_type <- function(x) { 154 | wrapper_type_id_to_label[x] 155 | } 156 | 157 | 158 | 159 | get_scaling_renderer <- function( 160 | formatter, 161 | palette = palettes$scalability, 162 | min, 163 | max, 164 | upper_question_id = "time", 165 | upper_processor = process_time 166 | ) { 167 | function(x, options, answers) { 168 | # determine upper limit for coloring 169 | upper <- invoke(upper_processor, answers$answer[[upper_question_id]]) 170 | if (upper > max) upper <- max 171 | 172 | y <- tibble( 173 | x = x, 174 | formatted = formatter(x, min, max), 175 | normalised = ifelse(is.na(x), 0, scale_01(log(x), lower = log(min), upper = log(upper))), 176 | rounded = format_100(normalised), 177 | width = paste0(rounded, "px"), 178 | background = ifelse(is.na(x), "none", html_color(scaled_color(1-normalised, palette))), 179 | color = case_when(normalised > 0.5 ~ "white", is.na(x) ~ "grey", TRUE ~ "black"), 180 | style = pmap(list(`background-color` = background, color = color, display = "block", width = width), htmltools::css), 181 | class = "score bar" 182 | ) 183 | 184 | pmap(list(y$formatted, style = y$style, class = y$class), span) 185 | } 186 | } 187 | 188 | time_renderer <- get_scaling_renderer(format_time, min = 0.1, max = 60*60*24*7, upper_question_id = "time", upper_processor = process_time) 189 | memory_renderer <- get_scaling_renderer(format_memory, min = process_memory("100MB"), max = process_memory("1TB"), upper_question_id = "memory", upper_processor = process_memory) 190 | 191 | 192 | get_warning_renderer <- function( 193 | label, 194 | title, 195 | palette 196 | ) { 197 | function(x) { 198 | map(x, function(x) { 199 | if (x > 0) { 200 | background <- scaled_color(1-x, palette) 201 | color <- color_based_on_background(background) 202 | 203 | tags$span( 204 | icon("warning"), 205 | label, 206 | class = "score box", 207 | style = paste( 208 | paste0("background-color:", background), 209 | paste0("color: ", color), 210 | "white-space: nowrap", 211 | sep = ";" 212 | ), 213 | `data-toggle` = "tooltip", 214 | `data-placement` = "top", 215 | title = title 216 | ) 217 | } else { 218 | NULL 219 | } 220 | }) 221 | } 222 | } 223 | 224 | stability_warning_renderer <- get_warning_renderer( 225 | "Unstable", 226 | title = "This method can generate unstable results. We advise you to rerun it multiple times on a dataset.", 227 | palette = palettes$stability 228 | ) 229 | 230 | error_warning_renderer <- get_warning_renderer( 231 | "Errors", 232 | title = "This method errors often. It may not work on your dataset.", 233 | palette = palettes$overall 234 | ) 235 | 236 | #' @importFrom utils data 237 | get_renderers <- function() { 238 | utils::data(trajectory_types, package = "dynwrap", envir = environment()) 239 | 240 | renderers <- tribble( 241 | ~column_id, ~category, ~renderer, ~label, ~title, ~style, ~default, ~name, 242 | "selected", "method", render_selected, icon("check-circle"), "Selected methods for TI", NA, -100, NA, 243 | "method_name", "method", render_identity, "Name", "Name of the method", "max-width:99%;width:100%", -98, NA, 244 | "method_doi", "method", render_article, icon("paper-plane"), "Paper/study describing the method", NA, -99, "paper", 245 | "method_code_url", "method", render_code, icon("code"), "Code of method", NA, -99, "code", 246 | "method_required_priors", "method", render_required_priors, "Priors", "Required priors", NA, 1, NA, 247 | "method_wrapper_type", "method", render_wrapper_type, "Wrapper", "How the method was wrapped using dynwrap", NA, NA, NA, 248 | "method_most_complex_trajectory_type", "method", render_detects_trajectory_type, "Topology", "The most complex topology this method can predict", NA, NA, NA, 249 | "method_platform", "method", render_identity, "Platform", "Platform", NA, NA, NA, 250 | "scaling_predicted_time", "scalability", time_renderer, icon("clock"), "Estimated running time", NA, 2, NA, 251 | "scaling_predicted_mem", "scalability", memory_renderer, icon("memory"), "Estimated maximal memory usage", NA, 2.1, NA, 252 | "stability_warning", "stability", stability_warning_renderer, "Stability", "Whether the stability is low", NA, 3, NA, 253 | "error_warning", "method", error_warning_renderer, "Errors", "Whether the method errors often", NA, 99, NA 254 | ) %>% bind_rows( 255 | tibble( 256 | trajectory_type = trajectory_types$id, 257 | column_id = paste0("method_detects_", trajectory_type), 258 | category = "method", 259 | renderer = map(column_id, get_trajectory_type_renderer), 260 | label = map(column_id, ~""), 261 | name = paste0("Detects ", trajectory_type), 262 | title = as.character(str_glue("Whether this method can predict a {label_split(trajectory_type)} topology")), 263 | style = NA, 264 | default = ifelse(trajectory_type %in% c("convergence", "acyclic_graph"), NA, 3 + seq_len(length(trajectory_type))/100) 265 | ) 266 | ) %>% bind_rows( 267 | tibble( 268 | column_id = methods_aggr %>% select(matches("(benchmark|scaling_pred|stability|qc|summary)_overall_overall")) %>% colnames(), 269 | category_old = gsub("(benchmark|scaling_pred|stability|qc|summary)_overall_overall", "\\1", column_id), 270 | category = c(benchmark = "accuracy", scaling_pred = "scalability", stability = "stability", qc = "usability", summary = "overall")[category_old], 271 | renderer = map(palettes[category], get_score_renderer), 272 | label = list("Overall"), 273 | name = NA, 274 | title = paste0("Average ", category, " score"), 275 | style = "", 276 | default = NA 277 | ) 278 | ) %>% bind_rows( 279 | tibble( 280 | trajectory_type = trajectory_types$id, 281 | column_id = paste0("benchmark_tt_", trajectory_type), 282 | category = "accuracy", 283 | renderer = map(column_id, ~get_score_renderer()), 284 | label = as.list(str_glue("{label_capitalise(trajectory_type)}")), 285 | name = NA, 286 | title = as.character(str_glue("Score on datasets containing a {label_split(trajectory_type)} topology")), 287 | style = "", 288 | default = NA 289 | ) %>% select(-trajectory_type) 290 | ) %>% bind_rows( 291 | tibble( 292 | metric_id = benchmark_metrics$metric_id, 293 | column_id = paste0("benchmark_overall_norm_", metric_id), 294 | category = "accuracy", 295 | renderer = map(column_id, ~get_score_renderer()), 296 | label = map(benchmark_metrics$html, HTML), 297 | name = NA, 298 | title = benchmark_metrics$html, 299 | style = "width:11px;", 300 | default = NA 301 | ) %>% select(-metric_id) 302 | ) %>% bind_rows( 303 | tibble( 304 | dataset_source = gsub("/", "_", unique(benchmark_datasets_info$source)), 305 | column_id = paste0("benchmark_source_", dataset_source), 306 | category = "accuracy", 307 | renderer = map(column_id, ~get_score_renderer()), 308 | label = as.list(label_capitalise(dataset_source)), 309 | name = NA, 310 | title = dataset_source, 311 | style = "", 312 | default = NA 313 | ) %>% select(-dataset_source) 314 | ) %>% bind_rows( 315 | tibble( 316 | column_id = methods_aggr %>% 317 | select(starts_with("qc_"), -qc_overall_overall) %>% 318 | select_if(is.numeric) %>% 319 | colnames(), 320 | category = "usability", 321 | renderer = map(column_id, ~get_score_renderer(palettes$usability)), 322 | label = str_match(column_id, "qc_(app|cat)_(.*)") %>% 323 | as.data.frame() %>% 324 | mutate_all(as.character) %>% 325 | glue::glue_data("{label_capitalise(.$V3)}") %>% 326 | as.character() %>% 327 | as.list(), 328 | name = NA, 329 | title = as.character(label), 330 | style = "", 331 | default = NA 332 | ) %>% bind_rows( 333 | tibble( 334 | column_id = methods_aggr %>% select(matches("scaling_pred_(time|mem)_")) %>% colnames(), 335 | scaling_type = gsub("scaling_pred_(time|mem)_.*", "\\1", column_id), 336 | category = "scalability", 337 | renderer = list(mem = memory_renderer, time = time_renderer)[scaling_type], 338 | label = str_match(column_id, "scaling_pred_(time|mem)_cells(.*)_features(.*)") %>% 339 | as.data.frame() %>% 340 | mutate_all(as.character) %>% 341 | mutate(icon = list(mem = icon("memory"), time = icon("clock-o"))[V2]) %>% 342 | pmap(function(icon, V3, V4, ...) {tags$span(icon, V3, " \U00D7 ", V4)}) 343 | , 344 | name = NA, 345 | title = "", 346 | style = "", 347 | default = NA 348 | ) 349 | ) %>% bind_rows( 350 | tibble( 351 | metric_id = benchmark_metrics$metric_id, 352 | column_id = paste0("stability_", metric_id), 353 | category = "stability", 354 | renderer = map(column_id, ~get_score_renderer(palettes$stability)), 355 | label = map(benchmark_metrics$html, HTML), 356 | name = NA, 357 | title = benchmark_metrics$html, 358 | style = "width:11px;", 359 | default = NA 360 | ) %>% select(-metric_id) 361 | ) 362 | ) 363 | 364 | renderers 365 | } 366 | 367 | 368 | get_column_categories <- function() { 369 | palettes$column_annotation %>% 370 | enframe("category", "color") %>% 371 | mutate(category_order = row_number()) 372 | } 373 | 374 | 375 | 376 | get_column_presets <- function() { 377 | list( 378 | list( 379 | id = "default", 380 | label = "Default", 381 | activate = function(show_columns) { 382 | show_columns[names(show_columns)] <- "indeterminate" 383 | show_columns 384 | } 385 | ), 386 | list( 387 | id = "fig2", 388 | label = "Summary (Fig. 2)", 389 | activate = function(show_columns) { 390 | show_columns[] <- "false" 391 | 392 | columns_oi <- c( 393 | "column_selected", 394 | "column_method_name", 395 | "column_method_required_priors", 396 | "column_method_wrapper_type", 397 | "column_method_platform", 398 | names(show_columns)[str_detect(names(show_columns), "^column_method_detects")] %>% discard(str_detect, "(convergence|acyclic_graph)"), 399 | "column_summary_overall_overall", 400 | "column_benchmark_overall_overall", 401 | "column_qc_overall_overall", 402 | "column_stability_overall_overall", 403 | "column_scaling_pred_overall_overall" 404 | ) 405 | show_columns[columns_oi] <- "true" 406 | 407 | show_columns 408 | } 409 | ) 410 | ) %>% 411 | c(map(unique(get_renderers()$category), function(category) { 412 | list( 413 | id = category, 414 | label = label_capitalise(category), 415 | activate = activate_column_preset_category(category) 416 | ) 417 | }) 418 | ) %>% 419 | c( 420 | list( 421 | list( 422 | id = "everything", 423 | label = "Everything", 424 | activate = function(show_columns) { 425 | show_columns[names(show_columns)] <- "true" 426 | show_columns 427 | } 428 | ) 429 | ) 430 | ) 431 | } 432 | 433 | 434 | 435 | activate_column_preset_category <- function(category) { 436 | function(show_columns) { 437 | show_columns[names(show_columns)] <- "false" 438 | columns_oi <- get_renderers() %>% filter((category %in% !!category) | (column_id %in% c("selected", "method_name" ))) %>% pull(column_id) %>% paste0("column_", .) 439 | columns_oi <- c("column_method_name", columns_oi) 440 | show_columns[columns_oi] <- "true" 441 | show_columns 442 | } 443 | } -------------------------------------------------------------------------------- /R/shiny_server.R: -------------------------------------------------------------------------------- 1 | #' The shiny server 2 | #' 3 | #' @param answers Previous answers other than default, see the [answer_questions()] function 4 | #' 5 | #' @export 6 | shiny_server <- function( 7 | answers = answer_questions() 8 | ) { 9 | # create the server function, which will be called by shiny internally 10 | server <- function(input, output, session, answers = answer_questions()) { 11 | questions <- get_questions() 12 | 13 | # make sure questions and answers match 14 | testthat::expect_setequal(names(questions), answers$question_id) 15 | 16 | # update question defaults based on given (default) answers 17 | # add question answer and source reactive inputs 18 | questions <- map(questions, function(question) { 19 | question_answer <- answers %>% extract_row_to_list(which(question_id == question$question_id)) 20 | 21 | question[["default"]] <- question_answer$answer 22 | question$source_default <- question_answer$source 23 | 24 | question$answer <- reactive(get_answer(question, input)) 25 | 26 | question$source <- reactive({ 27 | if (isTRUE(all.equal(question$answer(), question[["default"]]))) { 28 | question$source_default 29 | } else { 30 | "adapted" 31 | } 32 | }) 33 | 34 | question$active <- reactive(question$active_if(input)) 35 | 36 | question 37 | }) 38 | 39 | # nest questions based on category 40 | question_categories <- split(questions, factor(map_chr(questions, "category"), unique(map_chr(questions, "category")))) 41 | 42 | ## create show/hide columns reactivity 43 | show_column_ids <- paste0("column_", get_renderers()$column_id) 44 | show_columns <- reactive(map(show_column_ids, ~input[[.]]) %>% set_names(show_column_ids) %>% unlist()) 45 | 46 | output$column_presets <- renderUI(get_columns_presets_ui(column_presets = get_column_presets(), session = session, show_columns = show_columns)) 47 | output$column_show_hide <- renderUI(get_columns_show_hide_ui(renderers = get_renderers())) 48 | outputOptions(output, "column_show_hide", suspendWhenHidden = FALSE) 49 | 50 | ## create answer reactivity 51 | reactive_answers <- reactive({ 52 | answers$answer <- map(questions[answers$question_id], get_answer, input = input) 53 | 54 | answers$source <- map_chr(questions[answers$question_id], function(question) question$source()) 55 | answers 56 | }) 57 | current_guidelines <- reactive({ 58 | # wait with calculating the guidelines until the answers have all been initialized, using the hidden input "questions_loaded" 59 | if (!is.null(input$questions_loaded)) { 60 | guidelines(dataset = NULL, answers = reactive_answers()) 61 | } else { 62 | NULL 63 | } 64 | }) 65 | 66 | ## create the UI 67 | # questions 68 | output$questions_panel <- renderUI(get_questions_ui(question_categories, reactive_answers())) 69 | 70 | # methods table 71 | output$methods_table <- renderUI( 72 | if(!is.null(current_guidelines())) { 73 | get_guidelines_methods_table(current_guidelines(), show_columns(), options = options(), answers = reactive_answers()) 74 | } else { 75 | icon("spinner", class = "fa-pulse fa-3x fa-fw") 76 | } 77 | ) 78 | 79 | # code 80 | output$code <- renderText(get_answers_code(answers = reactive_answers())) 81 | 82 | # citations 83 | observe({ 84 | if (input$show_citation) { 85 | get_citations_modal() 86 | } 87 | }) 88 | 89 | # options 90 | output$options <- renderUI(get_options_ui()) 91 | options <- reactive({ 92 | lst( 93 | score_visualisation = input$score_visualisation 94 | ) 95 | }) 96 | 97 | ## on exit, return guidelines 98 | if (interactive() || Sys.getenv("CI") == "true") { 99 | return_guidelines <- function() { 100 | isolate({ 101 | if (isRunning()) { 102 | cat( 103 | c( 104 | "Code to reproduce the guidelines, copy it over to your script!", 105 | "", 106 | crayon::bold(get_answers_code(reactive_answers())) 107 | ) %>% glue::glue_collapse("\n"), 108 | "\n" 109 | ) 110 | 111 | return_value <- guidelines(dataset = NULL, answers = reactive_answers()) 112 | 113 | stopApp(return_value) 114 | } 115 | }) 116 | } 117 | 118 | # activate this function when pressing the submit button 119 | observe({ 120 | if(!is.null(input$submit) && input$submit > 0) { 121 | return_guidelines() 122 | } 123 | }) 124 | 125 | # or when exiting through rstudio exit button 126 | session$onSessionEnded(return_guidelines) 127 | } 128 | } 129 | 130 | # set default answers argument to given answers 131 | formals(server)$answers <- answers 132 | 133 | server 134 | } 135 | 136 | # Get the answer either directly from the input or from the module 137 | get_answer <- function(question, input) { 138 | if (question$type == "module") { 139 | parse_answers(callModule(question$module_server, question$question_id)()) 140 | } else { 141 | parse_answers(input[[question$question_id]]) 142 | } 143 | } 144 | 145 | 146 | # Function which converts "TRUE" -> TRUE and "FALSE" -> FALSE because shiny cannot handle such values 147 | # It also converts singleton characters to numbers if possible 148 | parse_answers <- function(x) { 149 | if (identical(x, "TRUE")) { 150 | TRUE 151 | } else if (identical(x, "FALSE")) { 152 | FALSE 153 | } else if (length(x) == 1 && !is.na(suppressWarnings(as.numeric(x)))) { 154 | as.numeric(x) 155 | } else { 156 | x 157 | } 158 | } -------------------------------------------------------------------------------- /R/shiny_ui.R: -------------------------------------------------------------------------------- 1 | #' Shiny user interface 2 | #' 3 | #' @export 4 | shiny_ui <- function() { 5 | # add path of images 6 | addResourcePath("img", system.file("img/", package = "dynguidelines")) 7 | 8 | ## build the page ---------------------------- 9 | fluidPage( 10 | title = "Selecting the most optimal TI method - dynguidelines", 11 | shinyjs::useShinyjs(), 12 | tags$head(tags$script(src = "https://www.googletagmanager.com/gtag/js?id=UA-578149-3")), 13 | tags$head(includeScript(system.file("js/tooltips.js", package = "dynguidelines"))), 14 | tags$head(includeScript(system.file("js/google-analytics.js", package = "dynguidelines"))), 15 | 16 | tags$head(tags$script(src = "https://cdn.jsdelivr.net/combine/npm/lodash@4.17.10,npm/intro.js@2.9.3")), 17 | 18 | tags$head(tags$link(rel = "stylesheet", href = "https://cdn.jsdelivr.net/npm/intro.js@2.9.3/introjs.min.css")), 19 | 20 | tags$head(includeCSS(system.file("css/style.css", package = "dynguidelines"))), 21 | 22 | tags$head(tags$link(rel = "icon", type = "image/png", href = "img/favicon_16.png")), 23 | 24 | # navbar 25 | tags$nav( 26 | class = "navbar navbar-default navbar-fixed-top", 27 | div( 28 | class = "container-fluid", 29 | div( 30 | class = "navbar-header", 31 | tags$a( 32 | class = "", 33 | href = "#", 34 | img(src = "img/logo_horizontal.png"), 35 | `data-intro` = "dynguidelines is an app for selecting the most optimal set of trajectory inference (TI) methods for a given use case. It uses data from a comprehensive benchmarking of TI methods and is part of a larger set of open packages for doing and interpreting trajectories called the dynverse.", 36 | `data-step` = 1 37 | ) 38 | ), 39 | 40 | div( 41 | class = "navbar-collapse collapse", 42 | tags$ul( 43 | class = "nav navbar-nav navbar-left", 44 | # tutorial 45 | tags$li( 46 | class = "nav-highlight", 47 | tags$a( 48 | "Tutorial", 49 | icon("question-circle"), 50 | href = "#intro", 51 | onclick="javascript:introJs().setOption('showBullets', false).setOption('scrollToElement', false).start();" 52 | ) 53 | ), 54 | 55 | # citation 56 | tags$li( 57 | class = "nav-highlight", 58 | actionLink( 59 | "show_citation", 60 | tagList("Citation ", icon("quote-right")) 61 | ) 62 | ) 63 | ), 64 | tags$ul( 65 | class = "nav navbar-nav navbar-right", 66 | 67 | # benchmarking study 68 | tags$li( 69 | tags$a( 70 | "Benchmark study ", 71 | icon("paper-plane"), 72 | href = "https://doi.org/10.1101/276907", 73 | target = "blank" 74 | ) 75 | ), 76 | 77 | # benchmarking repo 78 | tags$li( 79 | tags$a( 80 | HTML("Evaluating methods with dynbenchmark "), 81 | icon("github"), 82 | href = "https://github.com/dynverse/dynbenchmark", 83 | target = "blank" 84 | ) 85 | ), 86 | 87 | tags$li( 88 | a( 89 | style = "display: inline;", 90 | href = "https://github.com/dynverse/dynverse", 91 | target = "blank", 92 | "Part of", 93 | img( 94 | src = "img/logo_dynverse.png" 95 | ) 96 | ) 97 | ) 98 | ) 99 | ) 100 | ) 101 | ), 102 | 103 | div( 104 | style = "position:relative; width:100%; top:80px;", 105 | div( 106 | div( 107 | style = "width:30%", 108 | div( 109 | style = "overflow-y:scroll; position:fixed; bottom:0px; top:80px; width:inherit; padding-right: 10px;background-color:white;z-index:1;", 110 | uiOutput("questions_panel"), 111 | `data-intro` = "The choice of methods depends on the use case. These questions are designed to make deciding which method to use easier, by polling for the prior information on the trajectory, the size of the data and the execution environment.", 112 | `data-step` = 2 113 | ) 114 | ), 115 | div( 116 | style = "width:70%;float:right;padding-left:20px;", 117 | 118 | # top buttons 119 | div( 120 | class = "btn-group btn-group-justified", 121 | # code button 122 | tags$a( 123 | class = "btn btn-default", 124 | style = "", 125 | "Show code ", 126 | icon("code"), 127 | href = "#toggle-code", 128 | `data-target` = "#code", 129 | `data-toggle` = "collapse", 130 | `data-intro` = "You can get the code necessary to reproduce the guidelines here. Copy it over to your script!", 131 | `data-step` = 4 132 | ), 133 | 134 | # columns button 135 | tags$a( 136 | class = "btn btn-default", 137 | style = "", 138 | "Show/hide columns ", 139 | icon("columns"), 140 | href = "#toggle-columns", 141 | `data-target` = "#columns", 142 | `data-toggle` = "collapse" 143 | ), 144 | 145 | # options button 146 | tags$a( 147 | class = "btn btn-default", 148 | style = "", 149 | "Options ", 150 | icon("gear"), 151 | href = "#toggle-options", 152 | `data-target` = "#options", 153 | `data-toggle` = "collapse" 154 | ), 155 | 156 | if (interactive()) { 157 | # submit button 158 | actionLink( 159 | class = "btn", 160 | "submit", 161 | label = span( 162 | icon("share", class = "arrow4"), 163 | " Close & use ", 164 | icon("share", class = "arrow4") 165 | ), 166 | style = "color: white;font-weight: bold; background-color:#9362e0", 167 | `data-step` = 6, 168 | `data-intro` = "When ready, click this button to return the selected set of methods in R.", 169 | onclick = "window.close();" 170 | ) 171 | } else { 172 | # dyno button 173 | tags$a( 174 | class = "btn", 175 | style = "color: white;font-weight: bold; background-color:#9362e0", 176 | span( 177 | icon("share", class = "arrow4"), 178 | HTML("Infer trajectories with dyno"), 179 | icon("share", class = "arrow4") 180 | ), 181 | href = "https://github.com/dynverse/dyno", 182 | `data-intro` = "All methods presented here are available in the dyno pipeline, which can also be used to interpret and visualise the inferred trajectories.", 183 | `data-step` = 6, 184 | target = "blank" 185 | ) 186 | } 187 | ), 188 | 189 | # columns collapsible 190 | tags$div( 191 | class = "panel-collapse collapse", 192 | id = "columns", 193 | 194 | tags$div( 195 | 196 | # individual checkboxes 197 | tags$div( 198 | class = "indeterminate-checkbox-group", 199 | uiOutput("column_show_hide") 200 | ) 201 | ) 202 | ), 203 | 204 | # code collapible 205 | tags$div( 206 | class = "panel-collapse collapse", 207 | id = "code", 208 | 209 | # copy button 210 | singleton(tags$head(tags$script(src = "https://cdn.jsdelivr.net/npm/clipboard@2/dist/clipboard.min.js"))), 211 | tags$button( 212 | class = "btn btn-default btn-s btn-copy", 213 | style = "float:left", 214 | icon("copy"), 215 | `data-clipboard-target`="#code" 216 | ), 217 | tags$script("$(document).ready(function() {new ClipboardJS('.btn-copy')});"), 218 | 219 | # actual code 220 | textOutput("code", container = tags$pre) 221 | ), 222 | 223 | # options collapsible 224 | tags$div( 225 | class = "panel-collapse collapse", 226 | id = "options", 227 | 228 | # actual code 229 | uiOutput("options") 230 | ), 231 | 232 | # presets buttons 233 | tags$div( 234 | uiOutput("column_presets"), 235 | `data-intro` = "Here, you can change the columns displayed in the main table. It allows you to focus on particular aspects of the benchmarking, such as scalability, accuracy metrics, and usability.", 236 | `data-step` = 5 237 | ), 238 | 239 | # method table 240 | div( 241 | `data-intro` = "The relevant methods are displayed here, along with information on how they were ordered and selected.", 242 | `data-step` = 3, 243 | uiOutput("methods_table") 244 | ) 245 | ) 246 | ) 247 | ) 248 | ) 249 | } -------------------------------------------------------------------------------- /R/shiny_ui_methods_table.R: -------------------------------------------------------------------------------- 1 | add_icons <- function(label, conditions, icons) { 2 | pmap(c(list(label = label), conditions), function(label, ...) { 3 | icons <- list(...) %>% 4 | keep(~!is.na(.) && .) %>% 5 | names() %>% 6 | {icons[.]} 7 | 8 | span(c(list(label), icons)) 9 | }) 10 | } 11 | 12 | get_guidelines_methods_table <- function(guidelines, show_columns = character(), options = list(), answers = list()) { 13 | testthat::expect_true(length(names(show_columns)) == length(show_columns)) 14 | 15 | if(nrow(guidelines$methods_aggr) == 0) { 16 | span(class = "text-danger", "No methods fullfilling selection") 17 | } else { 18 | # remove duplicate columns 19 | method_columns <- guidelines$method_columns %>% 20 | group_by(column_id) %>% 21 | slice(n()) %>% 22 | ungroup() 23 | 24 | # add or remove columns based on `show_columns` 25 | if (is.null(show_columns)) {show_columns <- character()} 26 | names(show_columns) <- gsub("^column_(.*)", "\\1", names(show_columns)) 27 | method_columns <- method_columns %>% 28 | filter( 29 | isTRUE(show_columns[method_columns$column_id]) | 30 | show_columns[method_columns$column_id] %in% c("true", "indeterminate") | 31 | is.na(show_columns[method_columns$column_id]) 32 | ) %>% 33 | bind_rows( 34 | tibble( 35 | column_id = names(show_columns[show_columns == "true" | isTRUE(show_columns)]) %>% as.character() %>% setdiff(method_columns$column_id) 36 | ) 37 | ) 38 | 39 | # add renderers 40 | method_columns <- method_columns %>% 41 | left_join(get_renderers(), c("column_id" = "column_id")) %>% 42 | mutate(renderer = map(renderer, ~ifelse(is.null(.), function(x) {x}, .))) 43 | 44 | # add labels 45 | method_columns <- method_columns %>% 46 | mutate( 47 | label = add_icons(label, lst(filter, order), list(filter = icon("filter"), order = icon("sort-amount-asc"))) 48 | ) 49 | 50 | # order columns 51 | method_columns <- method_columns %>% 52 | mutate(order = case_when(!is.na(default)~default, filter~1, order~2, TRUE~3)) %>% 53 | left_join(get_column_categories(), "category") %>% 54 | arrange(category_order, order) 55 | 56 | # extract correct columns from guidelines 57 | methods <- guidelines$methods_aggr %>% select(!!method_columns$column_id) 58 | 59 | if (ncol(methods) == 0) { 60 | span(class = "text-danger", "No columns selected") 61 | } else { 62 | # render individual columns 63 | methods_rendered <- methods %>% 64 | map2(method_columns$renderer, function(col, renderer) { 65 | if ("answers" %in% names(formals(renderer))) { 66 | renderer(col, options, answers) 67 | } else if ("options" %in% names(formals(renderer))) { 68 | renderer(col, options) 69 | } else { 70 | renderer(col) 71 | } 72 | }) %>% 73 | as_tibble() 74 | 75 | # get information on categories 76 | rle_group <- function(x) { 77 | rle <- rle(x) 78 | unlist(map2(seq_along(rle$length), rle$length, rep)) 79 | } 80 | 81 | method_column_categories <- method_columns %>% 82 | mutate(run = rle_group(category)) %>% 83 | group_by(run, category) %>% 84 | summarise(colspan = n(), color = first(color)) 85 | 86 | # construct html of table 87 | methods_table <- tags$table( 88 | class = "table table-responsive", 89 | tags$tr( 90 | pmap(method_column_categories, function(category, colspan, color, ...) { 91 | tags$th( 92 | label_capitalise(category), 93 | style = paste0("background-color:", color), 94 | class = "method-column-header method-column-header-category", 95 | colspan = colspan 96 | ) 97 | }) 98 | ), 99 | tags$tr( 100 | pmap(method_columns, function(label, title, style, ...) { 101 | tags$th( 102 | label, 103 | `data-toggle` = "tooltip", 104 | `data-placement` = "top", 105 | title = title, 106 | style = ifelse(is.na(style), "", style), 107 | class = "method-column-header tooltippable" 108 | ) 109 | }) 110 | ), 111 | map( 112 | seq_len(nrow(methods)), 113 | function(row_i) { 114 | row_rendered <- extract_row_to_list(methods_rendered, row_i) 115 | row <- extract_row_to_list(methods, row_i) 116 | if ("selected" %in% names(row) && row$selected) { 117 | class <- "selected" 118 | } else { 119 | class <- "" 120 | } 121 | 122 | tags$tr( 123 | class = class, 124 | map(row_rendered, .f = tags$td) 125 | ) 126 | } 127 | ), 128 | tags$script('activeTooltips()') 129 | ) 130 | 131 | methods_table 132 | } 133 | } 134 | } -------------------------------------------------------------------------------- /R/shiny_ui_modals.R: -------------------------------------------------------------------------------- 1 | # get the modal to display the citations 2 | get_citations_modal <- function() { 3 | showModal(modalDialog( 4 | title = tagList( 5 | "If ", 6 | HTML("dynguidelines was helpful to you, please cite: "), 7 | tags$button(type = "button", class = "close", `data-dismiss` = "modal", "\U00D7") 8 | ), 9 | 10 | tags$div( 11 | style = "float:right;", 12 | 13 | singleton(tags$head(tags$script(type = "text/javascript", src = "https://d1bxh8uas1mnw7.cloudfront.net/assets/embed.js"))), 14 | tags$div( 15 | class = "altmetric-embed", 16 | `data-badge-type` = "medium-donut", 17 | `data-doi` = "10.1101/276907" 18 | ), 19 | tags$script("if (typeof _altmetric_embed_init !== 'undefined') {_altmetric_embed_init()};"), 20 | 21 | singleton(tags$head(tags$script(type = "text/javascript",src = "https://badge.dimensions.ai/badge.js"))), 22 | tags$div( 23 | class = "__dimensions_badge_embed__", 24 | `data-doi` = "10.1101/276907" 25 | ), 26 | tags$script("if (typeof __dimensions_embed !== 'undefined') {__dimensions_embed.addBadges()};") 27 | ), 28 | 29 | 30 | 31 | tags$a( 32 | href = "http://dx.doi.org/10.1101/276907", 33 | tags$blockquote(HTML(paste0("

", glue::glue_collapse(sample(c("Wouter Saelens*", "Robrecht Cannoodt*")), ", "), ", Helena Todorov, and Yvan Saeys.

\U201C A Comparison of Single-Cell Trajectory Inference Methods: Towards More Accurate and Robust Tools.\U201D

BioRxiv, March 5, 2018, 276907.

https://doi.org/10.1101/276907

"))), 34 | target = "blank" 35 | ), 36 | 37 | tags$p( 38 | style = "font-size: 17.5px;", 39 | "... or give us a shout-out on twitter (", tags$a(href = "https://twitter.com/saeyslab", "@saeyslab", target = "blank"), "). We'd love to hear your feedback!" 40 | ), 41 | 42 | tags$p( 43 | style = "font-size: 17.5px;", 44 | "Don't forget to also cite the papers describing the individual methods which you're using. They can be found by clicking the ", icon("paper-plane"), "icon." 45 | ), 46 | 47 | style = "overflow:visible;", 48 | 49 | easyClose = TRUE, 50 | size = "l", 51 | footer = NULL 52 | )) 53 | } 54 | 55 | -------------------------------------------------------------------------------- /R/shiny_ui_options.R: -------------------------------------------------------------------------------- 1 | get_columns_presets_ui <- function(column_presets, session, show_columns) { 2 | tags$div( 3 | tags$label("Lenses ", style = "float:left;line-height: 38px;font-size: 14px;margin-right: 5px;"), 4 | tags$div( 5 | class = "btn-group btn-group-justified", 6 | style = "width:initial!important", 7 | map(column_presets, function(column_preset) { 8 | # observe button event, and change the show columns accordingly 9 | button_id <- paste0("column_preset_", column_preset$id) 10 | observeEvent(session$input[[button_id]], { 11 | # change the columns checkboxes 12 | new_show_columns <- column_preset$activate(show_columns()) 13 | changed_show_columns <- new_show_columns[new_show_columns != show_columns()[names(new_show_columns)]] 14 | 15 | walk2(names(changed_show_columns), changed_show_columns, function(column_id, value) { 16 | updateIndeterminateCheckboxInput(session, column_id, value) 17 | }) 18 | }) 19 | 20 | actionLink( 21 | button_id, 22 | label = column_preset$label, 23 | class = "btn btn-default" 24 | ) 25 | }) 26 | ) 27 | ) 28 | } 29 | 30 | 31 | get_columns_show_hide_ui <- function(renderers) { 32 | tags$ul( 33 | class = "list-group", 34 | style = "position:static;", 35 | tidyr::nest(renderers, -category, .key = "renderers") %>% 36 | pmap(function(category, renderers) { 37 | tags$li( 38 | class = "list-group-item", 39 | tags$em(label_capitalise(category)), 40 | pmap(renderers, function(column_id, label, name, ...) { 41 | # use label by default, unless name is not na 42 | if (!is.na(name)) { 43 | label <- name 44 | } 45 | indeterminateCheckbox( 46 | paste0("column_", column_id), 47 | label, 48 | "indeterminate" 49 | ) 50 | }) %>% tags$div() 51 | ) 52 | }) 53 | ) 54 | } 55 | 56 | 57 | 58 | 59 | 60 | get_options_ui <- function() { 61 | tagList( 62 | shinyWidgets::radioGroupButtons( 63 | "score_visualisation", 64 | "How to show the scores", 65 | choices = c(Circles = "circle", Bars = "bar"), 66 | selected = "bar" 67 | ), 68 | shinyWidgets::radioGroupButtons( 69 | "advanced_mode", 70 | "Show advanced questions", 71 | choiceNames = c("Yes", "No"), 72 | choiceValues = c(TRUE, FALSE), 73 | selected = FALSE 74 | ) 75 | ) 76 | } -------------------------------------------------------------------------------- /R/shiny_ui_questions.R: -------------------------------------------------------------------------------- 1 | # Functions to create each type of input 2 | input_functions <- list( 3 | radiobuttons = function(q) { 4 | if (is.null(q[["default"]])) q[["default"]] <- character() 5 | 6 | # if choices not defined, use choiceNames and choiceValues 7 | if (is.null(q$choices)) { 8 | choiceNames <- q$choiceNames 9 | choiceValues <- q$choiceValues 10 | } else { 11 | # default choiceNames is simply the choices 12 | if (is.null(names(q$choices))) { 13 | choiceNames <- q$choices 14 | } else { 15 | choiceNames <- names(q$choices) 16 | } 17 | choiceValues <- unname(q$choices) 18 | } 19 | 20 | shinyWidgets::radioGroupButtons( 21 | inputId = q$question_id, 22 | label = q$label, 23 | selected = as.character(q[["default"]]), 24 | choiceNames = choiceNames, 25 | choiceValues = choiceValues, 26 | status = "default" 27 | ) 28 | }, 29 | radio = function(q) { 30 | if (is.null(q[["default"]])) q[["default"]] <- character() 31 | 32 | radioButtons( 33 | q$question_id, 34 | q$label, 35 | q$choices, 36 | q[["default"]] 37 | ) 38 | }, 39 | checkbox = function(q) { 40 | checkboxGroupInput( 41 | q$question_id, 42 | q$label, 43 | q$choices, 44 | q[["default"]] 45 | ) 46 | }, 47 | picker = function(q) { 48 | shinyWidgets::pickerInput( 49 | inputId = q$question_id, 50 | label = q$label, 51 | choices = q$choices, 52 | selected = q[["default"]], 53 | multiple = q$multiple %||% TRUE, 54 | options = list( 55 | `actions-box` = TRUE, 56 | `deselect-all-text` = "None", 57 | `select-all-text` = "All", 58 | `none-selected-text` = "None" 59 | ) 60 | ) 61 | }, 62 | slider = function(q) { 63 | sliderInput( 64 | inputId = q$question_id, 65 | label = q$label, 66 | min = q$min, 67 | max = q$max, 68 | value = q[["default"]], 69 | step = q$step, 70 | ticks = FALSE 71 | ) 72 | }, 73 | textslider = function(q) { 74 | testthat::expect_true(q$default %in% q$choices) 75 | shinyWidgets::sliderTextInput( 76 | inputId = q$question_id, 77 | label = q$label, 78 | choices = q$choices, 79 | selected = q[["default"]], 80 | grid = TRUE 81 | ) 82 | }, 83 | balancing_sliders = function(q) { 84 | balancingSliders( 85 | inputId = q$question_id, 86 | label = q$label, 87 | labels = q$labels, 88 | ids = q$ids, 89 | values = q[["default"]], 90 | min = q$min, 91 | max = q$max, 92 | sum = q$sum, 93 | step = q$step, 94 | ticks = q$ticks 95 | ) 96 | }, 97 | numeric = function(q) { 98 | numericInput( 99 | inputId = q$question_id, 100 | label = q$label, 101 | value = q[["default"]], 102 | min = 0 103 | ) 104 | }, 105 | module = function(q) { 106 | q$module_input( 107 | id = q$question_id, 108 | data = q$data 109 | ) 110 | } 111 | ) 112 | 113 | 114 | get_questions_ui <- function(question_categories, answers) { 115 | # build the questions ui 116 | 117 | # create every category 118 | questions_ui <- map(question_categories, function(question_category) { 119 | # get the header of the panel 120 | category_id <- question_category[[1]]$category 121 | category_header <- category_id %>% label_capitalise 122 | 123 | # check if the panel has to be opened from the start 124 | show_on_start <- map_lgl(question_category, ~ifelse(is.null(.$show_on_start), FALSE, .$show_on_start)) %>% any() 125 | 126 | # create the panel of the category 127 | category_panel <- collapsePanel( 128 | id = category_id, 129 | header = category_header, 130 | show_on_start = show_on_start, 131 | map(question_category, function(question) { 132 | if(!question$type %in% names(input_functions)) {stop("Invalid question type")} 133 | 134 | # if this question has a label and title, add the tooltip help information 135 | if (!is.null(question$label) && !is.null(question$title)) { 136 | question$label <- 137 | tags$span( 138 | class = "tooltippable", 139 | title = question$title, 140 | question$label, 141 | `data-toggle` = "tooltip", 142 | `data-trigger` = "hover click", 143 | `data-placement` = "right" 144 | ) 145 | } 146 | 147 | question_panel <- div( 148 | conditionalPanel( 149 | question$activeIf, 150 | input_functions[[question$type]](question) 151 | ) 152 | ) 153 | 154 | question_panel 155 | }) 156 | ) 157 | 158 | # observe changes in completion 159 | observe({ 160 | category_sources <- question_category %>% keep(~.$active()) %>% map_chr(~.$source()) 161 | 162 | if (all(category_sources != "none")) { 163 | shinyjs::toggleClass( 164 | category_panel$attr$id, 165 | "completed-category", 166 | any(category_sources == "adapted") 167 | ) 168 | 169 | shinyjs::toggleClass( 170 | category_panel$attr$id, 171 | "computed-category", 172 | any(category_sources == "computed") && all(category_sources %in% c("computed", "default")) 173 | ) 174 | 175 | shinyjs::toggleClass( 176 | category_panel$attr$id, 177 | "default-category", 178 | all(category_sources == "default") 179 | ) 180 | } 181 | }) 182 | 183 | category_panel 184 | }) %>% add_loaded_proxy() 185 | } 186 | 187 | 188 | 189 | 190 | # adds a proxy input, which can tell others that these inputs have been loaded and that their inputs are "correct" 191 | add_loaded_proxy <- function(inputs, id) { 192 | c( 193 | inputs, 194 | list( 195 | tags$div( 196 | style = "display:none;", 197 | shiny::radioButtons( 198 | "questions_loaded", 199 | "whatevs", 200 | "loaded", 201 | "loaded", 202 | width = "0%" 203 | ) 204 | ) 205 | ) 206 | ) 207 | } -------------------------------------------------------------------------------- /R/sysdata.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/R/sysdata.rda -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | editor_options: 4 | chunk_output_type: console 5 | --- 6 | 7 | 8 | 9 | ```{r, echo = FALSE, message = FALSE, error = FALSE, warning = FALSE} 10 | library(tidyverse) 11 | ``` 12 | 13 | 14 | [![R build status](https://github.com/dynverse/dynguidelines/workflows/R-CMD-check/badge.svg)](https://github.com/dynverse/dynguidelines/actions) 15 | [![codecov](https://codecov.io/gh/dynverse/dynguidelines/branch/master/graph/badge.svg)](https://codecov.io/gh/dynverse/dynguidelines) 16 | 17 | 18 | 19 | # Selecting the most optimal TI methods 20 | 21 | This package summarises the results from the [dynbenchmark](https://www.github.com/dynverse/dynbenchmark) evaluation of trajectory inference methods. Both programmatically and through a (shiny) app, users can select the most optimal set of methods given a set of user and dataset specific parameters. 22 | 23 | Installing the app: 24 | ```{r eval=FALSE} 25 | # install.packages("devtools") 26 | devtools::install_github("dynverse/dynguidelines") 27 | ``` 28 | 29 | Running the app: 30 | ```{r eval=FALSE} 31 | dynguidelines::guidelines_shiny() 32 | ``` 33 | 34 | See [dyno](https://www.github.com/dynverse/dyno) for more information on how to use this package to infer and interpret trajectories. 35 | 36 | 37 | ![demo](man/figures/demo.gif) 38 | 39 | ## Latest changes 40 | Check out `news(package = "dynguidelines")` or [NEWS.md](NEWS.md) for a full list of changes. 41 | 42 | 43 | 44 | ```{r news, echo=FALSE, results="asis"} 45 | cat(dynutils::recent_news()) 46 | ``` 47 | 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | [![R build 7 | status](https://github.com/dynverse/dynguidelines/workflows/R-CMD-check/badge.svg)](https://github.com/dynverse/dynguidelines/actions) 8 | [![codecov](https://codecov.io/gh/dynverse/dynguidelines/branch/master/graph/badge.svg)](https://codecov.io/gh/dynverse/dynguidelines) 9 | 10 | 11 | 12 | # Selecting the most optimal TI methods 13 | 14 | This package summarises the results from the 15 | [dynbenchmark](https://www.github.com/dynverse/dynbenchmark) evaluation 16 | of trajectory inference methods. Both programmatically and through a 17 | (shiny) app, users can select the most optimal set of methods given a 18 | set of user and dataset specific parameters. 19 | 20 | Installing the app: 21 | 22 | ``` r 23 | # install.packages("devtools") 24 | devtools::install_github("dynverse/dynguidelines") 25 | ``` 26 | 27 | Running the app: 28 | 29 | ``` r 30 | dynguidelines::guidelines_shiny() 31 | ``` 32 | 33 | See [dyno](https://www.github.com/dynverse/dyno) for more information on 34 | how to use this package to infer and interpret trajectories. 35 | 36 | 37 | 38 | ![demo](man/figures/demo.gif) 39 | 40 | ## Latest changes 41 | 42 | Check out `news(package = "dynguidelines")` or [NEWS.md](NEWS.md) for a 43 | full list of changes. 44 | 45 | 46 | 47 | ### Recent changes in dynguidelines 1.0.1 (29-06-2020) 48 | 49 | #### Fixes 50 | 51 | - Fix `get_questions()`: Remove accidental reliance on list name 52 | autocompletion, which has been removed from R. 53 | 54 | #### Minor changes 55 | 56 | - Migrate from Travis CI to Github Actions for CMD check and codecov, 57 | not yet for automated deployment. 58 | 59 | ### Recent changes in dynguidelines 1.0 (29-03-2019) 60 | 61 | #### Minor changes 62 | 63 | - Remove dyneval dependency 64 | - Minor changes due to changes in dynwrap v1.0 65 | -------------------------------------------------------------------------------- /clean_history.sh: -------------------------------------------------------------------------------- 1 | wget http://repo1.maven.org/maven2/com/madgag/bfg/1.13.0/bfg-1.13.0.jar 2 | git clone --single-branch -b devel --mirror git@github.com:dynverse/dynguidelines.git 3 | java -jar bfg-1.13.0.jar --delete-files methods_aggr.rda dynguidelines.git 4 | cd dynguidelines.git 5 | git reflog expire --expire=now --all && git gc --prune=now --aggressive 6 | git push 7 | rm bfg-1.13.0.jar -------------------------------------------------------------------------------- /data-raw/generate_help_pictures.R: -------------------------------------------------------------------------------- 1 | library(dyntoy) 2 | library(dynplot) 3 | library(tidyverse) 4 | 5 | 6 | ## disconnected example 7 | dataset <- dyntoy::generate_dataset(model = "disconnected", num_cells = 1000) 8 | plot <- plot_dimred(dataset) 9 | ggsave("inst/img/disconnected_example.png", plot = plot, width = 3, height = 3) 10 | 11 | 12 | 13 | ## cyclic example 14 | dataset <- dyntoy::generate_dataset(model = tibble(from = c("A", "A", "B", "C"), to = c("D", "B", "C", "A")), num_cells = 1000) 15 | plot <- plot_dimred(dataset) 16 | ggsave("inst/img/cyclic_example.png", plot = plot, width = 3, height = 3) 17 | 18 | 19 | 20 | 21 | ## complex tree example 22 | dataset <- dyntoy::generate_dataset(model = tibble(from = c("A", "B", "B", "C", "C"), to = c("B", "C", "D", "E", "F")), num_cells = 1000) 23 | plot <- plot_dimred(dataset, dimred = dyndimred::dimred_landmark_mds) 24 | ggsave("inst/img/complex_tree_example.png", plot = plot, width = 3, height = 3) 25 | -------------------------------------------------------------------------------- /data-raw/generate_trajectory_type_pictures.R: -------------------------------------------------------------------------------- 1 | library(dynbenchmark) 2 | library(dynwrap) 3 | library(tidyverse) 4 | 5 | trajectory_types$id %>% map(function(trajectory_type) { 6 | plot <- dynbenchmark::plot_trajectory_types(trajectory_type = trajectory_type, size = 5) + scale_x_continuous(expand = c(0.1, 0)) + scale_y_continuous(expand = c(0.3, 0)) 7 | 8 | ggsave(glue::glue("inst/img/trajectory_types/{trajectory_type}.png"), width = 2, height = 1.2, bg = "transparent") 9 | 10 | }) 11 | -------------------------------------------------------------------------------- /data-raw/internal.R: -------------------------------------------------------------------------------- 1 | # see dynbenchmark 09-guidelines/01-aggregate -------------------------------------------------------------------------------- /dynguidelines.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | StripTrailingWhitespace: Yes 16 | 17 | BuildType: Package 18 | PackageUseDevtools: Yes 19 | PackageInstallArgs: --no-multiarch --with-keep.source 20 | PackageRoxygenize: rd,collate,namespace 21 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citEntry( 2 | entry = "Article", 3 | author = "Wouter Saelens and Robrecht Cannoodt", 4 | title = "dynguidelines: Practical guidelines for trajectory inference.", 5 | journal = "In Progress", 6 | year = "2019", 7 | month = "", 8 | volume = "", 9 | number = "", 10 | pages = "", 11 | doi = "", 12 | textVersion = "Saelens W. and Cannoodt R., dynguidelines: Practical guidelines for trajectory inference, In Progress, 2019." 13 | ) 14 | -------------------------------------------------------------------------------- /inst/NEWS: -------------------------------------------------------------------------------- 1 | dynguidelines 1.0 (29-03-2019) 2 | 3 | **Minor changes** 4 | * Remove dyneval dependency 5 | * Minor changes due to changes in dynwrap v1.0 6 | 7 | dynguidelines 0.3.2 (17-12-2018) 8 | 9 | **New features** 10 | 11 | * Enable automatic deployment via travis-ci 12 | 13 | **Fixes** 14 | 15 | * Justify lens buttons 16 | * Use master branch of dynwrap instead of devel 17 | 18 | 19 | dynguidelines 0.3.1 (16-11-2018) 20 | 21 | **New features** 22 | 23 | * Time and memory are now formatted relative to the limits in the questions (fixes #46) 24 | * If time and memory exceed the limit, they are clipped 25 | 26 | **Fixes** 27 | 28 | * Remove debug javascript messages 29 | * Fix javascript error for lenses which activated wrong columns 30 | * Fix bug when no n_cells or n_features is entered 31 | * Clean stability column names 32 | * Clean scalability column names 33 | * Add tooltips to priors 34 | * Small fixes for default columns 35 | * Cleanup of exported function and documentation 36 | 37 | dynguidelines 0.3.0 (15-11-2018) 38 | 39 | **New features** 40 | 41 | * Add category headers, just like figure 2/3 42 | * Columns are now sorted within each category, categories are sorted according to figure 2/3 43 | * New columns: overall scores within each category, wrapper type, prior information 44 | * New lens: Summary (Fig. 2) 45 | * Show lenses by default 46 | 47 | **Fixes** 48 | 49 | * Several small cosmetic changes 50 | * Code and doi links are opened in a new tab 51 | * Not knowing the explicit topology will now filter on multifurcations as well 52 | 53 | dynguidelines 0.2.1 (14-11-2018) 54 | 55 | * Add warning column for when a method errors too often 56 | * Several fixes for more readable columns (such as usability) 57 | * Update deployment instructions 58 | * Rename scaling to scalability 59 | 60 | dynguidelines 0.2.0 (14-11-2018) 61 | 62 | * Update for new dynbenchmark results 63 | * Add new coloring scheme 64 | * Add stability, shown by default as a warning that a method produces an unstable result 65 | 66 | dynguidelines 0.1.0 (16-04-2018) 67 | 68 | * INITIAL RELEASE: dynguidelines, user guidelines for trajectory inference 69 | - A shiny app which lets you select the most optimal trajectory inference method based on a number of user-dependent and dataset-dependent parameters 70 | -------------------------------------------------------------------------------- /inst/css/balancing-sliders.css: -------------------------------------------------------------------------------- 1 | button.lock { 2 | opacity: 0.5; 3 | } 4 | 5 | button.lock.locked { 6 | opacity: 1; 7 | } -------------------------------------------------------------------------------- /inst/css/indeterminate-checkbox.css: -------------------------------------------------------------------------------- 1 | .indeterminate-checkbox-group span { 2 | display: inline-block; 3 | padding-right: 20px; 4 | } 5 | 6 | .indeterminate-checkbox-group label { 7 | font-weight: normal; 8 | } 9 | 10 | -------------------------------------------------------------------------------- /inst/css/style.css: -------------------------------------------------------------------------------- 1 | /*****************/ 2 | /*** Title bar ***/ 3 | /*****************/ 4 | 5 | /* title */ 6 | .navbar img { 7 | max-height: 70px; 8 | } 9 | 10 | .navbar-header { 11 | margin-right: 20px !important; 12 | } 13 | 14 | /* navbar elements */ 15 | .navbar-nav>li>a { 16 | padding-bottom: 25px; 17 | padding-top: 25px; 18 | } 19 | 20 | .nav-highlight { 21 | background-color:#9362e0; 22 | border-left: 1px solid white; 23 | border-right: 1px solid white; 24 | } 25 | 26 | .nav-highlight>a { 27 | color: white!important; 28 | font-weight: bold; 29 | } 30 | 31 | 32 | /*** collapse panels ***/ 33 | .panel-heading { 34 | transition: all 0.5s; 35 | } 36 | 37 | .panel-collapse > div { 38 | padding: 10px 15px; 39 | width:100%; 40 | } 41 | 42 | span.computed { 43 | font-size: 0.8em; 44 | font-variant: small-caps; 45 | float:right; 46 | } 47 | 48 | div.computed { 49 | opacity:0.5; 50 | } 51 | 52 | /* heading arrow */ 53 | 54 | .panel-heading i { 55 | transition: all 0.5s; 56 | transform: rotate(0deg); 57 | } 58 | 59 | .panel-heading.collapsed i { 60 | transform: rotate(-90deg); 61 | } 62 | 63 | /**********************/ 64 | /***** Questions ******/ 65 | /**********************/ 66 | 67 | .shiny-input-container:not(.shiny-input-container-inline) { 68 | width: auto !important; 69 | max-width: 100%; 70 | } 71 | 72 | /* Header of panels */ 73 | div.panel-heading { 74 | cursor: pointer; 75 | } 76 | 77 | /* Category completion */ 78 | .completed-category div.panel-heading { 79 | background-color: #d0e0b6; 80 | } 81 | .completed-category div.panel-heading span:after { 82 | float: right; 83 | font-size: 0.8em; 84 | font-variant: small-caps; 85 | content: "adapted"; 86 | } 87 | 88 | .default-category div.panel-heading { 89 | background-color: #f1d4a5; 90 | } 91 | .default-category div.panel-heading span:after { 92 | float: right; 93 | font-size: 0.8em; 94 | font-variant: small-caps; 95 | content: "default"; 96 | } 97 | 98 | .computed-category div.panel-heading { 99 | background-color: #a5ccf1; 100 | } 101 | .computed-category div.panel-heading span:after { 102 | float: right; 103 | font-size: 0.8em; 104 | font-variant: small-caps; 105 | content: "computed"; 106 | } 107 | 108 | /** Modifications to components **/ 109 | 110 | /* Hiding ugly minor tick marks */ 111 | .irs-grid-pol.small { 112 | height: 0 !important; 113 | } 114 | 115 | /* Hide mispositioned spinners: the spinners are incorrectly displayed in the rstudio viewer and are thus hidden here */ 116 | input[type=number]::-webkit-inner-spin-button, 117 | input[type=number]::-webkit-outer-spin-button { 118 | -webkit-appearance: none; 119 | margin: 0; 120 | } 121 | 122 | /**************************/ 123 | /***** Methods table ******/ 124 | /**************************/ 125 | 126 | tr.selected > td:first-of-type { 127 | background-color: #333333; 128 | color: white; 129 | } 130 | 131 | tr.selected { 132 | background-color: #EEEEEE; 133 | } 134 | 135 | /* Headers */ 136 | th.method-column-header { 137 | vertical-align:bottom!important; 138 | width: 10px; 139 | } 140 | 141 | th.method-column-header-category { 142 | color: white; 143 | text-align: center; 144 | border-left: 2px solid white; 145 | border-right: 2px solid white; 146 | } 147 | 148 | /* Cells */ 149 | 150 | .table>tbody>tr>td, .table>tbody>tr>th { 151 | padding: 8px 5px 8px 5px; 152 | width: 1px; 153 | } 154 | 155 | /* Score */ 156 | td > span.score { 157 | padding-right: 3px; 158 | padding-left: 3px; 159 | display: block; 160 | border: 1px solid #444444; 161 | } 162 | 163 | td > span.bar { 164 | border-radius: 3px; 165 | } 166 | 167 | td > span.circle { 168 | border-radius: 50%; 169 | } 170 | 171 | td > span.box { 172 | text-align:center; 173 | } 174 | 175 | 176 | /***** Tooltips ******/ 177 | 178 | .tooltippable { 179 | text-decoration: dotted underline; 180 | } 181 | 182 | .tooltip-inner { 183 | background-color: #EEE; 184 | border: 1px solid black; 185 | color: black; 186 | max-width: 400px; 187 | font-size: 14px; 188 | } 189 | 190 | .tooltip-inner img{ 191 | max-width: 380px; 192 | } 193 | 194 | 195 | /* Footer */ 196 | .footer { 197 | margin: 0 auto; 198 | text-align: center; 199 | } 200 | 201 | .footer img { 202 | max-height: 75px; 203 | } 204 | 205 | 206 | 207 | /*** Arrow animation ***/ 208 | 209 | .arrow4 { 210 | animation: slide4 4s linear infinite; 211 | animation-play-state: paused; 212 | } 213 | 214 | a:hover .arrow4, a.introjs-showElement .arrow4 { 215 | animation-play-state: running; 216 | } 217 | 218 | @keyframes slide4 { 219 | 0% { 220 | transform: rotate(0); 221 | } 222 | 223 | 100% { 224 | transform: rotate(360deg); 225 | } 226 | } 227 | 228 | 229 | 230 | /* Trajectory types */ 231 | img.trajectory_type { 232 | width:50px; 233 | margin: -4px; 234 | } 235 | 236 | img.trajectory_type.inactive { 237 | opacity:0.1; 238 | } 239 | 240 | 241 | 242 | /*** Tutorial ***/ 243 | .introjs-helperNumberLayer { 244 | background:#9362e0; 245 | } 246 | 247 | 248 | 249 | 250 | 251 | /*** Badges ***/ 252 | 253 | .__dimensions_badge_embed__ { 254 | display: inline !important; 255 | } -------------------------------------------------------------------------------- /inst/deploy/.gitignore: -------------------------------------------------------------------------------- 1 | common_commands.html 2 | -------------------------------------------------------------------------------- /inst/deploy/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM rocker/tidyverse:latest 2 | 3 | MAINTAINER Wouter Saelens "wouter.saelens@gmail.com" 4 | 5 | # install shiny server dependencies 6 | RUN apt-get update && apt-get install -y \ 7 | sudo \ 8 | gdebi-core \ 9 | pandoc \ 10 | pandoc-citeproc \ 11 | libcurl4-gnutls-dev \ 12 | libxt-dev \ 13 | libssl-dev \ 14 | libxml2 \ 15 | libxml2-dev 16 | 17 | # download and install shiny server 18 | RUN wget --no-verbose https://s3.amazonaws.com/rstudio-shiny-server-os-build/ubuntu-12.04/x86_64/VERSION -O "version.txt" && \ 19 | VERSION=$(cat version.txt) && \ 20 | wget --no-verbose "https://s3.amazonaws.com/rstudio-shiny-server-os-build/ubuntu-12.04/x86_64/shiny-server-$VERSION-amd64.deb" -O ss-latest.deb && \ 21 | gdebi -n ss-latest.deb && \ 22 | rm -f version.txt ss-latest.deb 23 | 24 | # install xtail for logging through docker logs 25 | RUN apt-get install -y xtail 26 | 27 | # clone dynguidelines repo 28 | RUN git clone -b master https://github.com/dynverse/dynguidelines.git 29 | 30 | # install dynguidelines 31 | RUN cd dynguidelines; R -e "devtools::install(dep = TRUE)" 32 | 33 | # copy over files of the server and the app 34 | EXPOSE 8080 35 | COPY server/shiny-server.sh /home/rstudio/shiny-server.sh 36 | COPY server/shiny-server.conf /etc/shiny-server/shiny-server.conf 37 | COPY server/server.R /srv/shiny-server/ 38 | COPY server/ui.R /srv/shiny-server/ 39 | 40 | # define run command 41 | CMD ["sh", "/home/rstudio/shiny-server.sh"] -------------------------------------------------------------------------------- /inst/deploy/common_commands.md: -------------------------------------------------------------------------------- 1 | # Kubernetes 2 | 3 | ## Set context 4 | 5 | Make sure this is correct, otherwise everything will time out 6 | ``` 7 | kubectl config use-context gke_dynguidelines_us-central1-a_dynguidelines 8 | ``` 9 | 10 | # Rollout 11 | 12 | ## Go to correct folder 13 | ``` 14 | cd inst/deploy 15 | ``` 16 | 17 | ## Change current version tag (necessary to do rolling updates on google cloud) 18 | ``` 19 | export version=`R --vanilla -e "cat(as.character(packageVersion('dynguidelines'))[[1]]);cat('\n')" | grep "^[^>]" | tail -n 1` 20 | echo $version 21 | ``` 22 | 23 | ## Build the container 24 | ``` 25 | # without cache: 26 | # docker build --no-cache --build-arg CACHE_DATE=$(date +%Y-%m-%d:%H:%M:%S) -t dynverse/dynguidelines_server:${version} . 27 | 28 | # with cache 29 | docker build -t dynverse/dynguidelines_server:${version} inst/deploy 30 | ``` 31 | 32 | ## Push the container 33 | ``` 34 | docker push dynverse/dynguidelines_server:${version} 35 | ``` 36 | 37 | ## Run the container locally for testing 38 | ``` 39 | docker run --rm -p 8080:8080 --name shiny dynverse/dynguidelines_server:${version} 40 | docker kill shiny 41 | ``` 42 | 43 | ## Push to google cloud 44 | 45 | ``` 46 | docker tag dynverse/dynguidelines_server:${version} gcr.io/dynguidelines/dynguidelines_server:${version} 47 | docker push -- gcr.io/dynguidelines/dynguidelines_server:${version} 48 | kubectl set image deployment/dynguidelines dynguidelines=gcr.io/dynguidelines/dynguidelines_server:${version} 49 | ``` 50 | 51 | ## Get rollout status 52 | ``` 53 | kubectl rollout status deployment/dynguidelines 54 | kubectl get deployments 55 | ``` 56 | 57 | # Create cluster from scratch 58 | 59 | Add the cluster as a google cloud context: 60 | https://cloud.google.com/kubernetes-engine/docs/tutorials/hello-app 61 | 62 | Create the cluster 63 | ``` 64 | gcloud container clusters create dynguidelines --num-nodes=1 65 | ``` 66 | 67 | Push container (see up) 68 | 69 | Run container 70 | ``` 71 | kubectl run dynguidelines --image=gcr.io/dynguidelines/dynguidelines_server:${version} --port 8080 72 | 73 | kubectl expose deployment dynguidelines --type=LoadBalancer --port 80 --target-port 8080 74 | ``` 75 | 76 | ## Get public ip 77 | ``` 78 | kubectl get service 79 | ``` 80 | 81 | 82 | # Continuous deployment 83 | 84 | Create a service account: https://cloud.google.com/iam/docs/creating-managing-service-accounts#creating_a_service_account 85 | 86 | Generate key 87 | 88 | Base 64 key 89 | ``` 90 | base64 ~/Downloads/dynguidelines-465c5aa876d4.json > /tmp/decrypted_key.json 91 | ``` 92 | 93 | Add as `GCLOUD_SERVICE_KEY` to travis environment variables -------------------------------------------------------------------------------- /inst/deploy/deploy.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | GOOGLE_APPLICATION_CREDENTIALS=~/gcloud-service-key.json 6 | PROJECT_NAME_PRD=dynguidelines 7 | CLUSTER_NAME_PRD=dynguidelines 8 | CLOUDSDK_COMPUTE_ZONE=us-central1-a 9 | DOCKER_IMAGE_NAME=dynguidelines_server 10 | KUBE_DEPLOYMENT_NAME=dynguidelines 11 | KUBE_DEPLOYMENT_CONTAINER_NAME=dynguidelines 12 | 13 | docker build -t gcr.io/${PROJECT_NAME_PRD}/${DOCKER_IMAGE_NAME}:$TRAVIS_COMMIT ./inst/deploy/ 14 | 15 | echo $GCLOUD_SERVICE_KEY_PRD | base64 --decode -i > ${HOME}/gcloud-service-key.json 16 | gcloud auth activate-service-account --key-file ${HOME}/gcloud-service-key.json 17 | 18 | gcloud --quiet config set project $PROJECT_NAME_PRD 19 | gcloud --quiet config set container/cluster $CLUSTER_NAME_PRD 20 | gcloud --quiet config set compute/zone ${CLOUDSDK_COMPUTE_ZONE} 21 | gcloud --quiet container clusters get-credentials $CLUSTER_NAME_PRD 22 | 23 | gcloud docker push gcr.io/${PROJECT_NAME_PRD}/${DOCKER_IMAGE_NAME} 24 | 25 | yes | gcloud beta container images add-tag gcr.io/${PROJECT_NAME_PRD}/${DOCKER_IMAGE_NAME}:$TRAVIS_COMMIT gcr.io/${PROJECT_NAME_PRD}/${DOCKER_IMAGE_NAME}:latest 26 | 27 | kubectl config view 28 | kubectl config current-context 29 | 30 | kubectl set image deployment/${KUBE_DEPLOYMENT_NAME} ${KUBE_DEPLOYMENT_CONTAINER_NAME}=gcr.io/${PROJECT_NAME_PRD}/${DOCKER_IMAGE_NAME}:$TRAVIS_COMMIT 31 | 32 | # kubectl rollout status deployment/dynguidelines 33 | # kubectl get deployments -------------------------------------------------------------------------------- /inst/deploy/dynguidelines-service.yaml: -------------------------------------------------------------------------------- 1 | apiVersion: v1 2 | kind: Service 3 | metadata: 4 | creationTimestamp: 2018-09-24T13:18:53Z 5 | labels: 6 | run: dynguidelines 7 | name: dynguidelines 8 | namespace: default 9 | resourceVersion: "991" 10 | selfLink: /api/v1/namespaces/default/services/dynguidelines 11 | uid: 6201f3e7-bffc-11e8-b4cd-42010a80018a 12 | spec: 13 | clusterIP: 10.31.244.30 14 | externalTrafficPolicy: Cluster 15 | ports: 16 | - nodePort: 32498 17 | port: 80 18 | protocol: TCP 19 | targetPort: 8080 20 | selector: 21 | run: dynguidelines 22 | sessionAffinity: None 23 | type: LoadBalancer 24 | status: 25 | loadBalancer: 26 | ingress: 27 | - ip: 146.148.59.79 28 | -------------------------------------------------------------------------------- /inst/deploy/server/server.R: -------------------------------------------------------------------------------- 1 | library(dynguidelines) 2 | 3 | server <- dynguidelines::shiny_server() -------------------------------------------------------------------------------- /inst/deploy/server/shiny-server.conf: -------------------------------------------------------------------------------- 1 | # Define the user we should use when spawning R Shiny processes 2 | run_as shiny; 3 | 4 | # Define a top-level server which will listen on a port 5 | server { 6 | # Instruct this server to listen on port 80. The app at dokku-alt need expose PORT 80, or 500 e etc. See the docs 7 | listen 8080; 8 | 9 | # Define the location available at the base URL 10 | location / { 11 | 12 | # Run this location in 'site_dir' mode, which hosts the entire directory 13 | # tree at '/srv/shiny-server' 14 | site_dir /srv/shiny-server; 15 | 16 | # Define where we should put the log files for this location 17 | log_dir /var/log/shiny-server; 18 | 19 | # Should we list the contents of a (non-Shiny-App) directory when the user 20 | # visits the corresponding URL? 21 | directory_index on; 22 | } 23 | } -------------------------------------------------------------------------------- /inst/deploy/server/shiny-server.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Make sure the directory for individual app logs exists 4 | mkdir -p /var/log/shiny-server 5 | chown shiny.shiny /var/log/shiny-server 6 | 7 | exec shiny-server 2>&1 & 8 | exec xtail /var/log/shiny-server/ -------------------------------------------------------------------------------- /inst/deploy/server/ui.R: -------------------------------------------------------------------------------- 1 | library(dynguidelines) 2 | 3 | ui <- dynguidelines::shiny_ui() 4 | -------------------------------------------------------------------------------- /inst/img/complex_tree_example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/complex_tree_example.png -------------------------------------------------------------------------------- /inst/img/cyclic_example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/cyclic_example.png -------------------------------------------------------------------------------- /inst/img/disconnected_example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/disconnected_example.png -------------------------------------------------------------------------------- /inst/img/favicon_16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/favicon_16.png -------------------------------------------------------------------------------- /inst/img/logo_dynverse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/logo_dynverse.png -------------------------------------------------------------------------------- /inst/img/logo_horizontal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/logo_horizontal.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/acyclic_graph.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/acyclic_graph.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/bifurcation.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/bifurcation.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/convergence.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/convergence.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/cycle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/cycle.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/disconnected_graph.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/disconnected_graph.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/graph.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/graph.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/linear.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/linear.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/multifurcation.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/multifurcation.png -------------------------------------------------------------------------------- /inst/img/trajectory_types/tree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/inst/img/trajectory_types/tree.png -------------------------------------------------------------------------------- /inst/js/balancing-sliders.js: -------------------------------------------------------------------------------- 1 | // Listener functions for the lock buttons 2 | var lockListener = function(e) { 3 | $(this).toggleClass("locked") 4 | 5 | var id = $(this).attr("id"); 6 | 7 | // find the input with the same id 8 | var slider = $(this).parent().parent().find("input#" + id).data("ionRangeSlider"); 9 | slider.update({block:!slider.options.block}); 10 | } 11 | 12 | 13 | 14 | 15 | var balancingSliders = new Shiny.InputBinding(); 16 | $.extend(balancingSliders, { 17 | find: function(scope) { 18 | return $(scope).find(".balancing-sliders"); 19 | }, 20 | getValue: function(el) { 21 | var inputs = $(el).find(".js-range-slider"); 22 | var vals = inputs.map(function() {return Number($(this).val())}).get(); 23 | var ids = inputs.map(function() {return $(this).attr("id")}).get(); 24 | 25 | return _.zipObject(ids, vals); 26 | }, 27 | setValue: function(el, value) { 28 | $(el).text(value); 29 | }, 30 | subscribe: function(el, callback) { 31 | // activate lock listener 32 | $(el).find("button").on("click", lockListener) 33 | 34 | // activate drag listener 35 | $(el).find("input").on("change.balancing-sliders", function(e) { 36 | // get the changed input and the non-changed inputs (otherInputs) 37 | var changedInput = $(e.currentTarget); 38 | 39 | if (changedInput.attr("data-dependent") != "true") { 40 | // fixed inputs = changedInput + all locked inputs 41 | var otherInputs = $(el).find(".js-range-slider:not(#" + changedInput.attr("id") + ")"); 42 | 43 | // these inputs can be changed 44 | var changeableInputs = otherInputs.filter(function() { 45 | return !$(this).data("ionRangeSlider").options.block; 46 | }); 47 | 48 | // these inputs cannot be changed 49 | var fixedInputs = otherInputs.filter(function() { 50 | return $(this).data("ionRangeSlider").options.block; 51 | }); 52 | fixedInputs = fixedInputs.add(changedInput) 53 | 54 | // make the other inputs "dependent", so that their change event won't induce a recursion 55 | changeableInputs.attr("data-dependent", "true"); 56 | 57 | // calculate the scaling of all other values, based on what is left over of the values of fixedInputs 58 | var fixedVals = fixedInputs.map(function() {return Number($(this).val())}); 59 | var fixedSum = _.sum(fixedVals) 60 | 61 | var changeableVals = changeableInputs.map(function() {return Number($(this).val())}); 62 | var changeableSum = _.sum(changeableVals); 63 | 64 | var scale = (1-fixedSum) / changeableSum; 65 | 66 | // special case where a slider goes out of possible bounds (eg. everything is locked) 67 | // this is also triggered when there are no other available sliders 68 | // this will reset the value of the changed slider back to its original position 69 | if ((fixedSum > 1 && changeableSum === 0) || (changeableInputs.length === 0)) { 70 | changedInput.attr("data-dependent", "true"); 71 | changeableInputs.attr("data-dependent", "false"); 72 | var changedVal = Number(changedInput.val()); 73 | 74 | changedInput.data("ionRangeSlider").update({"from": changedVal + (1-fixedSum)}); 75 | 76 | // special case where all otherVals are 0, but the fixedVal has just become lower than 1 77 | // in that case, the otherVals should become (1-changeVal)/nOthers 78 | } else if (fixedSum < 1 && changeableSum === 0) { 79 | changeableInputs.each(function() { 80 | var changeableVal = (1 - fixedSum) / changeableVals.length; 81 | $(this).data("ionRangeSlider").update({"from":changeableVal}); 82 | }); 83 | 84 | // regular case 85 | } else { 86 | changeableInputs.each(function() { 87 | var changeableVal = $(this).val() * scale; 88 | $(this).data("ionRangeSlider").update({"from":changeableVal}); 89 | }); 90 | } 91 | 92 | callback(true); 93 | } else { 94 | changedInput.attr("data-dependent", "false"); 95 | } 96 | 97 | // 98 | }); 99 | }, 100 | unsubscribe: function(el) { 101 | $(el).off(".balancing-sliders"); 102 | }, 103 | getRatePolicy: function() { 104 | return { 105 | policy: "throttle", 106 | delay: 1000 107 | }; 108 | } 109 | }); 110 | 111 | Shiny.inputBindings.register(balancingSliders); -------------------------------------------------------------------------------- /inst/js/google-analytics.js: -------------------------------------------------------------------------------- 1 | window.dataLayer = window.dataLayer || []; 2 | function gtag(){dataLayer.push(arguments);} 3 | gtag('js', new Date()); 4 | 5 | gtag('config', 'UA-578149-3'); 6 | -------------------------------------------------------------------------------- /inst/js/indeterminate-checkbox.js: -------------------------------------------------------------------------------- 1 | var indeterminateCheckbox = new Shiny.InputBinding(); 2 | 3 | 4 | function setIndeterminateCheckboxValue(input, value) { 5 | if (value == "indeterminate") { 6 | input.prop("indeterminate", true); 7 | input.prop("readOnly", true); 8 | input.prop('checked',true); 9 | } else if (value == "true") { 10 | input.prop('readOnly',false); 11 | input.prop('indeterminate',false); 12 | input.prop('checked',true); 13 | } else { 14 | input.prop('readOnly',true); 15 | input.prop('indeterminate',false); 16 | input.prop('checked',false); 17 | } 18 | } 19 | 20 | 21 | $.extend(indeterminateCheckbox, { 22 | find: function(scope) { 23 | return $(scope).find(".indeterminate-checkbox"); 24 | }, 25 | getValue: function(el) { 26 | var input = $(el).find("input"); 27 | 28 | /* if already setup in subscribe, give value, otherwise give initial */ 29 | if (input.data("setup")) { 30 | if (input.prop("indeterminate")) { 31 | return "indeterminate"; 32 | } else if (input.prop("checked")) { 33 | return "true"; 34 | } else { 35 | return "false"; 36 | } 37 | } else { 38 | return input.data("initial"); 39 | } 40 | }, 41 | setValue: function(el, value) { 42 | var input = $(el).find("input"); 43 | setIndeterminateCheckboxValue(input, value); 44 | }, 45 | subscribe: function(el, callback) { 46 | var input = $(el).find("input"); 47 | input.on("change", function(e) { 48 | var input = $(this); 49 | 50 | console.log("checked: ", input.prop("checked")); 51 | if (input.prop("readOnly")) { 52 | input.prop("checked", false) 53 | input.prop("readOnly", false) 54 | } else if (!input.prop("checked")) { 55 | input.prop("indeterminate", true) 56 | input.prop("readOnly", true) 57 | } 58 | 59 | callback(); 60 | }) 61 | 62 | /* set initial value */ 63 | setIndeterminateCheckboxValue(input, input.data("initial")); 64 | input.data("setup", true) 65 | }, 66 | unsubscribe: function(el) { 67 | 68 | }, 69 | getRatePolicy: function() { 70 | return { 71 | policy: "throttle", 72 | delay: 1000 73 | }; 74 | }, 75 | receiveMessage: function(el, data) { 76 | var input = $(el).find("input"); 77 | 78 | if (data.hasOwnProperty("value")) { 79 | setIndeterminateCheckboxValue(input, data["value"]) 80 | } 81 | 82 | input.trigger('change'); 83 | } 84 | }); 85 | 86 | Shiny.inputBindings.register(indeterminateCheckbox, 'shiny.indeterminateCheckbox'); -------------------------------------------------------------------------------- /inst/js/tooltips.js: -------------------------------------------------------------------------------- 1 | function activeTooltips() { 2 | $('.tooltip').remove() 3 | $('[data-toggle="tooltip"]').tooltip({container: 'body', html: true}) 4 | } -------------------------------------------------------------------------------- /man/answer_questions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/answers.R 3 | \name{answer_questions} 4 | \alias{answer_questions} 5 | \title{Provide answers to questions} 6 | \usage{ 7 | answer_questions(dataset = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{dataset}{The dynwrap dataset object from which the answers will be computed} 11 | 12 | \item{...}{Answers to questions: 13 | \itemize{ 14 | \item multiple_disconnected: Do you expect multiple disconnected trajectories in the data? defaults to \code{NULL}: 15 | \item expect_topology: Do you expect a particular topology in the data? defaults to \code{NULL}: 16 | \item expected_topology: What is the expected topology defaults to \code{NULL}: 17 | \item expect_cycles: Do you expect cycles in the data? defaults to \code{NULL}: 18 | \item expect_complex_tree: Do you expect a complex tree in the data? defaults to \code{NULL}: 19 | \item n_cells: Number of cells defaults to \code{1000}: 20 | \item n_features: Number of features (genes) defaults to \code{1000}: 21 | \item time: Time limit defaults to \verb{1h}: 22 | \item memory: Memory limit defaults to \verb{30GB}: 23 | \item prior_information: Are you able to provide the following prior information? defaults to \code{c("start_id", "end_id", "end_n", "start_n", "leaves_n", "groups_n", "features_id", "dimred")}: 24 | \item method_selection: How to select the number of methods defaults to \code{dynamic_n_methods}: 25 | \item dynamic_n_methods: Minimal probability of selecting the top model for the task defaults to \code{80}: 26 | \item fixed_n_methods: Number of methods defaults to \code{4}: 27 | \item metric_importance: How important are the following aspects of the trajectory? defaults to \code{list(correlation = 0.25, him = 0.25, featureimp_wcor = 0.25, F1_branches = 0.25)}: 28 | \item user: Are you an end-user or a method developer? defaults to \code{user}: 29 | \item dynmethods: Do you use dynmethods to run the methods? defaults to \code{TRUE}: 30 | \item docker: Is docker installed? defaults to \code{TRUE}: 31 | \item programming_interface: Can you work in a programming interface? defaults to \code{TRUE}: 32 | \item languages: Which languages can you work with? defaults to \code{c("Python", "R", "C++")}: 33 | \item user_friendliness: Minimal user friendliness score defaults to \code{60}: 34 | \item developer_friendliness: Minimal developer friendliness score defaults to \code{60}: 35 | \item exclude_datasets: Which datasets should be excluded defaults to \code{character(0)}: 36 | }} 37 | } 38 | \description{ 39 | Provide answers to questions 40 | } 41 | -------------------------------------------------------------------------------- /man/dynguidelines.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/package.R 3 | \name{dynguidelines} 4 | \alias{dynguidelines} 5 | \title{Dynguidelines packages} 6 | \description{ 7 | The dynguidelines package can be used to find the most optimal TI methods on a given dataset 8 | This can be done both directly in R or through a shiny interface. 9 | } 10 | -------------------------------------------------------------------------------- /man/figures/demo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/man/figures/demo.gif -------------------------------------------------------------------------------- /man/figures/dependencies.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/man/figures/dependencies.png -------------------------------------------------------------------------------- /man/figures/favicon.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 22 | 24 | 46 | 48 | 49 | 51 | image/svg+xml 52 | 54 | 55 | 56 | 57 | 58 | 63 | 67 | 83 | 86 | 89 | 92 | 95 | 98 | 101 | 104 | 107 | 110 | 113 | 116 | 119 | 122 | 125 | 128 | 134 | 139 | 145 | 151 | 157 | 163 | 169 | 175 | 182 | 187 | 191 | 198 | 205 | 206 | 211 | 215 | 222 | 229 | 230 | 235 | 236 | 239 | 245 | 246 | 252 | 253 | 254 | -------------------------------------------------------------------------------- /man/figures/favicon_16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/man/figures/favicon_16.png -------------------------------------------------------------------------------- /man/figures/favicon_32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/man/figures/favicon_32.png -------------------------------------------------------------------------------- /man/figures/favicon_96.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/man/figures/favicon_96.png -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/man/figures/logo.png -------------------------------------------------------------------------------- /man/figures/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 22 | 24 | 46 | 48 | 49 | 51 | image/svg+xml 52 | 54 | 55 | 56 | 57 | 58 | 63 | 69 | 73 | 89 | 92 | 95 | 98 | 101 | 104 | 107 | 110 | 113 | 116 | 119 | 122 | 125 | 128 | 131 | 134 | 140 | 145 | 151 | 157 | 163 | 169 | 175 | 181 | 188 | 193 | 197 | 204 | 211 | 212 | 217 | 221 | 228 | 235 | 236 | 241 | 242 | dynguidelines 255 | 258 | 264 | 265 | 271 | 272 | 273 | -------------------------------------------------------------------------------- /man/figures/logo_horizontal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dynverse/dynguidelines/57f2da74b28eb7a88a16de11e4c3290e6af9b950/man/figures/logo_horizontal.png -------------------------------------------------------------------------------- /man/figures/logo_horizontal.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 22 | 24 | 46 | 48 | 49 | 51 | image/svg+xml 52 | 54 | 55 | 56 | 57 | 58 | 63 | 69 | 73 | 89 | 92 | 95 | 98 | 101 | 104 | 107 | 110 | 113 | 116 | 119 | 122 | 125 | 128 | 131 | 134 | 140 | 145 | 151 | 157 | 163 | 169 | 175 | 181 | 188 | 193 | 197 | 204 | 211 | 212 | 217 | 221 | 228 | 235 | 236 | 241 | 242 | dynguidelines 255 | 258 | 264 | 265 | 271 | 272 | 273 | -------------------------------------------------------------------------------- /man/get_answers_code.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/answers.R 3 | \name{get_answers_code} 4 | \alias{get_answers_code} 5 | \title{Produces the code necessary to reproduce guidelines given a set of answers} 6 | \usage{ 7 | get_answers_code(answers = answer_questions()) 8 | } 9 | \arguments{ 10 | \item{answers}{An answers tibble as generated by \code{\link[=answer_questions]{answer_questions()}}} 11 | } 12 | \description{ 13 | Produces the code necessary to reproduce guidelines given a set of answers 14 | } 15 | -------------------------------------------------------------------------------- /man/get_questions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/questions.R 3 | \name{get_questions} 4 | \alias{get_questions} 5 | \title{Get the the questions, their modifiers and properties} 6 | \usage{ 7 | get_questions() 8 | } 9 | \description{ 10 | Get the the questions, their modifiers and properties 11 | } 12 | -------------------------------------------------------------------------------- /man/guidelines.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/guidelines.R, R/guidelines_shiny.R 3 | \name{guidelines} 4 | \alias{guidelines} 5 | \alias{guidelines_shiny} 6 | \title{Provide guidelines on which methods to use, optionally based on a given dataset} 7 | \usage{ 8 | guidelines(dataset = NULL, answers = answer_questions(dataset = dataset)) 9 | 10 | guidelines_shiny( 11 | dataset = NULL, 12 | answers = answer_questions(dataset = dataset), 13 | port = NULL, 14 | launch.browser = TRUE, 15 | host = NULL, 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{dataset}{The dynwrap dataset object from which some of the answers will be precomputed} 21 | 22 | \item{answers}{A set answers generated by \code{\link[=answer_questions]{answer_questions()}}} 23 | 24 | \item{port}{The TCP port that the application should listen on. If the 25 | \code{port} is not specified, and the \code{shiny.port} option is set (with 26 | \code{options(shiny.port = XX)}), then that port will be used. Otherwise, 27 | use a random port.} 28 | 29 | \item{launch.browser}{If true, the system's default web browser will be 30 | launched automatically after the app is started. Defaults to true in 31 | interactive sessions only. This value of this parameter can also be a 32 | function to call with the application's URL.} 33 | 34 | \item{host}{The IPv4 address that the application should listen on. Defaults 35 | to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not. See 36 | Details.} 37 | 38 | \item{...}{Other parameters given to \code{\link[shiny:runApp]{shiny::runApp()}}} 39 | } 40 | \value{ 41 | Returns a dynguidelines::guidelines object, containing 42 | \itemize{ 43 | \item \code{methods}: Ordered tibble containing information about the selected methods 44 | \item \code{method_columns}: Information about what columns in methods are given and whether the were used for filtering or ordering 45 | \item \code{methods_aggr}: Same columns as \code{methods}, but includes filtered methods 46 | \item \code{answers}: An answers tibble, can be provided again to this function to reproduce the guidelines 47 | \item \code{methods_selected}: Ids for all selected methods, can be given to \code{\link[dynwrap:infer_trajectories]{dynwrap::infer_trajectory()}} 48 | } 49 | } 50 | \description{ 51 | \code{guidelines()} immediately returns a set of guidelines. Use the \code{answers} arguments to provide answers 52 | \code{guidelines_shiny()} opens the shiny app 53 | } 54 | -------------------------------------------------------------------------------- /man/shiny_server.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/shiny_server.R 3 | \name{shiny_server} 4 | \alias{shiny_server} 5 | \title{The shiny server} 6 | \usage{ 7 | shiny_server(answers = answer_questions()) 8 | } 9 | \arguments{ 10 | \item{answers}{Previous answers other than default, see the \code{\link[=answer_questions]{answer_questions()}} function} 11 | } 12 | \description{ 13 | The shiny server 14 | } 15 | -------------------------------------------------------------------------------- /man/shiny_ui.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/shiny_ui.R 3 | \name{shiny_ui} 4 | \alias{shiny_ui} 5 | \title{Shiny user interface} 6 | \usage{ 7 | shiny_ui() 8 | } 9 | \description{ 10 | Shiny user interface 11 | } 12 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(dynguidelines) 3 | 4 | test_check("dynguidelines") 5 | -------------------------------------------------------------------------------- /tests/testthat/test-answers.R: -------------------------------------------------------------------------------- 1 | context("Testing answers") 2 | 3 | 4 | test_that("answer_questions", { 5 | answers <- answer_questions() 6 | testthat::expect_true(all(answers$source %in% c("default", "computed"))) 7 | 8 | answers <- answer_questions(multiple_disconnected = TRUE) 9 | testthat::expect_false(all(answers$source %in% c("default", "computed"))) 10 | testthat::expect_true(answers$source[answers$question_id == "multiple_disconnected"] == "adapted") 11 | }) 12 | 13 | test_that("answer_questions_docs", { 14 | answers_questions_docs <- dynguidelines:::answer_questions_docs() 15 | testthat::expect_is(answers_questions_docs, "character") 16 | }) 17 | 18 | test_that("get_answers_code", { 19 | answers <- answer_questions(multiple_disconnected = TRUE) 20 | testthat::expect_false(get_answers_code(answers) == "# Reproduces the guidelines as created in the shiny app\nanswers <- dynguidelines::answer_questions()") 21 | }) -------------------------------------------------------------------------------- /tests/testthat/test-formatters.R: -------------------------------------------------------------------------------- 1 | context("Test formatters") 2 | 3 | # test time formatters 4 | expect_equal(format_time(10), "10s") 5 | expect_equal(process_time("10s"), 10) 6 | 7 | expect_equal(format_time(0.1, min = 1), "<1s") 8 | expect_equal(format_time(10, max = 1), ">1s") 9 | 10 | expect_error(process_time("10GB")) 11 | 12 | 13 | # test memory formatters 14 | expect_equal(format_memory(10^9), "1GB") 15 | expect_equal(process_memory("1GB"), 10^9) 16 | 17 | expect_equal(format_memory(10^8, min = 10^9), "<1GB") 18 | expect_equal(format_memory(10^10, max = 10^9), ">1GB") 19 | -------------------------------------------------------------------------------- /tests/testthat/test-guidelines.R: -------------------------------------------------------------------------------- 1 | context("Testing") 2 | 3 | test_that("guidelines", { 4 | guidelines <- guidelines(answers = answer_questions()) 5 | 6 | expect_true(is(guidelines, "dynguidelines::guidelines")) 7 | expect_is(guidelines$methods_selected, "character") 8 | expect_is(guidelines$methods_aggr, "tbl") 9 | expect_is(guidelines$methods, "tbl") 10 | expect_is(guidelines$answers, "tbl") 11 | expect_is(guidelines$method_columns, "tbl") 12 | }) -------------------------------------------------------------------------------- /tests/testthat/test-guidelines_shiny.R: -------------------------------------------------------------------------------- 1 | library(shinytest) 2 | library(testthat) 3 | 4 | context("Test Shiny app") 5 | 6 | skip_on_os("windows") 7 | skip_on_os("mac") 8 | 9 | # open Shiny app and PhantomJS 10 | app <- ShinyDriver$new(system.file("deploy/server", package = "dynguidelines")) 11 | Sys.sleep(5) 12 | 13 | test_that("A methods table is returned", { 14 | app$setInputs(multiple_disconnected = "TRUE") 15 | app$setInputs(multiple_disconnected = "FALSE") 16 | app$setInputs(expect_topology = "TRUE") 17 | app$setInputs(expected_topology = "linear") 18 | app$setInputs(expect_topology = "FALSE") 19 | app$setInputs(expect_cycles = "TRUE") 20 | app$setInputs(expect_cycles = "FALSE") 21 | app$setInputs(expect_complex_tree = "FALSE") 22 | app$setInputs(expect_complex_tree = "TRUE") 23 | 24 | app$setInputs(time = "\U221E") 25 | app$setInputs(memory = "\U221E") 26 | app$setInputs(n_cells = "1") 27 | app$setInputs(n_features = "1") 28 | app$setInputs(n_cells = "10000000") 29 | app$setInputs(n_features = "10000000") 30 | 31 | app$setInputs(dynmethods = "TRUE") 32 | app$setInputs(dynmethods = "FALSE") 33 | app$setInputs(programming_interface = "TRUE") 34 | app$setInputs(languages = c("python", "R")) 35 | app$setInputs(languages = c()) 36 | app$setInputs(programming_interface = "FALSE") 37 | 38 | # test show/hide columns 39 | app$executeScript("$('a[data-target=\"#columns\"]').trigger('click')") 40 | Sys.sleep(1) 41 | 42 | # get text_out 43 | output <- app$getValue(name = "methods_table") 44 | # test 45 | expect_is(output, "character") 46 | }) 47 | 48 | # stop the Shiny app 49 | app$stop() 50 | -------------------------------------------------------------------------------- /tests/testthat/test-renderers.R: -------------------------------------------------------------------------------- 1 | context("Test renderers") 2 | 3 | renderers <- get_renderers() 4 | 5 | expect_false(any(duplicated(get_renderers()$column_id))) --------------------------------------------------------------------------------