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

updated with new data types

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-03-20 11:46:02 +01:00
parent d664adc500
commit 184bce42c5
No known key found for this signature in database
5 changed files with 127 additions and 80 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
R/app_version.R
View file

@ -1 +1 @@
app_version <- function()'250319_1327' app_version <- function()'250320_1144'

4
R/plot_box.R
View file

@ -49,13 +49,13 @@ plot_box_single <- function(data, x, y=NULL, seed = 2103) {
data[[y]] <- y data[[y]] <- y
} }
discrete <- !outcome_type(data[[y]]) %in% "continuous" discrete <- !data_type(data[[y]]) %in% "continuous"
data |> data |>
ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + 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) + ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) +
## THis could be optional in future ## 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() + ggplot2::coord_flip() +
viridis::scale_fill_viridis(discrete = discrete, option = "D") + viridis::scale_fill_viridis(discrete = discrete, option = "D") +
# ggplot2::theme_void() + # ggplot2::theme_void() +

2
R/plot_euler.R
View file

@ -95,7 +95,7 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
# patchwork::wrap_plots(out, guides = "collect") # patchwork::wrap_plots(out, guides = "collect")
} }
?withCallingHandlers()
#' Easily plot single euler diagrams #' Easily plot single euler diagrams
#' #'
#' @returns ggplot2 object #' @returns ggplot2 object

46
R/regression_model.R
View file

@ -178,7 +178,6 @@ regression_model_uv <- function(data,
fun = NULL, fun = NULL,
vars = NULL, vars = NULL,
...) { ...) {
## This will handle if outcome is not in data for nicer shiny behavior ## 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] outcome.str <- names(data)[1]
@ -241,7 +240,7 @@ regression_model_uv <- function(data,
### HELPERS ### HELPERS
#' Outcome data type assessment #' Data type assessment
#' #'
#' @param data data #' @param data data
#' #'
@ -251,17 +250,35 @@ regression_model_uv <- function(data,
#' @examples #' @examples
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' lapply(outcome_type) #' lapply(data_type)
outcome_type <- function(data) { #' 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) cl_d <- class(data)
if (any(c("numeric", "integer") %in% cl_d)) { if (all(is.na(data))) {
out <- "continuous" out <- "empty"
} else if (any(c("factor", "logical") %in% cl_d)) { } else if (length(unique(data)) < 2) {
if (length(levels(data)) == 2 | identical("logical",cl_d)) { 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" out <- "dichotomous"
} else if (length(levels(data)) > 2) { } else {
if (is.ordered(data)) {
out <- "ordinal" 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 { } else {
out <- "unknown" out <- "unknown"
} }
@ -307,7 +324,7 @@ supported_functions <- function() {
polr = list( polr = list(
descr = "Ordinal logistic regression model", descr = "Ordinal logistic regression model",
design = "cross-sectional", design = "cross-sectional",
out.type = "ordinal", out.type = c("ordinal","categorical"),
fun = "MASS::polr", fun = "MASS::polr",
args.list = list( args.list = list(
Hess = TRUE, Hess = TRUE,
@ -345,7 +362,7 @@ possible_functions <- function(data, design = c("cross-sectional")) {
} }
design <- match.arg(design) design <- match.arg(design)
type <- outcome_type(data) type <- data_type(data)
design_ls <- supported_functions() |> design_ls <- supported_functions() |>
lapply(\(.x){ lapply(\(.x){
@ -537,11 +554,14 @@ list2str <- function(data) {
#' #'
#' @examples #' @examples
#' \dontrun{ #' \dontrun{
#' gtsummary::trial |> regression_model_uv( #' gtsummary::trial |>
#' regression_model_uv(
#' outcome.str = "trt", #' outcome.str = "trt",
#' fun = "stats::glm", #' fun = "stats::glm",
#' args.list = list(family = stats::binomial(link = "logit")) #' args.list = list(family = stats::binomial(link = "logit"))
#' ) |> lapply(broom::tidy) |> dplyr::bind_rows() #' ) |>
#' lapply(broom::tidy) |>
#' dplyr::bind_rows()
#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") #' 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()
#' } #' }

115
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()'250319_1327' app_version <- function()'250320_1144'
######## ########
@ -296,16 +296,18 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
{ {
"name": "%s", "name": "%s",
"label": "%s", "label": "%s",
"dataclass": "%s",
"datatype": "%s" "datatype": "%s"
}'), }'),
col, col,
attr(datar()[[col]], "label") %||% "", attr(datar()[[col]], "label") %||% "",
IDEAFilter:::get_dataFilter_class(datar()[[col]]) IDEAFilter:::get_dataFilter_class(datar()[[col]]),
data_type(datar()[[col]])
) )
}, col = names(datar())) }, col = names(datar()))
if (!"none" %in% 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 <- setNames(names(labels), labels)
choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)] choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)]
} else { } else {
@ -327,7 +329,10 @@ 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) + ' ' +
'<span style=\"opacity: 0.3;\"><code style=\"color: black;\"> ' + '<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
item.data.dataclass +
'</code></span>' + ' ' +
'<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
item.data.datatype + item.data.datatype +
'</code></span>' + '</code></span>' +
'</strong></div>' + '</strong></div>' +
@ -1407,9 +1412,9 @@ data_visuals_server <- function(id,
z = input$tertiary z = input$tertiary
) )
}, },
warning = function(warn) { # warning = function(warn) {
showNotification(paste0(warn), type = "warning") # showNotification(paste0(warn), type = "warning")
}, # },
error = function(err) { error = function(err) {
showNotification(paste0(err), type = "err") showNotification(paste0(err), type = "err")
} }
@ -1475,9 +1480,9 @@ all_but <- function(data, ...) {
#' #'
#' @examples #' @examples
#' default_parsing(mtcars) |> subset_types("ordinal") #' 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) #' #' 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] data[sapply(data, type.fun) %in% types]
} }
@ -1510,58 +1515,58 @@ supported_plots <- function() {
fun = "plot_hbars", fun = "plot_hbars",
descr = "Stacked horizontal bars", 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", 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"), primary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.type = c("dichotomous", "ordinal"), secondary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
tertiary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.extra = "none" secondary.extra = "none"
), ),
plot_violin = list( plot_violin = list(
fun = "plot_violin", fun = "plot_violin",
descr = "Violin plot", descr = "Violin plot",
note = "A modern alternative to the classic boxplot to visualise data distribution", note = "A modern alternative to the classic boxplot to visualise data distribution",
primary.type = c("continuous", "dichotomous", "ordinal"), primary.type = c("continuous", "dichotomous", "ordinal" ,"categorical"),
secondary.type = c("dichotomous", "ordinal"), secondary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
secondary.extra = "none", secondary.extra = "none",
tertiary.type = c("dichotomous", "ordinal") tertiary.type = c("dichotomous", "ordinal" ,"categorical")
), ),
# plot_ridge = list( # plot_ridge = list(
# descr = "Ridge plot", # descr = "Ridge plot",
# note = "An alternative option to visualise data distribution", # note = "An alternative option to visualise data distribution",
# primary.type = "continuous", # primary.type = "continuous",
# secondary.type = c("dichotomous", "ordinal"), # secondary.type = c("dichotomous", "ordinal" ,"categorical"),
# tertiary.type = c("dichotomous", "ordinal"), # tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
# secondary.extra = NULL # secondary.extra = NULL
# ), # ),
plot_sankey = list( plot_sankey = list(
fun = "plot_sankey", fun = "plot_sankey",
descr = "Sankey plot", descr = "Sankey plot",
note = "A way of visualising change between groups", note = "A way of visualising change between groups",
primary.type = c("dichotomous", "ordinal"), primary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.type = c("dichotomous", "ordinal"), secondary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
secondary.extra = NULL, secondary.extra = NULL,
tertiary.type = c("dichotomous", "ordinal") tertiary.type = c("dichotomous", "ordinal" ,"categorical")
), ),
plot_scatter = list( plot_scatter = list(
fun = "plot_scatter", fun = "plot_scatter",
descr = "Scatter plot", descr = "Scatter plot",
note = "A classic way of showing the association between to variables", note = "A classic way of showing the association between to variables",
primary.type = "continuous", primary.type = "continuous",
secondary.type = c("continuous", "ordinal"), secondary.type = c("continuous", "ordinal" ,"categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
tertiary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.extra = NULL secondary.extra = NULL
), ),
plot_box = list( plot_box = list(
fun = "plot_box", fun = "plot_box",
descr = "Box plot", descr = "Box plot",
note = "A classic way to plot data distribution by groups", note = "A classic way to plot data distribution by groups",
primary.type = c("continuous", "dichotomous", "ordinal"), primary.type = c("continuous", "dichotomous", "ordinal" ,"categorical"),
secondary.type = c("dichotomous", "ordinal"), secondary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
tertiary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.extra = "none" secondary.extra = "none"
), ),
plot_euler = list( plot_euler = list(
@ -1572,7 +1577,7 @@ supported_plots <- function() {
secondary.type = "dichotomous", secondary.type = "dichotomous",
secondary.multi = TRUE, secondary.multi = TRUE,
secondary.max = 4, secondary.max = 4,
tertiary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
secondary.extra = NULL secondary.extra = NULL
) )
) )
@ -1601,7 +1606,7 @@ possible_plots <- function(data) {
data <- data[[1]] data <- data[[1]]
} }
type <- outcome_type(data) type <- data_type(data)
if (type == "unknown") { if (type == "unknown") {
out <- type out <- type
@ -1793,7 +1798,9 @@ allign_axes <- function(...) {
xr <- clean_common_axis(p, "x") 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 #' Extract and clean axis ranges
@ -1811,7 +1818,7 @@ clean_common_axis <- function(p, axis) {
if (is.numeric(.x)) { if (is.numeric(.x)) {
range(.x) range(.x)
} else { } else {
.x as.character(.x)
} }
})() |> })() |>
unique() unique()
@ -3392,13 +3399,13 @@ plot_box_single <- function(data, x, y=NULL, seed = 2103) {
data[[y]] <- y data[[y]] <- y
} }
discrete <- !outcome_type(data[[y]]) %in% "continuous" discrete <- !data_type(data[[y]]) %in% "continuous"
data |> data |>
ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + 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) + ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) +
## THis could be optional in future ## 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() + ggplot2::coord_flip() +
viridis::scale_fill_viridis(discrete = discrete, option = "D") + viridis::scale_fill_viridis(discrete = discrete, option = "D") +
# ggplot2::theme_void() + # ggplot2::theme_void() +
@ -3524,7 +3531,7 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
# patchwork::wrap_plots(out, guides = "collect") # patchwork::wrap_plots(out, guides = "collect")
} }
?withCallingHandlers()
#' Easily plot single euler diagrams #' Easily plot single euler diagrams
#' #'
#' @returns ggplot2 object #' @returns ggplot2 object
@ -4741,7 +4748,6 @@ regression_model_uv <- function(data,
fun = NULL, fun = NULL,
vars = NULL, vars = NULL,
...) { ...) {
## This will handle if outcome is not in data for nicer shiny behavior ## 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] outcome.str <- names(data)[1]
@ -4804,7 +4810,7 @@ regression_model_uv <- function(data,
### HELPERS ### HELPERS
#' Outcome data type assessment #' Data type assessment
#' #'
#' @param data data #' @param data data
#' #'
@ -4814,17 +4820,35 @@ regression_model_uv <- function(data,
#' @examples #' @examples
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' lapply(outcome_type) #' lapply(data_type)
outcome_type <- function(data) { #' 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) cl_d <- class(data)
if (any(c("numeric", "integer") %in% cl_d)) { if (all(is.na(data))) {
out <- "continuous" out <- "empty"
} else if (any(c("factor", "logical") %in% cl_d)) { } else if (length(unique(data)) < 2) {
if (length(levels(data)) == 2 | identical("logical",cl_d)) { 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" out <- "dichotomous"
} else if (length(levels(data)) > 2) { } else {
if (is.ordered(data)) {
out <- "ordinal" 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 { } else {
out <- "unknown" out <- "unknown"
} }
@ -4870,7 +4894,7 @@ supported_functions <- function() {
polr = list( polr = list(
descr = "Ordinal logistic regression model", descr = "Ordinal logistic regression model",
design = "cross-sectional", design = "cross-sectional",
out.type = "ordinal", out.type = c("ordinal","categorical"),
fun = "MASS::polr", fun = "MASS::polr",
args.list = list( args.list = list(
Hess = TRUE, Hess = TRUE,
@ -4908,7 +4932,7 @@ possible_functions <- function(data, design = c("cross-sectional")) {
} }
design <- match.arg(design) design <- match.arg(design)
type <- outcome_type(data) type <- data_type(data)
design_ls <- supported_functions() |> design_ls <- supported_functions() |>
lapply(\(.x){ lapply(\(.x){
@ -5100,11 +5124,14 @@ list2str <- function(data) {
#' #'
#' @examples #' @examples
#' \dontrun{ #' \dontrun{
#' gtsummary::trial |> regression_model_uv( #' gtsummary::trial |>
#' regression_model_uv(
#' outcome.str = "trt", #' outcome.str = "trt",
#' fun = "stats::glm", #' fun = "stats::glm",
#' args.list = list(family = stats::binomial(link = "logit")) #' args.list = list(family = stats::binomial(link = "logit"))
#' ) |> lapply(broom::tidy) |> dplyr::bind_rows() #' ) |>
#' lapply(broom::tidy) |>
#' dplyr::bind_rows()
#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") #' 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()
#' } #' }