diff --git a/.Rbuildignore b/.Rbuildignore index 50c93d4e..7db599ed 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,5 +13,3 @@ ^pkgdown$ ^data-raw$ ^CITATION\.cff$ -^app_hosted$ -^app$ diff --git a/.gitignore b/.gitignore index 6201650b..8e58845e 100644 --- a/.gitignore +++ b/.gitignore @@ -10,5 +10,3 @@ inst/shiny-examples/casting/functions.R functions.R docs inst/doc -app_hosted -app diff --git a/CITATION.cff b/CITATION.cff index 27be40e0..772834b5 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -9,7 +9,7 @@ type: software license: AGPL-3.0-or-later title: 'FreesearchR: A free and open-source browser based data analysis tool for researchers with publication ready output' -version: 25.4.5 +version: 25.4.4 doi: 10.5281/zenodo.14527429 abstract: Easily evaluate and analysis clinical health data in your browser on a server or on your own device. Import data from multiple sources, summarise, modify and diff --git a/DESCRIPTION b/DESCRIPTION index 1832158a..ecafe43e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: A free and open-source browser based data analysis tool for researchers with publication ready output -Version: 25.4.5 +Version: 25.4.4 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), diff --git a/NEWS.md b/NEWS.md index 4de9b76d..4336c49e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,11 +1,3 @@ -# FreesearchR 25.4.5 - -- *BUG*: Regression results and code not returned correctly - -- *IMPROVED*: analyses results are reset on data change - -- *NEW*: app usage tracking only in hosted app. README updated to reflect. - # FreesearchR 25.4.4 Minor updates in docs and easier citation. diff --git a/R/app_version.R b/R/app_version.R index 6d74916b..84fbc45c 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'v25.4.5.250430' +app_version <- function()'v25.4.4.250429' diff --git a/R/data_plots.R b/R/data_plots.R index 51fc249c..d93b0ead 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -351,25 +351,9 @@ data_visuals_server <- function(id, prismCodeBlock(paste0("#Plotting\n", rv$code)) }) - shiny::observeEvent( - list( - data() - ), - { - shiny::req(data()) - - rv$plot <- NULL - } - ) - output$plot <- shiny::renderPlot({ - # shiny::req(rv$plot) - # rv$plot - if (!is.null(rv$plot)) { - rv$plot - } else { - return(NULL) - } + shiny::req(rv$plot) + rv$plot }) output$download_plot <- shiny::downloadHandler( diff --git a/R/regression-module.R b/R/regression-module.R index 57806bde..6cd4aea0 100644 --- a/R/regression-module.R +++ b/R/regression-module.R @@ -331,10 +331,10 @@ regression_server <- function(id, "Multivariable" = "regression_model_list" ) |> lapply(\(.fun){ - parameters <- list( + parameters=list( data = data_r()[regression_vars()], - outcome.str = input$outcome_var, - fun.descr = input$regression_type + outcome.str = input$outcome_var, + fun.descr = input$regression_type ) do.call( @@ -413,68 +413,49 @@ regression_server <- function(id, shiny::req(rv$check_plot) shiny::req(input$plot_checks) - ## Print checks if a regression table is present - if (!is.null(rv$list$regression$tables)) { - p <- rv$check_plot() + - # patchwork::wrap_plots() + - patchwork::plot_annotation(title = "Multivariable regression model checks") + p <- rv$check_plot() + + # patchwork::wrap_plots() + + patchwork::plot_annotation(title = "Multivariable regression model checks") - layout <- sapply(seq_len(length(p)), \(.x){ - patchwork::area(.x, 1) + layout <- sapply(seq_len(length(p)), \(.x){ + patchwork::area(.x, 1) + }) + + out <- p + patchwork::plot_layout(design = Reduce(c, layout)) + + index <- match( + input$plot_checks, + sapply(rv$check_plot(), \(.i){ + get_ggplot_label(.i, "title") }) + ) - p_list <- p + patchwork::plot_layout(design = Reduce(c, layout)) + ls <- list() - index <- match( - input$plot_checks, - sapply(rv$check_plot(), \(.i){ - get_ggplot_label(.i, "title") - }) - ) - - ls <- list() - - for (i in index) { - p <- p_list[[i]] + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 10), - axis.title = ggplot2::element_text(size = 12), - legend.text = ggplot2::element_text(size = 12), - plot.subtitle = ggplot2::element_text(size = 12), - plot.title = ggplot2::element_text(size = 18) - ) - ls <- c(ls, list(p)) - } - # browser() - tryCatch( - { - out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) - }, - error = function(err) { - showNotification(err, type = "err") - } - ) - - out - } else { - return(NULL) + for (i in index) { + p <- out[[i]] + + ggplot2::theme(axis.text = ggplot2::element_text(size = 10), + axis.title = ggplot2::element_text(size = 12), + legend.text = ggplot2::element_text(size = 12), + plot.subtitle = ggplot2::element_text(size = 12), + plot.title = ggplot2::element_text(size = 18)) + ls <- c(ls, list(p)) } + # browser() + tryCatch( + { + patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) + }, + error = function(err) { + showNotification(err, type = "err") + } + ) }, alt = "Assumptions testing of the multivariable regression model" ) - shiny::observeEvent( - list( - data_r(), - regression_vars() - ), - { - rv$list$regression$tables <- NULL - } - ) - - ### Creating the regression table +### Creating the regression table shiny::observeEvent( input$load, { @@ -482,7 +463,6 @@ regression_server <- function(id, ## To avoid plotting old models on fail/error rv$list$regression$tables <- NULL - # browser() tryCatch( { parameters <- list( @@ -495,9 +475,9 @@ regression_server <- function(id, purrr::map(\(.x){ do.call( regression_table, - append_list(.x, parameters, "x") + append_list(.x,parameters,"x") ) - }) +}) # if (input$add_regression_p == "no") { # out <- out |> @@ -510,17 +490,23 @@ regression_server <- function(id, # } rv$list$regression$models |> - purrr::imap(\(.x, .i){ + purrr::imap(\(.x,.i){ rv$list$regression$models[[.i]][["code_table"]] <- paste( - .x$code, - expression_string(rlang::call2(.fn = "regression_table", !!!parameters, .ns = "FreesearchR"), assign.str = NULL), - sep = "|>\n" - ) + .x$code, + expression_string(rlang::call2(.fn = "regression_table",!!!parameters,.ns = "FreesearchR"),assign.str=NULL),sep="|>\n") }) - rv$list$regression$tables <- out - rv$list$input <- input + list( + rv$code$import, + rlang::call2(.fn = "select",!!!list(input$import_var),.ns = "dplyr"), + rlang::call2(.fn = "default_parsing",.ns = "FreesearchR") + ) |> + merge_expression() |> + expression_string() + rv$list$regression$tables <- out + + rv$list$input <- input }, warning = function(warn) { showNotification(paste0(warn), type = "warning") @@ -533,15 +519,11 @@ regression_server <- function(id, ) output$table2 <- gt::render_gt({ - ## Print checks if a regression table is present - if (!is.null(rv$list$regression$tables)) { - rv$list$regression$tables |> - tbl_merge() |> - gtsummary::as_gt() |> - gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**"))) - } else { - return(NULL) - } + shiny::req(rv$list$regression$tables) + rv$list$regression$tables |> + tbl_merge() |> + gtsummary::as_gt() |> + gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**"))) }) ############################################################################## @@ -632,8 +614,10 @@ regression_server <- function(id, ############################################################################## return(shiny::reactive({ - rv$list + return(rv$list) })) } ) } + + diff --git a/R/sysdata.rda b/R/sysdata.rda index e6434994..cef8f94e 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/theme.R b/R/theme.R index 7f8c7f75..d0852ada 100644 --- a/R/theme.R +++ b/R/theme.R @@ -54,7 +54,7 @@ FreesearchR_colors <- function(choose = NULL) { fg = "#000000" ) if (!is.null(choose)) { - unname(out[choose]) + out[choose] } else { out } diff --git a/README.md b/README.md index 85b5347a..10d809f8 100644 --- a/README.md +++ b/README.md @@ -23,27 +23,23 @@ This app has the following simple goals: 1. ease quick data overview and basic visualisations for any clinical researcher -## Run locally on your own machine +## Install locally -The ***FreesearchR*** app can also run on your own machine with no data transmitted anywhere. Any data.frame available in the global environment will be accessible from the interface. Just follow the below steps: +The ***FreesearchR***-tool can also be launched locally. Any data.frame available in the global environment will be accessible from the interface. -1. **Requirement:** You need to have [*R* installed](https://www.r-project.org/) and possibly an editor like [RStudio](https://posit.co/download/rstudio-desktop/). - -1. Then open the *R* console and copy/paste the following code, that will install the `{devtools}` package and then the `{FreesearchR}` *R*-package with its dependencies: - - ``` - require("devtools") - devtools::install_github("agdamsbo/FreesearchR") - library(FreesearchR) - # By loading mtcars to the environment, it will be available - # in the interface like any other data.frame - data(mtcars) - launch_FreesearchR() - ``` +``` +require("devtools") +devtools::install_github("agdamsbo/FreesearchR") +library(FreesearchR) +# By loading mtcars to the environment, it will be available +# in the interface like any other data.frame +data(mtcars) +launch_FreesearchR() +``` ## Code of Conduct -Please note that the ***FreesearchR*** project is published with a [Contributor Code of Conduct](https://contributor-covenant.org/version/2/1/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. +Please note that the ***FreesearchR*** project is released with a [Contributor Code of Conduct](https://contributor-covenant.org/version/2/1/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. ## Acknowledgements @@ -60,5 +56,3 @@ Like any other project, this project was never possible without the great work o - [IDEAfilter](https://biogen-inc.github.io/IDEAFilter/): a visually appealing data filter function based on the [{shinyDataFilter}](https://github.com/dgkf/shinyDataFilter). This project was all written by a human and not by any AI-based tools. - -The online ***FreesearchR*** app contains a tracking script, transmitting minimal data on usage. No uploaded data is transmitted anywhere. Have a look at the [tracking data here](https://analytics.gdamsbo.dk/share/2i4BNpMcDMB9lJvF/agdamsbo.shinyapps.io). No tracking data is sent running the app locally (see above). diff --git a/SESSION.md b/SESSION.md index 33e6cc5e..cffa4610 100644 --- a/SESSION.md +++ b/SESSION.md @@ -11,11 +11,11 @@ |collate |en_US.UTF-8 | |ctype |en_US.UTF-8 | |tz |Europe/Copenhagen | -|date |2025-04-30 | +|date |2025-04-29 | |rstudio |2024.12.1+563 Kousa Dogwood (desktop) | |pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | |quarto |1.6.40 @ /usr/local/bin/quarto | -|FreesearchR |25.4.5.250430 | +|FreesearchR |25.4.4.250429 | -------------------------------------------------------------------------------- @@ -24,10 +24,8 @@ |package |loadedversion |date |source | |:-------------|:-------------|:----------|:--------------| |apexcharter |0.4.4 |2024-09-06 |CRAN (R 4.4.1) | -|askpass |1.2.1 |2024-10-04 |CRAN (R 4.4.1) | |assertthat |0.2.1 |2019-03-21 |CRAN (R 4.4.1) | |backports |1.5.0 |2024-05-23 |CRAN (R 4.4.1) | -|base64enc |0.1-3 |2015-07-28 |CRAN (R 4.4.1) | |bayestestR |0.15.3 |2025-04-28 |CRAN (R 4.4.1) | |bit |4.6.0 |2025-03-06 |CRAN (R 4.4.1) | |bit64 |4.6.0-1 |2025-01-16 |CRAN (R 4.4.1) | @@ -37,21 +35,14 @@ |bsicons |0.1.2 |2023-11-04 |CRAN (R 4.4.0) | |bslib |0.9.0 |2025-01-30 |CRAN (R 4.4.1) | |cachem |1.1.0 |2024-05-16 |CRAN (R 4.4.1) | -|cards |0.6.0 |2025-04-11 |CRAN (R 4.4.1) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.4.0) | -|cffr |1.2.0 |2025-01-25 |CRAN (R 4.4.1) | -|checkmate |2.3.2 |2024-07-29 |CRAN (R 4.4.0) | |class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.4.1) | |cli |3.6.5 |2025-04-23 |CRAN (R 4.4.1) | -|cluster |2.1.8.1 |2025-03-12 |CRAN (R 4.4.1) | -|colorspace |2.1-1 |2024-07-26 |CRAN (R 4.4.1) | |commonmark |1.9.5 |2025-03-17 |CRAN (R 4.4.1) | |correlation |0.8.7 |2025-03-03 |CRAN (R 4.4.1) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.4.1) | -|credentials |2.0.2 |2024-10-04 |CRAN (R 4.4.1) | |crosstalk |1.2.1 |2023-11-23 |CRAN (R 4.4.0) | -|curl |6.2.2 |2025-03-24 |CRAN (R 4.4.1) | |data.table |1.17.0 |2025-02-22 |CRAN (R 4.4.1) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.4.1) | |datawizard |1.0.2 |2025-03-24 |CRAN (R 4.4.1) | @@ -70,47 +61,30 @@ |fastmap |1.2.0 |2024-05-15 |CRAN (R 4.4.1) | |fontawesome |0.5.3 |2024-11-16 |CRAN (R 4.4.1) | |forcats |1.0.0 |2023-01-29 |CRAN (R 4.4.0) | -|foreign |0.8-90 |2025-03-31 |CRAN (R 4.4.1) | -|Formula |1.2-5 |2023-02-24 |CRAN (R 4.4.1) | |fs |1.6.6 |2025-04-12 |CRAN (R 4.4.1) | |generics |0.1.3 |2022-07-05 |CRAN (R 4.4.1) | -|gert |2.1.5 |2025-03-25 |CRAN (R 4.4.1) | -|ggcorrplot |0.1.4.1 |2023-09-05 |CRAN (R 4.4.0) | |ggplot2 |3.5.2 |2025-04-09 |CRAN (R 4.4.1) | -|ggstats |0.9.0 |2025-03-10 |CRAN (R 4.4.1) | -|gh |1.4.1 |2024-03-28 |CRAN (R 4.4.0) | -|gitcreds |0.1.2 |2022-09-08 |CRAN (R 4.4.1) | |glue |1.8.0 |2024-09-30 |CRAN (R 4.4.1) | -|gridExtra |2.3 |2017-09-09 |CRAN (R 4.4.1) | |gt |1.0.0 |2025-04-05 |CRAN (R 4.4.1) | |gtable |0.3.6 |2024-10-25 |CRAN (R 4.4.1) | |gtsummary |2.2.0 |2025-04-14 |CRAN (R 4.4.1) | |haven |2.5.4 |2023-11-30 |CRAN (R 4.4.0) | |here |1.0.1 |2020-12-13 |CRAN (R 4.4.1) | -|Hmisc |5.2-3 |2025-03-16 |CRAN (R 4.4.1) | |hms |1.1.3 |2023-03-21 |CRAN (R 4.4.0) | -|htmlTable |2.4.3 |2024-07-21 |CRAN (R 4.4.0) | |htmltools |0.5.8.1 |2024-04-04 |CRAN (R 4.4.1) | |htmlwidgets |1.6.4 |2023-12-06 |CRAN (R 4.4.0) | |httpuv |1.6.16 |2025-04-16 |CRAN (R 4.4.1) | -|httr2 |1.1.2 |2025-03-26 |CRAN (R 4.4.1) | |IDEAFilter |0.2.0 |2024-04-15 |CRAN (R 4.4.0) | |insight |1.2.0 |2025-04-22 |CRAN (R 4.4.1) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.4.1) | -|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.4.1) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) | -|keyring |1.3.2 |2023-12-11 |CRAN (R 4.4.0) | |knitr |1.50 |2025-03-16 |CRAN (R 4.4.1) | -|labeling |0.4.3 |2023-08-29 |CRAN (R 4.4.1) | -|labelled |2.14.0 |2025-01-08 |CRAN (R 4.4.1) | |later |1.4.2 |2025-04-08 |CRAN (R 4.4.1) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.4.1) | |lifecycle |1.0.4 |2023-11-07 |CRAN (R 4.4.1) | -|litedown |0.7 |2025-04-08 |CRAN (R 4.4.1) | |lme4 |1.1-37 |2025-03-26 |CRAN (R 4.4.1) | |magrittr |2.0.3 |2022-03-30 |CRAN (R 4.4.1) | -|markdown |2.0 |2025-03-23 |CRAN (R 4.4.1) | |MASS |7.3-65 |2025-02-28 |CRAN (R 4.4.1) | |Matrix |1.7-3 |2025-03-11 |CRAN (R 4.4.1) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.4.0) | @@ -120,9 +94,6 @@ |modelbased |0.10.0 |2025-03-10 |CRAN (R 4.4.1) | |nlme |3.1-168 |2025-03-31 |CRAN (R 4.4.1) | |nloptr |2.2.1 |2025-03-17 |CRAN (R 4.4.1) | -|nnet |7.3-20 |2025-01-01 |CRAN (R 4.4.1) | -|openssl |2.3.2 |2025-02-03 |CRAN (R 4.4.1) | -|openxlsx2 |1.15 |2025-04-25 |CRAN (R 4.4.1) | |parameters |0.24.2 |2025-03-04 |CRAN (R 4.4.1) | |patchwork |1.3.0 |2024-09-16 |CRAN (R 4.4.1) | |performance |0.13.0 |2025-01-15 |CRAN (R 4.4.1) | @@ -131,7 +102,6 @@ |pkgbuild |1.4.7 |2025-03-24 |CRAN (R 4.4.1) | |pkgconfig |2.0.3 |2019-09-22 |CRAN (R 4.4.1) | |pkgload |1.4.0 |2024-06-28 |CRAN (R 4.4.0) | -|plyr |1.8.9 |2023-10-02 |CRAN (R 4.4.1) | |processx |3.8.6 |2025-02-21 |CRAN (R 4.4.1) | |profvis |0.4.0 |2024-09-20 |CRAN (R 4.4.1) | |promises |1.3.2 |2024-11-28 |CRAN (R 4.4.1) | @@ -139,13 +109,7 @@ |ps |1.9.1 |2025-04-12 |CRAN (R 4.4.1) | |purrr |1.0.4 |2025-02-05 |CRAN (R 4.4.1) | |quarto |1.4.4 |2024-07-20 |CRAN (R 4.4.0) | -|R.cache |0.16.0 |2022-07-21 |CRAN (R 4.4.0) | -|R.methodsS3 |1.8.2 |2022-06-13 |CRAN (R 4.4.1) | -|R.oo |1.27.0 |2024-11-01 |CRAN (R 4.4.1) | -|R.utils |2.13.0 |2025-02-24 |CRAN (R 4.4.1) | |R6 |2.6.1 |2025-02-15 |CRAN (R 4.4.1) | -|ragg |1.4.0 |2025-04-10 |CRAN (R 4.4.1) | -|rappdirs |0.3.3 |2021-01-31 |CRAN (R 4.4.1) | |rbibutils |2.3 |2024-10-04 |CRAN (R 4.4.1) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.4.1) | |Rcpp |1.0.14 |2025-01-12 |CRAN (R 4.4.1) | @@ -154,17 +118,13 @@ |readODS |2.3.2 |2025-01-13 |CRAN (R 4.4.1) | |readr |2.1.5 |2024-01-10 |CRAN (R 4.4.0) | |readxl |1.4.5 |2025-03-07 |CRAN (R 4.4.1) | -|REDCapCAST |25.3.2 |2025-03-10 |CRAN (R 4.4.1) | -|REDCapR |1.4.0 |2025-01-11 |CRAN (R 4.4.1) | |reformulas |0.4.0 |2024-11-03 |CRAN (R 4.4.1) | |remotes |2.5.0 |2024-03-17 |CRAN (R 4.4.1) | |renv |1.1.4 |2025-03-20 |CRAN (R 4.4.1) | |report |0.6.1 |2025-02-07 |CRAN (R 4.4.1) | -|reshape2 |1.4.4 |2020-04-09 |CRAN (R 4.4.0) | |rio |1.2.3 |2024-09-25 |CRAN (R 4.4.1) | |rlang |1.1.6 |2025-04-11 |CRAN (R 4.4.1) | |rmarkdown |2.29 |2024-11-04 |CRAN (R 4.4.1) | -|rpart |4.1.24 |2025-01-07 |CRAN (R 4.4.1) | |rprojroot |2.0.4 |2023-11-05 |CRAN (R 4.4.1) | |rsconnect |1.3.4 |2025-01-22 |CRAN (R 4.4.1) | |rstudioapi |0.17.1 |2024-10-22 |CRAN (R 4.4.1) | @@ -176,12 +136,6 @@ |shinybusy |0.3.3 |2024-03-09 |CRAN (R 4.4.0) | |shinyTime |1.0.3 |2022-08-19 |CRAN (R 4.4.0) | |shinyWidgets |0.9.0 |2025-02-21 |CRAN (R 4.4.1) | -|stringi |1.8.7 |2025-03-27 |CRAN (R 4.4.1) | -|stringr |1.5.1 |2023-11-14 |CRAN (R 4.4.0) | -|styler |1.10.3 |2024-04-07 |CRAN (R 4.4.0) | -|sys |3.4.3 |2024-10-04 |CRAN (R 4.4.1) | -|systemfonts |1.2.2 |2025-04-04 |CRAN (R 4.4.1) | -|textshaping |1.0.0 |2025-01-20 |CRAN (R 4.4.1) | |tibble |3.2.1 |2023-03-20 |CRAN (R 4.4.0) | |tidyr |1.3.1 |2024-01-24 |CRAN (R 4.4.1) | |tidyselect |1.2.1 |2024-03-11 |CRAN (R 4.4.0) | @@ -189,7 +143,6 @@ |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.4.1) | |urlchecker |1.0.1 |2021-11-30 |CRAN (R 4.4.1) | |usethis |3.1.0 |2024-11-26 |CRAN (R 4.4.1) | -|V8 |6.0.3 |2025-03-26 |CRAN (R 4.4.1) | |vctrs |0.6.5 |2023-12-01 |CRAN (R 4.4.0) | |vroom |1.6.5 |2023-12-05 |CRAN (R 4.4.0) | |withr |3.0.2 |2024-10-28 |CRAN (R 4.4.1) | @@ -198,4 +151,3 @@ |xml2 |1.3.8 |2025-03-14 |CRAN (R 4.4.1) | |xtable |1.8-4 |2019-04-21 |CRAN (R 4.4.1) | |yaml |2.3.10 |2024-07-26 |CRAN (R 4.4.1) | -|zip |2.3.2 |2025-02-01 |CRAN (R 4.4.1) | diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 347b471c..082962ba 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /Users/au301842/FreesearchR/app/functions.R +#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/functions.R ######## @@ -10,7 +10,7 @@ #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'v25.4.4.250430' +app_version <- function()'v25.4.4.250429' ######## @@ -1925,25 +1925,9 @@ data_visuals_server <- function(id, prismCodeBlock(paste0("#Plotting\n", rv$code)) }) - shiny::observeEvent( - list( - data() - ), - { - shiny::req(data()) - - rv$plot <- NULL - } - ) - output$plot <- shiny::renderPlot({ - # shiny::req(rv$plot) - # rv$plot - if (!is.null(rv$plot)) { - rv$plot - } else { - return(NULL) - } + shiny::req(rv$plot) + rv$plot }) output$download_plot <- shiny::downloadHandler( @@ -7386,10 +7370,10 @@ regression_server <- function(id, "Multivariable" = "regression_model_list" ) |> lapply(\(.fun){ - parameters <- list( + parameters=list( data = data_r()[regression_vars()], - outcome.str = input$outcome_var, - fun.descr = input$regression_type + outcome.str = input$outcome_var, + fun.descr = input$regression_type ) do.call( @@ -7468,67 +7452,49 @@ regression_server <- function(id, shiny::req(rv$check_plot) shiny::req(input$plot_checks) - ## Print checks if a regression table is present - if (!is.null(rv$list$regression$tables)) { - p <- rv$check_plot() + - # patchwork::wrap_plots() + - patchwork::plot_annotation(title = "Multivariable regression model checks") + p <- rv$check_plot() + + # patchwork::wrap_plots() + + patchwork::plot_annotation(title = "Multivariable regression model checks") - layout <- sapply(seq_len(length(p)), \(.x){ - patchwork::area(.x, 1) + layout <- sapply(seq_len(length(p)), \(.x){ + patchwork::area(.x, 1) + }) + + out <- p + patchwork::plot_layout(design = Reduce(c, layout)) + + index <- match( + input$plot_checks, + sapply(rv$check_plot(), \(.i){ + get_ggplot_label(.i, "title") }) + ) - p_list <- p + patchwork::plot_layout(design = Reduce(c, layout)) + ls <- list() - index <- match( - input$plot_checks, - sapply(rv$check_plot(), \(.i){ - get_ggplot_label(.i, "title") - }) - ) - - ls <- list() - - for (i in index) { - p <- p_list[[i]] + - ggplot2::theme( - axis.text = ggplot2::element_text(size = 10), - axis.title = ggplot2::element_text(size = 12), - legend.text = ggplot2::element_text(size = 12), - plot.subtitle = ggplot2::element_text(size = 12), - plot.title = ggplot2::element_text(size = 18) - ) - ls <- c(ls, list(p)) - } - # browser() - tryCatch( - { - out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) - }, - error = function(err) { - showNotification(err, type = "err") - } - ) - - out - } else { - return(NULL) + for (i in index) { + p <- out[[i]] + + ggplot2::theme(axis.text = ggplot2::element_text(size = 10), + axis.title = ggplot2::element_text(size = 12), + legend.text = ggplot2::element_text(size = 12), + plot.subtitle = ggplot2::element_text(size = 12), + plot.title = ggplot2::element_text(size = 18)) + ls <- c(ls, list(p)) } + # browser() + tryCatch( + { + patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) + }, + error = function(err) { + showNotification(err, type = "err") + } + ) }, alt = "Assumptions testing of the multivariable regression model" ) - shiny::observeEvent( - list( - data_r() - ), - { - rv$list$regression$tables <- NULL - } - ) - - ### Creating the regression table +### Creating the regression table shiny::observeEvent( input$load, { @@ -7536,7 +7502,6 @@ regression_server <- function(id, ## To avoid plotting old models on fail/error rv$list$regression$tables <- NULL - # browser() tryCatch( { parameters <- list( @@ -7549,9 +7514,9 @@ regression_server <- function(id, purrr::map(\(.x){ do.call( regression_table, - append_list(.x, parameters, "x") + append_list(.x,parameters,"x") ) - }) +}) # if (input$add_regression_p == "no") { # out <- out |> @@ -7564,17 +7529,23 @@ regression_server <- function(id, # } rv$list$regression$models |> - purrr::imap(\(.x, .i){ + purrr::imap(\(.x,.i){ rv$list$regression$models[[.i]][["code_table"]] <- paste( - .x$code, - expression_string(rlang::call2(.fn = "regression_table", !!!parameters, .ns = "FreesearchR"), assign.str = NULL), - sep = "|>\n" - ) + .x$code, + expression_string(rlang::call2(.fn = "regression_table",!!!parameters,.ns = "FreesearchR"),assign.str=NULL),sep="|>\n") }) - rv$list$regression$tables <- out - rv$list$input <- input + list( + rv$code$import, + rlang::call2(.fn = "select",!!!list(input$import_var),.ns = "dplyr"), + rlang::call2(.fn = "default_parsing",.ns = "FreesearchR") + ) |> + merge_expression() |> + expression_string() + rv$list$regression$tables <- out + + rv$list$input <- input }, warning = function(warn) { showNotification(paste0(warn), type = "warning") @@ -7587,15 +7558,11 @@ regression_server <- function(id, ) output$table2 <- gt::render_gt({ - ## Print checks if a regression table is present - if (!is.null(rv$list$regression$tables)) { - rv$list$regression$tables |> - tbl_merge() |> - gtsummary::as_gt() |> - gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**"))) - } else { - return(NULL) - } + shiny::req(rv$list$regression$tables) + rv$list$regression$tables |> + tbl_merge() |> + gtsummary::as_gt() |> + gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**"))) }) ############################################################################## @@ -7686,13 +7653,15 @@ regression_server <- function(id, ############################################################################## return(shiny::reactive({ - rv$list + return(rv$list) })) } ) } + + ######## #### Current file: /Users/au301842/FreesearchR/R//report.R ######## @@ -7872,7 +7841,7 @@ FreesearchR_colors <- function(choose = NULL) { fg = "#000000" ) if (!is.null(choose)) { - unname(out[choose]) + out[choose] } else { out } @@ -9193,17 +9162,7 @@ grepl_fix <- function(data, pattern, type = c("prefix", "infix", "suffix")) { ######## -#### Current file: /Users/au301842/FreesearchR/dev/header_include.R -######## - -header_include <- function(){ - shiny::tags$head( - tags$link(rel = "stylesheet", type = "text/css", href = "style.css")) -} - - -######## -#### Current file: /Users/au301842/FreesearchR/app/ui.R +#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/ui.R ######## # ns <- NS(id) @@ -9719,10 +9678,10 @@ dark <- custom_theme( ui <- bslib::page_fixed( prismDependencies, prismRDependency, - header_include(), - ## This adds the actual favicon - ## png and ico versions are kept for compatibility - shiny::tags$head(tags$link(rel="shortcut icon", href="favicon.svg")), + shiny::tags$head( + includeHTML(("www/umami-app.html")), + tags$link(rel = "stylesheet", type = "text/css", href = "style.css")), + tags$head(tags$link(rel="shortcut icon", href="favicon.svg")), title = "FreesearchR", theme = light, shiny::useBusyIndicators(), @@ -9742,7 +9701,7 @@ ui <- bslib::page_fixed( style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", shiny::p( style = "margin: 1", - "Data is only stored for analyses and deleted when the app is closed.", shiny::markdown("Consider [running ***FreesearchR*** locally](https://agdamsbo.github.io/FreesearchR/#run-locally-on-your-own-machine) if working with sensitive data.") + "Data is only stored for analyses and deleted when the app is closed." ), shiny::p( style = "margin: 1; color: #888;", @@ -9753,9 +9712,8 @@ ui <- bslib::page_fixed( ) - ######## -#### Current file: /Users/au301842/FreesearchR/app/server.R +#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/server.R ######## library(readr) @@ -9793,7 +9751,7 @@ library(gtsummary) data(starwars) data(mtcars) mtcars_date <- mtcars |> append_column(as.Date(sample(1:365, nrow(mtcars))), "rand_dates") -mtcars_date$date <- as.Date(sample(seq_len(365), nrow(mtcars))) +mtcars_date$date <- as.Date(sample(seq_len(365),nrow(mtcars))) data(trial) @@ -9839,7 +9797,7 @@ server <- function(input, output, session) { rv <- shiny::reactiveValues( list = list(), - regression = NULL, + regression = list(), ds = NULL, local_temp = NULL, ready = NULL, @@ -10224,20 +10182,6 @@ server <- function(input, output, session) { )) }) - ## Evaluation table/plots reset on data change - ## This does not work (!?) - shiny::observeEvent( - list( - rv$data_filtered - ), - { - shiny::req(rv$data_filtered) - - rv$list$table1 <- NULL - # rv$regression <- NULL - } - ) - ############################################################################## ######### @@ -10299,7 +10243,6 @@ server <- function(input, output, session) { ## Just a note to self ## This is a very rewarding couple of lines marking new insights to dynamically rendering code shiny::observe({ - shiny::req(rv$regression) rv$regression()$regression$models |> purrr::imap(\(.x, .i){ output[[paste0("code_", tolower(.i))]] <- shiny::renderUI({ prismCodeBlock(paste0(paste("#", .i, "regression model\n"), .x$code_table)) @@ -10376,13 +10319,11 @@ server <- function(input, output, session) { }) output$table1 <- gt::render_gt({ - if (!is.null(rv$list$table1)) { - rv$list$table1 |> - gtsummary::as_gt() |> - gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) - } else { - return(NULL) - } + shiny::req(rv$list$table1) + + rv$list$table1 |> + gtsummary::as_gt() |> + gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) }) data_correlations_server( @@ -10414,22 +10355,6 @@ server <- function(input, output, session) { rv$regression <- regression_server("regression", data = shiny::reactive(rv$list$data)) - # shiny::observeEvent(rv$regression, { - # browser() - # if (shiny::is.reactive(rv$regression)) { - # rv$list$regression <- rv$regression() - # } else { - # rv$list$regression <- rv$regression - # } - # # rv$list$regression <- rv$regression() - # }) - - # output$regression_models <- renderText({ - # req(rv$list$regression) - # browser() - # names(rv$list$regression) - # }) - ############################################################################## ######### ######### Page navigation @@ -10480,7 +10405,6 @@ server <- function(input, output, session) { paste0("report.", input$output_type) }), content = function(file, type = input$output_type) { - # browser() # shiny::req(rv$list$regression) ## Notification is not progressing ## Presumably due to missing @@ -10489,11 +10413,6 @@ server <- function(input, output, session) { format <- ifelse(type == "docx", "word_document", "odt_document") # browser() - # if (shiny::is.reactive(rv$regression)){ - # rv$list$regression <- rv$regression() - # } - - # rv$list$regression <- rv$regression() rv$list$regression <- rv$regression() shiny::withProgress(message = "Generating the report. Hold on for a moment..", { @@ -10547,7 +10466,7 @@ server <- function(input, output, session) { ######## -#### Current file: /Users/au301842/FreesearchR/app/launch.R +#### Current file: /Users/au301842/FreesearchR/inst/apps/FreesearchR/launch.R ######## shinyApp(ui, server) diff --git a/inst/apps/FreesearchR/launch.R b/inst/apps/FreesearchR/launch.R new file mode 100644 index 00000000..739d7781 --- /dev/null +++ b/inst/apps/FreesearchR/launch.R @@ -0,0 +1 @@ +shinyApp(ui, server) diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/FreesearchR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/FreesearchR.dcf new file mode 100644 index 00000000..b42b77a5 --- /dev/null +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/FreesearchR.dcf @@ -0,0 +1,10 @@ +name: FreesearchR +title: +username: agdamsbo +account: agdamsbo +server: shinyapps.io +hostUrl: https://api.shinyapps.io/v1 +appId: 14600805 +bundleId: 10199884 +url: https://agdamsbo.shinyapps.io/FreesearchR/ +version: 1 diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf new file mode 100644 index 00000000..dd1b9615 --- /dev/null +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -0,0 +1,10 @@ +name: freesearcheR +title: +username: agdamsbo +account: agdamsbo +server: shinyapps.io +hostUrl: https://api.shinyapps.io/v1 +appId: 13611288 +bundleId: 10164589 +url: https://agdamsbo.shinyapps.io/freesearcheR/ +version: 1 diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/webResearch.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/webResearch.dcf new file mode 100644 index 00000000..6fa449ff --- /dev/null +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/webResearch.dcf @@ -0,0 +1,10 @@ +name: webResearch +title: +username: agdamsbo +account: agdamsbo +server: shinyapps.io +hostUrl: https://api.shinyapps.io/v1 +appId: 13276335 +bundleId: 9436643 +url: https://agdamsbo.shinyapps.io/webResearch/ +version: 1 diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/cognitiveindex/freesearcheR_dev.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/cognitiveindex/freesearcheR_dev.dcf new file mode 100644 index 00000000..ab5be8e1 --- /dev/null +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/cognitiveindex/freesearcheR_dev.dcf @@ -0,0 +1,10 @@ +name: freesearcheR_dev +title: +username: cognitiveindex +account: cognitiveindex +server: shinyapps.io +hostUrl: https://api.shinyapps.io/v1 +appId: 13786206 +bundleId: 9688582 +url: https://cognitiveindex.shinyapps.io/freesearcheR_dev/ +version: 1 diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/cognitiveindex/freesearcheR_extra.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/cognitiveindex/freesearcheR_extra.dcf new file mode 100644 index 00000000..befa5713 --- /dev/null +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/cognitiveindex/freesearcheR_extra.dcf @@ -0,0 +1,10 @@ +name: freesearcheR_extra +title: +username: cognitiveindex +account: cognitiveindex +server: shinyapps.io +hostUrl: https://api.shinyapps.io/v1 +appId: 13622743 +bundleId: 9544828 +url: https://cognitiveindex.shinyapps.io/freesearcheR_extra/ +version: 1 diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R new file mode 100644 index 00000000..25fd8384 --- /dev/null +++ b/inst/apps/FreesearchR/server.R @@ -0,0 +1,747 @@ +library(readr) +library(MASS) +library(stats) +library(gt) +# library(openxlsx2) +library(haven) +library(readODS) +require(shiny) +library(bslib) +library(assertthat) +library(dplyr) +library(quarto) +library(here) +library(broom) +library(broom.helpers) +# library(REDCapCAST) +library(easystats) +# library(esquisse) +library(patchwork) +library(DHARMa) +library(apexcharter) +library(toastui) +library(datamods) +library(IDEAFilter) +library(shinyWidgets) +library(DT) +library(data.table) +library(gtsummary) +# library(FreesearchR) + +# source("functions.R") + +data(starwars) +data(mtcars) +mtcars_date <- mtcars |> append_column(as.Date(sample(1:365, nrow(mtcars))), "rand_dates") +mtcars_date$date <- as.Date(sample(seq_len(365),nrow(mtcars))) +data(trial) + + +# light <- custom_theme() +# +# dark <- custom_theme(bg = "#000",fg="#fff") + + +server <- function(input, output, session) { + ## Listing files in www in session start to keep when ending and removing + ## everything else. + files.to.keep <- list.files("www/") + + output$docs_file <- shiny::renderUI({ + # shiny::includeHTML("www/docs.html") + shiny::HTML(readLines("www/docs.html")) + }) + + ############################################################################## + ######### + ######### Night mode (just very popular, not really needed) + ######### + ############################################################################## + + # observeEvent(input$dark_mode,{ + # session$setCurrentTheme( + # if (isTRUE(input$dark_mode)) dark else light + # )}) + + # observe({ + # if(input$dark_mode==TRUE) + # session$setCurrentTheme(bs_theme_update(theme = custom_theme(version = 5))) + # if(input$dark_mode==FALSE) + # session$setCurrentTheme(bs_theme_update(theme = custom_theme(version = 5, bg = "#000",fg="#fff"))) + # }) + + + ############################################################################## + ######### + ######### Setting reactive values + ######### + ############################################################################## + + rv <- shiny::reactiveValues( + list = list(), + regression = list(), + ds = NULL, + local_temp = NULL, + ready = NULL, + test = "no", + data_original = NULL, + data_temp = NULL, + data = NULL, + data_variables = NULL, + data_filtered = NULL, + models = NULL, + code = list() + ) + + ############################################################################## + ######### + ######### Data import section + ######### + ############################################################################## + + data_file <- import_file_server( + id = "file_import", + show_data_in = "popup", + trigger_return = "change", + return_class = "data.frame" + ) + + shiny::observeEvent(data_file$data(), { + shiny::req(data_file$data()) + rv$data_temp <- data_file$data() + rv$code <- modifyList(x = rv$code, list(import = data_file$code())) + }) + + from_redcap <- m_redcap_readServer( + id = "redcap_import" + ) + + shiny::observeEvent(from_redcap$data(), { + rv$data_temp <- from_redcap$data() + rv$code <- modifyList(x = rv$code, list(import = from_redcap$code())) + }) + + ## This is used to ensure the reactive data is retrieved + output$redcap_prev <- DT::renderDT( + { + DT::datatable(head(from_redcap$data(), 5), + caption = "First 5 observations" + ) + }, + server = TRUE + ) + + from_env <- datamods::import_globalenv_server( + id = "env", + trigger_return = "change", + btn_show_data = FALSE, + reset = reactive(input$hidden) + ) + + shiny::observeEvent(from_env$data(), { + shiny::req(from_env$data()) + + rv$data_temp <- from_env$data() + rv$code <- modifyList(x = rv$code, list(import = from_env$name())) + }) + + output$import_var <- shiny::renderUI({ + shiny::req(rv$data_temp) + + preselect <- names(rv$data_temp)[sapply(rv$data_temp, missing_fraction) <= input$complete_cutoff / 100] + + shinyWidgets::virtualSelectInput( + inputId = "import_var", + label = "Select variables to include", + selected = preselect, + choices = names(rv$data_temp), + updateOn = "change", + multiple = TRUE, + search = TRUE, + showValueAsTags = TRUE + ) + }) + + output$data_loaded <- shiny::reactive({ + !is.null(rv$data_temp) + }) + + shiny::observeEvent(input$source, { + rv$data_temp <- NULL + }) + + shiny::outputOptions(output, "data_loaded", suspendWhenHidden = FALSE) + + shiny::observeEvent( + eventExpr = list( + input$import_var, + input$complete_cutoff, + rv$data_temp + ), + handlerExpr = { + shiny::req(rv$data_temp) + shiny::req(input$import_var) + # browser() + temp_data <- rv$data_temp + if (all(input$import_var %in% names(temp_data))) { + temp_data <- temp_data |> dplyr::select(input$import_var) + } + + rv$data_original <- temp_data |> + default_parsing() + + rv$code$import <- rv$code$import |> + expression_string(assign.str = "df <-") + + rv$code$format <- list( + "df", + rlang::expr(dplyr::select(dplyr::all_of(!!input$import_var))), + rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") + ) |> + lapply(expression_string) |> + pipe_string() |> + expression_string(assign.str = "df <-") + + rv$code$filter <- NULL + rv$code$modify <- NULL + }, ignoreNULL = FALSE + ) + + output$data_info_import <- shiny::renderUI({ + shiny::req(rv$data_original) + data_description(rv$data_original) + }) + + ## Activating action buttons on data imported + shiny::observeEvent(rv$data_original, { + if (is.null(rv$data_original) | NROW(rv$data_original) == 0) { + shiny::updateActionButton(inputId = "act_start", disabled = TRUE) + shiny::updateActionButton(inputId = "modal_browse", disabled = TRUE) + shiny::updateActionButton(inputId = "act_eval", disabled = TRUE) + } else { + shiny::updateActionButton(inputId = "act_start", disabled = FALSE) + shiny::updateActionButton(inputId = "modal_browse", disabled = FALSE) + shiny::updateActionButton(inputId = "act_eval", disabled = FALSE) + } + }) + + ############################################################################## + ######### + ######### Data modification section + ######### + ############################################################################## + + shiny::observeEvent( + eventExpr = list( + rv$data_original + ), + handlerExpr = { + shiny::req(rv$data_original) + + rv$data <- rv$data_original + } + ) + + ## For now this solution work, but I would prefer to solve this with the above + shiny::observeEvent(input$reset_confirm, + { + if (isTRUE(input$reset_confirm)) { + shiny::req(rv$data_original) + rv$data <- rv$data_original + rv$code$filter <- NULL + rv$code$variables <- NULL + rv$code$modify <- NULL + } + }, + ignoreNULL = TRUE + ) + + + shiny::observeEvent(input$data_reset, { + shinyWidgets::ask_confirmation( + cancelOnDismiss = TRUE, + inputId = "reset_confirm", + title = "Please confirm data reset?", + type = "warning" + ) + }) + + + ######### + ######### Modifications + ######### + + ## Using modified version of the datamods::cut_variable_server function + ## Further modifications are needed to have cut/bin options based on class of variable + ## Could be defined server-side + + output$data_info <- shiny::renderUI({ + shiny::req(data_filter()) + data_description(data_filter(), "The filtered data") + }) + + ######### Create factor + + shiny::observeEvent( + input$modal_cut, + modal_cut_variable("modal_cut", title = "Create new factor") + ) + + data_modal_cut <- cut_variable_server( + id = "modal_cut", + data_r = shiny::reactive(rv$data) + ) + + shiny::observeEvent(data_modal_cut(), { + rv$data <- data_modal_cut() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + ######### Modify factor + + shiny::observeEvent( + input$modal_update, + datamods::modal_update_factor(id = "modal_update", title = "Reorder factor levels") + ) + + data_modal_update <- datamods::update_factor_server( + id = "modal_update", + data_r = reactive(rv$data) + ) + + shiny::observeEvent(data_modal_update(), { + shiny::removeModal() + rv$data <- data_modal_update() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + ######### Create column + + shiny::observeEvent( + input$modal_column, + modal_create_column( + id = "modal_column", + footer = shiny::markdown("This window is aimed at advanced users and require some *R*-experience!"), + title = "Create new variables" + ) + ) + data_modal_r <- create_column_server( + id = "modal_column", + data_r = reactive(rv$data) + ) + shiny::observeEvent( + data_modal_r(), + { + rv$data <- data_modal_r() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + } + ) + + ######### Subset, rename, reclass + + updated_data <- update_variables_server( + id = "modal_variables", + data = shiny::reactive(rv$data), + return_data_on_init = FALSE + ) + + shiny::observeEvent(updated_data(), { + rv$data <- updated_data() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + ### Column filter + ### Completely implemented, but it takes a little considering where in the + ### data flow to implement, as it will act destructively on previous + ### manipulations + + output$column_filter <- shiny::renderUI({ + shiny::req(rv$data) + # c("dichotomous", "ordinal", "categorical", "datatime", "continuous") + shinyWidgets::virtualSelectInput( + inputId = "column_filter", + label = "Select variable types to include", + selected = unique(data_type(rv$data)), + choices = unique(data_type(rv$data)), + updateOn = "change", + multiple = TRUE, + search = FALSE, + showValueAsTags = TRUE + ) + }) + + shiny::observe({ + # shiny::req(input$column_filter) + out <- data_type_filter(rv$data, input$column_filter) + rv$data_variables <- out + if (!is.null(input$column_filter)) { + rv$code$variables <- attr(out, "code") + } + # rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + + ######### Data filter + # IDEAFilter has the least cluttered UI, but might have a License issue + # Consider using shinyDataFilter, though not on CRAN + data_filter <- IDEAFilter::IDEAFilter("data_filter", + data = shiny::reactive(rv$data_variables), + verbose = TRUE + ) + + shiny::observeEvent( + list( + shiny::reactive(rv$data_variables), + shiny::reactive(rv$data_original), + data_filter(), + # regression_vars(), + input$complete_cutoff + ), + { + ### Save filtered data + rv$data_filtered <- data_filter() + + ### Save filtered data + ### without empty factor levels + rv$list$data <- data_filter() |> + REDCapCAST::fct_drop() |> + (\(.x){ + .x[!sapply(.x, is.character)] + })() + + ## This looks messy!! But it works as intended for now + + out <- gsub( + "filter", "dplyr::filter", + gsub( + "\\s{2,}", " ", + paste0( + capture.output(attr(rv$data_filtered, "code")), + collapse = " " + ) + ) + ) + + out <- strsplit(out, "%>%") |> + unlist() |> + (\(.x){ + paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"), + collapse = "|> \n " + ) + })() + + rv$code <- append_list(data = out, list = rv$code, index = "filter") + } + ) + + ######### Data preview + + ### Overview + + data_summary_server( + id = "data_summary", + data = shiny::reactive({ + rv$data_filtered + }), + color.main = "#2A004E", + color.sec = "#C62300", + pagination = 10 + ) + + observeEvent(input$modal_browse, { + show_data(REDCapCAST::fct_drop(rv$data_filtered), title = "Uploaded data overview", type = "modal") + }) + + output$original_str <- renderPrint({ + str(rv$data_original) + }) + + output$modified_str <- renderPrint({ + str(as.data.frame(rv$data_filtered) |> + REDCapCAST::set_attr( + label = NULL, + attr = "code" + )) + }) + + + ############################################################################## + ######### + ######### Code export + ######### + ############################################################################## + + ## This really should be collapsed to only one call, but I'll leave it for now + ## as a working example of dynamically defining outputs and rendering. + + # output$code_import <- shiny::renderPrint({ + # shiny::req(rv$code$import) + # cat(c("#Data import\n", rv$code$import)) + # }) + + output$code_import <- shiny::renderUI({ + prismCodeBlock(paste0("#Data import\n", rv$code$import)) + }) + + output$code_import <- shiny::renderUI({ + prismCodeBlock(paste0("#Data import formatting\n", rv$code$format)) + }) + + output$code_data <- shiny::renderUI({ + shiny::req(rv$code$modify) + # browser() + ## This will create three lines for each modification + # ls <- rv$code$modify + ## This will remove all non-unique entries + # ls <- rv$code$modify |> unique() + ## This will only remove all non-repeating entries + ls <- rv$code$modify[!is_identical_to_previous(rv$code$modify)] + + out <- ls |> + lapply(expression_string) |> + pipe_string() |> + expression_string(assign.str = "df <- df |>\n") + + prismCodeBlock(paste0("#Data modifications\n", out)) + }) + + output$code_variables <- shiny::renderUI({ + shiny::req(rv$code$variables) + out <- expression_string(rv$code$variables, assign.str = "df <- df |>\n") + prismCodeBlock(paste0("#Variables filter\n", out)) + }) + + output$code_filter <- shiny::renderUI({ + shiny::req(rv$code$filter) + prismCodeBlock(paste0("#Data filter\n", rv$code$filter)) + }) + + output$code_table1 <- shiny::renderUI({ + shiny::req(rv$code$table1) + prismCodeBlock(paste0("#Data characteristics table\n", rv$code$table1)) + }) + + + ## Just a note to self + ## This is a very rewarding couple of lines marking new insights to dynamically rendering code + shiny::observe({ + rv$regression()$regression$models |> purrr::imap(\(.x, .i){ + output[[paste0("code_", tolower(.i))]] <- shiny::renderUI({ + prismCodeBlock(paste0(paste("#", .i, "regression model\n"), .x$code_table)) + }) + }) + }) + + + ############################################################################## + ######### + ######### Data analyses Inputs + ######### + ############################################################################## + + output$strat_var <- shiny::renderUI({ + columnSelectInput( + inputId = "strat_var", + selected = "none", + label = "Select variable to stratify baseline", + data = shiny::reactive(rv$data_filtered)(), + col_subset = c( + "none", + names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] + ) + ) + }) + + ############################################################################## + ######### + ######### Descriptive evaluations + ######### + ############################################################################## + + + output$data_info_nochar <- shiny::renderUI({ + shiny::req(rv$list$data) + data_description(rv$list$data, data_text = "The dataset without text variables") + }) + + shiny::observeEvent( + list( + input$act_eval + ), + { + shiny::req(input$strat_var) + shiny::req(rv$list$data) + + parameters <- list( + by.var = input$strat_var, + add.p = input$add_p == "yes", + add.overall = TRUE + ) + + shiny::withProgress(message = "Creating the table. Hold on for a moment..", { + rv$list$table1 <- rlang::exec(create_baseline, !!!append_list(rv$list$data, parameters, "data")) + }) + + rv$code$table1 <- glue::glue("FreesearchR::create_baseline(data,{list2str(parameters)})") + } + ) + + output$outcome_var_cor <- shiny::renderUI({ + columnSelectInput( + inputId = "outcome_var_cor", + selected = "none", + data = rv$list$data, + label = "Select outcome variable", + col_subset = c( + "none", + colnames(rv$list$data) + ), + multiple = FALSE + ) + }) + + output$table1 <- gt::render_gt({ + shiny::req(rv$list$table1) + + rv$list$table1 |> + gtsummary::as_gt() |> + gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) + }) + + data_correlations_server( + id = "correlations", + data = shiny::reactive({ + shiny::req(rv$list$data) + out <- rv$list$data + if (!is.null(input$outcome_var_cor) && input$outcome_var_cor != "none") { + out <- out[!names(out) %in% input$outcome_var_cor] + } + out + }), + cutoff = shiny::reactive(input$cor_cutoff) + ) + + ############################################################################## + ######### + ######### Data visuals + ######### + ############################################################################## + + pl <- data_visuals_server("visuals", data = shiny::reactive(rv$list$data)) + + ############################################################################## + ######### + ######### Regression model analyses + ######### + ############################################################################## + + rv$regression <- regression_server("regression", data = shiny::reactive(rv$list$data)) + + ############################################################################## + ######### + ######### Page navigation + ######### + ############################################################################## + + shiny::observeEvent(input$act_start, { + bslib::nav_select(id = "main_panel", selected = "Data") + }) + + ############################################################################## + ######### + ######### Reactivity + ######### + ############################################################################## + + output$uploaded <- shiny::reactive({ + if (is.null(rv$ds)) { + "no" + } else { + "yes" + } + }) + + shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE) + + output$ready <- shiny::reactive({ + if (is.null(rv$ready)) { + "no" + } else { + "yes" + } + }) + + shiny::outputOptions(output, "ready", suspendWhenHidden = FALSE) + + ############################################################################## + ######### + ######### Downloads + ######### + ############################################################################## + + # Could be rendered with other tables or should show progress + # Investigate quarto render problems + # On temp file handling: https://github.com/quarto-dev/quarto-cli/issues/3992 + output$report <- downloadHandler( + filename = shiny::reactive({ + paste0("report.", input$output_type) + }), + content = function(file, type = input$output_type) { + # shiny::req(rv$list$regression) + ## Notification is not progressing + ## Presumably due to missing + # browser() + # Simplified for .rmd output attempt + format <- ifelse(type == "docx", "word_document", "odt_document") + + # browser() + rv$list$regression <- rv$regression() + + shiny::withProgress(message = "Generating the report. Hold on for a moment..", { + tryCatch( + { + rv$list |> + write_rmd( + output_format = format, + input = file.path(getwd(), "www/report.rmd") + ) + }, + error = function(err) { + showNotification(paste0("We encountered the following error creating your report: ", err), type = "err") + } + ) + }) + file.rename(paste0("www/report.", type), file) + } + ) + + output$data_modified <- downloadHandler( + filename = shiny::reactive({ + paste0("modified_data.", input$data_type) + }), + content = function(file, type = input$data_type) { + if (type == "rds") { + readr::write_rds(rv$list$data, file = file) + } else if (type == "dta") { + haven::write_dta(as.data.frame(rv$list$data), path = file) + } else if (type == "csv") { + readr::write_csv(rv$list$data, file = file) + } + } + ) + + ############################################################################## + ######### + ######### Clearing the session on end + ######### + ############################################################################## + + session$onSessionEnded(function() { + cat("Session Ended\n") + files <- list.files("www/") + lapply(files[!files %in% files.to.keep], \(.x){ + unlink(paste0("www/", .x), recursive = FALSE) + print(paste(.x, "deleted")) + }) + }) +} diff --git a/inst/apps/FreesearchR/ui.R b/inst/apps/FreesearchR/ui.R index d1a7259a..3e792943 100644 --- a/inst/apps/FreesearchR/ui.R +++ b/inst/apps/FreesearchR/ui.R @@ -508,10 +508,13 @@ dark <- custom_theme( # Fonts to consider: # https://webdesignerdepot.com/17-open-source-fonts-youll-actually-love/ -ui_list <- shiny::tagList( +ui <- bslib::page_fixed( prismDependencies, prismRDependency, - header_include(), + ## Basic Umami page tracking + shiny::tags$head( + includeHTML(("www/umami-app.html")), + tags$link(rel = "stylesheet", type = "text/css", href = "style.css")), ## This adds the actual favicon ## png and ico versions are kept for compatibility shiny::tags$head(tags$link(rel="shortcut icon", href="favicon.svg")), @@ -543,12 +546,3 @@ ui_list <- shiny::tagList( ) ) ) - -# ui_list <- shiny::tagAppendChild(ui_list,list( -# ## Basic Umami page tracking -# shiny::tags$head(includeHTML("www/umami-app.html")) -# # shiny::tags$head(shiny::tags$script(rel="defer", src="https://analytics.gdamsbo.dk/script.js", "data-website-id"="e7d4e13a-5824-4778-bbc0-8f92fb08303a")) -# )) - -ui <- do.call( - bslib::page_fixed,ui_list) diff --git a/inst/apps/FreesearchR/www/umami-app.html b/inst/apps/FreesearchR/www/umami-app.html new file mode 100644 index 00000000..1270d512 --- /dev/null +++ b/inst/apps/FreesearchR/www/umami-app.html @@ -0,0 +1 @@ +