From c69baaaac1f4234a689e4f8eb80fd2becc79e094 Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Thu, 20 Mar 2025 11:45:17 +0100
Subject: [PATCH 1/7] both data class and data type included

---
 R/custom_SelectInput.R | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R
index 7a72fc42..d9da27bd 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,7 +64,10 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
           return '<div style=\"padding: 3px 12px\">' +
                    '<div><strong>' +
                       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 +
                       '</code></span>' +
                    '</strong></div>' +

From d664adc50050532976e62cbb335f3d35480f6fd9 Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Thu, 20 Mar 2025 11:45:37 +0100
Subject: [PATCH 2/7] dont stop on warning!

---
 R/data_plots.R | 52 ++++++++++++++++++++++++++------------------------
 1 file changed, 27 insertions(+), 25 deletions(-)

diff --git a/R/data_plots.R b/R/data_plots.R
index ccc14b85..7e234a03 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
     )
   )
@@ -504,7 +504,7 @@ possible_plots <- function(data) {
     data <- data[[1]]
   }
 
-  type <- outcome_type(data)
+  type <- data_type(data)
 
   if (type == "unknown") {
     out <- type
@@ -696,7 +696,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 +716,7 @@ clean_common_axis <- function(p, axis) {
       if (is.numeric(.x)) {
         range(.x)
       } else {
-        .x
+        as.character(.x)
       }
     })() |>
     unique()

From 184bce42c594b6e9e35e5b5ae91429cf2ed89f3d Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Thu, 20 Mar 2025 11:46:02 +0100
Subject: [PATCH 3/7] updated with new data types

---
 R/app_version.R             |   2 +-
 R/plot_box.R                |   4 +-
 R/plot_euler.R              |   2 +-
 R/regression_model.R        |  64 +++++++++++------
 inst/apps/FreesearchR/app.R | 135 +++++++++++++++++++++---------------
 5 files changed, 127 insertions(+), 80 deletions(-)

diff --git a/R/app_version.R b/R/app_version.R
index d3c4a1b4..79df9cf7 100644
--- a/R/app_version.R
+++ b/R/app_version.R
@@ -1 +1 @@
-app_version <- function()'250319_1327'
+app_version <- function()'250320_1144'
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..6682fff1 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,
@@ -345,7 +362,7 @@ possible_functions <- function(data, design = c("cross-sectional")) {
   }
 
   design <- match.arg(design)
-  type <- outcome_type(data)
+  type <- data_type(data)
 
   design_ls <- supported_functions() |>
     lapply(\(.x){
@@ -537,13 +554,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..ecda4796 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_1144'
 
 
 ########
@@ -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,7 +329,10 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
           return '<div style=\"padding: 3px 12px\">' +
                    '<div><strong>' +
                       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 +
                       '</code></span>' +
                    '</strong></div>' +
@@ -1407,9 +1412,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 +1480,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 +1515,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 +1577,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
     )
   )
@@ -1601,7 +1606,7 @@ possible_plots <- function(data) {
     data <- data[[1]]
   }
 
-  type <- outcome_type(data)
+  type <- data_type(data)
 
   if (type == "unknown") {
     out <- type
@@ -1793,7 +1798,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 +1818,7 @@ clean_common_axis <- function(p, axis) {
       if (is.numeric(.x)) {
         range(.x)
       } else {
-        .x
+        as.character(.x)
       }
     })() |>
     unique()
@@ -3392,13 +3399,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 +3531,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 +4614,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 +4630,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 +4740,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 +4748,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 +4810,7 @@ regression_model_uv <- function(data,
 
 ### HELPERS
 
-#' Outcome data type assessment
+#' Data type assessment
 #'
 #' @param data data
 #'
@@ -4814,17 +4820,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 +4894,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,
@@ -4908,7 +4932,7 @@ possible_functions <- function(data, design = c("cross-sectional")) {
   }
 
   design <- match.arg(design)
-  type <- outcome_type(data)
+  type <- data_type(data)
 
   design_ls <- supported_functions() |>
     lapply(\(.x){
@@ -5100,13 +5124,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,

From b945b6af339d615538226350a1d838b4a7ac9a22 Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Thu, 20 Mar 2025 11:46:13 +0100
Subject: [PATCH 4/7] temporary favicon

---
 inst/apps/FreesearchR/www/favicon.png | Bin 0 -> 6547 bytes
 1 file changed, 0 insertions(+), 0 deletions(-)
 create mode 100644 inst/apps/FreesearchR/www/favicon.png

diff --git a/inst/apps/FreesearchR/www/favicon.png b/inst/apps/FreesearchR/www/favicon.png
new file mode 100644
index 0000000000000000000000000000000000000000..e284d2d2b85572bf031f3eb87e38e9a33fbc41f7
GIT binary patch
literal 6547
zcmdscS5#A5)b7qEXhHxJq=OOyC`AE5s+7=+^e!kxdIv#Kq$CvSf(l3#6bT?56afJP
z3J8YYkrJgVP3ir{bIyId&v*R))7*Q_Z+>%*HOm-ltr!D64LTZj8UO(3v@}(X002Vy
zgaEKp6mj!Tp%VbGS!$^&ncTNt$wu^+nVPmI-j1Z!9-!mo&`ZeBl}gdp=~ua@G{`T)
zeeXMuFYkcB+0Qz&d797`QH;SQ`e!u!N~tlaZGEhfh8lxaZP!E6V{Q@pvDuwPTQd)v
z{F?l_10GB-+;T5(%sH|Vckjk;$hof^O}n2=H||vLjPHzdqd?_cE9mNwXP2ojHyU~`
z8eoJf=h{P6fpbz#Z-gl_7Q)?o1;pSUbJ&=&fEb_^hg@WZps?);<!=xW6z(<_<{yuP
z<<7L34@Kf&*ehtLtU4Cj>pN5YQyB}*WkrJLc+lWt?Qhe&+-T5%7KVR}LPGo}cHh(^
zkr4h<5!iNEG$890WO|Dt8L9r~x+gNi$@t+Cjg0ezc_#2NEU3dHc-X(S&#AsB6;4)o
zG$lOnOegW2tbDc&2KowxgZ1vDH+5{T5Rj^V{TPTG$sh#3bXGUfh2EFxek^RlF(t5g
zX^!yF@{R3v=(+>dHse4+4YZ<j{2VA{kx(wtSQ(k|9t+TJiHOTjCV#vhfknV>I!6Yj
z3gm^m<=+FPr;@G>Y<_k_nKVZb=V22bC;pX7m*0h%h(oeGa<d%+bxO%aH<fKqL8lax
zh+E=vR)<e4;kZ2o(q3sR>WK<BIgxmgG>gzJwqhxK0z4Ma6&4Fl4!!o}6;e}$EKdcW
z$S@0|;~Y^3&alZUPH*!m+q%IjoN-Tx8tz3Fp3n*pVwM#`S}+O;!;&SOo|RLXYU)DQ
zEmUT=2xkgGHYR1*XY@Lo_yO%eKwDZ)kDD&kC!gtPY=g;0AA!Gsx}TD=AJ49Bjez*v
zUwB4{8U|uJ(NG%ny3dBM21L=SzAzFHerr@EjX{BpXyWs->S`e?DhTIobi>!p(^bt$
zq1*;Yd_ZP-ds;|cZcq5lAuRBr#AL`Th2+7x_d*WzxI6vq##eS2PDR1oF$_JejE3Vk
zy4Ga0n$~<NM9VdIvNGUdK?poAH2P@ZX^^=Jkd-FOeHOaM3~IrWRA+x{H5GH?&RA%D
z`NKnrfg8K5h^g+E(1DDy-8H!Y`*Ruk6j?iPNLURj#RJFfSOY@NYgqC(f2h%c?VAnA
z{>gQ3kO>Q$<xUzuZJZqk{CTDKqF4$2?hHYe1!8hGLQwNOSQIQeR0l(g{G6?0|HsY`
zg_Te$4EtYYw1EY8?W>QP-7;!}l=Q@&PZbTDljbGnij5N5^GbQIL-Ms&!i&18;N**4
zlDxge6Anx#@P*Fsi?!Q=WO&)s(|`A`!QQo89)(kUivdD))+$+_FyG_>5`czJrciQ1
zp*o-xT}E#zLA@Sn4kgDeSi7@BcBzEG^>z~|IkAWUD5b>$hj=E)uDu`#YoRQjDS;8W
zj8Rx5fkJ4j1{_lWVWJeke^$tdA_~BQ;*o&Cp>-$#B8A}!69j4}2(F(t`%4Q$!;C3_
zioYSL{Xbj`h=S5xm)7V7y%A33HOj&=%$wJpe!bV}@qIg%QFP0UYz5L}2V$g#_5eaR
zxT}#e0wYTbu|EJRb_`E$OFA0z;Bw~~C}Dlzha9%{E-f7f?6Z_>#bI!{PH|{J7t*E+
zIUX3_l^YP!W!t{K&7CWNHMpvZ#4&`Co}VEP4A;yas3<ZIc9&)j!O(@&JTNQ|ZcGDM
ztG*ZfLSQ4fV;;uoe6nc{0rJZ}<;!vr86mqGLziqIt77k+)0^5hLyzJ_wc_;OTi&t@
zjIdw%r@XOXFQe@*0ixHZ;~kypU#wpm({A&wa}F4131<D9t}Nw6Tk*_bY6~`5h3u16
z(X|1o!*^z_Hk{GqLh9noe?iQ&*<Ci%(ZJO0L>sTp90o2ZtE(9M?ssZZ{&us;0v?*H
zMm%DHcuSPzICMHI#E5`V=`yf@OYqnKsU>j1?tq9?mWav1&dSzli-)+Qoj9Gn46*Y6
zi$D>7!pKI(X8Z3t6}{hc?i_l5bN?u}Q2cM}*>)SGANeX!-H{Q5q6OjrD1agf{-+vd
zO+TpPSxM;WK1#J-SH>NIp)P?rY_x>GzA-qq7L~-eu|(ri@<=!KzfR5_8oehV^<k-L
zAlcMk{nFygObhGElb#3E>Jo=zog?vlLP7(TrM&;nfLj08%<;Wr0qF{N7B|mSD{|Fh
zo4LVm;R&zK8>f!Dhv(TN%c)pA3@Zi|(th5A8rV0~rz}}i`-d&f=<FR_+W21Cz1LaU
zzNt%?6}3$^c;>Nn_rK{f$e1VW_}x6XW7A~dbe#pKb3}svNam_!shtC`S9zXTPsIP%
zRBdVjk>0*$FB*T_2Yga9jd=%Zl2ZsmhI&qK5%47Aq))29`2LNS#45X`px&-Hk}MP4
z)x!9_i{KHvfB&}9$El#u(PZi#iGP|{4TyPJo8~^heaT~J>i3xvK2>ae^@h%g=M|Xx
zN4k4baR8-0BhY#FMZ0l_VU@XC;;r%rvJP&<J(y9pv&XZh(Zd%qCIVX;(nEFXK$GD)
z56_O}v$aV?lL-B2Mfd%HNTJVxK!*jZ(mw@)!L`^)b)P%;!n2h2Rsp|*qLU{%0AarR
zk_yggJ-QaMstTkpj;v)exhvRQu5v9nwk%6sU-{&cJIfY3&~;IUZNT9TlnCn6O^3>J
zr0U<`)8DBKUy;(`ky^k1W5zB{1j?%?AkVkXf56XS%!f0yH92IE+B(c~jj<`no?qZ2
z^pvnBetGpfeHAk>qApw1S_8{XO&zW0>=C?bGU3*4$)UNI{8WU>;i$2>{br+?DzH`4
zW!YhYn;B8GY<jpm7i#%7PkmWD!GU-4je6&`H)$B0VFgq0(&;Xahu?VAJ|1%9ebppu
z=<KM5<+xfwlVXmyn`Fk+!v<XHNSty~<63#!H*`XRAPjnV4QLX0K+;PTS^rf%`Cuy@
zaqau*bo!v2rOv^h{9xgGHMVW>!$ihABfqn4s^r0dQJzGx?7??S7~Ben!c2@v=D@|w
zW361jWk0o1DeC>S4A*X@!_H(uKCrM_Vl4X43SP~=FR{3+V~{8P4BjZmVL@o<OMx1|
zgGYp{u#gnm&GH<^X#F04G`mq5_C%w1gWapVzKVbM79qLv0SYoW5<$B1aqQ~P2HB7M
zhx^Xnzw>#1r_6W~X4h4UHumE`CO`3macU}ad1^B-RKcA)t-54vPGzv5u)(^lM@wt+
zW^*Mk6|K_8ZfX4KmM7Tv{8*!m68N^W8N1kHl+?#t7El8&NCov)eeP|?(*2F%kQf2D
zbc1=HjIsWUuzppd%Um;|bi%O0PBR7w3mn(1<}E}gY%gdueH?P1wmaFC9aw``G^Tg#
zoN+kyQmx>pLPrqR=VE4R>@UX+wZKZJd`1H+2;&omlA%*}njO7j%JYqH@AQc|WR(|?
zN>Dx_VH{DfB5h8*uXx^LM1#@vPxh8KgqVM?<fw@+GnDlGDW4}Zg&zmJt=3&WDLe{o
z8ac6moGhdzZXkByzT6-Te>b^Lf6VG;Hk0rCNvqS2ltzkM({lye#OfQ5Y{(vVomB9{
zARndLN7-kSxe(iDZ(Bo=;4l6>(#e?jd2WBwBI6X2Wz4@&<8q6$Dl;toShaJb>wbra
zuGd`@q*ke};$?LgnC{XLNmA&0uyEWKlr*2QHuJ9Is016YjnM#a%7S|m7cscNjCj9=
zOIZ)Ta&(c^1NtBA7X?4Ogb0fd!>kDf)s8I?4UEN1L0fS;zv|T4IWvnj?^&oq+?}XX
zppxv$0`>TgSeG(?X6~yddQoay!QNz@6hN=qY;@A(`e(*e{o7KlX-(~dJj^wpA5ZqN
zSiGgv^~*CH1o=3^n_l`yGH*$lg6KH<Jls^I=X-rPh&T1Vce!e;fN76Lh(GhGG|f5g
z#4CAO)h_C)K-blw3F^7|^ni?znF;UiZ7|?egMW=iabRqAn4wjvjZ4km&))cGAj9=d
z9isF7k`(D^*h3`f%lVm+6P{{$>q+AgtC$eMTob8`u0oVK*7xg5`qZ0slokHnsfzuT
z%pMz5|7_TZEPC{8vpK}u?sCLkoKwvy{ku>!XmM*fwze%3t=M^0&;}n+FhQEi8CR6M
zLcB4!FoAoe7Xa-&z>pg+TON;J#gvW?IZ53y*451QwoT^1^GI5&Is4sd)!+flrHik$
zy<a_{5!9{zW_^YjuA_3oitF>L?ts08rwc+h6+pDiDVEqk#HSFW6#ehp6DlR=*CdZZ
zoRhpHA6}IGMk`L)u*G0HGBl1A?6XQUOG5ey-ocwj#2Ly(PG;?FU1fE>4n@Xzy;u<^
zZ81SswU$~Z9tbk1B_nY=HLFNcfi}>n52;-bZ{_!Pb;G+q>a6xl>@u2aF@GA}KtDBi
zDfOCXahN+7?qT(+ZGK3{^s;=M)d#9&r*z&S>8SjM$Od|eIknNZA;#w*I+qO==z94<
zGFd;t`FNq#`Dg>Bh;7ddmyct7Gx&irL8l4;?@A!Hwl<9C9q&n6Eb=5CXzH$0?&74$
z5QMluk>b?oqQzK0=MKpoEg_=bg0c%#^mHytrD6(>cH<Bov7eUI_*S#dpNSu3oE5;}
zWP0P#e_6A%si?f|!uzf@BwQGe8>joiynI3Ox+_f*YcRe{hMM&WJiv{om>+bxphz}>
z=kB10k?H_%!FuXKM)TK3ijDotWNKsmy;p4ZT*L*r1obgWJUT1S-KMr}s#taz7cU!s
zgMab0eN6q3rafOvemH_sS1yD)gciF`KmH+NV?3ItZE7xS$ojL1YiriVyVw7wk2-q%
zM<;4VBQvBnW^t-M$zhcnzwlmWWG<0py(v%YrS{@)lBv<y#S)avdcmFZXu->@??rtL
zwa-$zY%v&$U7z&&89aRM!$_L21ZvWX<qyMwv+$WM=KhMt?r$#1jYSMNb>P~)n~q9;
zfmpH+DaCZviNVGz3^Kr4Bl+;Ucn(lh3nPBm`&Fs25Cz4|%8A!=+SMj?6>>aVt@^`d
zT}UtNr3wg(nz{12Jwv4M^>TTPe@@?_vWyb?bTWMP$18&}Z5|;XaY{J7?8L|CW*cV2
zbh-%|U%rwS%hg!vYaV!!7w5*D4u+cN0whF0pU7%i`;Yc~vGsL3XPpj~2)evYtd{ev
z2OE@=A>2iPf$(Q9rBCf2J`C9nrtWy!8sQ^sn;`AaID{7#|K#EPIO!URAA!^DFo9!@
zaYLdG)d;qr^C;Goo5)VJm+!t-F(rKuO<vc!@>8&;Q0$iwmbGe&^)Y>r+dl7r)QIt1
zxb~f_qZ})p8$dimfBrMcMu9$9ZqYousl|N$1ZsUKZ|cPgA9zAd2vzttqn5MpyV1sd
zp~+IUBgIJ?gYYwXurr=bsYW{6lirwmm|r6cJ<Sz{-TU_kyBBg*Co^?ZW&hcW<Lp_s
z?Hs<Ef~pUzOoR^$zw)^CpEboBb{H#{tceGPA8oldE3}aGQ-G_Ww6sGS)f!FQ>)=N+
zXHJR<v>&P?bQPr1)jhW4EA({RGhk>T)vpKn8!BM_?7R7Bd02iA?fTM&rLpi)G&AAa
ztOjl~BbkzG0&qHt=Z4#qZKuMnQA<7XE@327{X&Ps$V^9g)uOqw=F!#wA^vIx6AD|c
zEA@s<iVB_HJkFasf6{;YGy@KH9MX_ZH~m`A|G0l+ozQ*c{b-NU4@(cy{Z7mD-kkNS
zU5Pz*eTY-5RurGKm%X<b^t$o7!pDoWq3R*i(<OS(YI&5P6}P_VtxYFZ2v%CI1+%p^
zX!^cND*fy&e(OpkXD^i&zPpL=nrB9PZ7qA`263ZDD)afN(aUaCr@-ji^vG~Fs6}xL
zI4*;aTtJ>dI7-mOJ#t4xU30%gt{0Qg2PKfiC|ZLWL+x#DVz(@_Se_)M07CMY{Gj{F
zunJ_YM_`|_8G}t39vD>^H(`iWUTJMT&vJVIhvp@f(P*m(s<>O(OCq$q$T2g!6bkB<
za1||8X_DR32ck5)3)oOn0XJlAa1^gr*1tJP1$XcYVW-xigZenFi%jy{3O<P0><{va
zP0kph!u&dC_n}S#Pq{=`$uO>U!C-PNsG{XsYs{R489Y}nJ%p0!B{MM;J=vXhGaz04
zLaC3-$kns?!m~k7hSo=PGwVi#OVw)bks>dBC2+>Rv35fP*xTp#uMg#=7!!9gzVQtt
zGWzrsXlP=qSiu}F&D?!M)5}ogUEP7(T^2px_|EE8T=2uYwyo9&B6kF|wg&K)Fraoz
z!geF~;JF<m)+vYKkB(o9^Oxx5I=)VuxWpbh9=uxs?XW6vk=^38hj6e#eyZ(Q87JrK
z8)9>AWehDv&DFYzm%n?oD2xu(dUUoG|9pJ`1hR^w(B<@n+B7EnPE*+`nagipAD1$R
zZ_pK_-9f$)EJ^^RXPcd3+sz`4<RicL!<%Rh9h)(eJwZxxi+$8bdR;@I7LlpCbtU=i
z6fE%Q^V1~Ud=5ucM*`&{>4tP{+AH6CIG)<4zOcgsEXdhWrtHQG;9}|<-_i7*qk$;B
zn6q`ZJ{vWTa8A2((KaU8Y9rNqcwuKWyrehBt@A?RQ==jOTr)6N33fHjC?`*nUZ38;
zm&5Z>k}>YF%JAeTF&feSiz5L_S-*T|tb*V38i+%B+j#E><q1G8j&VWC=I4d$Nka8n
zgUv2LRatuBm{He-i+|2~@lHO)u0XN&@`K5r;|>KVP_KFUsjJua;I6f7dVUqrA4kx%
z@AmRPwj~ektn??|)dDXgf#%O5bUB8-g$Jwdu<<L7yHpQj<PJTUJDGnhMd@%!9qxT;
zq27<*n?ZD3d!(o+5q0uu<%aMXM@wTPm-mhXLfW#oHil>*B`E=(s~vR^UBtGUP6C@-
zI>WM<d`EJZYSz93s?SRE<X-X83W4^wIkSK7kY=s~XyN{CtGSgWd>Q&2(U$e~7s<CL
zppwx(qWcWo$9U}uA?qY}a-RFn(?|Wy-W;-Wp?^*q@;Mk>QUH37_3UlMVduoTHF=t-
zM`A40?YHSs>k{~T;Yb5nNq3Gx=ipbpl?wC0<p_o}8VKoIZJ;&GBMKNPs=h#cS@^W&
zRJr4T`EwsZkRM+aL^<>ZM|E3dKrKje<xqGuU`eN&@_`Xd0(c;L>Zy#HluJU>CwgkY
zlf}+$6QnKVECbrpQfsdO4{c%i6booe76iSECz{jo5?{nUZMn@qfJZVQA;})vdv53O
z<(wf;#5HkCfYh}Qu`nW&9@{SfLis1gAx2WJUFC+{3#pHR5$Uwqe!?I|1u7tCgrI<j
z=OgHstT_w@U}1H9tpXiQpn*5M_L;n;g@qc_Zq0fb!8pYZG0!jHLs<`3tr>Mu#8<GN
z!Q2&rrIt&tF~T=qssc1N+!fN`&Upfr$gPRN8s?j8>_~`5-23xLP@EfUV=0-y3)vBB
zR|Ul1m7Zt#yB2!e4!Om=)2$Ct1E#uoA1d2&!S8RCS8zl%(iEz*fXcR^&|!5jZo9Ig
zyBvj6HiLb}5CZ{KBIY|QH#f~Mn&<Hk9;5~^I~LpsT4dwy6$f9tg+oWhMH3?eLK1*^
zS9*CNXd4evom<m(_`})N^C5eC!(4*wkcbwc8D(1$u=**s@-Oo%V_32p?vqM9R9ffl
zlOVg@xsSCbl~+Oj$hU_uyeU*#ofhs>a=(#r?T{V9&l`!Q2YDIs&@W;ULB14hp}#K$
zn^1cQ|BIFT%#E2fGA<Jm5ys$tBz=8}9E}5bef-T93K%hfTHgQvCj$J*X{nAM!a3mA
SbCkyxKub+ewM^MI?Ee6NQoSkw

literal 0
HcmV?d00001


From 2495da555add48029220831f9a28b30ae13bb461 Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Thu, 20 Mar 2025 13:12:38 +0100
Subject: [PATCH 5/7] no type or clase if missing

---
 R/app_version.R        |  2 +-
 R/custom_SelectInput.R | 10 ++++++----
 2 files changed, 7 insertions(+), 5 deletions(-)

diff --git a/R/app_version.R b/R/app_version.R
index 79df9cf7..ff73a306 100644
--- a/R/app_version.R
+++ b/R/app_version.R
@@ -1 +1 @@
-app_version <- function()'250320_1144'
+app_version <- function()'250320_1310'
diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R
index d9da27bd..3704c98b 100644
--- a/R/custom_SelectInput.R
+++ b/R/custom_SelectInput.R
@@ -64,13 +64,16 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
           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>' + ' ' +
+                      '</code></span>' : '' ) + ' ' +
+                      (item.data.datatype != '' ?
                       '<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
                         item.data.datatype +
-                      '</code></span>' +
-                   '</strong></div>' +
+                      '</code></span>' : '' ) +
+                   '</div>' +
                    (item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') +
                  '</div>';
         },
@@ -89,7 +92,6 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
 }
 
 
-
 #' A selectizeInput customized for named vectors
 #'
 #' @param inputId passed to \code{\link[shiny]{selectizeInput}}

From 7df711424eca7be50e335787a4cc1c0c21487c99 Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Thu, 20 Mar 2025 13:12:51 +0100
Subject: [PATCH 6/7] logical icon

---
 R/data-summary.R | 2 ++
 1 file changed, 2 insertions(+)

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) {

From 1bfad4ba4c5d0d94f6aab3440f8db592e53bc0bf Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Thu, 20 Mar 2025 13:13:14 +0100
Subject: [PATCH 7/7] strugling with reactivity

---
 R/data_plots.R                                |   2 +
 R/regression_model.R                          |   1 +
 inst/apps/FreesearchR/app.R                   | 189 +++++++++++++++---
 .../shinyapps.io/agdamsbo/freesearcheR.dcf    |   2 +-
 inst/apps/FreesearchR/server.R                |  95 ++++++---
 inst/apps/FreesearchR/ui.R                    |   9 +
 6 files changed, 237 insertions(+), 61 deletions(-)

diff --git a/R/data_plots.R b/R/data_plots.R
index 7e234a03..e9225dec 100644
--- a/R/data_plots.R
+++ b/R/data_plots.R
@@ -500,6 +500,7 @@ 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]]
   }
@@ -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]]
   }
diff --git a/R/regression_model.R b/R/regression_model.R
index 6682fff1..1ed69e7e 100644
--- a/R/regression_model.R
+++ b/R/regression_model.R
@@ -357,6 +357,7 @@ 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]]
   }
diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R
index ecda4796..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()'250320_1144'
+app_version <- function()'250320_1310'
 
 
 ########
@@ -329,13 +329,16 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
           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>' + ' ' +
+                      '</code></span>' : '' ) + ' ' +
+                      (item.data.datatype != '' ?
                       '<span style=\"opacity: 0.9;\"><code style=\"color: black;\"> ' +
                         item.data.datatype +
-                      '</code></span>' +
-                   '</strong></div>' +
+                      '</code></span>' : '' ) +
+                   '</div>' +
                    (item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></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
 #'
@@ -1602,6 +1674,7 @@ 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]]
   }
@@ -1698,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]]
   }
@@ -2270,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) {
@@ -4927,6 +5003,7 @@ 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]]
   }
@@ -7244,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(
@@ -7916,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()
 
@@ -8045,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({
@@ -8104,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
+    # )
   })
 
 
@@ -8147,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(