andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2025-09-12 09:59:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

strugling with reactivity
Some checks failed
pkgdown.yaml / pkgdown (push) Has been cancelled
Details

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-03-20 13:13:14 +01:00
parent 7df711424e
commit 1bfad4ba4c
No known key found for this signature in database
6 changed files with 237 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
R/data_plots.R
View file

@ -500,6 +500,7 @@ supported_plots <- function() {
#' possible_plots() #' possible_plots()
possible_plots <- function(data) { possible_plots <- function(data) {
# browser() # browser()
# data <- if (is.reactive(data)) data() else data
if (is.data.frame(data)) { if (is.data.frame(data)) {
data <- data[[1]] data <- data[[1]]
} }
@ -596,6 +597,7 @@ create_plot <- function(data, type, x, y, z = NULL, ...) {
#' gtsummary::trial |> get_label(var = "trt") #' gtsummary::trial |> get_label(var = "trt")
#' 1:10 |> get_label() #' 1:10 |> get_label()
get_label <- function(data, var = NULL) { get_label <- function(data, var = NULL) {
# data <- if (is.reactive(data)) data() else data
if (!is.null(var) & is.data.frame(data)) { if (!is.null(var) & is.data.frame(data)) {
data <- data[[var]] data <- data[[var]]
} }

1
R/regression_model.R
View file

@ -357,6 +357,7 @@ supported_functions <- function() {
#' possible_functions(design = "cross-sectional") #' possible_functions(design = "cross-sectional")
possible_functions <- function(data, design = c("cross-sectional")) { possible_functions <- function(data, design = c("cross-sectional")) {
# browser() # browser()
# data <- if (is.reactive(data)) data() else data
if (is.data.frame(data)) { if (is.data.frame(data)) {
data <- data[[1]] data <- data[[1]]
} }

189
inst/apps/FreesearchR/app.R
View file

@ -10,7 +10,7 @@
#### Current file: R//app_version.R #### Current file: R//app_version.R
######## ########
app_version <- function()'250320_1144' app_version <- function()'250320_1310'
######## ########
@ -329,13 +329,16 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
return '<div style=\"padding: 3px 12px\">' + return '<div style=\"padding: 3px 12px\">' +
'<div><strong>' + '<div><strong>' +
escape(item.data.name) + ' ' + escape(item.data.name) + ' ' +
'</strong>' +
(item.data.dataclass != '' ?
'<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' + '<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
item.data.dataclass + item.data.dataclass +
'</code></span>' + ' ' + '</code></span>' : '' ) + ' ' +
(item.data.datatype != '' ?
'<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' + '<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
item.data.datatype + item.data.datatype +
'</code></span>' + '</code></span>' : '' ) +
'</strong></div>' + '</div>' +
(item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') + (item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') +
'</div>'; '</div>';
}, },
@ -353,7 +356,76 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
) )
} }
columnSelectInputStat <- function(inputId, label, data, selected = "", ...,
col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected",maxItems=NULL) {
data <- if (is.reactive(data)) data() else data
col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset)
labels <- Map(function(col) {
json <- sprintf(
IDEAFilter:::strip_leading_ws('
{
"name": "%s",
"label": "%s",
"dataclass": "%s",
"datatype": "%s"
}'),
col,
attr(data[[col]], "label") %||% "",
IDEAFilter:::get_dataFilter_class(data[[col]]),
data_type(data[[col]])
)
}, col = names(data))
if (!"none" %in% names(data)){
labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }',none_label)),labels)
choices <- setNames(names(labels), labels)
choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(data) else col_subsetr(), choices)]
} else {
choices <- setNames(names(data), labels)
choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)]
}
shiny::selectizeInput(
inputId = inputId,
label = label,
choices = choices,
selected = selected,
...,
options = c(
list(render = I("{
// format the way that options are rendered
option: function(item, escape) {
item.data = JSON.parse(item.label);
return '<div style=\"padding: 3px 12px\">' +
'<div><strong>' +
escape(item.data.name) + ' ' +
'</strong>' +
(item.data.dataclass != '' ?
'<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
item.data.dataclass +
'</code></span>' : '' ) + ' ' +
(item.data.datatype != '' ?
'<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
item.data.datatype +
'</code></span>' : '' ) +
'</div>' +
(item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') +
'</div>';
},
// avoid data vomit splashing on screen when an option is selected
item: function(item, escape) {
item.data = JSON.parse(item.label);
return '<div>' +
escape(item.data.name) +
'</div>';
}
}")),
if (!is.null(maxItems)) list(maxItems=maxItems)
)
)
}
#' A selectizeInput customized for named vectors #' A selectizeInput customized for named vectors
#' #'
@ -1602,6 +1674,7 @@ supported_plots <- function() {
#' possible_plots() #' possible_plots()
possible_plots <- function(data) { possible_plots <- function(data) {
# browser() # browser()
# data <- if (is.reactive(data)) data() else data
if (is.data.frame(data)) { if (is.data.frame(data)) {
data <- data[[1]] data <- data[[1]]
} }
@ -1698,6 +1771,7 @@ create_plot <- function(data, type, x, y, z = NULL, ...) {
#' gtsummary::trial |> get_label(var = "trt") #' gtsummary::trial |> get_label(var = "trt")
#' 1:10 |> get_label() #' 1:10 |> get_label()
get_label <- function(data, var = NULL) { get_label <- function(data, var = NULL) {
# data <- if (is.reactive(data)) data() else data
if (!is.null(var) & is.data.frame(data)) { if (!is.null(var) & is.data.frame(data)) {
data <- data[[var]] data <- data[[var]]
} }
@ -2270,6 +2344,8 @@ add_class_icon <- function(grid, column = "class") {
shiny::icon("arrow-down-1-9") shiny::icon("arrow-down-1-9")
} else if (identical(x, "character")) { } else if (identical(x, "character")) {
shiny::icon("arrow-down-a-z") shiny::icon("arrow-down-a-z")
} else if (identical(x, "logical")) {
shiny::icon("toggle-off")
} else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) { } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) {
shiny::icon("calendar-days") shiny::icon("calendar-days")
} else if ("hms" %in% x) { } else if ("hms" %in% x) {
@ -4927,6 +5003,7 @@ supported_functions <- function() {
#' possible_functions(design = "cross-sectional") #' possible_functions(design = "cross-sectional")
possible_functions <- function(data, design = c("cross-sectional")) { possible_functions <- function(data, design = c("cross-sectional")) {
# browser() # browser()
# data <- if (is.reactive(data)) data() else data
if (is.data.frame(data)) { if (is.data.frame(data)) {
data <- data[[1]] data <- data[[1]]
} }
@ -7244,6 +7321,15 @@ ui_elements <- list(
) )
), ),
shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
),
shiny::br(),
shiny::br(),
shiny::actionButton(
inputId = "act_eval",
label = "Evaluate",
width = "100%",
icon = shiny::icon("calculator"),
disabled = FALSE
) )
), ),
bslib::accordion_panel( bslib::accordion_panel(
@ -7916,6 +8002,7 @@ server <- function(input, output, session) {
rv$data_filtered <- data_filter() rv$data_filtered <- data_filter()
### Save filtered data ### Save filtered data
### without empty factor levels
rv$list$data <- data_filter() |> rv$list$data <- data_filter() |>
REDCapCAST::fct_drop() REDCapCAST::fct_drop()
@ -8045,23 +8132,39 @@ server <- function(input, output, session) {
## Keep these "old" selection options as a simple alternative to the modification pane ## Keep these "old" selection options as a simple alternative to the modification pane
output$include_vars <- shiny::renderUI({ output$include_vars <- shiny::renderUI({
shiny::selectizeInput( columnSelectInputStat(
inputId = "include_vars", inputId = "include_vars",
selected = NULL, selected = NULL,
label = "Covariables to include", label = "Covariables to include",
choices = colnames(rv$data_filtered), data = rv$data_filtered,
multiple = TRUE multiple = TRUE
) )
# shiny::selectizeInput(
# inputId = "include_vars",
# selected = NULL,
# label = "Covariables to include",
# choices = colnames(rv$data_filtered),
# multiple = TRUE
# )
}) })
output$outcome_var <- shiny::renderUI({ output$outcome_var <- shiny::renderUI({
shiny::selectInput( columnSelectInputStat(
inputId = "outcome_var", inputId = "outcome_var",
selected = NULL, selected = NULL,
label = "Select outcome variable", label = "Select outcome variable",
choices = colnames(rv$data_filtered), data = rv$data_filtered,
multiple = FALSE multiple = FALSE
) )
# shiny::selectInput(
# inputId = "outcome_var",
# selected = NULL,
# label = "Select outcome variable",
# choices = colnames(rv$data_filtered),
# multiple = FALSE
# )
}) })
output$regression_type <- shiny::renderUI({ output$regression_type <- shiny::renderUI({
@ -8104,25 +8207,37 @@ server <- function(input, output, session) {
}) })
output$strat_var <- shiny::renderUI({ output$strat_var <- shiny::renderUI({
shiny::selectInput( columnSelectInputStat(
inputId = "strat_var", inputId = "strat_var",
selected = "none", selected = "none",
label = "Select variable to stratify baseline", label = "Select variable to stratify baseline",
choices = c( data = rv$data_filtered,
col_subset = c(
"none", "none",
rv$data_filtered |> names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")]
(\(.x){
lapply(.x, \(.c){
if (identical("factor", class(.c))) {
.c
}
}) |>
dplyr::bind_cols()
})() |>
colnames()
),
multiple = FALSE
) )
)
# shiny::selectInput(
# inputId = "strat_var",
# selected = "none",
# label = "Select variable to stratify baseline",
# choices = c(
# "none",
# names(rv$list$data)[unlist(lapply(rv$list$data,data_type)) %in% c("dichotomous","categorical","ordinal")]
# # rv$data_filtered |>
# # (\(.x){
# # lapply(.x, \(.c){
# # if (identical("factor", class(.c))) {
# # .c
# # }
# # }) |>
# # dplyr::bind_cols()
# # })() |>
# # colnames()
# ),
# multiple = FALSE
# )
}) })
@ -8147,27 +8262,37 @@ server <- function(input, output, session) {
shiny::observeEvent( shiny::observeEvent(
# ignoreInit = TRUE, # ignoreInit = TRUE,
list( list(
shiny::reactive(rv$list$data), # shiny::reactive(rv$list$data),
shiny::reactive(rv$data), # shiny::reactive(rv$data),
shiny::reactive(rv$data_original), # shiny::reactive(rv$data_original),
data_filter(), # data_filter(),
input$strat_var, # input$strat_var,
input$include_vars, # input$include_vars,
input$complete_cutoff, # input$complete_cutoff,
input$add_p # input$add_p
input$act_eval
), ),
{ {
shiny::req(input$strat_var) shiny::req(input$strat_var)
shiny::req(rv$list$data) shiny::req(rv$list$data)
if (input$strat_var == "none" | !input$strat_var %in% names(rv$list$data)) { data_tbl1 <- rv$list$data
if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) {
by.var <- NULL by.var <- NULL
} else { } else {
by.var <- input$strat_var by.var <- input$strat_var
} }
## These steps are to handle logicals/booleans, that messes up the order of columns
## Has been reported
if (!is.null(by.var) & identical("logical",class(data_tbl1[[by.var]]))) {
data_tbl1[by.var] <- as.character(data_tbl1[[by.var]])
}
rv$list$table1 <- rv$list$table1 <-
rv$list$data |> data_tbl1 |>
baseline_table( baseline_table(
fun.args = fun.args =
list( list(

2
inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf
View file

@ -5,6 +5,6 @@ account: agdamsbo
server: shinyapps.io server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1 hostUrl: https://api.shinyapps.io/v1
appId: 13611288 appId: 13611288
bundleId: 9969300 bundleId: 9974967
url: https://agdamsbo.shinyapps.io/freesearcheR/ url: https://agdamsbo.shinyapps.io/freesearcheR/
version: 1 version: 1

95
inst/apps/FreesearchR/server.R
View file

@ -339,6 +339,7 @@ server <- function(input, output, session) {
rv$data_filtered <- data_filter() rv$data_filtered <- data_filter()
### Save filtered data ### Save filtered data
### without empty factor levels
rv$list$data <- data_filter() |> rv$list$data <- data_filter() |>
REDCapCAST::fct_drop() REDCapCAST::fct_drop()
@ -468,23 +469,39 @@ server <- function(input, output, session) {
## Keep these "old" selection options as a simple alternative to the modification pane ## Keep these "old" selection options as a simple alternative to the modification pane
output$include_vars <- shiny::renderUI({ output$include_vars <- shiny::renderUI({
shiny::selectizeInput( columnSelectInputStat(
inputId = "include_vars", inputId = "include_vars",
selected = NULL, selected = NULL,
label = "Covariables to include", label = "Covariables to include",
choices = colnames(rv$data_filtered), data = rv$data_filtered,
multiple = TRUE multiple = TRUE
) )
# shiny::selectizeInput(
# inputId = "include_vars",
# selected = NULL,
# label = "Covariables to include",
# choices = colnames(rv$data_filtered),
# multiple = TRUE
# )
}) })
output$outcome_var <- shiny::renderUI({ output$outcome_var <- shiny::renderUI({
shiny::selectInput( columnSelectInputStat(
inputId = "outcome_var", inputId = "outcome_var",
selected = NULL, selected = NULL,
label = "Select outcome variable", label = "Select outcome variable",
choices = colnames(rv$data_filtered), data = rv$data_filtered,
multiple = FALSE multiple = FALSE
) )
# shiny::selectInput(
# inputId = "outcome_var",
# selected = NULL,
# label = "Select outcome variable",
# choices = colnames(rv$data_filtered),
# multiple = FALSE
# )
}) })
output$regression_type <- shiny::renderUI({ output$regression_type <- shiny::renderUI({
@ -527,25 +544,37 @@ server <- function(input, output, session) {
}) })
output$strat_var <- shiny::renderUI({ output$strat_var <- shiny::renderUI({
shiny::selectInput( columnSelectInputStat(
inputId = "strat_var", inputId = "strat_var",
selected = "none", selected = "none",
label = "Select variable to stratify baseline", label = "Select variable to stratify baseline",
choices = c( data = rv$data_filtered,
col_subset = c(
"none", "none",
rv$data_filtered |> names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")]
(\(.x){
lapply(.x, \(.c){
if (identical("factor", class(.c))) {
.c
}
}) |>
dplyr::bind_cols()
})() |>
colnames()
),
multiple = FALSE
) )
)
# shiny::selectInput(
# inputId = "strat_var",
# selected = "none",
# label = "Select variable to stratify baseline",
# choices = c(
# "none",
# names(rv$list$data)[unlist(lapply(rv$list$data,data_type)) %in% c("dichotomous","categorical","ordinal")]
# # rv$data_filtered |>
# # (\(.x){
# # lapply(.x, \(.c){
# # if (identical("factor", class(.c))) {
# # .c
# # }
# # }) |>
# # dplyr::bind_cols()
# # })() |>
# # colnames()
# ),
# multiple = FALSE
# )
}) })
@ -570,27 +599,37 @@ server <- function(input, output, session) {
shiny::observeEvent( shiny::observeEvent(
# ignoreInit = TRUE, # ignoreInit = TRUE,
list( list(
shiny::reactive(rv$list$data), # shiny::reactive(rv$list$data),
shiny::reactive(rv$data), # shiny::reactive(rv$data),
shiny::reactive(rv$data_original), # shiny::reactive(rv$data_original),
data_filter(), # data_filter(),
input$strat_var, # input$strat_var,
input$include_vars, # input$include_vars,
input$complete_cutoff, # input$complete_cutoff,
input$add_p # input$add_p
input$act_eval
), ),
{ {
shiny::req(input$strat_var) shiny::req(input$strat_var)
shiny::req(rv$list$data) shiny::req(rv$list$data)
if (input$strat_var == "none" | !input$strat_var %in% names(rv$list$data)) { data_tbl1 <- rv$list$data
if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) {
by.var <- NULL by.var <- NULL
} else { } else {
by.var <- input$strat_var by.var <- input$strat_var
} }
## These steps are to handle logicals/booleans, that messes up the order of columns
## Has been reported
if (!is.null(by.var) & identical("logical",class(data_tbl1[[by.var]]))) {
data_tbl1[by.var] <- as.character(data_tbl1[[by.var]])
}
rv$list$table1 <- rv$list$table1 <-
rv$list$data |> data_tbl1 |>
baseline_table( baseline_table(
fun.args = fun.args =
list( list(

9
inst/apps/FreesearchR/ui.R
View file

@ -304,6 +304,15 @@ ui_elements <- list(
) )
), ),
shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
),
shiny::br(),
shiny::br(),
shiny::actionButton(
inputId = "act_eval",
label = "Evaluate",
width = "100%",
icon = shiny::icon("calculator"),
disabled = FALSE
) )
), ),
bslib::accordion_panel( bslib::accordion_panel(