From 1e85fd347f0766290b65392781c7ca9b7ff8176b Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 30 Apr 2025 10:02:29 +0200 Subject: [PATCH] reset outputs on updated data --- R/app_version.R | 2 +- R/data_plots.R | 20 ++- R/regression-module.R | 123 +++++++------ R/sysdata.rda | Bin 1932 -> 2358 bytes SESSION.md | 307 +++++++++++++++++++-------------- inst/apps/FreesearchR/app.R | 179 ++++++++++++------- inst/apps/FreesearchR/server.R | 29 +++- 7 files changed, 409 insertions(+), 251 deletions(-) diff --git a/R/app_version.R b/R/app_version.R index 84fbc45..33d7631 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'v25.4.4.250429' +app_version <- function()'v25.4.4.250430' diff --git a/R/data_plots.R b/R/data_plots.R index d93b0ea..51fc249 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -351,9 +351,25 @@ 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 + # shiny::req(rv$plot) + # rv$plot + if (!is.null(rv$plot)) { + rv$plot + } else { + return(NULL) + } }) output$download_plot <- shiny::downloadHandler( diff --git a/R/regression-module.R b/R/regression-module.R index 6cd4aea..c131f30 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,49 +413,68 @@ regression_server <- function(id, shiny::req(rv$check_plot) shiny::req(input$plot_checks) - p <- rv$check_plot() + - # patchwork::wrap_plots() + - patchwork::plot_annotation(title = "Multivariable regression model 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") - 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") + layout <- sapply(seq_len(length(p)), \(.x){ + patchwork::area(.x, 1) }) - ) - ls <- list() + p_list <- p + patchwork::plot_layout(design = Reduce(c, layout)) - 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") + 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) + } }, alt = "Assumptions testing of the multivariable regression model" ) -### Creating the regression table + shiny::observeEvent( + list( + data_r(), + regression_vars() + ), + { + rv$list$regression$tables <- NULL + } + ) + + ### Creating the regression table shiny::observeEvent( input$load, { @@ -475,9 +494,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 |> @@ -490,16 +509,18 @@ 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" + ) }) list( rv$code$import, - rlang::call2(.fn = "select",!!!list(input$import_var),.ns = "dplyr"), - rlang::call2(.fn = "default_parsing",.ns = "FreesearchR") + rlang::call2(.fn = "select", !!!list(input$import_var), .ns = "dplyr"), + rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") ) |> merge_expression() |> expression_string() @@ -519,11 +540,15 @@ regression_server <- function(id, ) output$table2 <- gt::render_gt({ - 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}**"))) + ## 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) + } }) ############################################################################## @@ -619,5 +644,3 @@ regression_server <- function(id, } ) } - - diff --git a/R/sysdata.rda b/R/sysdata.rda index cef8f94e026cd891e68d2988d5d9c0cdd5a78e85..d77ab95cb016bf329440288de556030464f3378c 100644 GIT binary patch literal 2358 zcmV-63CZ?CT4*^jL0KkKSqB*{(*PCUf6)K`Xaz!l|KNXX-@w2B|L{Nn00;;H;0j+p z-b8!D;Bh5JfkO`pEO#%T75lqSrlnj6X0qQg~^#-ZwrhrVNB|k}l zsivmMGBjw=000^Q0icQLkV;Sk)Ea0Wpa1|g000000Va|pDxaz3k5qaMOivWh+9m-E zMuvdM^%*q6Fd0c1sgNcCKTwS_X@fvOG-wPH5IsFaF$76XL_J0k05s8~C#V_#000dJ zjDTdpE^-r0qeTpcDnizz6fngFP7l3{l|;JY8U78;jGGzjpc)(g?hW%8p4g@`OHvgK z9VA?5m(BY?l9Uob1c|5wt{BqO+gR0p{{pr&hZn6d0=0Yft}id?U-fHDO3(Mk9zM58 z&a!cQl4f8WjCm{MQkJF~>5Rmbl1#iX#gm^Bh-fSvv)v$&V$Q7;))*3;YK$m)7Fj!0 z)X;&4x+&ckI?cAzzSdEf?W_CC@pS|D+9=LztnIX}6Tq)E;>8#wg(;_#n6ft{QD2#U zy7|XLjBvR)X&Xy&nv>Bxib$YpHU~J2F+0o4wh~YH_ku0=Ki(}fV`fG%WmGRE403f% zj<>C3bRRm>WvVBP+g?CzZXnsdo%op=rYc0qJSz$~wU=s9m!}A`prKqDkuOqUqsg{- zdd^-BTFX4cNui=dRp`9lT)br3hs(xd^HiADYVbu|MCL=tl;lJ*YXBhi8xYJjOm(`c zvnAD94OW)qHo+Z}Ho0TV#lzXj%FfZatU8r`YAlL|j7I)8hP}0COb+Z+5a~`nKEBR@sdG= z0Yp@SAfT{ORxCyfBv6V$NU=c}EJRUcSst%Pp11i+AI}VAdn(hOutq2uz3(&&2Pjml z;-QQ%MFUAh;fCF{rjswGhV{cRt(Na9_?d!Zp)|v6=c}`f#*LW5y4B4z z7%I5iYiyyDrFAgT2|PpwyNQ@6G9kDFF4uFJu!CH%6LSV0j!G{;mJc-exPT!bt}$7; zlNW0Z1wITTUo2f#iC9x{W||skW^@R}Ow%jhE_BW{vHgzw+E$G5?+Q`GSJyghy}JBS^`4<)Pu>ng^hYL!nbL<1t}3MfCm!H4iX_XJ&1 z>Lr+&HD-*8Pvfm&r^4bN7mNwe5J(~kl}?% zQQ>=(?X(3K{L;RMI2fVB0Ydcebl>2%wXKyH@te`0V1h(sQH(?mEt7Ux5fVzln_vOa`?X7-@(hoE^V={to%AT?X4=+v&IYt_YiLnhZ^<~5dVC55$_+Y6qJJ! z1$ylbuEr90j!~+ndmpl1EPxKV9zJzL09KIB%1RFvO|d$aRhh9+mgNbvD0k@_M6@@Q zdbhYzMOGdwS?P~Z{`l`gR#>-e(I1?w5Y>seB*E-e#f*ie5!okao$AGR8g5+LF``2 z)Ymc;Txt)@aE-hHhb^Z2i3w}iGEy%hlZKo(g0W;=#*G<@g$GO6YHA~uVc{#5C0d2H zGlSMmSh(aXaFx3^<*L}QV`D`Wwfu*7K8Om4Tu~JlLMEn6Dj_On_oatS_b#jEK{(WU zlr1SB3BX)ALZ>XVgA-1YrRE@8%ASzD-gF0kcE+|3kze1eN|SYAL8ATeCbAO}1y}H5eG;T(Vp@V`ud%E`S5fw#-z%MvYqrOhoxdSNVeM*F3B6j_tIF{kEx3Y`YmbtFz zU}Uj0$cZ0+9<{b1u@G1Vaa|!5I6C5T8!TeYb)_PU>JPF8XM&N!xsI&b$;4<^THj}Z zq;bU>_4X_b)UI&nk92 zgE&im0h);&wm#0od2@UL$aZ=o9-bOuO%S~KU8fkN1#0DJga~f((IKAeVSX$FYK7@} zCrq>E+Cfz8^t-KqEh?Tj_invnwes?W3UeOs9FogGm86j`1BIBtZE|Ml0)^$gcQvppl_x4zP2*xzI3KnYF%rIwQK{ComZj|ij+d8g$f*( zWLR@z@USKW%Vokr@VHco?W#QNeQ`ZC4M*PFr9l|=F;tR4^nG zvC#S8dq@E%Y#=}w1R$hAMGydhumZ4>Ne|&50n&g-W46-vbyeHq$ZvQ+aKfPO?%}hB zRNu$Wga9qKT1mwqu|PqB!5FeA3JMD#q*$vKMHE;)_l>_hdDQa*3?5dS>>jwa!nN~1BhH(j%nhHnJhco3Cj2^7dyDLA1hfrgACF`P|6?we)U6k=2< zgvBP_2_i^ZB%CRR?{x)pGNw~s` z7jalgC}KqPcG-WFL!IQ@~ZSbUtY!>3ag)=$f~+H z>+RcSzXs1lxr<(@yj(xS!MIOV4n_QZn<-K^5FakTK>R)LNf8e($AelO`3~_|E0oCj z)=BJB{$#I#{nmx~KNV zSUa%v%r9kYQ2p(7Zon&ZgogYdCY~Xvg7gVQZ6k6izx79g^fz*KC(=6h-nLkK@Y!M$uYAV8EEh0PsUTxUT)T;;{#WQ(&hU=oc4G!$B6VM8eCV;c0XbgjCJ zn<&Vs6j_cmI;d*c<@fWa9SSTjiX1SqY%MkCjfe{gBs#Eaq!ZUdTLxD))05_faI+`} zO?YI98iXLlkymv{s8=D{Sm~yTPJsk$%6%Xt_uN$nnr%v9M|_b-Or7u|azO(% 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( @@ -7452,49 +7468,68 @@ regression_server <- function(id, shiny::req(rv$check_plot) shiny::req(input$plot_checks) - p <- rv$check_plot() + - # patchwork::wrap_plots() + - patchwork::plot_annotation(title = "Multivariable regression model 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") - 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") + layout <- sapply(seq_len(length(p)), \(.x){ + patchwork::area(.x, 1) }) - ) - ls <- list() + p_list <- p + patchwork::plot_layout(design = Reduce(c, layout)) - 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") + 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) + } }, alt = "Assumptions testing of the multivariable regression model" ) -### Creating the regression table + shiny::observeEvent( + list( + data_r(), + regression_vars() + ), + { + rv$list$regression$tables <- NULL + } + ) + + ### Creating the regression table shiny::observeEvent( input$load, { @@ -7514,9 +7549,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 |> @@ -7529,16 +7564,18 @@ 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" + ) }) list( rv$code$import, - rlang::call2(.fn = "select",!!!list(input$import_var),.ns = "dplyr"), - rlang::call2(.fn = "default_parsing",.ns = "FreesearchR") + rlang::call2(.fn = "select", !!!list(input$import_var), .ns = "dplyr"), + rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") ) |> merge_expression() |> expression_string() @@ -7558,11 +7595,15 @@ regression_server <- function(id, ) output$table2 <- gt::render_gt({ - 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}**"))) + ## 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) + } }) ############################################################################## @@ -7660,8 +7701,6 @@ regression_server <- function(id, } - - ######## #### Current file: /Users/au301842/FreesearchR/R//report.R ######## @@ -9678,10 +9717,13 @@ dark <- custom_theme( ui <- bslib::page_fixed( prismDependencies, prismRDependency, + ## Basic Umami page tracking 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")), + ## This adds the actual favicon + ## png and ico versions are kept for compatibility + shiny::tags$head(tags$link(rel="shortcut icon", href="favicon.svg")), title = "FreesearchR", theme = light, shiny::useBusyIndicators(), @@ -9751,7 +9793,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) @@ -10182,6 +10224,20 @@ 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 + } + ) + ############################################################################## ######### @@ -10243,6 +10299,7 @@ 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)) @@ -10319,11 +10376,13 @@ server <- function(input, output, session) { }) 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**")) + if (!is.null(rv$list$table1)) { + rv$list$table1 |> + gtsummary::as_gt() |> + gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) + } else { + return(NULL) + } }) data_correlations_server( diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R index 25fd838..fdc7f4e 100644 --- a/inst/apps/FreesearchR/server.R +++ b/inst/apps/FreesearchR/server.R @@ -33,7 +33,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) @@ -464,6 +464,20 @@ 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 + } + ) + ############################################################################## ######### @@ -525,6 +539,7 @@ 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)) @@ -601,11 +616,13 @@ server <- function(input, output, session) { }) 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**")) + if (!is.null(rv$list$table1)) { + rv$list$table1 |> + gtsummary::as_gt() |> + gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) + } else { + return(NULL) + } }) data_correlations_server(