diff --git a/R/app_version.R b/R/app_version.R index ff73a306..d3c4a1b4 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'250320_1310' +app_version <- function()'250319_1327' diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R index 3704c98b..7a72fc42 100644 --- a/R/custom_SelectInput.R +++ b/R/custom_SelectInput.R @@ -31,18 +31,16 @@ 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]]), - data_type(datar()[[col]]) + IDEAFilter:::get_dataFilter_class(datar()[[col]]) ) }, col = names(datar())) if (!"none" %in% names(datar())){ - labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }',none_label)),labels) + labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\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 { @@ -64,16 +62,10 @@ 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) + '
' : '') + ''; }, @@ -92,6 +84,7 @@ 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 b0669581..a8d960c4 100644 --- a/R/data-summary.R +++ b/R/data-summary.R @@ -282,8 +282,6 @@ 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 e9225dec..ccc14b85 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" ,"categorical")) +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal")) #' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { +subset_types <- function(data, types, type.fun = outcome_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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("continuous", "dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, secondary.extra = "none", - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal") ), # plot_ridge = list( # descr = "Ridge plot", # note = "An alternative option to visualise data distribution", # primary.type = "continuous", - # secondary.type = c("dichotomous", "ordinal" ,"categorical"), - # tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + # secondary.type = c("dichotomous", "ordinal"), + # tertiary.type = c("dichotomous", "ordinal"), # 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, secondary.extra = NULL, - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal") ), 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" ,"categorical"), + secondary.type = c("continuous", "ordinal"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("continuous", "dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), 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" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), secondary.extra = NULL ) ) @@ -500,12 +500,11 @@ 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 <- data_type(data) + type <- outcome_type(data) if (type == "unknown") { out <- type @@ -597,7 +596,6 @@ 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]] } @@ -698,9 +696,7 @@ allign_axes <- function(...) { xr <- clean_common_axis(p, "x") - suppressWarnings({ - p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) - }) + p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) } #' Extract and clean axis ranges @@ -718,7 +714,7 @@ clean_common_axis <- function(p, axis) { if (is.numeric(.x)) { range(.x) } else { - as.character(.x) + .x } })() |> unique() diff --git a/R/plot_box.R b/R/plot_box.R index 97f88f73..6f16e79b 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 <- !data_type(data[[y]]) %in% "continuous" + discrete <- !outcome_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, width = 0.1, height = .5) + + ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9) + 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 88ce437f..bd8a1aba 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 1ed69e7e..6d51e334 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,8 +178,9 @@ 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") } @@ -240,7 +241,7 @@ regression_model_uv <- function(data, ### HELPERS -#' Data type assessment +#' Outcome data type assessment #' #' @param data data #' @@ -250,35 +251,17 @@ regression_model_uv <- function(data, #' @examples #' mtcars |> #' default_parsing() |> -#' 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) { +#' lapply(outcome_type) +outcome_type <- function(data) { cl_d <- class(data) - 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 (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) & + 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)) { + out <- "dichotomous" + } else if (length(levels(data)) > 2) { + out <- "ordinal" + } } else { out <- "unknown" } @@ -324,7 +307,7 @@ supported_functions <- function() { polr = list( descr = "Ordinal logistic regression model", design = "cross-sectional", - out.type = c("ordinal","categorical"), + out.type = "ordinal", fun = "MASS::polr", args.list = list( Hess = TRUE, @@ -357,13 +340,12 @@ 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 <- data_type(data) + type <- outcome_type(data) design_ls <- supported_functions() |> lapply(\(.x){ @@ -555,16 +537,13 @@ 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 683b6f23..59101fcc 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()'250320_1310' +app_version <- function()'250319_1327' ######## @@ -296,18 +296,16 @@ 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]]), - data_type(datar()[[col]]) + IDEAFilter:::get_dataFilter_class(datar()[[col]]) ) }, col = names(datar())) if (!"none" %in% names(datar())){ - labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }',none_label)),labels) + labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\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 { @@ -329,16 +327,10 @@ 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) + '
' : '') + ''; }, @@ -356,76 +348,7 @@ 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 #' @@ -1484,9 +1407,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") } @@ -1552,9 +1475,9 @@ all_but <- function(data, ...) { #' #' @examples #' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical")) +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal")) #' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { +subset_types <- function(data, types, type.fun = outcome_type) { data[sapply(data, type.fun) %in% types] } @@ -1587,58 +1510,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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("continuous", "dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, secondary.extra = "none", - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal") ), # plot_ridge = list( # descr = "Ridge plot", # note = "An alternative option to visualise data distribution", # primary.type = "continuous", - # secondary.type = c("dichotomous", "ordinal" ,"categorical"), - # tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + # secondary.type = c("dichotomous", "ordinal"), + # tertiary.type = c("dichotomous", "ordinal"), # 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, secondary.extra = NULL, - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal") ), 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" ,"categorical"), + secondary.type = c("continuous", "ordinal"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("continuous", "dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), secondary.extra = "none" ), plot_euler = list( @@ -1649,7 +1572,7 @@ supported_plots <- function() { secondary.type = "dichotomous", secondary.multi = TRUE, secondary.max = 4, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal"), secondary.extra = NULL ) ) @@ -1674,12 +1597,11 @@ 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 <- data_type(data) + type <- outcome_type(data) if (type == "unknown") { out <- type @@ -1771,7 +1693,6 @@ 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]] } @@ -1872,9 +1793,7 @@ allign_axes <- function(...) { xr <- clean_common_axis(p, "x") - suppressWarnings({ - p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) - }) + p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) } #' Extract and clean axis ranges @@ -1892,7 +1811,7 @@ clean_common_axis <- function(p, axis) { if (is.numeric(.x)) { range(.x) } else { - as.character(.x) + .x } })() |> unique() @@ -2344,8 +2263,6 @@ 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) { @@ -3475,13 +3392,13 @@ plot_box_single <- function(data, x, y=NULL, seed = 2103) { data[[y]] <- y } - discrete <- !data_type(data[[y]]) %in% "continuous" + discrete <- !outcome_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, width = 0.1, height = .5) + + ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9) + ggplot2::coord_flip() + viridis::scale_fill_viridis(discrete = discrete, option = "D") + # ggplot2::theme_void() + @@ -3607,7 +3524,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 @@ -4690,7 +4607,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, @@ -4706,7 +4623,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") } @@ -4816,7 +4733,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, @@ -4824,8 +4741,9 @@ 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") } @@ -4886,7 +4804,7 @@ regression_model_uv <- function(data, ### HELPERS -#' Data type assessment +#' Outcome data type assessment #' #' @param data data #' @@ -4896,35 +4814,17 @@ regression_model_uv <- function(data, #' @examples #' mtcars |> #' default_parsing() |> -#' 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) { +#' lapply(outcome_type) +outcome_type <- function(data) { cl_d <- class(data) - 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 (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) & + 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)) { + out <- "dichotomous" + } else if (length(levels(data)) > 2) { + out <- "ordinal" + } } else { out <- "unknown" } @@ -4970,7 +4870,7 @@ supported_functions <- function() { polr = list( descr = "Ordinal logistic regression model", design = "cross-sectional", - out.type = c("ordinal","categorical"), + out.type = "ordinal", fun = "MASS::polr", args.list = list( Hess = TRUE, @@ -5003,13 +4903,12 @@ 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 <- data_type(data) + type <- outcome_type(data) design_ls <- supported_functions() |> lapply(\(.x){ @@ -5201,16 +5100,13 @@ 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, @@ -7321,15 +7217,6 @@ 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( @@ -8002,7 +7889,6 @@ 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() @@ -8132,39 +8018,23 @@ server <- function(input, output, session) { ## Keep these "old" selection options as a simple alternative to the modification pane output$include_vars <- shiny::renderUI({ - columnSelectInputStat( + shiny::selectizeInput( inputId = "include_vars", selected = NULL, label = "Covariables to include", - data = rv$data_filtered, + choices = colnames(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({ - columnSelectInputStat( + shiny::selectInput( inputId = "outcome_var", selected = NULL, label = "Select outcome variable", - data = rv$data_filtered, + choices = colnames(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({ @@ -8207,37 +8077,25 @@ server <- function(input, output, session) { }) output$strat_var <- shiny::renderUI({ - columnSelectInputStat( + shiny::selectInput( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - data = rv$data_filtered, - col_subset = c( + choices = c( "none", - names(rv$data_filtered)[unlist(lapply(rv$data_filtered, 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 ) - - # 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 - # ) }) @@ -8262,37 +8120,27 @@ 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 - input$act_eval + 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::req(input$strat_var) shiny::req(rv$list$data) - data_tbl1 <- rv$list$data - - if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) { + if (input$strat_var == "none" | !input$strat_var %in% names(rv$list$data)) { 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 <- - data_tbl1 |> + rv$list$data |> 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 8d5d512d..de976fae 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: 9974967 +bundleId: 9969300 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R index 30ee43e0..59b49170 100644 --- a/inst/apps/FreesearchR/server.R +++ b/inst/apps/FreesearchR/server.R @@ -339,7 +339,6 @@ 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() @@ -469,39 +468,23 @@ server <- function(input, output, session) { ## Keep these "old" selection options as a simple alternative to the modification pane output$include_vars <- shiny::renderUI({ - columnSelectInputStat( + shiny::selectizeInput( inputId = "include_vars", selected = NULL, label = "Covariables to include", - data = rv$data_filtered, + choices = colnames(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({ - columnSelectInputStat( + shiny::selectInput( inputId = "outcome_var", selected = NULL, label = "Select outcome variable", - data = rv$data_filtered, + choices = colnames(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({ @@ -544,37 +527,25 @@ server <- function(input, output, session) { }) output$strat_var <- shiny::renderUI({ - columnSelectInputStat( + shiny::selectInput( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - data = rv$data_filtered, - col_subset = c( + choices = c( "none", - names(rv$data_filtered)[unlist(lapply(rv$data_filtered, 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 ) - - # 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 - # ) }) @@ -599,37 +570,27 @@ 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 - input$act_eval + 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::req(input$strat_var) shiny::req(rv$list$data) - data_tbl1 <- rv$list$data - - if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) { + if (input$strat_var == "none" | !input$strat_var %in% names(rv$list$data)) { 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 <- - data_tbl1 |> + rv$list$data |> baseline_table( fun.args = list( diff --git a/inst/apps/FreesearchR/ui.R b/inst/apps/FreesearchR/ui.R index ea40eb8d..cdbd7697 100644 --- a/inst/apps/FreesearchR/ui.R +++ b/inst/apps/FreesearchR/ui.R @@ -304,15 +304,6 @@ 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 deleted file mode 100644 index e284d2d2..00000000 Binary files a/inst/apps/FreesearchR/www/favicon.png and /dev/null differ