├── LICENSE ├── inst ├── media │ ├── logo.png │ └── supreme-diagram.png └── extdata │ ├── file │ ├── module-utils.R │ ├── module-items.R │ ├── module-transactions.R │ ├── module-customers.R │ └── app.R │ └── yaml │ └── example-model.yaml ├── tests ├── testthat.R └── testthat │ ├── integration-data │ ├── server-without-session-arg.Rtest │ ├── cycle-modules.yaml │ ├── multiple-server-definition.Rtest │ ├── module-with-namespaced-fun.Rtest │ ├── without-any-calling-module.Rtest │ ├── module-output.Rtest │ └── server-exprs-elems.Rtest │ ├── test-src-print-output.R │ ├── test-checkers.R │ ├── test-example.R │ ├── test-shorten-file-path.R │ ├── test-finders.R │ ├── test-src-yaml.R │ ├── test-tabular.R │ ├── test-graph.R │ └── test-supreme-integration.R ├── man ├── figures │ └── README-supreme-graph-example-1.png ├── supreme.Rd ├── example_yaml.Rd ├── src_file.Rd ├── as.data.frame.supreme.Rd ├── example_app_path.Rd ├── src_yaml.Rd └── graph.Rd ├── .Rbuildignore ├── .gitignore ├── codecov.yml ├── NAMESPACE ├── .travis.yml ├── _pkgdown.yml ├── supreme.Rproj ├── R ├── zzz.R ├── utils.R ├── supreme.R ├── example.R ├── tabular.R ├── constructor.R ├── shorten-file-path.R ├── checkers.R ├── finders.R ├── src-methods.R └── graph.R ├── DESCRIPTION ├── appveyor.yml ├── NEWS.md └── README.md /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2019 2 | COPYRIGHT HOLDER: Metin Yazici 3 | -------------------------------------------------------------------------------- /inst/media/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/strboul/supreme/HEAD/inst/media/logo.png -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(supreme) 3 | 4 | test_check("supreme") 5 | -------------------------------------------------------------------------------- /inst/media/supreme-diagram.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/strboul/supreme/HEAD/inst/media/supreme-diagram.png -------------------------------------------------------------------------------- /man/figures/README-supreme-graph-example-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/strboul/supreme/HEAD/man/figures/README-supreme-graph-example-1.png -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^codecov\.yml$ 2 | ^appveyor\.yml$ 3 | ^\.travis\.yml$ 4 | ^README\.Rmd$ 5 | ^supreme\.Rproj$ 6 | ^\.Rproj\.user$ 7 | ^_pkgdown\.yml$ 8 | -------------------------------------------------------------------------------- /inst/extdata/file/module-utils.R: -------------------------------------------------------------------------------- 1 | 2 | module_modal_dialog <- function(input, output, session, text) { 3 | showModal(modalDialog( 4 | title = "Important message", 5 | text 6 | )) 7 | } 8 | 9 | -------------------------------------------------------------------------------- /tests/testthat/integration-data/server-without-session-arg.Rtest: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | 3 | ui <- fluidPage( 4 | 5 | ) 6 | 7 | server <- function(input, output) { 8 | 9 | } 10 | 11 | shinyApp(ui, server) 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | inst/doc 2 | .Rproj.user 3 | .Rhistory 4 | .Rapp.history 5 | .RData 6 | *-Ex.R 7 | /*.tar.gz 8 | /*.Rcheck/ 9 | .Rproj.user/ 10 | vignettes/*.html 11 | vignettes/*.pdf 12 | .httr-oauth 13 | docs/ 14 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | patch: 10 | default: 11 | target: auto 12 | threshold: 1% 13 | -------------------------------------------------------------------------------- /inst/extdata/file/module-items.R: -------------------------------------------------------------------------------- 1 | 2 | items_tab_module_ui <- function(id) { 3 | ns <- NS(id) 4 | tagList() 5 | } 6 | 7 | items_tab_module_server <- function(input, output, session, items_list, is_fired) { 8 | 9 | rv_items_list <- reactive({ 10 | if (is_fired) { 11 | 12 | } 13 | }) 14 | 15 | callModule(module_modal_dialog, NULL) 16 | 17 | } 18 | 19 | -------------------------------------------------------------------------------- /tests/testthat/test-src-print-output.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("test src_yaml print", { 3 | out <- trimws(utils::capture.output(src_yaml(example_yaml()))) 4 | expect_equal(out, "Model yaml object") 5 | }) 6 | 7 | 8 | test_that("test src_file print", { 9 | out <- trimws(utils::capture.output(src_file(example_app_path()))) 10 | expect_equal(out, "Model file object") 11 | }) 12 | 13 | -------------------------------------------------------------------------------- /tests/testthat/integration-data/cycle-modules.yaml: -------------------------------------------------------------------------------- 1 | - name: server 2 | input: 3 | - ax 4 | - by 5 | - cz 6 | output: 7 | - O1 8 | - O2 9 | return: rv 10 | calling_modules: 11 | - reusableModule: ~ 12 | 13 | - name: reusableModule 14 | input: 15 | - a 16 | - b 17 | output: 18 | - OO1 19 | - OO2 20 | - OO3 21 | return: 22 | - RV1 23 | - RV2 24 | -------------------------------------------------------------------------------- /tests/testthat/integration-data/multiple-server-definition.Rtest: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | 3 | ui <- fluidPage( 4 | p("Multiple server side functions defined!") 5 | ) 6 | 7 | server <- function(input, output, session) { 8 | output$table <- renderTable({ head(iris) }) 9 | } 10 | 11 | server <- function(input, output, session) { 12 | output$plot <- renderPlot({ plot(iris) }) 13 | } 14 | 15 | shinyApp(ui, server) 16 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(as.data.frame,supreme) 4 | S3method(print,supreme) 5 | S3method(print,supreme_src_obj) 6 | export(example_app_path) 7 | export(example_yaml) 8 | export(graph) 9 | export(src_file) 10 | export(src_yaml) 11 | export(supreme) 12 | importFrom(nomnoml,nomnoml) 13 | importFrom(stats,setNames) 14 | importFrom(yaml,yaml.load) 15 | importFrom(yaml,yaml.load_file) 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | sudo: false 5 | cache: packages 6 | 7 | before_deploy: Rscript -e 'remotes::install_cran("pkgdown")' 8 | deploy: 9 | provider: script 10 | script: Rscript -e 'pkgdown::deploy_site_github()' 11 | skip_cleanup: true 12 | 13 | r_packages: 14 | - covr 15 | 16 | after_success: 17 | - Rscript -e 'covr::codecov()' 18 | 19 | 20 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | navbar: 2 | structure: 3 | left: 4 | - home 5 | - reference 6 | - news 7 | right: 8 | - icon: fa-github fa-lg 9 | href: https://github.com/strboul/supreme 10 | components: 11 | home: 12 | icon: fa-home fa-lg 13 | href: index.html 14 | reference: 15 | text: Reference 16 | href: reference/index.html 17 | news: 18 | text: News 19 | href: news/index.html 20 | 21 | -------------------------------------------------------------------------------- /man/supreme.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/supreme.R 3 | \name{supreme} 4 | \alias{supreme} 5 | \title{Create a supreme object} 6 | \usage{ 7 | supreme(x) 8 | } 9 | \arguments{ 10 | \item{x}{a valid source input.} 11 | } 12 | \value{ 13 | a \code{supreme} object. 14 | } 15 | \description{ 16 | Create a supreme object 17 | } 18 | \examples{ 19 | path <- example_app_path() 20 | supreme(src_file(path)) 21 | } 22 | -------------------------------------------------------------------------------- /supreme.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 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 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /inst/extdata/file/module-transactions.R: -------------------------------------------------------------------------------- 1 | 2 | transactions_tab_module_ui <- function(id) { 3 | ns <- NS(id) 4 | tagList( 5 | tableOutput(ns("transactions_table")) 6 | ) 7 | } 8 | 9 | transactions_tab_module_server <- function(input, output, session, table, button_clicked) { 10 | 11 | output$transactions_table <- renderTable({ 12 | table 13 | }) 14 | 15 | transactions_keys <- reactive({ 16 | if (button_clicked) { 17 | table[["keys"]] 18 | } 19 | }) 20 | 21 | return(transactions_keys) 22 | } 23 | 24 | -------------------------------------------------------------------------------- /man/example_yaml.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/example.R 3 | \name{example_yaml} 4 | \alias{example_yaml} 5 | \title{Get YAML to supreme example} 6 | \usage{ 7 | example_yaml() 8 | } 9 | \value{ 10 | a character vector containing the YAML file path for the example. 11 | } 12 | \description{ 13 | Get YAML to supreme example 14 | } 15 | \examples{ 16 | yaml <- example_yaml() 17 | supreme(src_yaml(yaml)) 18 | } 19 | \seealso{ 20 | Other source examples: 21 | \code{\link{example_app_path}()} 22 | } 23 | \concept{source examples} 24 | -------------------------------------------------------------------------------- /inst/extdata/file/module-customers.R: -------------------------------------------------------------------------------- 1 | 2 | customers_tab_module_ui <- function(id) { 3 | ns <- NS(id) 4 | tagList( 5 | tableOutput(ns("paid_customers_table")), 6 | tableOutput(ns("free_customers_table")), 7 | br() 8 | ) 9 | } 10 | 11 | customers_tab_module_server <- function(input, output, session, customers_list) { 12 | 13 | output$paid_customers_table <- renderTable({ 14 | subset(customers_list, category == "Paid") 15 | }) 16 | 17 | output$free_customers_table <- renderTable({ 18 | subset(customers_list, category == "Free") 19 | }) 20 | 21 | } 22 | 23 | -------------------------------------------------------------------------------- /man/src_file.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/src-methods.R 3 | \name{src_file} 4 | \alias{src_file} 5 | \title{Read \R files} 6 | \usage{ 7 | src_file(x) 8 | } 9 | \arguments{ 10 | \item{x}{a file path.} 11 | } 12 | \value{ 13 | A \code{src_file} object. 14 | } 15 | \description{ 16 | Read files contain at least one Shiny application. 17 | } 18 | \examples{ 19 | paths <- example_app_path() 20 | s <- supreme(src_file(paths)) 21 | } 22 | \seealso{ 23 | Other source functions: 24 | \code{\link{src_yaml}()} 25 | } 26 | \concept{source functions} 27 | -------------------------------------------------------------------------------- /man/as.data.frame.supreme.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tabular.R 3 | \name{as.data.frame.supreme} 4 | \alias{as.data.frame.supreme} 5 | \title{Turn supreme data into a \code{data.frame}} 6 | \usage{ 7 | \method{as.data.frame}{supreme}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{a \code{supreme} object.} 11 | 12 | \item{...}{methods to be passed onto.} 13 | } 14 | \value{ 15 | a \code{data.frame}. 16 | } 17 | \description{ 18 | Turn supreme data into a \code{data.frame} 19 | } 20 | \examples{ 21 | paths <- example_app_path() 22 | sp <- supreme(src_file(paths)) 23 | as.data.frame(sp) 24 | } 25 | -------------------------------------------------------------------------------- /tests/testthat/integration-data/module-with-namespaced-fun.Rtest: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinyauthr) 3 | 4 | ui <- fluidPage() 5 | 6 | server <- function(input, output, session) { 7 | 8 | module1 <- callModule(shinyauthr::logout, 9 | id = "logout", 10 | active = reactive(credentials()$user_auth)) 11 | 12 | module2 <- callModule(shinyauthr::login, 13 | id = "login", 14 | data = user_base, 15 | user_col = user, 16 | pwd_col = password, 17 | log_out = reactive(logout_init())) 18 | 19 | } 20 | -------------------------------------------------------------------------------- /tests/testthat/test-checkers.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("is_named_list", { 3 | 4 | expect_false(is_named_list(list(1, 2))) 5 | expect_false(is_named_list(list(A = 1, 2))) 6 | 7 | expect_true(is_named_list(list(A = 1, B = 2))) 8 | expect_true(is_named_list(list(X = 1, "Y" = 2))) 9 | expect_true(is_named_list(list("X" = 1, Y = 2))) 10 | expect_true(is_named_list(list("X" = 1, "Y" = 2))) 11 | 12 | }) 13 | 14 | 15 | test_that("is_shiny_server_component", { 16 | 17 | expr <- expression({ 18 | server <- function(input, output, session) { 19 | } 20 | }) 21 | expect_true(is_shiny_server_component(expr[[1]][[2]])) 22 | 23 | expr2 <- expression({ 24 | square <- function(x) { 25 | } 26 | }) 27 | expect_false(is_shiny_server_component(expr2[[1]][[2]])) 28 | 29 | }) 30 | 31 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | 2 | #nocov start 3 | 4 | .onLoad <- function(libname, pkgname) { 5 | op <- options() 6 | op_supreme <- list( 7 | SUPREME_MODEL_REQUIRED_FIELDS = "name", 8 | SUPREME_MODEL_OPTIONAL_FIELDS = c("input", "output", "return", "calling_modules", "src"), 9 | SUPREME_MODEL_MULTI_VAR_FIELDS = c("input", "output", "return", "calling_modules"), 10 | ## graph symbols from: https://unicode.org/charts/nameslist/n_25A0.html 11 | SUPREME_GRAPH_BULLET_SYMBOLS = list("circle" = "\u25CB", 12 | "triangular" = "\u25B9", 13 | "square" = "\u25FB") 14 | ) 15 | toset <- !(names(op_supreme) %in% names(op)) 16 | if(any(toset)) options(op_supreme[toset]) 17 | 18 | invisible() 19 | } 20 | 21 | #nocov end 22 | 23 | -------------------------------------------------------------------------------- /tests/testthat/integration-data/without-any-calling-module.Rtest: -------------------------------------------------------------------------------- 1 | 2 | ## A module that doesn't have any calling modules 3 | main_table_server <- function(input, output, session, data, tbl.pageLength = 10, 4 | tbl.selection = c("none", "single", "multiple")) { 5 | tbl.selection <- match.arg(tbl.selection) 6 | rv <- reactiveValues(selected = NULL) 7 | output$tbl <- renderDataTable({ 8 | datatable(data(), style = "bootstrap", selection = list(mode = tbl.selection, 9 | selected = if (tbl.selection != "none") 1L else NULL), 10 | options = list(pageLength = tbl.pageLength)) 11 | }) 12 | observeEvent(input$tbl_rows_selected, { 13 | rv$selected <- input$tbl_rows_selected 14 | }, ignoreNULL = FALSE) 15 | return({ 16 | rv 17 | }) 18 | } 19 | 20 | -------------------------------------------------------------------------------- /man/example_app_path.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/example.R 3 | \name{example_app_path} 4 | \alias{example_app_path} 5 | \title{Get paths to supreme example} 6 | \usage{ 7 | example_app_path(file = NULL) 8 | } 9 | \arguments{ 10 | \item{file}{file names. If no file names are put (which \code{path} is \code{NULL}), then 11 | all the example file paths will be listed.} 12 | } 13 | \value{ 14 | a character vector containing the R file path for the example. 15 | } 16 | \description{ 17 | The example Shiny application to demonstrate all the capabilities of what 18 | \code{supreme} offers. 19 | } 20 | \examples{ 21 | files <- example_app_path(c("app", "module-customers")) 22 | supreme(src_file(files)) 23 | } 24 | \seealso{ 25 | Other source examples: 26 | \code{\link{example_yaml}()} 27 | } 28 | \concept{source examples} 29 | -------------------------------------------------------------------------------- /tests/testthat/test-example.R: -------------------------------------------------------------------------------- 1 | 2 | context("test-example: the examples are the equivalents") 3 | 4 | 5 | supreme_file <- supreme(src_file(example_app_path())) 6 | supreme_yaml <- supreme(src_yaml(example_yaml())) 7 | 8 | 9 | test_that("example supreme$data outputs are equivalent", { 10 | expect_equivalent(supreme_file$data, supreme_yaml$data) 11 | }) 12 | 13 | 14 | test_that("example as.data.frame outputs are equal", { 15 | expect_equal(as.data.frame(supreme_file), as.data.frame(supreme_yaml)) 16 | }) 17 | 18 | 19 | test_that("example supreme graphs are equal (test nomnoml code)", { 20 | ## set seed due to the random classifier: 21 | {set.seed(2019); graph_supreme_file <- graph(supreme_file)} 22 | {set.seed(2019); graph_supreme_yaml <- graph(supreme_yaml)} 23 | expect_equal( 24 | graph_supreme_yaml[["x"]][["code"]], 25 | graph_supreme_file[["x"]][["code"]] 26 | ) 27 | }) 28 | 29 | -------------------------------------------------------------------------------- /inst/extdata/yaml/example-model.yaml: -------------------------------------------------------------------------------- 1 | - name: server 2 | calling_modules: 3 | - items_tab_module_server: ItemsTab 4 | - customers_tab_module_server: CustomersTab 5 | - transactions_tab_module_server: TransactionsTab 6 | src: app.R 7 | 8 | - name: customers_tab_module_server 9 | input: customers_list 10 | output: 11 | - paid_customers_table 12 | - free_customers_table 13 | src: module-customers.R 14 | 15 | - name: items_tab_module_server 16 | input: 17 | - items_list 18 | - is_fired 19 | calling_modules: 20 | - module_modal_dialog: ~ 21 | src: module-items.R 22 | 23 | - name: transactions_tab_module_server 24 | input: 25 | - table 26 | - button_clicked 27 | output: transactions_table 28 | return: transactions_keys 29 | src: module-transactions.R 30 | 31 | - name: module_modal_dialog 32 | input: 33 | - text 34 | src: module-utils.R 35 | 36 | -------------------------------------------------------------------------------- /man/src_yaml.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/src-methods.R 3 | \name{src_yaml} 4 | \alias{src_yaml} 5 | \title{Read a YAML file containing a model} 6 | \usage{ 7 | src_yaml(file = NULL, text = NULL) 8 | } 9 | \arguments{ 10 | \item{file}{file path to a YAML file.} 11 | 12 | \item{text}{a YAML formatted character string.} 13 | } 14 | \value{ 15 | A \code{src_yaml} object. 16 | } 17 | \description{ 18 | Reads an object or a file in YAML format and returns a model YAML object. 19 | } 20 | \examples{ 21 | ## Read from a file: 22 | path <- example_yaml() 23 | src_yaml(path) 24 | 25 | ## Read from an (text) object: 26 | model <- " 27 | - name: childModuleA 28 | input: [input.data, reactive] 29 | src: package 30 | 31 | - name: childModuleB 32 | input: selected.model 33 | " 34 | src_yaml(text = model) 35 | } 36 | \seealso{ 37 | Other source functions: 38 | \code{\link{src_file}()} 39 | } 40 | \concept{source functions} 41 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: supreme 2 | Title: Modeling Tool for 'Shiny' Applications Developed with Modules 3 | Version: 1.1.1 4 | Authors@R: 5 | person("Metin", "Yazici", email = "name@example.com", role = c("aut", "cre", "cph")) 6 | Description: A modeling tool helping users better structure 'Shiny' 7 | applications developed with 'Shiny' modules. Users are able to: 1. Visualize 8 | relationship of modules in existing applications 2. Design new applications 9 | from scratch. 10 | License: MIT + file LICENSE 11 | URL: https://strboul.github.io/supreme/ 12 | BugReports: https://github.com/strboul/supreme/issues 13 | Depends: 14 | R (>= 3.6.0) 15 | Imports: 16 | stats, 17 | utils, 18 | yaml (>= 2.2.0), 19 | nomnoml, 20 | shiny (>= 1.5.0) 21 | Suggests: 22 | testthat (>= 2.1.0), 23 | covr, 24 | knitr, 25 | rmarkdown, 26 | digest (>= 0.6.23) 27 | Language: en-US 28 | LazyData: true 29 | Encoding: UTF-8 30 | RoxygenNote: 7.1.1 31 | Roxygen: list(markdown = TRUE) 32 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | 3 | # Download script file from GitHub 4 | init: 5 | ps: | 6 | $ErrorActionPreference = "Stop" 7 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 8 | Import-Module '..\appveyor-tool.ps1' 9 | 10 | install: 11 | ps: Bootstrap 12 | 13 | cache: 14 | - C:\RLibrary 15 | 16 | # Adapt as necessary starting from here 17 | 18 | build_script: 19 | - travis-tool.sh install_deps 20 | 21 | test_script: 22 | - travis-tool.sh run_tests 23 | 24 | on_failure: 25 | - 7z a failure.zip *.Rcheck\* 26 | - appveyor PushArtifact failure.zip 27 | 28 | artifacts: 29 | - path: '*.Rcheck\**\*.log' 30 | name: Logs 31 | 32 | - path: '*.Rcheck\**\*.out' 33 | name: Logs 34 | 35 | - path: '*.Rcheck\**\*.fail' 36 | name: Logs 37 | 38 | - path: '*.Rcheck\**\*.Rout' 39 | name: Logs 40 | 41 | - path: '\*_*.tar.gz' 42 | name: Bits 43 | 44 | - path: '\*_*.zip' 45 | name: Bits 46 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | 2 | #' ncstopf: 'N'o 'c'all stop 'f'ormat 3 | #' 4 | #' @param ... arguments to be passed to the `sprintf`. 5 | #' @param single.line remove new lines and multi-spaces in the message. 6 | #' @noRd 7 | ncstopf <- function(..., single.line = FALSE) { 8 | desc <- paste("[supreme]", sprintf(...)) 9 | if (single.line) { 10 | desc <- gsub("\\n+", "", desc) 11 | desc <- gsub("\\s+", " ", desc) 12 | } 13 | stop(desc, call. = FALSE) 14 | } 15 | 16 | 17 | #' Paste by separating new lines 18 | #' @noRd 19 | pasten <- function(...) paste(..., sep = "\n") 20 | 21 | 22 | #' Paste by separating new lines and collapsing empty string 23 | #' @noRd 24 | pastenc <- function(...) paste(..., sep = "\n", collapse = "") 25 | 26 | 27 | #' Checks if file paths exist and throws an (supreme) error unless otherwise 28 | #' 29 | #' @param x a file path. 30 | #' @noRd 31 | check_paths_exist <- function(x) { 32 | tryCatch( 33 | file.exists(as.character(x)), 34 | error = function(e) { 35 | ncstopf("cannot read file: %s", conditionMessage(e)) 36 | } 37 | ) 38 | } 39 | 40 | -------------------------------------------------------------------------------- /R/supreme.R: -------------------------------------------------------------------------------- 1 | 2 | #' Create a supreme object 3 | #' 4 | #' @param x a valid source input. 5 | #' 6 | #' @return a `supreme` object. 7 | #' @examples 8 | #' path <- example_app_path() 9 | #' supreme(src_file(path)) 10 | #' @export 11 | supreme <- function(x) { 12 | if (!is_source_object(x)) { 13 | ncstopf("the provided input cannot be turned into a supreme object") 14 | } 15 | ret <- list( 16 | data = unclass(x), 17 | source_input = class(x) 18 | ) 19 | structure(ret, class = "supreme") 20 | } 21 | 22 | 23 | #' @export 24 | print.supreme <- function(x, ...) { 25 | dta <- x[["data"]] 26 | len.dta <- length(dta) 27 | nms <- vapply(seq_along(dta), function(i) dta[[i]][["name"]], character(1)) 28 | nms.disp <- if (length(nms) > 4L) { 29 | c(nms[seq(4L)], "...") 30 | } else { 31 | nms 32 | } 33 | cat( 34 | paste( 35 | "A supreme model object", 36 | paste0( 37 | len.dta, 38 | if (len.dta > 1) " entities" else " entity", 39 | ": ", 40 | paste(nms.disp, sep = "", collapse = ", ") 41 | ), 42 | sep = "\n" 43 | ), 44 | "\n" 45 | ) 46 | invisible(NULL) 47 | } 48 | 49 | 50 | is_supreme <- function(x) { 51 | inherits(x, "supreme") 52 | } 53 | 54 | 55 | is_source_object <- function(x) { 56 | inherits(x, "supreme_src_obj") 57 | } 58 | 59 | -------------------------------------------------------------------------------- /R/example.R: -------------------------------------------------------------------------------- 1 | #' Get paths to supreme example 2 | #' 3 | #' The example Shiny application to demonstrate all the capabilities of what 4 | #' `supreme` offers. 5 | #' 6 | #' @param file file names. If no file names are put (which `path` is `NULL`), then 7 | #' all the example file paths will be listed. 8 | #' 9 | #' @return a character vector containing the R file path for the example. 10 | #' @examples 11 | #' files <- example_app_path(c("app", "module-customers")) 12 | #' supreme(src_file(files)) 13 | #' @family source examples 14 | #' @export 15 | example_app_path <- function(file = NULL) { 16 | pat <- file.path("extdata", "file") 17 | pkg <- system_file(pat) 18 | files <- list.files(pkg, pattern = "\\.R$", full.names = TRUE) 19 | if (is.null(file)) { 20 | files 21 | } else { 22 | files[grep(file, files)] 23 | } 24 | } 25 | 26 | 27 | #' Get YAML to supreme example 28 | #' 29 | #' @return a character vector containing the YAML file path for the example. 30 | #' @examples 31 | #' yaml <- example_yaml() 32 | #' supreme(src_yaml(yaml)) 33 | #' @family source examples 34 | #' @export 35 | example_yaml <- function() { 36 | pat_file <- file.path("extdata", "yaml", "example-model.yaml") 37 | yaml <- system_file(pat_file) 38 | yaml 39 | } 40 | 41 | system_file <- function(pat) { 42 | system.file(pat, package = "supreme", mustWork = TRUE) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # supreme 1.1.1 (2021-06-05) 2 | 3 | + Add a warning note in the README that supreme isn't compatible with the new 4 | `moduleServer` syntax. 5 | 6 | # supreme 1.1.0 (2020-07-05) 7 | 8 | + Preparation for [CRAN](https://cran.r-project.org/package=supreme). 9 | 10 | 11 | # supreme 1.0.0 (2019-12-25) 12 | 13 | + Refactored the `find_*` calls 14 | 15 | + Improved graph facility: introduced shapes for different fields e.g. input, output, 16 | return 17 | 18 | + Made graphing more customizable: allowed to choose fields, styles etc. 19 | 20 | + Removed some `src_*` calls (kept only `src_yaml()` and `src_file()`) because they 21 | were too expensive to maintain given the scope of the project 22 | 23 | + Added new unit & integration tests; increased the overall code coverage 24 | 25 | + Improved the modeling language 26 | 27 | 28 | # supreme 0.2.1 29 | 30 | + Make the exported variables in `R/globals.R` options placed in `R/zzz.R`. 31 | 32 | 33 | # supreme 0.2.0 (2019-08-07) 34 | 35 | + Create example functions in the API for demonstration purposes, e.g. 36 | `example_app_path()`. 37 | 38 | + Use [nomnoml](https://cran.r-project.org/package=nomnoml) package for the `graph()` 39 | facility. 40 | 41 | + Implement reading functions for files (`src_file()`), packages (`src_pkg()`), 42 | environments (`src_env()`), expressions (`src_expr()`) and YAML objects 43 | (`src_yaml()`). 44 | 45 | 46 | # supreme 0.1.0 (2019-02-06) 47 | 48 | + Added a `NEWS.md` file to track changes to the package. 49 | 50 | + Package creation and initial work. 51 | 52 | -------------------------------------------------------------------------------- /R/tabular.R: -------------------------------------------------------------------------------- 1 | 2 | #' Turn supreme data into a `data.frame` 3 | #' 4 | #' @param x a `supreme` object. 5 | #' @param ... methods to be passed onto. 6 | #' @return a `data.frame`. 7 | #' @examples 8 | #' paths <- example_app_path() 9 | #' sp <- supreme(src_file(paths)) 10 | #' as.data.frame(sp) 11 | #' @export 12 | as.data.frame.supreme <- function(x, ...) { 13 | supreme_to_df(x[["data"]]) 14 | } 15 | 16 | 17 | supreme_to_df <- function(x) { 18 | 19 | req_fields <- getOption("SUPREME_MODEL_REQUIRED_FIELDS") 20 | opt_fields <- getOption("SUPREME_MODEL_OPTIONAL_FIELDS") 21 | multi_fields <- getOption("SUPREME_MODEL_MULTI_VAR_FIELDS") 22 | all_fields <- c(req_fields, opt_fields) 23 | 24 | full.tbl <- do.call(rbind, lapply(seq_along(x), function(xi) { 25 | 26 | mod <- x[[xi]] 27 | 28 | entity <- do.call(cbind, lapply(seq_along(all_fields), function(u) { 29 | 30 | field <- all_fields[[u]] 31 | value <- mod[[field]] 32 | 33 | if (is.null(value)) { 34 | value <- NA_character_ 35 | } 36 | 37 | if (length(value) > 1L) { 38 | value <- list(value) 39 | } 40 | if (!field %in% names(mod)) { 41 | value <- NA_character_ 42 | } 43 | 44 | tbl <- if (length(value) > 0L && field %in% multi_fields) { 45 | if (identical(field, "calling_modules") && is.null(unlist(value))) { 46 | data.frame(I(list(value)), stringsAsFactors = FALSE) 47 | } else { 48 | data.frame(I(value), stringsAsFactors = FALSE) 49 | } 50 | } else { 51 | data.frame(value, stringsAsFactors = FALSE) 52 | } 53 | 54 | names(tbl) <- field 55 | 56 | tbl 57 | })) 58 | entity 59 | })) 60 | full.tbl 61 | } 62 | 63 | -------------------------------------------------------------------------------- /tests/testthat/integration-data/module-output.Rtest: -------------------------------------------------------------------------------- 1 | 2 | ## This example is taken from: 3 | ## https://github.com/rstudio/shiny-examples/tree/master/108-module-output 4 | 5 | library(shiny) 6 | library(ggplot2) 7 | 8 | linkedScatterUI <- function(id) { 9 | ns <- NS(id) 10 | 11 | fluidRow( 12 | column(6, plotOutput(ns("plot1"), brush = ns("brush"))), 13 | column(6, plotOutput(ns("plot2"), brush = ns("brush"))) 14 | ) 15 | } 16 | 17 | linkedScatter <- function(input, output, session, data, left, right) { 18 | # Yields the data frame with an additional column "selected_" 19 | # that indicates whether that observation is brushed 20 | dataWithSelection <- reactive({ 21 | brushedPoints(data(), input$brush, allRows = TRUE) 22 | }) 23 | 24 | output$plot1 <- renderPlot({ 25 | scatterPlot(dataWithSelection(), left()) 26 | }) 27 | 28 | output$plot2 <- renderPlot({ 29 | scatterPlot(dataWithSelection(), right()) 30 | }) 31 | 32 | return(dataWithSelection) 33 | } 34 | 35 | scatterPlot <- function(data, cols) { 36 | ggplot(data, aes_string(x = cols[1], y = cols[2])) + 37 | geom_point(aes(color = selected_)) + 38 | scale_color_manual(values = c("black", "#66D65C"), guide = FALSE) 39 | } 40 | 41 | ui <- fixedPage( 42 | h2("Module example"), 43 | linkedScatterUI("scatters"), 44 | textOutput("summary") 45 | ) 46 | 47 | server <- function(input, output, session) { 48 | df <- callModule(linkedScatter, "scatters", reactive(mpg), 49 | left = reactive(c("cty", "hwy")), 50 | right = reactive(c("drv", "hwy")) 51 | ) 52 | 53 | output$summary <- renderText({ 54 | sprintf("%d observation(s) selected", nrow(dplyr::filter(df(), selected_))) 55 | }) 56 | } 57 | 58 | shinyApp(ui, server) 59 | 60 | -------------------------------------------------------------------------------- /tests/testthat/integration-data/server-exprs-elems.Rtest: -------------------------------------------------------------------------------- 1 | 2 | library(shiny) 3 | 4 | data <- mtcars 5 | 6 | ui <- fluidPage( 7 | titlePanel("Module test application 1"), 8 | hr(), 9 | ConditionalItemsUI("ConditionalItems"), 10 | hr(), 11 | ObservedPanelUI("ObservedPanel"), 12 | hr(), 13 | SomeTabUI("SomeTab"), 14 | hr(), 15 | BarPlotPanelUI("BarPlotPanel"), 16 | hr(), 17 | CustomerListPanelUI("CustomerListPanel"), 18 | br() 19 | ) 20 | 21 | server <- function(input, output, session) { 22 | 23 | ## `callModule` in the server 24 | callModule(module = SomeTabServer, id = "SomeTab") 25 | 26 | ## `callModule` in the server without argument names: 27 | callModule(BarPlotPanelServer, "BarPlotPanel") 28 | 29 | ## `callModule` in the server with different ordered argument names: 30 | callModule(id = "CustomerListPanel", module = CustomerListPanelServer) 31 | 32 | ## `callModule` inside `observe()` call 33 | observe(callModule(module = ObservedPanelServer, id = "ObservedPanel")) 34 | 35 | ## `callModule` inside `observe()` call wrapped between curly braces 36 | observe({ 37 | req(someImportantData()) 38 | callModule(module = ConditionalItemsServer, id = "ConditionalItems") 39 | }) 40 | 41 | ## `callModule` inside `observe()` inside `reactive()` call where all calls are 42 | ## wrapped between curly braces 43 | react <- reactive({ 44 | req(someImportantData()) 45 | items1 <- callModule( 46 | module = ConditionalConditionalItems1Server, 47 | id = "ConditionalConditionalItems1" 48 | ) 49 | observe({ 50 | req(otherImportantData()) 51 | callModule( 52 | module = ConditionalConditionalItems2Server, 53 | id = "ConditionalConditionalItems2" 54 | ) 55 | }) 56 | }) 57 | 58 | ## `callModule` assigned to a variable: 59 | button <- callModule(id = "DetailsButton", module = DetailsButtonServer) 60 | 61 | ## an assigned constant variable: 62 | a <- 2L 63 | 64 | } 65 | 66 | shinyApp(ui, server) 67 | 68 | -------------------------------------------------------------------------------- /inst/extdata/file/app.R: -------------------------------------------------------------------------------- 1 | 2 | library(shiny) 3 | 4 | sapply(list.files(pattern = "^module", full.names = TRUE), source) 5 | 6 | ui <- fluidPage( 7 | titlePanel("Best clothes dashboard"), 8 | tabsetPanel(id = "tabs", 9 | tabPanel(title = "Items", 10 | value = "ItemsTab", 11 | items_tab_module_ui("ItemsTab") 12 | ), 13 | tabPanel(title = "Customers", 14 | value = "CustomersTab", 15 | customers_tab_module_ui("CustomersTab") 16 | ), 17 | tabPanel(title = "Transactions", 18 | value = "TransactionsTab", 19 | transactions_tab_module_ui("TransactionsTab") 20 | ), 21 | tabPanel(title = "About", 22 | value = "AboutTab", 23 | br(), 24 | paste("This is a purely fictional corporation.", 25 | "All the data displayed here is totally fake.") 26 | ) 27 | ) 28 | ) 29 | 30 | server <- function(input, output, session) { # some comment 31 | 32 | customers_data <- data.frame( 33 | id = seq(1e3), 34 | category = sample(c("Free", "Paid"), 1e3, replace = TRUE, prob = c(0.75, 0.25)), 35 | value = rnorm(1e3, 25, 20), 36 | stringsAsFactors = FALSE 37 | ) 38 | 39 | items_data <- data.frame(no = seq(1e2)) 40 | 41 | transactions_data <- data.frame(keys = seq(1e3), value = rnorm(1e3, 25, 20)) 42 | 43 | callModule(module = items_tab_module_server, id = "ItemsTab", 44 | items_list = items_data, 45 | is_fired = TRUE) 46 | callModule(customers_tab_module_server, "CustomersTab", customers_list = customers_data) 47 | ## explanatory comment.. 48 | callModule(id = "TransactionsTab", module = transactions_tab_module_server, 49 | table = transactions_data, 50 | button_clicked = TRUE) 51 | 52 | } 53 | 54 | shinyApp(ui, server) # comment1 55 | 56 | # a comment at the end of the file 57 | 58 | -------------------------------------------------------------------------------- /tests/testthat/test-shorten-file-path.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("can uniquely shorten relative file paths", { 3 | 4 | all_unique <- c( 5 | file.path("a", "b", "c"), 6 | file.path("x", "y", "z") 7 | ) 8 | expect_equal( 9 | shorten_src_file_path(all_unique), 10 | c("c", "z") 11 | ) 12 | 13 | ## two duplicated: 14 | dup2 <- c( 15 | file.path("a", "b", "c", "d"), 16 | file.path("x1", "x2", "c", "d"), 17 | file.path("k") 18 | ) 19 | expect_equal( 20 | shorten_src_file_path(dup2), 21 | c("b/c/d", "x2/c/d", "k") 22 | ) 23 | 24 | dup_long_short_paths <- c( 25 | file.path("x", "y", "z", "a", "b"), 26 | file.path("z", "a", "b"), 27 | file.path("a", "b") 28 | ) 29 | expect_equal( 30 | shorten_src_file_path(dup_long_short_paths), 31 | c("y/z/a/b", "z/a/b", "a/b") 32 | ) 33 | 34 | dup_long_short_paths2 <- c( 35 | file.path("h1", "h2", "z", "a", "b"), 36 | file.path("p", "a", "b"), 37 | file.path("t"), 38 | file.path("1", "2", "3") 39 | ) 40 | expect_equal( 41 | shorten_src_file_path(dup_long_short_paths2), 42 | c("z/a/b", "p/a/b", "t", "3") 43 | ) 44 | 45 | multiple_dups <- c( 46 | file.path("h", "x", "y", "z"), 47 | file.path("p", "y", "z"), 48 | file.path("z"), 49 | file.path("C", "B", "A"), 50 | file.path("D", "C", "B", "A"), 51 | file.path("1", "2", "3") 52 | ) 53 | expect_equal( 54 | shorten_src_file_path(multiple_dups), 55 | c("x/y/z", "p/y/z", "z", "D/C/B/A", "C/B/A", "3") 56 | ) 57 | 58 | ## no unique: 59 | none_uniq <- c( 60 | file.path("x", "y", "z"), 61 | file.path("x", "y", "z") 62 | ) 63 | expect_error( 64 | shorten_src_file_path(none_uniq), 65 | regexp = "[supreme] the following src path(s) not unique: 'x/y/z'", 66 | fixed = TRUE 67 | ) 68 | 69 | none_uniq2 <- c( 70 | file.path("x", "y", "z"), 71 | file.path("x", "y", "z"), 72 | file.path("a", "b", "c"), 73 | file.path("a", "b", "c"), 74 | file.path("1001") 75 | ) 76 | expect_error( 77 | shorten_src_file_path(none_uniq2), 78 | regexp = "[supreme] the following src path(s) not unique: 'x/y/z', 'a/b/c'", 79 | fixed = TRUE 80 | ) 81 | 82 | }) 83 | 84 | -------------------------------------------------------------------------------- /man/graph.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/graph.R 3 | \name{graph} 4 | \alias{graph} 5 | \title{Make a UML graph of Shiny modules} 6 | \usage{ 7 | graph(x, fields = NULL, styles = NULL, options = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{a \code{supreme} object.} 11 | 12 | \item{fields}{optional. name of the fields to include in the graph. The 13 | possible values can be found at \code{getOption("SUPREME_MODEL_REQUIRED_FIELDS")} 14 | and \code{getOption("SUPREME_MODEL_OPTIONAL_FIELDS")}. By default, the required 15 | fields such as the "name" field always visible. There are no ways to 16 | exclude the required fields. This parameter is set to \code{NULL} as default.} 17 | 18 | \item{styles}{optional. a named list to apply custom styles on the graph 19 | nodes. A full list of the available styles can be seen from: 20 | \href{https://github.com/skanaar/nomnoml#custom-classifier-styles}{nomnoml: Custom classifier styles}} 21 | 22 | \item{options}{optional. custom options for the whole graph. A full list 23 | of the available options can be seen from: 24 | \href{https://github.com/skanaar/nomnoml#directives}{nomnoml: Directives}} 25 | } 26 | \value{ 27 | a \code{supreme} graph. 28 | } 29 | \description{ 30 | Creates a \emph{UML-like} graph from your 'Shiny application' developed with modules. 31 | } 32 | \details{ 33 | The graph call uses the \code{nomnoml} tool to draw a UML diagram of the Shiny 34 | application. 35 | } 36 | \examples{ 37 | # create a graph: 38 | path <- example_yaml() 39 | sp <- supreme(src_yaml(path)) 40 | graph(sp) 41 | 42 | # filter fields, only return the certain fields in the graph entities: 43 | graph(sp, fields = c("input", "return")) 44 | 45 | # style entites: 46 | graph(sp, styles = list( 47 | "server" = list(fill = "#ff0", "underline", "bold"), 48 | "module_modal_dialog" = list(fill = "lightblue", "dashed", visual = "note") 49 | )) 50 | 51 | # style entities having a word "tab" in it: 52 | sp_df <- as.data.frame(sp) # turn supreme object to data.frame 53 | tab_modules <- sp_df$name[grep("_tab_", sp_df$name)] 54 | styles <- lapply(seq_along(tab_modules), function(x) list(fill = "orange")) 55 | names(styles) <- tab_modules 56 | graph(sp, styles = styles) 57 | 58 | # set graph options: 59 | graph(sp, options = list( 60 | direction = "right", 61 | fontSize = 10, 62 | title = "Model application" 63 | )) 64 | } 65 | \references{ 66 | \href{https://github.com/skanaar/nomnoml}{nomnoml: The sassy UML diagram renderer} 67 | } 68 | -------------------------------------------------------------------------------- /R/constructor.R: -------------------------------------------------------------------------------- 1 | 2 | #' The main constructor call for all `module entities` 3 | #' 4 | #' @description 5 | #' Parses language objects from `module entities`. 6 | #' 7 | #' @param x a list storing module entities. 8 | #' 9 | #' @noRd 10 | entity_constructor <- function(x) { 11 | 12 | stopifnot(is_supreme_module_entities(x)) 13 | 14 | res <- list() 15 | for (i in seq_along(x)) { 16 | 17 | entity <- x[[i]] 18 | src <- entity[["src"]] 19 | entity_body <- entity[["body"]][[1]] 20 | which_components <- which(vapply(entity_body, is_shiny_server_component, logical(1))) 21 | 22 | for (c in which_components) { 23 | 24 | fun_block <- entity_body[[c]] 25 | 26 | name <- find_binding_name(fun_block) 27 | 28 | inputs <- find_inputs(fun_block) 29 | ## exclude the compulsory Shiny input fields: 30 | inputs <- setdiff(inputs, c("input", "output", "session")) 31 | 32 | outputs <- find_outputs(fun_block) 33 | returns <- find_returns(fun_block) 34 | calling_modules <- find_calling_modules(fun_block) 35 | 36 | ## Add fields: 37 | out <- list(name = name) 38 | if (length(inputs) > 0L) { 39 | out <- c(out, list(input = inputs)) 40 | } 41 | if (length(outputs) > 0L) { 42 | out <- c(out, list(output = outputs)) 43 | } 44 | if (length(returns) > 0L) { 45 | out <- c(out, list(return = returns)) 46 | } 47 | if (length(calling_modules) > 0L) { 48 | out <- c(out, list(calling_modules = calling_modules)) 49 | } 50 | if (length(src) > 0L) { 51 | out <- c(out, list(src = src)) 52 | } 53 | 54 | ## assign to result: 55 | res[[length(res) + 1L]] <- out 56 | } 57 | } 58 | res <- structure(res, class = "supreme_entity_constructor") 59 | check_duplicate_module_names(res) 60 | res 61 | } 62 | 63 | 64 | check_duplicate_module_names <- function(x) { 65 | stopifnot(is_supreme_entity_constructor(x)) 66 | ## sapply->vapply failed because sometimes names are NULL 67 | mod_names <- sapply(x, `[[`, "name") 68 | if (anyDuplicated(mod_names) > 0) { 69 | ncstopf( 70 | "duplicated module names in the source: %s", 71 | paste( 72 | paste0("'", 73 | unique(mod_names[duplicated(mod_names)]), 74 | "'"), 75 | collapse = ", ") 76 | ) 77 | } 78 | } 79 | 80 | 81 | is_supreme_entity_constructor <- function(x) { 82 | is_list(x) && inherits(x, "supreme_entity_constructor") 83 | } 84 | 85 | 86 | is_supreme_module_entities <- function(x) { 87 | is_list(x) && inherits(x, "supreme_module_entities") 88 | } 89 | 90 | -------------------------------------------------------------------------------- /R/shorten-file-path.R: -------------------------------------------------------------------------------- 1 | 2 | #' Shorten src file paths 3 | #' 4 | #' This call "creates unique relative file paths" from full (absolute) file paths. 5 | #' 6 | #' @param x file paths as character. 7 | #' @details 8 | #' The file paths specified in the `src` field in any `supreme` or `supreme` related 9 | #' object will be shorter so that any long paths in `src` fields will not clutter the 10 | #' tables and graphs. 11 | #' 12 | #' This call behaves smarter when picking the base name from the file paths. If the 13 | #' total src file names have duplicated base names (but unique must be in essence), 14 | #' the call will walk through the previous names in the parent, and will include the 15 | #' parent directories until that those paths become unique. 16 | #' 17 | #' If they are more than one identical absolute paths, that function will throw an 18 | #' error. 19 | #' @noRd 20 | shorten_src_file_path <- function(x) { 21 | if (!is.character(x)) x <- as.character(x) 22 | if (anyDuplicated(x) > 0L) { 23 | ncstopf( 24 | "the following src path(s) not unique: %s", 25 | paste( 26 | paste0("'", x[duplicated(x)], "'"), 27 | collapse = ", " 28 | ) 29 | ) 30 | } 31 | .make_unique_relative_path <- function(x, current, stack, N) { 32 | if (anyDuplicated(current) > 0L) { 33 | prev <- sapply(x, function(s) { 34 | len <- length(s) 35 | if (len > N) s[[len - N]] else NA_character_ 36 | }) 37 | prev.valid <- prev[!is.na(prev)] 38 | compound <- file.path(prev.valid, current[seq_along(prev.valid)]) 39 | terminal <- current[is.na(prev)] 40 | if (length(terminal) > 0) { 41 | if (any(!is.na(terminal))) { 42 | terminal.non.na <- terminal[!is.na(terminal)] 43 | stack <- c(terminal.non.na, stack) 44 | } 45 | } 46 | N <- N + 1L 47 | Recall(x, compound, stack, N) 48 | } else { 49 | stack <- c(current, stack) 50 | stack 51 | } 52 | } 53 | out <- vector("character") 54 | bases <- basename(x) 55 | bases.unique_dups <- unique(bases[duplicated(bases)]) 56 | if (length(bases.unique_dups) > 0L) { 57 | traversed <- sapply(bases.unique_dups, function(uniq) { 58 | uniq.inds <- bases %in% uniq 59 | uniq.taken <- x[uniq.inds] 60 | splitted <- strsplit(uniq.taken, split = .Platform[["file.sep"]]) 61 | .make_unique_relative_path(splitted, bases[uniq.inds], vector("character"), 1L) 62 | }, USE.NAMES = FALSE) 63 | out <- c(out, unlist(traversed)) 64 | } 65 | uniques <- bases[!bases %in% bases.unique_dups] 66 | out <- c(out, uniques) 67 | ## just to be sure if everything is unique and same size: 68 | stopifnot(identical(anyDuplicated(out), 0L)) 69 | stopifnot(identical(length(out), length(x))) 70 | out 71 | } 72 | 73 | -------------------------------------------------------------------------------- /R/checkers.R: -------------------------------------------------------------------------------- 1 | 2 | #' Object checkers 3 | #' 4 | #' @param x a valid \R object. 5 | #' @name objcheck 6 | #' @noRd 7 | NULL 8 | 9 | 10 | #' Check if an object is a list (but not a data.frame) 11 | #' 12 | #' @rdname objcheck 13 | #' @noRd 14 | is_list <- function(x) { 15 | is.list(x) && !is.data.frame(x) 16 | } 17 | 18 | 19 | #' Checks whether a list is named 20 | #' 21 | #' @param x a list object. 22 | #' @rdname objcheck 23 | #' @noRd 24 | is_named_list <- function(x) { 25 | stopifnot(is_list(x)) 26 | !(is.null(names(x)) || any(names(x) == "")) 27 | } 28 | 29 | 30 | #' Symbol checkers 31 | #' 32 | #' @param x a valid \R expression. 33 | #' @name objsymcheck 34 | #' @noRd 35 | NULL 36 | 37 | 38 | #' @rdname objsymcheck 39 | #' @noRd 40 | is_left_assign_sym <- function(x) { 41 | is.symbol(x) && identical(x, quote(`<-`)) 42 | } 43 | 44 | 45 | #' @rdname objsymcheck 46 | #' @noRd 47 | is_expr_sym <- function(x) { 48 | is.symbol(x) && identical(x, quote(`{`)) 49 | } 50 | 51 | 52 | #' @rdname objsymcheck 53 | #' @noRd 54 | is_dollar_sym <- function(x) { 55 | is.symbol(x) && identical(x, quote(`$`)) 56 | } 57 | 58 | 59 | #' @rdname objsymcheck 60 | #' @noRd 61 | is_double_bracket_sym <- function(x) { 62 | is.symbol(x) && identical(x, quote(`[[`)) 63 | } 64 | 65 | 66 | #' @rdname objsymcheck 67 | #' @noRd 68 | is_func_sym <- function(x) { 69 | is.symbol(x) && identical(x, quote(`function`)) 70 | } 71 | 72 | 73 | #' @rdname objsymcheck 74 | #' @noRd 75 | is_callModule_sym <- function(x) { 76 | is_callModule_exist_in_shiny() 77 | is.symbol(x) && identical(x, quote(`callModule`)) 78 | } 79 | 80 | 81 | #' @rdname objsymcheck 82 | #' @noRd 83 | is_output_sym <- function(x) { 84 | is.symbol(x) && identical(x, quote(`output`)) 85 | } 86 | 87 | 88 | #' @rdname objsymcheck 89 | #' @noRd 90 | is_return_sym <- function(x) { 91 | is.symbol(x) && identical(x, quote(`return`)) 92 | } 93 | 94 | 95 | #' Shiny expression checkers 96 | #' 97 | #' @param x a valid \R expression, a Shiny function body. 98 | #' @name shinyexprcheck 99 | #' @noRd 100 | NULL 101 | 102 | 103 | #' @rdname shinyexprcheck 104 | #' @noRd 105 | is_shiny_server_component <- function(x) { 106 | if (is.language(x) || is.function(x)) { 107 | fun_formals <- find_inputs(x) 108 | } else { 109 | return(FALSE) 110 | } 111 | shiny_compulsory_formals <- c("input", "output", "session") 112 | all(shiny_compulsory_formals %in% fun_formals) 113 | } 114 | 115 | #' Checks if `shiny::callModule` function exists (and exported) in Shiny package 116 | #' @noRd 117 | is_callModule_exist_in_shiny <- function() { 118 | has_callmodule <- exists("callModule", where = asNamespace("shiny"), mode = "function") 119 | if (!has_callmodule) { 120 | ncstopf( 121 | "your 'Shiny' version (%s) doesn't seem to have `callModule` function.", 122 | utils::packageVersion("shiny") 123 | ) 124 | } 125 | } 126 | 127 | -------------------------------------------------------------------------------- /tests/testthat/test-finders.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("find_binding_name", { 3 | 4 | example1 <- expression({ 5 | moduleServer <- function(input, output, session) { 6 | } 7 | }) 8 | expect_equal(find_binding_name(example1[[1]]), "moduleServer") 9 | 10 | }) 11 | 12 | 13 | test_that("find_inputs", { 14 | 15 | example1 <- expression({ 16 | someModule <- function(input, output, session, data, button) { 17 | } 18 | }) 19 | expect_equal( 20 | find_inputs(example1[[1]]), 21 | c("input", "output", "session", "data", "button") 22 | ) 23 | 24 | example2 <- expression({ 25 | rnorm100 <- function(x) { 26 | val <- x * 100 27 | rnorm(val) 28 | } 29 | }) 30 | expect_equal(find_inputs(example2[[1]]), "x") 31 | 32 | example3 <- expression({ 33 | funWithoutInput <- function() { 34 | rnorm(1) 35 | } 36 | }) 37 | expect_null(find_inputs(example3[[1]])) 38 | 39 | }) 40 | 41 | 42 | test_that("find_outputs", { 43 | 44 | example1 <- expression({ 45 | tableDisplayModule <- function(input, output, session) { 46 | output$tbl <- renderTable({}) 47 | output$controllers <- renderUI({}) 48 | } 49 | }) 50 | expect_equal(find_outputs(example1[[1]]), c("tbl", "controllers")) 51 | 52 | example2 <- expression({ 53 | outputWithBrackets <- function(input, output, session) { 54 | output[["tbl"]] <- renderTable({}) 55 | output[["controllers"]] <- renderUI({}) 56 | } 57 | }) 58 | expect_equal(find_outputs(example2[[1]]), c("tbl", "controllers")) 59 | 60 | example3 <- expression({ 61 | outputInsideExprs <- function(input, output, session) { 62 | if (pass) { 63 | if (cond) { 64 | output$Table <- renderTable({}) 65 | } else { 66 | output[["Controllers"]] <- renderUI({}) 67 | } 68 | } 69 | } 70 | }) 71 | expect_equal(find_outputs(example3[[1]]), c("Table", "Controllers")) 72 | 73 | }) 74 | 75 | 76 | test_that("find_returns", { 77 | 78 | example1 <- expression({ 79 | sampleModule <- function(input, output, session) { 80 | out <- rnorm(100) 81 | return(out) 82 | } 83 | }) 84 | expect_equal(find_returns(example1[[1]]), "out") 85 | 86 | example2 <- expression({ 87 | doubleReturnModule <- function(input, output, session) { 88 | if (flag) { 89 | return("Even") 90 | } else if (!flag) { 91 | return("Odd") 92 | } else { 93 | return(NULL) 94 | } 95 | } 96 | }) 97 | expect_equal(find_returns(example2[[1]]), c("Even", "Odd", "NULL")) 98 | 99 | example3 <- expression({ 100 | noExplicitReturnModule <- function(input, output, session) { 101 | x ^ 2 102 | } 103 | }) 104 | expect_null(find_returns(example3[[1]])) 105 | 106 | example4 <- expression({ 107 | returnValuesInCurlyBraces <- function(input, output, session, flag_value) { 108 | if (flag_value) { 109 | table <- reactive({1}) 110 | return({ table }) 111 | } else if (!flag_value) { 112 | plot <- reactive({2}) 113 | return({ plot }) 114 | } else { 115 | return(other) 116 | } 117 | } 118 | }) 119 | expect_equal(find_returns(example4[[1]]), c("table", "plot", "other")) 120 | 121 | }) 122 | 123 | 124 | test_that("find_calling_modules", { 125 | 126 | example1 <- expression({ 127 | moduleA <- function(input, output, session, data) { 128 | observe({ 129 | req(data()) 130 | callModule(childModule1Server, "childModule1UI") 131 | }) 132 | callModule(childModule2Server, "childModule2UI") 133 | } 134 | 135 | moduleB <- function(input, output, session) { 136 | callModule(someModule, "someModuleUI") 137 | } 138 | 139 | emptyModuleFunction <- function(input, output, session) { 140 | } 141 | 142 | moduleWithoutAnyCallingModules <- function(input, output, session) { 143 | meann <- data.frame(mean = tapply(iris$Sepal.Length, iris$Species, mean)) 144 | output$tbl <- renderTable({ 145 | meann 146 | }) 147 | } 148 | 149 | normalFunction <- function(x) x + 2 150 | }) 151 | 152 | expect_equal( 153 | find_calling_modules(example1[[1]]), 154 | list( 155 | list(childModule1Server = "childModule1UI"), 156 | list(childModule2Server = "childModule2UI"), 157 | list(someModule = "someModuleUI") 158 | ) 159 | ) 160 | 161 | example2 <- expression({ 162 | moduleWithoutUIPart <- function(input, output, session) { 163 | callModule(moduleServer, NULL) 164 | } 165 | }) 166 | 167 | expect_equal( 168 | find_calling_modules(example2[[1]]), 169 | list( 170 | list(moduleServer = NULL) 171 | ) 172 | ) 173 | 174 | }) 175 | 176 | -------------------------------------------------------------------------------- /tests/testthat/test-src-yaml.R: -------------------------------------------------------------------------------- 1 | 2 | example_model <- example_yaml() 3 | 4 | str_model <- " 5 | - name: childModuleA 6 | input: [input.data, reactive] 7 | calling_modules: 8 | - grandChildModule1: 9 | - grandChildModule1UI 10 | " 11 | 12 | test_that("src_yaml", { 13 | 14 | expect_equal(src_yaml(example_model), 15 | structure( 16 | list( 17 | list( 18 | name = "server", 19 | calling_modules = list( 20 | list(items_tab_module_server = "ItemsTab"), 21 | list(customers_tab_module_server = "CustomersTab"), 22 | list(transactions_tab_module_server = "TransactionsTab") 23 | ), 24 | src = "app.R" 25 | ), 26 | list( 27 | name = "customers_tab_module_server", 28 | input = "customers_list", 29 | output = c("paid_customers_table", 30 | "free_customers_table"), 31 | src = "module-customers.R" 32 | ), 33 | list( 34 | name = "items_tab_module_server", 35 | input = c("items_list", 36 | "is_fired"), 37 | calling_modules = list(list(module_modal_dialog = NULL)), 38 | src = "module-items.R" 39 | ), 40 | list( 41 | name = "transactions_tab_module_server", 42 | input = c("table", "button_clicked"), 43 | output = "transactions_table", 44 | return = "transactions_keys", 45 | src = "module-transactions.R" 46 | ), 47 | list(name = "module_modal_dialog", input = "text", src = "module-utils.R") 48 | ), 49 | class = c("supreme_src_obj", 50 | "supreme_src_yaml") 51 | )) 52 | 53 | expect_equal(src_yaml(text = str_model), 54 | structure(list( 55 | list( 56 | name = "childModuleA", 57 | input = c("input.data", 58 | "reactive"), 59 | calling_modules = list(list(grandChildModule1 = "grandChildModule1UI")) 60 | ) 61 | ), class = c("supreme_src_obj", 62 | "supreme_src_yaml"))) 63 | 64 | }) 65 | 66 | test_that("src_yaml errors", { 67 | 68 | expect_error( 69 | src_yaml(file = example_model, text = str_model), 70 | regexp = "[supreme] Provide a file or text, not both.", 71 | fixed = TRUE 72 | ) 73 | 74 | expect_error( 75 | src_yaml(), 76 | regexp = "[supreme] Provide a file or text.", 77 | fixed = TRUE 78 | ) 79 | 80 | }) 81 | 82 | test_that("src_yaml (unique src paths)", { 83 | 84 | test_src_unique_file_paths <- " 85 | - name: server 86 | src: folder/proj/app.R 87 | - name: table 88 | src: folder/proj/sub-module/table.R 89 | - name: button 90 | src: folder/proj/sub-module/app.R 91 | " 92 | 93 | expect_equal(src_yaml(text = test_src_unique_file_paths), 94 | structure( 95 | list( 96 | list(name = "server", src = "folder/proj/app.R"), 97 | list(name = "table", src = "folder/proj/sub-module/table.R"), 98 | list(name = "button", src = "folder/proj/sub-module/app.R") 99 | ), 100 | class = c("supreme_src_obj", 101 | "supreme_src_yaml") 102 | )) 103 | 104 | }) 105 | 106 | 107 | test_that("verify_yaml", { 108 | 109 | ## first, check if example file is ok: 110 | ex <- yaml::yaml.load_file(example_yaml()) 111 | expect_true(.verify_yaml(ex)) 112 | 113 | missing <- " 114 | - input: [data, trigger.btn] 115 | " 116 | missing_yaml <- yaml::yaml.load(missing) 117 | expect_error( 118 | .verify_yaml(missing_yaml), 119 | regexp = "[supreme] 'name' field(s) required for every element", 120 | fixed = TRUE 121 | ) 122 | 123 | alien <- " 124 | - name: grandChildModule 125 | alien_field: 1 126 | " 127 | alien_yaml <- yaml::yaml.load(alien) 128 | expect_error( 129 | .verify_yaml(alien_yaml), 130 | regexp = "[supreme] following name(s) not required or optional: 'alien_field'", 131 | fixed = TRUE 132 | ) 133 | 134 | deep <- " 135 | - name: too deep 136 | calling_modules: 137 | - depth1: 138 | - depth2: 139 | - depth3 140 | " 141 | deep_yaml <- yaml::yaml.load(deep) 142 | expect_error( 143 | .verify_yaml(deep_yaml), 144 | regexp = "[supreme] model YAML cannot contain too depth lists in 'calling_modules'", 145 | fixed = TRUE 146 | ) 147 | 148 | cm <- " 149 | - name: childModuleA 150 | calling_modules: grandChildModule1 151 | " 152 | cm_yaml <- yaml::yaml.load(cm) 153 | expect_error( 154 | .verify_yaml(cm_yaml), 155 | regexp = "[supreme] 'calling_modules' field must have a UI part, a proper name or NULL (~)", 156 | fixed = TRUE 157 | ) 158 | 159 | }) 160 | 161 | -------------------------------------------------------------------------------- /tests/testthat/test-tabular.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("as.data.frame with src_yaml", { 3 | expect_equal(as.data.frame(supreme(src_yaml(example_yaml()))), 4 | structure( 5 | list( 6 | name = c( 7 | "server", 8 | "customers_tab_module_server", 9 | "items_tab_module_server", 10 | "transactions_tab_module_server", 11 | "module_modal_dialog" 12 | ), 13 | input = list( 14 | NA_character_, 15 | "customers_list", 16 | c("items_list", "is_fired"), 17 | c("table", "button_clicked"), 18 | "text" 19 | ), 20 | output = list( 21 | NA_character_, 22 | c("paid_customers_table", 23 | "free_customers_table"), 24 | NA_character_, 25 | "transactions_table", 26 | NA_character_ 27 | ), 28 | return = structure(c(NA, NA, NA, "transactions_keys", 29 | NA), class = "AsIs"), 30 | calling_modules = structure( 31 | list( 32 | list( 33 | list(items_tab_module_server = "ItemsTab"), 34 | list(customers_tab_module_server = "CustomersTab"), 35 | list(transactions_tab_module_server = "TransactionsTab") 36 | ), 37 | NA_character_, 38 | list(list(module_modal_dialog = NULL)), 39 | NA_character_, 40 | NA_character_ 41 | ), 42 | class = "AsIs" 43 | ), 44 | src = c( 45 | "app.R", 46 | "module-customers.R", 47 | "module-items.R", 48 | "module-transactions.R", 49 | "module-utils.R" 50 | ) 51 | ), 52 | row.names = c(NA,-5L), 53 | class = "data.frame" 54 | )) 55 | 56 | model <- " 57 | - name: childModuleA 58 | input: [input.data, reactive] 59 | calling_modules: 60 | - grandChildModule1: ~ 61 | 62 | - name: grandChildModule1 63 | input: selected.model 64 | " 65 | obj <- supreme(src_yaml(text = model)) 66 | expect_equal(as.data.frame(obj), 67 | structure( 68 | list( 69 | name = c("childModuleA", "grandChildModule1"), 70 | input = structure(list( 71 | c("input.data", "reactive"), "selected.model" 72 | ), class = "AsIs"), 73 | output = structure(c(NA_character_, NA_character_), class = "AsIs"), 74 | return = structure(c(NA_character_, NA_character_), class = "AsIs"), 75 | calling_modules = structure(list(list( 76 | list(grandChildModule1 = NULL) 77 | ), NA_character_), class = "AsIs"), 78 | src = c(NA_character_, NA_character_) 79 | ), 80 | row.names = c(NA,-2L), 81 | class = "data.frame" 82 | )) 83 | 84 | }) 85 | 86 | 87 | test_that("as.data.frame with src_file", { 88 | expect_equal(as.data.frame(supreme(src_file(example_app_path()))), 89 | structure( 90 | list( 91 | name = c( 92 | "server", 93 | "customers_tab_module_server", 94 | "items_tab_module_server", 95 | "transactions_tab_module_server", 96 | "module_modal_dialog" 97 | ), 98 | input = list( 99 | NA_character_, 100 | "customers_list", 101 | c("items_list", "is_fired"), 102 | c("table", "button_clicked"), 103 | "text" 104 | ), 105 | output = list( 106 | NA_character_, 107 | c("paid_customers_table", 108 | "free_customers_table"), 109 | NA_character_, 110 | "transactions_table", 111 | NA_character_ 112 | ), 113 | return = structure(c(NA, NA, NA, "transactions_keys", 114 | NA), class = "AsIs"), 115 | calling_modules = structure( 116 | list( 117 | list( 118 | list(items_tab_module_server = "ItemsTab"), 119 | list(customers_tab_module_server = "CustomersTab"), 120 | list(transactions_tab_module_server = "TransactionsTab") 121 | ), 122 | NA_character_, 123 | list(list(module_modal_dialog = NULL)), 124 | NA_character_, 125 | NA_character_ 126 | ), 127 | class = "AsIs" 128 | ), 129 | src = c( 130 | "app.R", 131 | "module-customers.R", 132 | "module-items.R", 133 | "module-transactions.R", 134 | "module-utils.R" 135 | ) 136 | ), 137 | row.names = c(NA,-5L), 138 | class = "data.frame" 139 | )) 140 | }) 141 | 142 | -------------------------------------------------------------------------------- /tests/testthat/test-graph.R: -------------------------------------------------------------------------------- 1 | 2 | test_that("graph test", { 3 | 4 | expect_error( 5 | graph(supreme(src_yaml(example_yaml())), fields = c("input", "output", "none", "mone")), 6 | regexp = "[supreme] unknown `fields` supplied: \"none\", \"mone\"", 7 | fixed = TRUE 8 | ) 9 | 10 | }) 11 | 12 | test_that("graph_create_general_directives", { 13 | expect_equal( 14 | graph_create_general_directives(list( 15 | direction = "down", 16 | font = "Arial", 17 | fontSize = 11, 18 | padding = 8 19 | )), 20 | "#direction: down\n#font: Arial\n#fontSize: 11\n#padding: 8" 21 | ) 22 | expect_error(graph_create_general_directives(list(1,2,3))) 23 | expect_error(graph_create_general_directives(list(a = "namely", "nameless"))) 24 | expect_error(graph_create_general_directives(NULL)) 25 | }) 26 | 27 | 28 | test_that("graph_generate_custom_classifier", { 29 | { 30 | set.seed(1234) 31 | cls1 <- graph_generate_custom_classifier("my_great_MoDule123_21") 32 | cls2 <- graph_generate_custom_classifier("server", 33 | list("fill" = "#8f8", "italic", "dashed")) 34 | } 35 | expect_equal( 36 | cls1, 37 | list( 38 | original = "my_great_MoDule123_21", 39 | classifier = "mygreatmodulepveloixfzdbgsjn", 40 | classifier.str = "#.mygreatmodulepveloixfzdbgsjn: fill=#fff" 41 | ) 42 | ) 43 | expect_equal( 44 | cls2, 45 | list( 46 | original = "server", 47 | classifier = "serverontydvhcuebwxkr", 48 | classifier.str = "#.serverontydvhcuebwxkr: fill=#8f8 italic dashed" 49 | ) 50 | ) 51 | }) 52 | 53 | 54 | test_that("graph_create_node", { 55 | x <- list( 56 | list( 57 | name = "childModuleA", 58 | input = c("input.data", "reactive"), 59 | output = c("output1", "output2"), 60 | return = "ret", 61 | calling_modules = list( 62 | list("grandChildModule1Server" = "grandChildModule1UI"), 63 | list("grandChildModule2Server" = "grandChildModule2UI") 64 | ) 65 | ) 66 | ) 67 | ## create a node with a classifier: 68 | set.seed(2019) 69 | cls <- graph_generate_custom_classifier(x[[1]][["name"]])[["classifier"]] 70 | ## disable 'centre' because it breaks the text output: 71 | node <- graph_create_node(x[[1]], classifier = cls, centre = FALSE) 72 | expect_equal( 73 | unlist(strsplit(node, "\\|")), 74 | c("[ childModuleA ", " ▹ input.data;▹ reactive ", 75 | " ○ output1;○ output2 ", " ◻ ret ", " grandChildModule1Server;;grandChildModule2Server;]" 76 | ) 77 | ) 78 | 79 | ## with some missing fields: 80 | y <- list(list(name = "childModuleB", input = "data")) 81 | node_incomplete <- graph_create_node(y[[1]]) 82 | expect_equal( 83 | unlist(strsplit(node_incomplete, "\\|")), 84 | c("[ childModuleB ", " ▹ data]") 85 | ) 86 | 87 | }) 88 | 89 | 90 | test_that("graph_create_edge", { 91 | x <- list( 92 | list( 93 | name = "childModuleA", 94 | input = c("input.data", "reactive"), 95 | output = c("tbl1", "tbl2"), 96 | return = "ret", 97 | calling_modules = "grandChildModule1" 98 | ), 99 | list( 100 | name = "childModuleB", 101 | input = NULL, 102 | calling_modules = NULL 103 | ) 104 | ) 105 | expect_equal(graph_create_edge(x[[1]]), "[childModuleA]->[NULL]") 106 | expect_null(graph_create_edge(x[[2]])) 107 | }) 108 | 109 | 110 | test_that("test graph styles - errors", { 111 | 112 | sp <- supreme(src_yaml(example_yaml())) 113 | 114 | expect_error( 115 | graph(sp, styles = list("xx")), 116 | regexp = "[supreme] `styles` must be a \"named list\" object", 117 | fixed = TRUE 118 | ) 119 | 120 | expect_error( 121 | graph(sp, styles = list(server = "xx")), 122 | regexp = "[supreme] objects inside the `styles` argument must be a list, see the element: 1", 123 | fixed = TRUE 124 | ) 125 | 126 | expect_error( 127 | graph(sp, styles = list(a_non_existing_module = list("dashed"))), 128 | regexp = "[supreme] module names specified in `styles` cannot be found: \"a_non_existing_module\"", 129 | fixed = TRUE 130 | ) 131 | 132 | }) 133 | 134 | 135 | test_that("test graph options - errors", { 136 | 137 | sp <- supreme(src_yaml(example_yaml())) 138 | 139 | expect_error( 140 | graph(sp, options = list(1)), 141 | regexp = "[supreme] `options` must be a \"named list\" object", 142 | fixed = TRUE 143 | ) 144 | 145 | }) 146 | 147 | 148 | test_that("test graph styles (test nomnoml text with hashing)", { 149 | { 150 | set.seed(2019) 151 | graph_supreme_yaml <- graph(supreme(src_yaml(example_yaml())), styles = list( 152 | "server" = list(fill = "#ff0", "underline", "bold"), 153 | "module_modal_dialog" = list(fill = "lightblue", "dashed", visual = "note") 154 | )) 155 | } 156 | expect_identical( 157 | digest::digest(graph_supreme_yaml[["x"]][["code"]]), 158 | "6bca5905defae1eafb12cbe00be94535" 159 | ) 160 | }) 161 | 162 | 163 | test_that("test graph options (test nomnoml text with hashing)", { 164 | { 165 | set.seed(2019) 166 | graph_supreme_yaml1 <- graph( 167 | supreme(src_yaml(example_yaml())), 168 | options = list( 169 | direction = "right", 170 | fontSize = 10, 171 | title = "Model application" 172 | )) 173 | } 174 | expect_identical( 175 | digest::digest(graph_supreme_yaml1[["x"]][["code"]]), 176 | "c1dfc6d6a1850cdcc1255b40d9abfc00" 177 | ) 178 | ## non default overriding options: 179 | { 180 | set.seed(2019) 181 | graph_supreme_yaml2 <- graph(supreme(src_yaml(example_yaml())), 182 | options = list(bendSize = 5)) 183 | } 184 | expect_identical( 185 | digest::digest(graph_supreme_yaml2[["x"]][["code"]]), 186 | "c37cf2642a9482a603013937890ff516" 187 | ) 188 | }) 189 | 190 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # supreme 2 | 3 | 4 | 5 | [![Travis build 6 | status](https://travis-ci.org/strboul/supreme.svg?branch=master)](https://travis-ci.org/strboul/supreme) 7 | [![AppVeyor build 8 | status](https://ci.appveyor.com/api/projects/status/github/strboul/supreme?branch=master&svg=true)](https://ci.appveyor.com/project/strboul/supreme) 9 | [![CRAN status 10 | badge](https://www.r-pkg.org/badges/version/supreme)](https://cran.r-project.org/package=supreme) 11 | [![CRAN mirror 12 | downloads](https://cranlogs.r-pkg.org/badges/supreme)](https://www.r-pkg.org/pkg/supreme) 13 | [![Coverage 14 | status](https://codecov.io/gh/strboul/supreme/branch/master/graph/badge.svg)](https://codecov.io/github/strboul/supreme?branch=master) 15 | 16 | 17 | As a ‘[Shiny](https://shiny.rstudio.com/) application’, developed with 18 | ‘[Shiny modules](https://shiny.rstudio.com/articles/modules.html)’, 19 | gets bigger, it becomes more difficult to track the relationships and to 20 | have a clear overview of the module hierarchy. supreme is a tool to help 21 | developers visualize the structure of their ‘Shiny applications’ 22 | developed with modules. 23 | 24 | Therefore, you are able to: 25 | 26 | 1. **Visualize** relationship of modules in *existing applications* 27 | 28 | 2. **Design** *new applications* from scratch 29 | 30 | --- 31 | 32 | :warning: supreme isn't yet compatible with the new `moduleServer` syntax introduced in the Shiny version `1.5.0` :warning: 33 | 34 | ## Usage 35 | 36 | ### 0\. The model language 37 | 38 |

39 | 40 | 41 | 42 |

43 | 44 | A graph consists of five main fields: 45 | 46 | 1. Module name (always required) 47 | 48 | 2. Module inputs (except the defaults: *input*, *output*, *session*) 49 | 50 | 3. Module outputs 51 | 52 | 4. Module returns 53 | 54 | 5. Calling modules, which are modules called a the module 55 | 56 | ### 1\. Model graph for existing applications 57 | 58 | ``` r 59 | library(supreme) 60 | path <- example_app_path() 61 | obj <- supreme(src_file(path)) 62 | graph(obj) 63 | ``` 64 | 65 | 66 | 67 |
68 | 69 | ### 2\. Model new applications 70 | 71 | ``` yaml 72 | - name: server 73 | calling_modules: 74 | - items_tab_module_server: ItemsTab 75 | - customers_tab_module_server: CustomersTab 76 | - transactions_tab_module_server: TransactionsTab 77 | src: app.R 78 | 79 | - name: customers_tab_module_server 80 | input: customers_list 81 | output: 82 | - paid_customers_table 83 | - free_customers_table 84 | src: module-customers.R 85 | 86 | - name: items_tab_module_server 87 | input: 88 | - items_list 89 | - is_fired 90 | calling_modules: 91 | - module_modal_dialog: ~ 92 | src: module-items.R 93 | 94 | - name: transactions_tab_module_server 95 | input: 96 | - table 97 | - button_clicked 98 | output: transactions_table 99 | return: transactions_keys 100 | src: module-transactions.R 101 | 102 | - name: module_modal_dialog 103 | input: 104 | - text 105 | src: module-utils.R 106 | ``` 107 | 108 | There are some special rules when creating model objects with *YAML*: 109 | 110 | - Each entity in the model must have a *name* field. 111 | 112 | - The entities can have optional fields, which are defined in the 113 | `getOption("SUPREME_MODEL_OPTIONAL_FIELDS")` 114 | 115 | - The fields defined in the 116 | `getOption("SUPREME_MODEL_MULTI_VAR_FIELDS")` can have multiple 117 | elements. It means that these fields can be expressed as an array. 118 | 119 | 120 | 121 | ``` r 122 | model_yaml <- src_yaml(text = model) 123 | obj <- supreme(model_yaml) 124 | ``` 125 | 126 | ## Known limitations 127 | 128 | - *supreme* will not properly parse the source code of your 129 | application if server side component is created with 130 | `shinyServer()`, which is soft-deprecated after a very early Shiny 131 | version of `0.10`. 132 | 133 | - Similarly, although it’s possible to create a Shiny application by 134 | only providing `input` and `output` arguments in the server side, 135 | *supreme* will not read any Shiny server side component missing a 136 | `session` argument. That’s reasonable decision because modules 137 | cannot work without a `session` argument. 138 | 139 | - For the module returns, all return values in a module should 140 | explicitly be wrapped in `return()` calls. 141 | 142 | - All the possible limitations comes from the fact that supreme is 143 | designed to perform static analysis on your code. Thus, some 144 | idiosyncratic Shiny application code may not be parsed as intended. 145 | For such cases, it would be great if you open an issue describing 146 | the situation with a reproducible example. 147 | 148 | ## Installation 149 | 150 | You can install the released version from 151 | [CRAN](https://cran.r-project.org/package=supreme): 152 | 153 | ``` r 154 | install.packages("supreme") 155 | ``` 156 | 157 | Or get the development version from 158 | [GitHub](https://github.com/strboul/supreme): 159 | 160 | ``` r 161 | # install.packages("devtools") 162 | devtools::install_github("strboul/supreme") 163 | ``` 164 | 165 | ## Acknowledgment 166 | 167 | - [R Core Team](https://www.r-project.org/): *supreme* package is 168 | brought to life thanks to *R* allowing *abstract syntax trees* (AST) 169 | that is used to practice static analysis on the code. 170 | 171 | - [datamodelr](https://github.com/bergant/datamodelr): Inspiring work 172 | for creating modeling language 173 | 174 | - [shinypod](https://github.com/ijlyttle/shinypod): Interesting 175 | thoughts regarding the implementation of Shiny modules 176 | 177 | ## License 178 | 179 | MIT © Metin Yazici 180 | -------------------------------------------------------------------------------- /R/finders.R: -------------------------------------------------------------------------------- 1 | 2 | #' Notes about the 'computing on the language' 3 | #' 4 | #' @details 5 | #' + If the class of a list element equals to "\{", that means the element is an 6 | #' "expr". Open it up. Every "expr" contains multiple number of list elements 7 | #' but the number of these list elements is unknown. The number of elements is 8 | #' depended upon the number of statements between curly braces in an expression. 9 | #' 10 | #' + If an object is a "symbol" (or "name"), it's a leaf which doesn't have any 11 | #' child elements. 12 | #' 13 | #' + In parsing \R code, recursive case is the type of "call" which it has 14 | #' always some more elements under. Base cases are more than one, such as symbol 15 | #' and constants (character, integer, numeric etc). 16 | #' 17 | #' + Recursive functions have two cases: 18 | #' - Base case: the part terminating the recursion (can still have more than 19 | #' one elements inside but they are not a `call`). 20 | #' - Recursive case: the part keep recursion occurring. 21 | #' 22 | #' + If an object is a `call`, that's never a 'leaf' (terminal node); therefore, 23 | #' a recursion (either with `Recall` or `lapply(x, )`) should be 24 | #' placed in order to go deep down the list. 25 | #' 26 | #' + If an object is a `pairlist`, it's technically a `list`, but not a 27 | #' `call`. Pairlist contains argument names of functions and their default 28 | #' values. Use `names()` to extract argument names. Get inside to each list 29 | #' element in order to extract individual argument values. 30 | #' 31 | #' @noRd 32 | NULL 33 | 34 | 35 | #' Find binding name of a function 36 | #' 37 | #' @param x an \R language object. 38 | #' @return 39 | #' The binding name of the function as a character vector. 40 | #' Returns `NULL` if the input is not a `call`. 41 | #' @noRd 42 | find_binding_name <- function(x) { 43 | if (is.call(x)) { 44 | if (is_left_assign_sym(x[[1]])) { 45 | return(as.character(x[[2]])) 46 | } else { 47 | unlist(lapply(x, find_binding_name)) 48 | } 49 | } else { 50 | NULL 51 | } 52 | } 53 | 54 | 55 | #' Find inputs of a `call` 56 | #' 57 | #' @param x an \R language object. 58 | #' @return 59 | #' Returns `NULL` if the given expression is not a function body. 60 | #' @noRd 61 | find_inputs <- function(x) { 62 | if (is.call(x)) { 63 | if (is_func_sym(x[[1L]])) { 64 | if (is.pairlist(x[[2L]])) { 65 | return(names(x[[2L]])) 66 | } 67 | } else if (is.function(x)) { 68 | return(names(formals(x))) 69 | } else { 70 | unlist(lapply(x, find_inputs)) 71 | } 72 | } else { 73 | NULL 74 | } 75 | } 76 | 77 | 78 | #' Find outputs of a `call`, which is a server side Shiny module 79 | #' 80 | #' @param x an \R language object. 81 | #' @return 82 | #' The name of the `output`s as a character vector. 83 | #' @noRd 84 | find_outputs <- function(x) { 85 | 86 | .find_outputs_from_block <- function(x) { 87 | if (is.call(x)) { 88 | if (is_dollar_sym(x[[1L]]) || is_double_bracket_sym(x[[1L]])) { 89 | if (is_output_sym(x[[2L]])) { 90 | value <- as.character(x[[3L]]) 91 | res[[length(res) + 1L]] <<- value 92 | } 93 | } else { 94 | unlist(lapply(x, .find_outputs_from_block)) 95 | } 96 | } else { 97 | NULL 98 | } 99 | } 100 | 101 | res <- list() 102 | .find_outputs_from_block(x) 103 | if (length(res) > 0) { 104 | unlist(res) 105 | } else { 106 | NULL 107 | } 108 | } 109 | 110 | 111 | #' Find return values of a `call` 112 | #' 113 | #' @param x an \R language object. 114 | #' 115 | #' @details 116 | #' Finds the return value of a call. Normally, functions can have 117 | #' early returns; therefore there can always be multiple return 118 | #' values. The common return syntax in \R as follows: 119 | #' 120 | #' + The object wrapped inside `return()` 121 | #' + The last object of a call 122 | #' + The last "binded object" of a `call` 123 | #' 124 | #' However, this finder is especially looking for the return values 125 | #' of the Shiny modules, we always look for the return calls that are 126 | #' wrapped inside the `return()`. 127 | #' 128 | #' @noRd 129 | find_returns <- function(x) { 130 | 131 | .find_returns_from_block <- function(x) { 132 | if (is.call(x)) { 133 | if (is_return_sym(x[[1L]])) { 134 | if (is.call(x[[2L]])) { 135 | if (is_expr_sym(x[[2L]][[1L]])) { 136 | value <- as.character(x[[2L]][[2L]]) 137 | res[[length(res) + 1L]] <<- value 138 | } 139 | } else { 140 | value <- if (is.null(x[[2L]])) "NULL" else as.character(x[[2L]]) 141 | res[[length(res) + 1L]] <<- value 142 | } 143 | } else { 144 | unlist(lapply(x, .find_returns_from_block)) 145 | } 146 | } else { 147 | NULL 148 | } 149 | } 150 | 151 | res <- list() 152 | .find_returns_from_block(x) 153 | if (length(res) > 0) { 154 | unlist(res) 155 | } else { 156 | NULL 157 | } 158 | } 159 | 160 | 161 | #' Find Shiny modules from a function block 162 | #' 163 | #' @param x an \R language object. 164 | #' 165 | #' @details 166 | #' What a `callModule` call can get: 167 | #' 168 | #' + name: the name for the Shiny module server function, 169 | #' + id: corresponding id with the module UI's function, 170 | #' and various arguments to be passed onto module function. 171 | #' 172 | #' What a Shiny module (*the server part*) can get: 173 | #' 174 | #' + symbol.name: the function name for the server-side of a module 175 | #' + arguments: arguments are passed into the module function 176 | #' (`input`, `output`, `session` arguments 177 | #' are "always" the default ones) 178 | #' @importFrom stats setNames 179 | #' @noRd 180 | find_calling_modules <- function(x) { 181 | 182 | .extract_callModule_arg_ind <- function(x, arg_name, default_arg_ind) { 183 | mod_arg_name <- names(x) 184 | mod_arg_name_ind <- if (!is.null(mod_arg_name)) { 185 | mod_arg <- which(mod_arg_name == arg_name) 186 | if (length(mod_arg) > 0L) { 187 | mod_arg 188 | } else { 189 | default_arg_ind 190 | } 191 | } else { 192 | default_arg_ind 193 | } 194 | mod_arg_name_ind 195 | } 196 | 197 | .find_modules_from_block <- function(x) { 198 | if (is.call(x)) { 199 | if (is_callModule_sym(x[[1L]])) { 200 | 201 | ## shiny::callModule 'module' arg: 202 | mod_module_name_ind <- .extract_callModule_arg_ind(x, "module", 2L) 203 | ## shiny::callModule 'id' arg: 204 | mod_id_name_ind <- .extract_callModule_arg_ind(x, "id", 3L) 205 | 206 | module_value <- deparse(x[[mod_module_name_ind]]) 207 | id_value <- if (!is.null(x[[mod_id_name_ind]])) { 208 | as.character(x[[mod_id_name_ind]]) 209 | } 210 | 211 | value <- stats::setNames(list(id_value), module_value) 212 | res[[length(res) + 1L]] <<- value 213 | } else { 214 | unlist(lapply(x, .find_modules_from_block)) 215 | } 216 | } else { 217 | NULL 218 | } 219 | } 220 | 221 | res <- list() 222 | .find_modules_from_block(x) 223 | if (length(res) > 0L) { 224 | res 225 | } else { 226 | NULL 227 | } 228 | } 229 | 230 | -------------------------------------------------------------------------------- /tests/testthat/test-supreme-integration.R: -------------------------------------------------------------------------------- 1 | 2 | context("test-supreme: Integration tests") 3 | 4 | # integration-data paths 5 | module_output <- file.path("integration-data", "module-output.Rtest") 6 | multiple_server_definition <- file.path("integration-data", "multiple-server-definition.Rtest") 7 | server_exprs_elems <- file.path("integration-data", "server-exprs-elems.Rtest") 8 | without_any_calling_module <- file.path("integration-data", "without-any-calling-module.Rtest") 9 | module_with_namespaced_fun <- file.path("integration-data", "module-with-namespaced-fun.Rtest") 10 | server_without_session_arg <- file.path("integration-data", "server-without-session-arg.Rtest") 11 | 12 | # src_yaml 13 | cycle_modules <- file.path("integration-data", "cycle-modules.yaml") 14 | 15 | test_that("supreme with src_file", { 16 | 17 | expect_equal(supreme(src_file(module_output)), 18 | structure(list( 19 | data = list( 20 | list( 21 | name = "linkedScatter", 22 | input = c("data", 23 | "left", "right"), 24 | output = c("plot1", "plot2"), 25 | return = "dataWithSelection", 26 | src = "module-output.Rtest" 27 | ), 28 | list( 29 | name = "server", 30 | output = "summary", 31 | calling_modules = list(list(linkedScatter = "scatters")), 32 | src = "module-output.Rtest" 33 | ) 34 | ), 35 | source_input = c("supreme_src_obj", "supreme_src_file") 36 | ), class = "supreme")) 37 | 38 | 39 | expect_error( 40 | supreme(src_file(multiple_server_definition)), 41 | regexp = "[supreme] duplicated module names in the source: 'server'", 42 | fixed = TRUE 43 | ) 44 | 45 | expect_equal(supreme(src_file(server_exprs_elems)), 46 | structure(list( 47 | data = list( 48 | list( 49 | name = "server", 50 | calling_modules = list( 51 | list(SomeTabServer = "SomeTab"), 52 | list(BarPlotPanelServer = "BarPlotPanel"), 53 | list(CustomerListPanelServer = "CustomerListPanel"), 54 | list(ObservedPanelServer = "ObservedPanel"), 55 | list(ConditionalItemsServer = "ConditionalItems"), 56 | list(ConditionalConditionalItems1Server = "ConditionalConditionalItems1"), 57 | list(ConditionalConditionalItems2Server = "ConditionalConditionalItems2"), 58 | list(DetailsButtonServer = "DetailsButton") 59 | ), 60 | src = "server-exprs-elems.Rtest" 61 | ) 62 | ), 63 | source_input = c("supreme_src_obj", "supreme_src_file") 64 | ), class = "supreme")) 65 | 66 | 67 | expect_equal(supreme(src_file(without_any_calling_module)), 68 | structure(list( 69 | data = list( 70 | list( 71 | name = "main_table_server", 72 | input = c("data", 73 | "tbl.pageLength", "tbl.selection"), 74 | output = "tbl", 75 | return = "rv", 76 | src = "without-any-calling-module.Rtest" 77 | ) 78 | ), 79 | source_input = c("supreme_src_obj", 80 | "supreme_src_file") 81 | ), class = "supreme")) 82 | 83 | }) 84 | 85 | 86 | test_that("supreme with src_yaml", { 87 | 88 | expect_equal(supreme(src_yaml(cycle_modules)), 89 | structure(list( 90 | data = list( 91 | list( 92 | name = "server", 93 | input = c("ax", 94 | "by", "cz"), 95 | output = c("O1", "O2"), 96 | return = "rv", 97 | calling_modules = list(list(reusableModule = NULL)) 98 | ), 99 | list( 100 | name = "reusableModule", 101 | input = c("a", "b"), 102 | output = c("OO1", "OO2", "OO3"), 103 | return = c("RV1", 104 | "RV2") 105 | ) 106 | ), 107 | source_input = c("supreme_src_obj", "supreme_src_yaml") 108 | ), class = "supreme")) 109 | 110 | }) 111 | 112 | 113 | test_that("supreme print methods", { 114 | 115 | sp_yaml <- supreme(src_yaml(example_yaml())) 116 | sp_file <- supreme(src_file(example_app_path())) 117 | 118 | expect_equal( 119 | trimws(paste(utils::capture.output(sp_yaml), collapse = " ")), 120 | "A supreme model object 5 entities: server, customers_tab_module_server, items_tab_module_server, transactions_tab_module_server, ..." 121 | ) 122 | 123 | expect_equal( 124 | trimws(paste(utils::capture.output(sp_file), collapse = " ")), 125 | "A supreme model object 5 entities: server, customers_tab_module_server, items_tab_module_server, transactions_tab_module_server, ..." 126 | ) 127 | 128 | model1 <- ' 129 | - name: displayImages 130 | ' 131 | s1 <- supreme(src_yaml(text = model1)) 132 | expect_equal( 133 | trimws(paste(utils::capture.output(s1), collapse = " ")), 134 | "A supreme model object 1 entity: displayImages" 135 | ) 136 | 137 | model2 <- ' 138 | - name: displayImages 139 | 140 | - name: checkInbox 141 | ' 142 | s2 <- supreme(src_yaml(text = model2)) 143 | expect_equal( 144 | trimws(paste(utils::capture.output(s2), collapse = " ")), 145 | "A supreme model object 2 entities: displayImages, checkInbox" 146 | ) 147 | }) 148 | 149 | 150 | test_that("graph supreme with src_file (test nomnoml code with hashing)", { 151 | {set.seed(2019); graph_module_output <- graph(supreme(src_file(module_output)))} 152 | expect_identical( 153 | digest::digest(graph_module_output[["x"]][["code"]]), 154 | "696db21a45f9dedc84524c8d28b7142c" 155 | ) 156 | {set.seed(2019); graph_server_exprs_elems <- graph(supreme(src_file(server_exprs_elems)))} 157 | expect_identical( 158 | digest::digest(graph_server_exprs_elems[["x"]][["code"]]), 159 | "542c09b280acf8048065b77d36f3557f" 160 | ) 161 | {set.seed(2019); graph_without_any_calling_module <- graph(supreme(src_file(without_any_calling_module)))} 162 | expect_identical( 163 | digest::digest(graph_without_any_calling_module[["x"]][["code"]]), 164 | "c16c3390c84bc187cf79d6a264c96746" 165 | ) 166 | }) 167 | 168 | 169 | test_that("graph supreme with src_yaml (test nomnoml code with hashing)", { 170 | {set.seed(2019); graph_cycle_modules <- graph(supreme(src_yaml(cycle_modules)))} 171 | expect_identical( 172 | digest::digest(graph_cycle_modules[["x"]][["code"]]), 173 | "f4c657a99b2debecd55406471c765c83" 174 | ) 175 | }) 176 | 177 | 178 | test_that("graph supreme with namespaced function (test nomnoml code with hashing)", { 179 | {set.seed(2019); graph_namespaced_fun <- graph(supreme(src_file(module_with_namespaced_fun )))} 180 | expect_identical( 181 | digest::digest(graph_namespaced_fun[["x"]][["code"]]), 182 | "72475a0144b2d66ddeb7633bbb6030e0" 183 | ) 184 | }) 185 | 186 | 187 | test_that("supreme error", { 188 | expect_error( 189 | supreme(1), 190 | "[supreme] the provided input cannot be turned into a supreme object", 191 | fixed = TRUE 192 | ) 193 | }) 194 | 195 | 196 | test_that("supreme error - Shiny server module not found", { 197 | expect_error( 198 | src_file(server_without_session_arg), 199 | "[supreme] cannot parse the file.", 200 | fixed = TRUE 201 | ) 202 | }) 203 | -------------------------------------------------------------------------------- /R/src-methods.R: -------------------------------------------------------------------------------- 1 | ### ----------------------------------------------------------------- ### 2 | ### PUBLIC ---- 3 | ### ----------------------------------------------------------------- ### 4 | 5 | #' Read \R files 6 | #' 7 | #' Read files contain at least one Shiny application. 8 | #' 9 | #' @param x a file path. 10 | #' 11 | #' @return A `src_file` object. 12 | #' @examples 13 | #' paths <- example_app_path() 14 | #' s <- supreme(src_file(paths)) 15 | #' @family source functions 16 | #' @export 17 | src_file <- function(x) { 18 | check_paths_exist(x) 19 | obj <- .make_module_entities_from_paths(x) 20 | out <- entity_constructor(obj) 21 | if (!length(out) > 0L) { 22 | ncstopf("cannot parse the file.") 23 | } 24 | structure(out, class = c("supreme_src_obj", "supreme_src_file")) 25 | } 26 | 27 | 28 | #' Read a YAML file containing a model 29 | #' 30 | #' Reads an object or a file in YAML format and returns a model YAML object. 31 | #' 32 | #' @param file file path to a YAML file. 33 | #' @param text a YAML formatted character string. 34 | #' @return A `src_yaml` object. 35 | #' 36 | #' @examples 37 | #' ## Read from a file: 38 | #' path <- example_yaml() 39 | #' src_yaml(path) 40 | #' 41 | #' ## Read from an (text) object: 42 | #' model <- " 43 | #' - name: childModuleA 44 | #' input: [input.data, reactive] 45 | #' src: package 46 | #' 47 | #' - name: childModuleB 48 | #' input: selected.model 49 | #' " 50 | #' src_yaml(text = model) 51 | #' @importFrom yaml yaml.load_file yaml.load 52 | #' @family source functions 53 | #' @export 54 | src_yaml <- function(file = NULL, text = NULL) { 55 | if (is.null(file) && is.null(text)) { 56 | ncstopf("Provide a file or text.") 57 | } 58 | if (is.null(file)) { 59 | if (is.null(text)) { 60 | ncstopf("Provide a file or text, not both.") 61 | } else { 62 | obj <- yaml::yaml.load(text) 63 | } 64 | } else { 65 | if (file.exists(file)) { 66 | if (is.null(text)) { 67 | obj <- yaml::yaml.load_file(file) 68 | } else { 69 | ncstopf("Provide a file or text, not both.") 70 | } 71 | } else { 72 | ncstopf( 73 | "File not found: `%s`", 74 | substr(file, 1, 35), 75 | single.line = TRUE 76 | ) 77 | } 78 | } 79 | .verify_yaml(obj) 80 | structure(obj, class = c("supreme_src_obj", "supreme_src_yaml")) 81 | } 82 | 83 | 84 | #' @export 85 | print.supreme_src_obj <- function(x, ...) { 86 | cls <- setdiff(class(x), "supreme_src_obj") 87 | switch (cls, 88 | "supreme_src_file" = "file", 89 | "supreme_src_yaml" = "yaml", 90 | NULL 91 | ) -> type 92 | stopifnot(!is.null(type)) 93 | cat("Model", type, "object", "\n") 94 | } 95 | 96 | 97 | ### ----------------------------------------------------------------- ### 98 | ### PRIVATE ---- 99 | ### ----------------------------------------------------------------- ### 100 | 101 | #' Read src file 102 | #' 103 | #' A small subset of [base::getSrcLines]. 104 | #' 105 | #' @param x a file name. 106 | #' @return A parsed expression. 107 | #' @details 108 | #' Lines starting with commenting symbol # (hash) are removed from the character 109 | #' vector before sending to parsing. Normally, `parse()` automatically removes the 110 | #' comments;however, we do it before anyway to avoid any potential problems, which 111 | #' can be caused by the paste collapsing. 112 | #' 113 | #' Before parsing, the character vector is wrapped between curly braces (`{` and `}`) 114 | #' as the system is designed around exprs. Also put new lines before the quotes to be 115 | #' sure that they are not commented out from # a previous commented line. 116 | #' @noRd 117 | .read_srcfile <- function(x) { 118 | lijnen <- lapply(seq_along(x), function(i) { 119 | fname <- x[i] 120 | srcfile <- srcfile(fname) 121 | if (!.isOpen(srcfile)) { 122 | on.exit(close(srcfile), add = TRUE) 123 | } 124 | first <- 1L 125 | conn <- open(srcfile, first) 126 | lines <- readLines(conn, warn = FALSE) 127 | # encoding stuff: 128 | Enc <- srcfile$Enc 129 | if (!is.null(Enc) && !(Enc %in% c("unknown", "native.enc"))) { 130 | lines <- iconv(lines, "", Enc) 131 | } 132 | lines 133 | }) 134 | lijnen <- unlist(lijnen) 135 | if (length(commented.lines <- grep("^#", lijnen)) > 0L) { 136 | lijnen <- lijnen[-commented.lines] 137 | } 138 | lines <- paste("{\n", paste(lijnen, collapse = "\n"), "\n}") 139 | parse(text = lines) 140 | } 141 | 142 | 143 | #' Make module entities from file paths 144 | #' 145 | #' @param x file paths. 146 | #' @noRd 147 | .make_module_entities_from_paths <- function(x) { 148 | short.src <- shorten_src_file_path(x) 149 | out <- lapply(seq_along(short.src), function(i) { 150 | src <- short.src[i] 151 | path <- x[grep(src, x)] 152 | body <- .read_srcfile(path) 153 | list(body = body, src = src) 154 | }) 155 | structure(out, class = "supreme_module_entities") 156 | } 157 | 158 | 159 | ### ----------------------------------------------------------------- ### 160 | ### VERIFY YAML ---- 161 | ### ----------------------------------------------------------------- ### 162 | 163 | #' Verify YAML object for supreme 164 | #' 165 | #' The loaded YAML model can be verified against the structure of an supreme 166 | #' object model. The errors catched during the parsing of YAML file will be handled 167 | #' by the *yaml* package. 168 | #' 169 | #' @param x a list (YAML) object. 170 | #' 171 | #' @details 172 | #' 173 | #' + Checks whether YAML object contains sub-lists 174 | #' 175 | #' + Checks whether YAML object does miss some or all required fields 176 | #' 177 | #' + Checks whether YAML object contains any other field not existing in either 178 | #' required or optional fields 179 | #' 180 | #' @return returns (invisibly) true if everything is fine. 181 | #' @noRd 182 | .verify_yaml <- function(x) { 183 | 184 | if (!is_list(x)) { 185 | ncstopf("cannot verify object with a class of: '%s'", class(x)) 186 | } 187 | 188 | if (!is.null(names(x))) { 189 | ncstopf("malformed YAML model") 190 | } 191 | 192 | for (entity in x) { 193 | .verify_yaml_check_names_and_missing(entity) 194 | .verify_yaml_check_field_depth(entity) 195 | } 196 | 197 | invisible(TRUE) 198 | } 199 | 200 | 201 | .verify_yaml_check_names_and_missing <- function( 202 | x, 203 | required = getOption("SUPREME_MODEL_REQUIRED_FIELDS"), 204 | optional = getOption("SUPREME_MODEL_OPTIONAL_FIELDS")) { 205 | 206 | required.names <- required %in% names(x) 207 | if (!all(required.names)) { 208 | ncstopf( 209 | "%s field(s) required for every element", 210 | paste("'", required[!required.names], "'", sep = "", collapse = ", ") 211 | ) 212 | } 213 | all.names <- c(required, optional) 214 | req.opt.names <- names(x) %in% all.names 215 | if (!all(req.opt.names)) { 216 | ncstopf( 217 | paste( 218 | "following name(s) not required or optional:", 219 | paste("'", names(x)[!req.opt.names], "'", sep = "", collapse = ", ") 220 | ) 221 | ) 222 | } 223 | } 224 | 225 | #' Also checks the calling_modules field that if it is formed properly 226 | #' A proper formation is that: 227 | #' - a module item is put as a sublist of calling_modules field and the module ends 228 | #' with a colon 229 | #' @noRd 230 | .verify_yaml_check_field_depth <- function(x) { 231 | for (xi in seq_along(x)) { 232 | 233 | current <- x[xi] 234 | current_key <- names(current) 235 | current_value <- current[[1L]] 236 | 237 | ## calling modules field treated differently: 238 | if (identical(current_key, "calling_modules")) { 239 | must_list <- any(vapply(current_value, is_list, logical(1))) 240 | if (!must_list) { 241 | ncstopf( 242 | "'%s' field must have a UI part, a proper name or NULL (~)", 243 | current_key 244 | ) 245 | } 246 | too_depth <- any(vapply(current_value, function(val) { 247 | vapply(val, is_list, logical(1)) 248 | }, logical(1))) 249 | if (too_depth) { 250 | ncstopf("model YAML cannot contain too depth lists in '%s'", current_key) 251 | } 252 | } else { 253 | ## the rest of the fields: 254 | res <- is_list(current_value) 255 | if (res) { 256 | ncstopf("model YAML cannot contain too depth lists in '%s'", current_key) 257 | } 258 | } 259 | 260 | } 261 | } 262 | 263 | -------------------------------------------------------------------------------- /R/graph.R: -------------------------------------------------------------------------------- 1 | 2 | ### ----------------------------------------------------------------- ### 3 | ### GRAPH UTILS ---- 4 | ### ----------------------------------------------------------------- ### 5 | 6 | 7 | #' @examples 8 | #' (dir <- graph_create_general_directives( 9 | #' list(direction = "down", font = "Arial", fontSize = 11, padding = 8) 10 | #' )) 11 | #' @noRd 12 | graph_create_general_directives <- function(directives) { 13 | stopifnot(is_list(directives)) 14 | stopifnot(is_named_list(directives)) 15 | out <- do.call(pastenc, lapply(seq_along(directives), function(i) { 16 | dr <- directives[i] 17 | paste0("#", names(dr), ": ", dr[[1L]]) 18 | })) 19 | out 20 | } 21 | 22 | 23 | #' @examples 24 | #' graph_generate_custom_classifier("my_great_MoDule123_21") 25 | #' graph_generate_custom_classifier("server", list("fill" = "#8f8", "italic", "dashed")) 26 | #' @noRd 27 | graph_generate_custom_classifier <- function(classifier.name, styles = NULL) { 28 | if (is.null(styles)) { 29 | ## white background node is default: 30 | styles <- list("fill" = "#fff") 31 | } 32 | list.styles <- vapply(seq_along(styles), function(i) { 33 | st <- styles[i] 34 | if (names(st) != "") { 35 | paste(names(st), st[[1L]], sep = "=") 36 | } else { 37 | st[[1L]] 38 | } 39 | }, character(1)) 40 | sanitized.name <- .graph_classifier_sanitize_name(classifier.name) 41 | out <- paste0("#.", sanitized.name[["result"]], ": ", paste(list.styles, collapse = " ")) 42 | list( 43 | original = classifier.name, 44 | classifier = sanitized.name[["result"]], 45 | classifier.str = out 46 | ) 47 | } 48 | 49 | 50 | .graph_classifier_sanitize_name <- function(name, random_str_len = 15L) { 51 | stopifnot(identical(length(name), 1L)) 52 | sanitized <- local({ 53 | no_digits <- gsub("[[:digit:]]+", "", name) 54 | no_underscore <- gsub("\\_+", "", no_digits) 55 | no_capital <- tolower(no_underscore) 56 | no_dot <- gsub("\\.+", "", no_capital) 57 | no_dot 58 | }) 59 | random <- paste(sample(letters, random_str_len), collapse = "") 60 | add_random <- paste0(sanitized, random) 61 | list( 62 | original = name, 63 | result = add_random 64 | ) 65 | } 66 | 67 | 68 | #' Create a comment in the graph text body 69 | #' 70 | #' @description 71 | #' The comments are helpful during graph debugging processes. 72 | #' 73 | #' @param comment a character object. 74 | #' @param sep_lines adds separation lines to make commentted lines more visually 75 | #' appealing. 76 | #' @noRd 77 | create_graph_comment <- function(comment, sep_lines = FALSE) { 78 | stopifnot(is.character(comment)) 79 | out <- paste("//", comment) 80 | if (sep_lines) { 81 | sep_lines_txt <- paste(rep("=", 8L), collapse = "") 82 | out <- paste("//", sep_lines_txt, comment, sep_lines_txt) 83 | } 84 | out 85 | } 86 | 87 | 88 | #' Center the field names displayed in the nodes. An invisible unicode character is 89 | #' used as a hidden quote because nomnoml only display spaces if they are between the 90 | #' character strings, otherwise the leading and trailing whitespaces are trimmed. 91 | #' @noRd 92 | centre_graph_strings <- function(x, quotes = "\u2063") { 93 | if (is.null(x)) return(x) 94 | if (!length(x) > 0L) return(NULL) 95 | stopifnot(is.character(x)) 96 | centred <- format(x, justify = "centre") 97 | paste(quotes, centred, quotes) 98 | } 99 | 100 | 101 | ### ----------------------------------------------------------------- ### 102 | ### NODES & EDGES ---- 103 | ### ----------------------------------------------------------------- ### 104 | 105 | 106 | graph_create_node <- function(x, classifier = NULL, centre = TRUE) { 107 | 108 | if (!(is.null(classifier) && !is.character(classifier))) { 109 | classifier <- as.character(classifier) 110 | } 111 | 112 | node <- list() 113 | node$identifier <- paste( 114 | if (!is.null(classifier)) paste0("<", classifier, ">") else "", 115 | x[["name"]] 116 | ) 117 | 118 | node$input <- .node_create_multi_vars_field(x[["input"]], bullet = "triangular") 119 | node$output <- .node_create_multi_vars_field(x[["output"]], bullet = "circle") 120 | node$return <- .node_create_multi_vars_field(x[["return"]], bullet = "square") 121 | 122 | node$calling_modules <- .node_create_calling_modules_field( 123 | calling_modules = x[["calling_modules"]], 124 | centre = centre 125 | ) 126 | 127 | .node_generate_string_node(node) 128 | } 129 | 130 | 131 | #' @param empty_to_null change empty strings to `NULL`. 132 | #' @noRd 133 | .node_generate_string_node <- function(node, empty_to_null = TRUE) { 134 | if (empty_to_null) node[node == ""] <- NULL 135 | nd_sep <- do.call(function(...) paste(..., sep = " | "), node) 136 | paste0("[", nd_sep, "]") 137 | } 138 | 139 | 140 | .node_create_calling_modules_field <- function(calling_modules, centre = TRUE) { 141 | as.vector(vapply(calling_modules, function(cm) { 142 | server_module <- names(cm) 143 | ui_module <- paste0("<", unlist(cm, use.names = FALSE), ">") 144 | c(server_module, ui_module) 145 | }, character(2))) -> out 146 | if (centre) { 147 | out <- centre_graph_strings(out) 148 | } 149 | paste(out, collapse = ";") 150 | } 151 | 152 | 153 | #' @description 154 | #' Multi vars field in the sense that: 155 | #' `getOption("SUPREME_MODEL_MULTI_VAR_FIELDS")` 156 | #' @noRd 157 | .node_create_multi_vars_field <- function(e, bullet, quote = FALSE) { 158 | bullet_sym <- getOption("SUPREME_GRAPH_BULLET_SYMBOLS")[[bullet]] 159 | if (!is.null(e)) { 160 | if (quote) e <- paste0("\"", e, "\"") 161 | e <- paste(bullet_sym, e) 162 | paste(e, collapse= ";") 163 | } else { 164 | "" 165 | } 166 | } 167 | 168 | 169 | graph_create_edge <- function(x) { 170 | if (is.null(x[["calling_modules"]])) return(NULL) 171 | edge <- list() 172 | edge$name <- x[["name"]] 173 | ## sapply->vapply failed because sometimes names are NULL 174 | edge$calling_modules <- sapply(x[["calling_modules"]], names) 175 | .edge_generate_string_edge(edge) 176 | } 177 | 178 | 179 | .edge_generate_string_edge <- function(edge) { 180 | paste( 181 | paste0( 182 | "[", edge$name, "]", 183 | "->", 184 | "[", edge$calling_modules, "]" 185 | ), 186 | collapse = "\n" 187 | ) 188 | } 189 | 190 | 191 | ### ----------------------------------------------------------------- ### 192 | ### GRAPH HELPERS ---- 193 | ### ----------------------------------------------------------------- ### 194 | 195 | 196 | #' Filters the input `x` list by modifying the input list in place. 197 | #' @noRd 198 | graph_filter_fields <- function(x, fields) { 199 | req_fields <- getOption("SUPREME_MODEL_REQUIRED_FIELDS") 200 | excepts <- which(!names(x) %in% c(req_fields, fields)) 201 | x[excepts] <- NULL 202 | x 203 | } 204 | 205 | 206 | #' Set graph styles for a particular `entity` 207 | #' 208 | #' @description 209 | #' The default_style is always added. 210 | #' @noRd 211 | graph_set_styles <- function(entity_name, entity_style) { 212 | default_style <- list("align" = "center", "bold") 213 | style <- if (!is.null(entity_style)) { 214 | c(default_style, entity_style) 215 | } else { 216 | default_style 217 | } 218 | graph_generate_custom_classifier(entity_name, style) 219 | } 220 | 221 | 222 | #' Set global graph options 223 | #' 224 | #' @description 225 | #' The user specified options overrides the default options but the default 226 | #' options are always added. 227 | #' @noRd 228 | graph_set_graph_options <- function(options) { 229 | default <- list(direction = "down", 230 | font = "Courier New", 231 | arrowSize = 0.5, 232 | fontSize = 11, 233 | padding = 8) 234 | graph_options <- if (!is.null(options)) { 235 | diffs <- setdiff(names(default), names(options)) 236 | c(options, default[diffs]) 237 | } else { 238 | default 239 | } 240 | graph_create_general_directives(graph_options) 241 | } 242 | 243 | 244 | graph_constructor <- function(x, fields, styles, options) { 245 | 246 | do.call(pasten, lapply(seq_along(x), function(i) { 247 | entity <- x[[i]] 248 | entity_name <- entity[["name"]] 249 | entity_style <- styles[[entity_name]] 250 | 251 | custom_classifier <- graph_set_styles(entity_name, entity_style) 252 | if (identical(custom_classifier[["original"]], entity_name)) { 253 | custom_classifier_name <- custom_classifier[["classifier"]] 254 | } 255 | 256 | ## create node elements: 257 | out <- list() 258 | out$comment <- create_graph_comment(custom_classifier$original, sep_lines = TRUE) 259 | out$classifier <- custom_classifier$classifier.str 260 | 261 | ## node fields filtered here, edges are still valid. 262 | out$node <- if (!is.null(fields)) { 263 | entity_filtered <- graph_filter_fields(entity, fields) 264 | graph_create_node(entity_filtered, custom_classifier_name) 265 | } else { 266 | graph_create_node(entity, custom_classifier_name) 267 | } 268 | out$edge <- graph_create_edge(entity) 269 | 270 | paste(out$comment, 271 | out$classifier, 272 | out$node, 273 | out$edge, 274 | "\n", 275 | sep = "\n") 276 | })) -> entity_bodies 277 | 278 | graph_options <- graph_set_graph_options(options) 279 | 280 | body <- list(graph_options, "", entity_bodies) 281 | out <- do.call(pastenc, body) 282 | structure(out, class = "supreme_graph_constructor") 283 | } 284 | 285 | 286 | #' @importFrom nomnoml nomnoml 287 | #' @noRd 288 | graph_render <- function(construct) { 289 | stopifnot(inherits(construct, "supreme_graph_constructor")) 290 | nomnoml::nomnoml(construct) 291 | } 292 | 293 | 294 | ### ----------------------------------------------------------------- ### 295 | ### GRAPH ---- 296 | ### ----------------------------------------------------------------- ### 297 | 298 | 299 | #' Validates the "fields" argument of the `graph` call 300 | #' 301 | #' @param x object returned from the `fields` argument. 302 | #' @noRd 303 | graph_fields_validator <- function(x) { 304 | if (!is.character(x)) { 305 | ncstopf("`fields` argument must be a character vector") 306 | } 307 | req_fields <- getOption("SUPREME_MODEL_REQUIRED_FIELDS") 308 | opt_fields <- getOption("SUPREME_MODEL_OPTIONAL_FIELDS") 309 | all_fields <- c(req_fields, opt_fields) 310 | check_opt_fields <- x %in% all_fields 311 | if (!all(check_opt_fields)) { 312 | ncstopf( 313 | "unknown `fields` supplied: %s", 314 | paste(paste0("\"", x[!check_opt_fields], "\""), collapse = ", ") 315 | ) 316 | } 317 | invisible(TRUE) 318 | } 319 | 320 | 321 | #' Validates the "styles" argument of the `graph` call 322 | #' 323 | #' @param x object returned from the `styles` argument. 324 | #' @param data the data element of the supreme object. 325 | #' @noRd 326 | graph_styles_validator <- function(x, data) { 327 | if (!(is_list(x) && is_named_list(x))) { 328 | ncstopf("`styles` must be a \"named list\" object") 329 | } 330 | sub_list <- vapply(x, is_list, logical(1)) 331 | if (!all(sub_list)) { 332 | ncstopf( 333 | "objects inside the `styles` argument must be a list, see the element: %s", 334 | which(!sub_list) 335 | ) 336 | } 337 | styles_names <- names(x) 338 | ## sapply->vapply failed because sometimes names are NULL 339 | module_names <- sapply(data, `[[`, "name") 340 | module_names_check <- styles_names %in% module_names 341 | if (!all(module_names_check)) { 342 | ncstopf( 343 | "module names specified in `styles` cannot be found: %s", 344 | paste(paste0("\"", styles_names[!module_names_check], "\""), collapse = ", ") 345 | ) 346 | } 347 | invisible(TRUE) 348 | } 349 | 350 | 351 | #' Validates the "options" argument of the `graph` call 352 | #' 353 | #' @param x object returned from the `options` argument. 354 | #' @noRd 355 | graph_options_validator <- function(x) { 356 | if (!(is_list(x) && is_named_list(x))) { 357 | ncstopf("`options` must be a \"named list\" object") 358 | } 359 | invisible(TRUE) 360 | } 361 | 362 | 363 | #' Make a UML graph of Shiny modules 364 | #' 365 | #' @description 366 | #' Creates a *UML-like* graph from your 'Shiny application' developed with modules. 367 | #' 368 | #' @param x a `supreme` object. 369 | #' @param fields optional. name of the fields to include in the graph. The 370 | #' possible values can be found at `getOption("SUPREME_MODEL_REQUIRED_FIELDS")` 371 | #' and `getOption("SUPREME_MODEL_OPTIONAL_FIELDS")`. By default, the required 372 | #' fields such as the "name" field always visible. There are no ways to 373 | #' exclude the required fields. This parameter is set to `NULL` as default. 374 | #' @param styles optional. a named list to apply custom styles on the graph 375 | #' nodes. A full list of the available styles can be seen from: 376 | #' \href{https://github.com/skanaar/nomnoml#custom-classifier-styles}{nomnoml: Custom classifier styles} 377 | #' @param options optional. custom options for the whole graph. A full list 378 | #' of the available options can be seen from: 379 | #' \href{https://github.com/skanaar/nomnoml#directives}{nomnoml: Directives} 380 | #' 381 | #' @details 382 | #' The graph call uses the `nomnoml` tool to draw a UML diagram of the Shiny 383 | #' application. 384 | #' 385 | #' @return a `supreme` graph. 386 | #' @references 387 | #' \href{https://github.com/skanaar/nomnoml}{nomnoml: The sassy UML diagram renderer} 388 | #' @examples 389 | #' # create a graph: 390 | #' path <- example_yaml() 391 | #' sp <- supreme(src_yaml(path)) 392 | #' graph(sp) 393 | #' 394 | #' # filter fields, only return the certain fields in the graph entities: 395 | #' graph(sp, fields = c("input", "return")) 396 | #' 397 | #' # style entites: 398 | #' graph(sp, styles = list( 399 | #' "server" = list(fill = "#ff0", "underline", "bold"), 400 | #' "module_modal_dialog" = list(fill = "lightblue", "dashed", visual = "note") 401 | #' )) 402 | #' 403 | #' # style entities having a word "tab" in it: 404 | #' sp_df <- as.data.frame(sp) # turn supreme object to data.frame 405 | #' tab_modules <- sp_df$name[grep("_tab_", sp_df$name)] 406 | #' styles <- lapply(seq_along(tab_modules), function(x) list(fill = "orange")) 407 | #' names(styles) <- tab_modules 408 | #' graph(sp, styles = styles) 409 | #' 410 | #' # set graph options: 411 | #' graph(sp, options = list( 412 | #' direction = "right", 413 | #' fontSize = 10, 414 | #' title = "Model application" 415 | #' )) 416 | #' @export 417 | graph <- function(x, fields = NULL, styles = NULL, options = NULL) { 418 | if (!is_supreme(x)) ncstopf("cannot graph a non-supreme object") 419 | sp_data <- x[["data"]] 420 | if (!is.null(fields)) graph_fields_validator(fields) 421 | if (!is.null(styles)) graph_styles_validator(styles, sp_data) 422 | if (!is.null(options)) graph_options_validator(options) 423 | constructs <- graph_constructor(sp_data, fields, styles, options) 424 | graph_render(constructs) 425 | } 426 | 427 | --------------------------------------------------------------------------------