diff --git a/R/app_version.R b/R/app_version.R index d3c4a1b4..ff73a306 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'250319_1327' +app_version <- function()'250320_1310' diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R index 7a72fc42..3704c98b 100644 --- a/R/custom_SelectInput.R +++ b/R/custom_SelectInput.R @@ -31,16 +31,18 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., { "name": "%s", "label": "%s", + "dataclass": "%s", "datatype": "%s" }'), col, attr(datar()[[col]], "label") %||% "", - IDEAFilter:::get_dataFilter_class(datar()[[col]]) + IDEAFilter:::get_dataFilter_class(datar()[[col]]), + data_type(datar()[[col]]) ) }, col = names(datar())) if (!"none" %in% names(datar())){ - labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"datatype\": \"\"\n }',none_label)),labels) + 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(datar()) else col_subsetr(), choices)] } else { @@ -62,10 +64,16 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., return '
' + '
' + escape(item.data.name) + ' ' + - ' ' + + '' + + (item.data.dataclass != '' ? + ' ' + + item.data.dataclass + + '' : '' ) + ' ' + + (item.data.datatype != '' ? + ' ' + item.data.datatype + - '' + - '
' + + '' : '' ) + + '
' + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + ''; }, @@ -84,7 +92,6 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., } - #' A selectizeInput customized for named vectors #' #' @param inputId passed to \code{\link[shiny]{selectizeInput}} diff --git a/R/data-summary.R b/R/data-summary.R index a8d960c4..b0669581 100644 --- a/R/data-summary.R +++ b/R/data-summary.R @@ -282,6 +282,8 @@ add_class_icon <- function(grid, column = "class") { shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { shiny::icon("arrow-down-a-z") + } else if (identical(x, "logical")) { + shiny::icon("toggle-off") } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) { shiny::icon("calendar-days") } else if ("hms" %in% x) { diff --git a/R/data_plots.R b/R/data_plots.R index ccc14b85..e9225dec 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -310,9 +310,9 @@ data_visuals_server <- function(id, z = input$tertiary ) }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, error = function(err) { showNotification(paste0(err), type = "err") } @@ -378,9 +378,9 @@ all_but <- function(data, ...) { #' #' @examples #' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal")) +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical")) #' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = outcome_type) { +subset_types <- function(data, types, type.fun = data_type) { data[sapply(data, type.fun) %in% types] } @@ -413,58 +413,58 @@ supported_plots <- function() { fun = "plot_hbars", descr = "Stacked horizontal bars", note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars", - primary.type = c("dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = "none" ), plot_violin = list( fun = "plot_violin", descr = "Violin plot", note = "A modern alternative to the classic boxplot to visualise data distribution", - primary.type = c("continuous", "dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("continuous", "dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, secondary.extra = "none", - tertiary.type = c("dichotomous", "ordinal") + tertiary.type = c("dichotomous", "ordinal" ,"categorical") ), # plot_ridge = list( # descr = "Ridge plot", # note = "An alternative option to visualise data distribution", # primary.type = "continuous", - # secondary.type = c("dichotomous", "ordinal"), - # tertiary.type = c("dichotomous", "ordinal"), + # secondary.type = c("dichotomous", "ordinal" ,"categorical"), + # tertiary.type = c("dichotomous", "ordinal" ,"categorical"), # secondary.extra = NULL # ), plot_sankey = list( fun = "plot_sankey", descr = "Sankey plot", note = "A way of visualising change between groups", - primary.type = c("dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, secondary.extra = NULL, - tertiary.type = c("dichotomous", "ordinal") + tertiary.type = c("dichotomous", "ordinal" ,"categorical") ), plot_scatter = list( fun = "plot_scatter", descr = "Scatter plot", note = "A classic way of showing the association between to variables", primary.type = "continuous", - secondary.type = c("continuous", "ordinal"), + secondary.type = c("continuous", "ordinal" ,"categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = NULL ), plot_box = list( fun = "plot_box", descr = "Box plot", note = "A classic way to plot data distribution by groups", - primary.type = c("continuous", "dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("continuous", "dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = "none" ), plot_euler = list( @@ -475,7 +475,7 @@ supported_plots <- function() { secondary.type = "dichotomous", secondary.multi = TRUE, secondary.max = 4, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = NULL ) ) @@ -500,11 +500,12 @@ supported_plots <- function() { #' possible_plots() possible_plots <- function(data) { # browser() + # data <- if (is.reactive(data)) data() else data if (is.data.frame(data)) { data <- data[[1]] } - type <- outcome_type(data) + type <- data_type(data) if (type == "unknown") { out <- type @@ -596,6 +597,7 @@ create_plot <- function(data, type, x, y, z = NULL, ...) { #' gtsummary::trial |> get_label(var = "trt") #' 1:10 |> get_label() get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data if (!is.null(var) & is.data.frame(data)) { data <- data[[var]] } @@ -696,7 +698,9 @@ allign_axes <- function(...) { xr <- clean_common_axis(p, "x") - p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) + suppressWarnings({ + p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) + }) } #' Extract and clean axis ranges @@ -714,7 +718,7 @@ clean_common_axis <- function(p, axis) { if (is.numeric(.x)) { range(.x) } else { - .x + as.character(.x) } })() |> unique() diff --git a/R/plot_box.R b/R/plot_box.R index 6f16e79b..97f88f73 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -49,13 +49,13 @@ plot_box_single <- function(data, x, y=NULL, seed = 2103) { data[[y]] <- y } - discrete <- !outcome_type(data[[y]]) %in% "continuous" + discrete <- !data_type(data[[y]]) %in% "continuous" data |> ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) + ## THis could be optional in future - ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9) + + ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) + ggplot2::coord_flip() + viridis::scale_fill_viridis(discrete = discrete, option = "D") + # ggplot2::theme_void() + diff --git a/R/plot_euler.R b/R/plot_euler.R index bd8a1aba..88ce437f 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -95,7 +95,7 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) { # patchwork::wrap_plots(out, guides = "collect") } - +?withCallingHandlers() #' Easily plot single euler diagrams #' #' @returns ggplot2 object diff --git a/R/regression_model.R b/R/regression_model.R index 6d51e334..1ed69e7e 100644 --- a/R/regression_model.R +++ b/R/regression_model.R @@ -44,7 +44,7 @@ #' args.list = NULL, #' vars = c("mpg", "cyl") #' ) -#' broom::tidy(m) +#' broom::tidy(m) regression_model <- function(data, outcome.str, auto.mode = FALSE, @@ -60,7 +60,7 @@ regression_model <- function(data, } ## This will handle if outcome is not in data for nicer shiny behavior - if (!outcome.str %in% names(data)){ + if (!outcome.str %in% names(data)) { outcome.str <- names(data)[1] print("outcome is not in data, first column is used") } @@ -170,7 +170,7 @@ regression_model <- function(data, #' fun = "stats::glm", #' args.list = list(family = stats::binomial(link = "logit")) #' ) -#' lapply(m,broom::tidy) |> dplyr::bind_rows() +#' lapply(m, broom::tidy) |> dplyr::bind_rows() #' } regression_model_uv <- function(data, outcome.str, @@ -178,9 +178,8 @@ regression_model_uv <- function(data, fun = NULL, vars = NULL, ...) { - ## This will handle if outcome is not in data for nicer shiny behavior - if (!outcome.str %in% names(data)){ + if (!outcome.str %in% names(data)) { outcome.str <- names(data)[1] print("outcome is not in data, first column is used") } @@ -241,7 +240,7 @@ regression_model_uv <- function(data, ### HELPERS -#' Outcome data type assessment +#' Data type assessment #' #' @param data data #' @@ -251,17 +250,35 @@ regression_model_uv <- function(data, #' @examples #' mtcars |> #' default_parsing() |> -#' lapply(outcome_type) -outcome_type <- function(data) { +#' lapply(data_type) +#' c(1, 2) |> data_type() +#' 1 |> data_type() +#' c(rep(NA, 10)) |> data_type() +#' sample(1:100, 50) |> data_type() +#' factor(letters[1:20]) |> data_type() +data_type <- function(data) { cl_d <- class(data) - if (any(c("numeric", "integer") %in% cl_d)) { - out <- "continuous" - } else if (any(c("factor", "logical") %in% cl_d)) { - if (length(levels(data)) == 2 | identical("logical",cl_d)) { + if (all(is.na(data))) { + out <- "empty" + } else if (length(unique(data)) < 2) { + out <- "monotone" + } else if (any(c("factor", "logical") %in% cl_d) | length(unique(data)) == 2) { + if (identical("logical", cl_d) | length(unique(data)) == 2) { out <- "dichotomous" - } else if (length(levels(data)) > 2) { - out <- "ordinal" + } else { + if (is.ordered(data)) { + out <- "ordinal" + } else { + out <- "categorical" + } } + } else if (identical(cl_d, "character")) { + out <- "text" + } else if (!length(unique(data)) == 2) { + ## Previously had all thinkable classes + ## Now just assumes the class has not been defined above + ## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) & + out <- "continuous" } else { out <- "unknown" } @@ -307,7 +324,7 @@ supported_functions <- function() { polr = list( descr = "Ordinal logistic regression model", design = "cross-sectional", - out.type = "ordinal", + out.type = c("ordinal","categorical"), fun = "MASS::polr", args.list = list( Hess = TRUE, @@ -340,12 +357,13 @@ supported_functions <- function() { #' possible_functions(design = "cross-sectional") possible_functions <- function(data, design = c("cross-sectional")) { # browser() + # data <- if (is.reactive(data)) data() else data if (is.data.frame(data)) { data <- data[[1]] } design <- match.arg(design) - type <- outcome_type(data) + type <- data_type(data) design_ls <- supported_functions() |> lapply(\(.x){ @@ -537,13 +555,16 @@ list2str <- function(data) { #' #' @examples #' \dontrun{ -#' gtsummary::trial |> regression_model_uv( -#' outcome.str = "trt", -#' fun = "stats::glm", -#' args.list = list(family = stats::binomial(link = "logit")) -#' ) |> lapply(broom::tidy) |> dplyr::bind_rows() +#' gtsummary::trial |> +#' regression_model_uv( +#' outcome.str = "trt", +#' fun = "stats::glm", +#' args.list = list(family = stats::binomial(link = "logit")) +#' ) |> +#' lapply(broom::tidy) |> +#' dplyr::bind_rows() #' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") -#' lapply(ms$model,broom::tidy) |> dplyr::bind_rows() +#' lapply(ms$model, broom::tidy) |> dplyr::bind_rows() #' } regression_model_uv_list <- function(data, outcome.str, diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 59101fcc..683b6f23 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -10,7 +10,7 @@ #### Current file: R//app_version.R ######## -app_version <- function()'250319_1327' +app_version <- function()'250320_1310' ######## @@ -296,16 +296,18 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., { "name": "%s", "label": "%s", + "dataclass": "%s", "datatype": "%s" }'), col, attr(datar()[[col]], "label") %||% "", - IDEAFilter:::get_dataFilter_class(datar()[[col]]) + IDEAFilter:::get_dataFilter_class(datar()[[col]]), + data_type(datar()[[col]]) ) }, col = names(datar())) if (!"none" %in% names(datar())){ - labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"datatype\": \"\"\n }',none_label)),labels) + 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(datar()) else col_subsetr(), choices)] } else { @@ -327,10 +329,16 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., return '
' + '
' + escape(item.data.name) + ' ' + - ' ' + + '' + + (item.data.dataclass != '' ? + ' ' + + item.data.dataclass + + '' : '' ) + ' ' + + (item.data.datatype != '' ? + ' ' + item.data.datatype + - '' + - '
' + + '' : '' ) + + '
' + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + ''; }, @@ -348,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 '
' + + '
' + + escape(item.data.name) + ' ' + + '' + + (item.data.dataclass != '' ? + ' ' + + item.data.dataclass + + '' : '' ) + ' ' + + (item.data.datatype != '' ? + ' ' + + item.data.datatype + + '' : '' ) + + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
'; + }, + + // avoid data vomit splashing on screen when an option is selected + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + escape(item.data.name) + + '
'; + } + }")), + if (!is.null(maxItems)) list(maxItems=maxItems) + ) + ) +} #' A selectizeInput customized for named vectors #' @@ -1407,9 +1484,9 @@ data_visuals_server <- function(id, z = input$tertiary ) }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, error = function(err) { showNotification(paste0(err), type = "err") } @@ -1475,9 +1552,9 @@ all_but <- function(data, ...) { #' #' @examples #' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal")) +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical")) #' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = outcome_type) { +subset_types <- function(data, types, type.fun = data_type) { data[sapply(data, type.fun) %in% types] } @@ -1510,58 +1587,58 @@ supported_plots <- function() { fun = "plot_hbars", descr = "Stacked horizontal bars", note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars", - primary.type = c("dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = "none" ), plot_violin = list( fun = "plot_violin", descr = "Violin plot", note = "A modern alternative to the classic boxplot to visualise data distribution", - primary.type = c("continuous", "dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("continuous", "dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, secondary.extra = "none", - tertiary.type = c("dichotomous", "ordinal") + tertiary.type = c("dichotomous", "ordinal" ,"categorical") ), # plot_ridge = list( # descr = "Ridge plot", # note = "An alternative option to visualise data distribution", # primary.type = "continuous", - # secondary.type = c("dichotomous", "ordinal"), - # tertiary.type = c("dichotomous", "ordinal"), + # secondary.type = c("dichotomous", "ordinal" ,"categorical"), + # tertiary.type = c("dichotomous", "ordinal" ,"categorical"), # secondary.extra = NULL # ), plot_sankey = list( fun = "plot_sankey", descr = "Sankey plot", note = "A way of visualising change between groups", - primary.type = c("dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, secondary.extra = NULL, - tertiary.type = c("dichotomous", "ordinal") + tertiary.type = c("dichotomous", "ordinal" ,"categorical") ), plot_scatter = list( fun = "plot_scatter", descr = "Scatter plot", note = "A classic way of showing the association between to variables", primary.type = "continuous", - secondary.type = c("continuous", "ordinal"), + secondary.type = c("continuous", "ordinal" ,"categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = NULL ), plot_box = list( fun = "plot_box", descr = "Box plot", note = "A classic way to plot data distribution by groups", - primary.type = c("continuous", "dichotomous", "ordinal"), - secondary.type = c("dichotomous", "ordinal"), + primary.type = c("continuous", "dichotomous", "ordinal" ,"categorical"), + secondary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = "none" ), plot_euler = list( @@ -1572,7 +1649,7 @@ supported_plots <- function() { secondary.type = "dichotomous", secondary.multi = TRUE, secondary.max = 4, - tertiary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal" ,"categorical"), secondary.extra = NULL ) ) @@ -1597,11 +1674,12 @@ supported_plots <- function() { #' possible_plots() possible_plots <- function(data) { # browser() + # data <- if (is.reactive(data)) data() else data if (is.data.frame(data)) { data <- data[[1]] } - type <- outcome_type(data) + type <- data_type(data) if (type == "unknown") { out <- type @@ -1693,6 +1771,7 @@ create_plot <- function(data, type, x, y, z = NULL, ...) { #' gtsummary::trial |> get_label(var = "trt") #' 1:10 |> get_label() get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data if (!is.null(var) & is.data.frame(data)) { data <- data[[var]] } @@ -1793,7 +1872,9 @@ allign_axes <- function(...) { xr <- clean_common_axis(p, "x") - p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) + suppressWarnings({ + p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) + }) } #' Extract and clean axis ranges @@ -1811,7 +1892,7 @@ clean_common_axis <- function(p, axis) { if (is.numeric(.x)) { range(.x) } else { - .x + as.character(.x) } })() |> unique() @@ -2263,6 +2344,8 @@ add_class_icon <- function(grid, column = "class") { shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { shiny::icon("arrow-down-a-z") + } else if (identical(x, "logical")) { + shiny::icon("toggle-off") } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) { shiny::icon("calendar-days") } else if ("hms" %in% x) { @@ -3392,13 +3475,13 @@ plot_box_single <- function(data, x, y=NULL, seed = 2103) { data[[y]] <- y } - discrete <- !outcome_type(data[[y]]) %in% "continuous" + discrete <- !data_type(data[[y]]) %in% "continuous" data |> ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) + ## THis could be optional in future - ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9) + + ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) + ggplot2::coord_flip() + viridis::scale_fill_viridis(discrete = discrete, option = "D") + # ggplot2::theme_void() + @@ -3524,7 +3607,7 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) { # patchwork::wrap_plots(out, guides = "collect") } - +?withCallingHandlers() #' Easily plot single euler diagrams #' #' @returns ggplot2 object @@ -4607,7 +4690,7 @@ redcap_demo_app <- function() { #' args.list = NULL, #' vars = c("mpg", "cyl") #' ) -#' broom::tidy(m) +#' broom::tidy(m) regression_model <- function(data, outcome.str, auto.mode = FALSE, @@ -4623,7 +4706,7 @@ regression_model <- function(data, } ## This will handle if outcome is not in data for nicer shiny behavior - if (!outcome.str %in% names(data)){ + if (!outcome.str %in% names(data)) { outcome.str <- names(data)[1] print("outcome is not in data, first column is used") } @@ -4733,7 +4816,7 @@ regression_model <- function(data, #' fun = "stats::glm", #' args.list = list(family = stats::binomial(link = "logit")) #' ) -#' lapply(m,broom::tidy) |> dplyr::bind_rows() +#' lapply(m, broom::tidy) |> dplyr::bind_rows() #' } regression_model_uv <- function(data, outcome.str, @@ -4741,9 +4824,8 @@ regression_model_uv <- function(data, fun = NULL, vars = NULL, ...) { - ## This will handle if outcome is not in data for nicer shiny behavior - if (!outcome.str %in% names(data)){ + if (!outcome.str %in% names(data)) { outcome.str <- names(data)[1] print("outcome is not in data, first column is used") } @@ -4804,7 +4886,7 @@ regression_model_uv <- function(data, ### HELPERS -#' Outcome data type assessment +#' Data type assessment #' #' @param data data #' @@ -4814,17 +4896,35 @@ regression_model_uv <- function(data, #' @examples #' mtcars |> #' default_parsing() |> -#' lapply(outcome_type) -outcome_type <- function(data) { +#' lapply(data_type) +#' c(1, 2) |> data_type() +#' 1 |> data_type() +#' c(rep(NA, 10)) |> data_type() +#' sample(1:100, 50) |> data_type() +#' factor(letters[1:20]) |> data_type() +data_type <- function(data) { cl_d <- class(data) - if (any(c("numeric", "integer") %in% cl_d)) { - out <- "continuous" - } else if (any(c("factor", "logical") %in% cl_d)) { - if (length(levels(data)) == 2 | identical("logical",cl_d)) { + if (all(is.na(data))) { + out <- "empty" + } else if (length(unique(data)) < 2) { + out <- "monotone" + } else if (any(c("factor", "logical") %in% cl_d) | length(unique(data)) == 2) { + if (identical("logical", cl_d) | length(unique(data)) == 2) { out <- "dichotomous" - } else if (length(levels(data)) > 2) { - out <- "ordinal" + } else { + if (is.ordered(data)) { + out <- "ordinal" + } else { + out <- "categorical" + } } + } else if (identical(cl_d, "character")) { + out <- "text" + } else if (!length(unique(data)) == 2) { + ## Previously had all thinkable classes + ## Now just assumes the class has not been defined above + ## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) & + out <- "continuous" } else { out <- "unknown" } @@ -4870,7 +4970,7 @@ supported_functions <- function() { polr = list( descr = "Ordinal logistic regression model", design = "cross-sectional", - out.type = "ordinal", + out.type = c("ordinal","categorical"), fun = "MASS::polr", args.list = list( Hess = TRUE, @@ -4903,12 +5003,13 @@ supported_functions <- function() { #' possible_functions(design = "cross-sectional") possible_functions <- function(data, design = c("cross-sectional")) { # browser() + # data <- if (is.reactive(data)) data() else data if (is.data.frame(data)) { data <- data[[1]] } design <- match.arg(design) - type <- outcome_type(data) + type <- data_type(data) design_ls <- supported_functions() |> lapply(\(.x){ @@ -5100,13 +5201,16 @@ list2str <- function(data) { #' #' @examples #' \dontrun{ -#' gtsummary::trial |> regression_model_uv( -#' outcome.str = "trt", -#' fun = "stats::glm", -#' args.list = list(family = stats::binomial(link = "logit")) -#' ) |> lapply(broom::tidy) |> dplyr::bind_rows() +#' gtsummary::trial |> +#' regression_model_uv( +#' outcome.str = "trt", +#' fun = "stats::glm", +#' args.list = list(family = stats::binomial(link = "logit")) +#' ) |> +#' lapply(broom::tidy) |> +#' dplyr::bind_rows() #' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") -#' lapply(ms$model,broom::tidy) |> dplyr::bind_rows() +#' lapply(ms$model, broom::tidy) |> dplyr::bind_rows() #' } regression_model_uv_list <- function(data, outcome.str, @@ -7217,6 +7321,15 @@ ui_elements <- list( ) ), 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( @@ -7889,6 +8002,7 @@ server <- function(input, output, session) { rv$data_filtered <- data_filter() ### Save filtered data + ### without empty factor levels rv$list$data <- data_filter() |> REDCapCAST::fct_drop() @@ -8018,23 +8132,39 @@ server <- function(input, output, session) { ## Keep these "old" selection options as a simple alternative to the modification pane output$include_vars <- shiny::renderUI({ - shiny::selectizeInput( + columnSelectInputStat( inputId = "include_vars", selected = NULL, label = "Covariables to include", - choices = colnames(rv$data_filtered), + data = rv$data_filtered, 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({ - shiny::selectInput( + columnSelectInputStat( inputId = "outcome_var", selected = NULL, label = "Select outcome variable", - choices = colnames(rv$data_filtered), + data = rv$data_filtered, 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({ @@ -8077,25 +8207,37 @@ server <- function(input, output, session) { }) output$strat_var <- shiny::renderUI({ - shiny::selectInput( + columnSelectInputStat( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - choices = c( + data = rv$data_filtered, + col_subset = c( "none", - rv$data_filtered |> - (\(.x){ - lapply(.x, \(.c){ - if (identical("factor", class(.c))) { - .c - } - }) |> - dplyr::bind_cols() - })() |> - colnames() - ), - multiple = FALSE + names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] + ) ) + + # 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 + # ) }) @@ -8120,27 +8262,37 @@ server <- function(input, output, session) { shiny::observeEvent( # ignoreInit = TRUE, list( - shiny::reactive(rv$list$data), - shiny::reactive(rv$data), - shiny::reactive(rv$data_original), - data_filter(), - input$strat_var, - input$include_vars, - input$complete_cutoff, - input$add_p + # shiny::reactive(rv$list$data), + # shiny::reactive(rv$data), + # shiny::reactive(rv$data_original), + # data_filter(), + # input$strat_var, + # input$include_vars, + # input$complete_cutoff, + # input$add_p + input$act_eval ), { shiny::req(input$strat_var) 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 } else { 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$data |> + data_tbl1 |> baseline_table( fun.args = list( diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index de976fae..8d5d512d 100644 --- a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -5,6 +5,6 @@ account: agdamsbo server: shinyapps.io hostUrl: https://api.shinyapps.io/v1 appId: 13611288 -bundleId: 9969300 +bundleId: 9974967 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R index 59b49170..30ee43e0 100644 --- a/inst/apps/FreesearchR/server.R +++ b/inst/apps/FreesearchR/server.R @@ -339,6 +339,7 @@ server <- function(input, output, session) { rv$data_filtered <- data_filter() ### Save filtered data + ### without empty factor levels rv$list$data <- data_filter() |> 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 output$include_vars <- shiny::renderUI({ - shiny::selectizeInput( + columnSelectInputStat( inputId = "include_vars", selected = NULL, label = "Covariables to include", - choices = colnames(rv$data_filtered), + data = rv$data_filtered, 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({ - shiny::selectInput( + columnSelectInputStat( inputId = "outcome_var", selected = NULL, label = "Select outcome variable", - choices = colnames(rv$data_filtered), + data = rv$data_filtered, 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({ @@ -527,25 +544,37 @@ server <- function(input, output, session) { }) output$strat_var <- shiny::renderUI({ - shiny::selectInput( + columnSelectInputStat( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - choices = c( + data = rv$data_filtered, + col_subset = c( "none", - rv$data_filtered |> - (\(.x){ - lapply(.x, \(.c){ - if (identical("factor", class(.c))) { - .c - } - }) |> - dplyr::bind_cols() - })() |> - colnames() - ), - multiple = FALSE + names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] + ) ) + + # 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( # ignoreInit = TRUE, list( - shiny::reactive(rv$list$data), - shiny::reactive(rv$data), - shiny::reactive(rv$data_original), - data_filter(), - input$strat_var, - input$include_vars, - input$complete_cutoff, - input$add_p + # shiny::reactive(rv$list$data), + # shiny::reactive(rv$data), + # shiny::reactive(rv$data_original), + # data_filter(), + # input$strat_var, + # input$include_vars, + # input$complete_cutoff, + # input$add_p + input$act_eval ), { shiny::req(input$strat_var) 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 } else { 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$data |> + data_tbl1 |> baseline_table( fun.args = list( diff --git a/inst/apps/FreesearchR/ui.R b/inst/apps/FreesearchR/ui.R index cdbd7697..ea40eb8d 100644 --- a/inst/apps/FreesearchR/ui.R +++ b/inst/apps/FreesearchR/ui.R @@ -304,6 +304,15 @@ ui_elements <- list( ) ), 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( diff --git a/inst/apps/FreesearchR/www/favicon.png b/inst/apps/FreesearchR/www/favicon.png new file mode 100644 index 00000000..e284d2d2 Binary files /dev/null and b/inst/apps/FreesearchR/www/favicon.png differ