docs

NAMESPACE

@@ -9,10 +9,13 @@ export(allign_axes)
 export(append_list)
 export(argsstring2list)
 export(baseline_table)
+export(clean_common_axis)
 export(clean_date)
 export(clean_sep)
 export(columnSelectInput)
 export(contrast_text)
+export(create_baseline)
+export(create_log_tics)
 export(create_overview_datagrid)
 export(create_plot)
 export(custom_theme)
@@ -20,8 +23,10 @@ export(cut_variable_server)
 export(cut_variable_ui)
 export(data_correlations_server)
 export(data_correlations_ui)
+export(data_description)
 export(data_summary_server)
 export(data_summary_ui)
+export(data_type)
 export(data_visuals_server)
 export(data_visuals_ui)
 export(default_format_arguments)
@@ -61,8 +66,9 @@ export(missing_fraction)
 export(modal_cut_variable)
 export(modal_update_factor)
 export(modify_qmd)
-export(outcome_type)
 export(overview_vars)
+export(plot_box)
+export(plot_box_single)
 export(plot_euler)
 export(plot_euler_single)
 export(plot_hbars)

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'250320_1310'
+app_version <- function()'250324_1432'

R/baseline_table.R

@@ -20,3 +20,55 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary,
   return(out)
 }
 
+
+
+#' Create a baseline table
+#'
+#' @param data data
+#' @param ... passed as fun.arg to baseline_table()
+#' @param strat.var grouping/strat variable
+#' @param add.p add comparison/p-value
+#' @param add.overall add overall column
+#'
+#' @returns gtsummary table list object
+#' @export
+#'
+#' @examples
+#' mtcars |> create_baseline(by.var = "gear", add.p="yes"=="yes")
+create_baseline <- function(data,...,by.var,add.p=FALSE,add.overall=FALSE){
+  if (by.var == "none" | !by.var %in% names(data)) {
+    by.var <- NULL
+  }
+
+  ## These steps are to handle logicals/booleans, that messes up the order of columns
+  ## Has been reported
+
+  if (!is.null(by.var)) {
+    if (identical("logical",class(data[[by.var]]))){
+      data[by.var] <- as.character(data[[by.var]])
+    }
+  }
+
+  out <- data |>
+    baseline_table(
+      fun.args =
+        list(
+          by = by.var,
+          ...
+        )
+    )
+
+  if (!is.null(by.var)) {
+    if (isTRUE(add.overall)){
+  out <- out |> gtsummary::add_overall()
+    }
+    if (isTRUE(add.p)) {
+      out <- out |>
+        gtsummary::add_p() |>
+        gtsummary::bold_p()
+    }
+
+    }
+
+  out
+}

R/data_plots.R

@@ -302,6 +302,7 @@ data_visuals_server <- function(id,
         {
           tryCatch(
             {
+              shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", {
               rv$plot <- create_plot(
                 data = data(),
                 type = rv$plot.params()[["fun"]],
@@ -309,6 +310,7 @@ data_visuals_server <- function(id,
                 y = input$secondary,
                 z = input$tertiary
               )
+              })
             },
             # warning = function(warn) {
             #   showNotification(paste0(warn), type = "warning")

R/helpers.R

@@ -239,7 +239,9 @@ default_parsing <- function(data) {
 #'
 #' @examples
 #' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label"))
-#' ds |> remove_na_attr() |> str()
+#' ds |>
+#'   remove_na_attr() |>
+#'   str()
 remove_na_attr <- function(data, attr = "label") {
   out <- data |> lapply(\(.x){
     ls <- REDCapCAST::get_attr(data = .x, attr = attr)
@@ -309,3 +311,29 @@ append_list <- function(data,list,index){
 missing_fraction <- function(data) {
   NROW(data[is.na(data)]) / NROW(data)
 }
+
+
+
+#' Ultra short data dascription
+#'
+#' @param data
+#'
+#' @returns character vector
+#' @export
+#'
+#' @examples
+#' data.frame(
+#'   sample(1:8, 20, TRUE),
+#'   sample(c(1:8, NA), 20, TRUE)
+#' ) |> data_description()
+data_description <- function(data) {
+  data <- if (shiny::is.reactive(data)) data() else data
+
+  sprintf(
+    i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases"),
+    nrow(data),
+    ncol(data),
+    sum(complete.cases(data)),
+    signif(100 * (1 - missing_fraction(data)), 3)
+  )
+}

R/plot_box.R

@@ -36,7 +36,7 @@ plot_box <- function(data, x, y, z = NULL) {
 #'
 #' @name data-plots
 #'
-#' @returns
+#' @returns ggplot object
 #' @export
 #'
 #' @examples

R/regression_plot.R

@@ -43,10 +43,11 @@ plot.tbl_regression <- function(x,
 
   # Removes redundant label
   df_coefs$label[df_coefs$row_type == "label"] <- ""
-
+  # browser()
   # Add estimate value to reference level
   if (plot_ref == TRUE) {
-  df_coefs[df_coefs$var_type == "categorical" & is.na(df_coefs$reference_row),"estimate"] <- if (x$inputs$exponentiate) 1 else 0}
+    df_coefs[df_coefs$var_type %in% c("categorical", "dichotomous") & df_coefs$reference_row & !is.na(df_coefs$reference_row), "estimate"] <- if (x$inputs$exponentiate) 1 else 0
+  }
 
   p <- df_coefs |>
     ggstats::ggcoef_plot(exponentiate = x$inputs$exponentiate, ...)
@@ -89,7 +90,8 @@ merge_long <- function(list, model.names) {
       )
       setNames(d, gsub("_[0-9]{,}$", "", names(d)))
     }) |>
-    dplyr::bind_rows() |> dplyr::mutate(model=as_factor(model))
+    dplyr::bind_rows() |>
+    dplyr::mutate(model = as_factor(model))
 
   l_merged$table_body <- df_body_long
 
@@ -117,6 +119,19 @@ limit_log <- function(data,fun,...){
   fun(10^-floor(data) * 10^data) / 10^-floor(data)
 }
 
+#' Create summetric log ticks
+#'
+#' @param data numeric vector
+#'
+#' @returns numeric vector
+#' @export
+#'
+#' @examples
+#' c(sample(seq(.1, 1, .1), 3), sample(1:10, 3)) |> create_log_tics()
+create_log_tics <- function(data) {
+  sort(round(unique(c(1 / data, data, 1)), 2))
+}
+
 #' Ensure symmetrical plot around 1 on a logarithmic x scale for ratio plots
 #'
 #' @param plot ggplot2 plot

R/regression_table.R

@@ -119,8 +119,8 @@ regression_table_create <- function(x, ..., args.list = NULL, fun = "gtsummary::
   }
 
   out <- do.call(getfun(fun), c(list(x = x), args.list))
-  out |>
+  out #|>
-    gtsummary::add_glance_source_note() # |>
+    # gtsummary::add_glance_source_note() # |>
   # gtsummary::bold_p()
 }
 

inst/apps/FreesearchR/app.R

@@ -10,7 +10,7 @@
 #### Current file: R//app_version.R 
 ########
 
-app_version <- function()'250320_1310'
+app_version <- function()'250324_1432'
 
 
 ########
@@ -41,6 +41,58 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary,
 
 
 
+#' Create a baseline table
+#'
+#' @param data data
+#' @param ... passed as fun.arg to baseline_table()
+#' @param strat.var grouping/strat variable
+#' @param add.p add comparison/p-value
+#' @param add.overall add overall column
+#'
+#' @returns gtsummary table list object
+#' @export
+#'
+#' @examples
+#' mtcars |> create_baseline(by.var = "gear", add.p="yes"=="yes")
+create_baseline <- function(data,...,by.var,add.p=FALSE,add.overall=FALSE){
+  if (by.var == "none" | !by.var %in% names(data)) {
+    by.var <- NULL
+  }
+
+  ## These steps are to handle logicals/booleans, that messes up the order of columns
+  ## Has been reported
+
+  if (!is.null(by.var)) {
+    if (identical("logical",class(data[[by.var]]))){
+      data[by.var] <- as.character(data[[by.var]])
+    }
+  }
+
+  out <- data |>
+    baseline_table(
+      fun.args =
+        list(
+          by = by.var,
+          ...
+        )
+    )
+
+  if (!is.null(by.var)) {
+    if (isTRUE(add.overall)){
+  out <- out |> gtsummary::add_overall()
+    }
+    if (isTRUE(add.p)) {
+      out <- out |>
+        gtsummary::add_p() |>
+        gtsummary::bold_p()
+    }
+
+    }
+
+  out
+}
+
+
 ########
 #### Current file: R//contrast_text.R 
 ########
@@ -356,76 +408,6 @@ 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
 #'
@@ -1476,6 +1458,7 @@ data_visuals_server <- function(id,
         {
           tryCatch(
             {
+              shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", {
               rv$plot <- create_plot(
                 data = data(),
                 type = rv$plot.params()[["fun"]],
@@ -1483,6 +1466,7 @@ data_visuals_server <- function(id,
                 y = input$secondary,
                 z = input$tertiary
               )
+              })
             },
             # warning = function(warn) {
             #   showNotification(paste0(warn), type = "warning")
@@ -2743,7 +2727,9 @@ default_parsing <- function(data) {
 #'
 #' @examples
 #' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label"))
-#' ds |> remove_na_attr() |> str()
+#' ds |>
+#'   remove_na_attr() |>
+#'   str()
 remove_na_attr <- function(data, attr = "label") {
   out <- data |> lapply(\(.x){
     ls <- REDCapCAST::get_attr(data = .x, attr = attr)
@@ -2815,6 +2801,32 @@ missing_fraction <- function(data){
 }
 
 
+
+#' Ultra short data dascription
+#'
+#' @param data
+#'
+#' @returns character vector
+#' @export
+#'
+#' @examples
+#' data.frame(
+#'   sample(1:8, 20, TRUE),
+#'   sample(c(1:8, NA), 20, TRUE)
+#' ) |> data_description()
+data_description <- function(data) {
+  data <- if (shiny::is.reactive(data)) data() else data
+
+  sprintf(
+    i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases"),
+    nrow(data),
+    ncol(data),
+    sum(complete.cases(data)),
+    signif(100 * (1 - missing_fraction(data)), 3)
+  )
+}
+
+
 ########
 #### Current file: R//import-file-ext.R 
 ########
@@ -5352,10 +5364,11 @@ plot.tbl_regression <- function(x,
 
   # Removes redundant label
   df_coefs$label[df_coefs$row_type == "label"] <- ""
-
+  # browser()
   # Add estimate value to reference level
   if (plot_ref == TRUE) {
-  df_coefs[df_coefs$var_type == "categorical" & is.na(df_coefs$reference_row),"estimate"] <- if (x$inputs$exponentiate) 1 else 0}
+    df_coefs[df_coefs$var_type %in% c("categorical", "dichotomous") & df_coefs$reference_row & !is.na(df_coefs$reference_row), "estimate"] <- if (x$inputs$exponentiate) 1 else 0
+  }
 
   p <- df_coefs |>
     ggstats::ggcoef_plot(exponentiate = x$inputs$exponentiate, ...)
@@ -5398,7 +5411,8 @@ merge_long <- function(list, model.names) {
       )
       setNames(d, gsub("_[0-9]{,}$", "", names(d)))
     }) |>
-    dplyr::bind_rows() |> dplyr::mutate(model=as_factor(model))
+    dplyr::bind_rows() |>
+    dplyr::mutate(model = as_factor(model))
 
   l_merged$table_body <- df_body_long
 
@@ -5426,6 +5440,19 @@ limit_log <- function(data,fun,...){
   fun(10^-floor(data) * 10^data) / 10^-floor(data)
 }
 
+#' Create summetric log ticks
+#'
+#' @param data numeric vector
+#'
+#' @returns
+#' @export
+#'
+#' @examples
+#' c(sample(seq(.1, 1, .1), 3), sample(1:10, 3)) |> create_log_tics()
+create_log_tics <- function(data) {
+  sort(round(unique(c(1 / data, data, 1)), 2))
+}
+
 #' Ensure symmetrical plot around 1 on a logarithmic x scale for ratio plots
 #'
 #' @param plot ggplot2 plot
@@ -5577,8 +5604,8 @@ regression_table_create <- function(x, ..., args.list = NULL, fun = "gtsummary::
   }
 
   out <- do.call(getfun(fun), c(list(x = x), args.list))
-  out |>
+  out #|>
-    gtsummary::add_glance_source_note() # |>
+    # gtsummary::add_glance_source_note() # |>
   # gtsummary::bold_p()
 }
 
@@ -7101,6 +7128,7 @@ ui_elements <- list(
             shinyWidgets::noUiSliderInput(
               inputId = "complete_cutoff",
               label = NULL,
+              update_on = "change",
               min = 0,
               max = 100,
               step = 5,
@@ -7111,7 +7139,8 @@ ui_elements <- list(
             shiny::helpText("Filter variables with completeness above the specified percentage."),
             shiny::br(),
             shiny::br(),
-            shiny::uiOutput(outputId = "import_var")
+            shiny::uiOutput(outputId = "import_var"),
+            shiny::uiOutput(outputId = "data_info_import", inline = TRUE)
           )
         ),
         shiny::br(),
@@ -7148,10 +7177,9 @@ ui_elements <- list(
           fluidRow(
             shiny::column(
               width = 9,
+              shiny::uiOutput(outputId = "data_info", inline = TRUE),
               shiny::tags$p(
-                "Below is a short summary table of the provided data.
+                "Below is a short summary table, on the right you can create data filters."
-              On the right hand side you have the option to create filters.
-              At the bottom you'll find a raw overview of the original vs the modified data."
               )
             )
           ),
@@ -7406,6 +7434,7 @@ ui_elements <- list(
         # bslib::layout_sidebar(
         #   fillable = TRUE,
         sidebar = bslib::sidebar(
+          shiny::uiOutput(outputId = "data_info_regression", inline = TRUE),
           bslib::accordion(
             open = "acc_reg",
             multiple = FALSE,
@@ -7467,7 +7496,7 @@ ui_elements <- list(
               ),
               shiny::conditionalPanel(
                 condition = "input.all==1",
-                shiny::uiOutput("include_vars")
+                shiny::uiOutput("regression_vars")
               )
             )
           ),
@@ -7823,11 +7852,12 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     eventExpr = list(
-      input$import_var
+      input$import_var,
+      input$complete_cutoff
     ),
     handlerExpr = {
       shiny::req(rv$data_temp)
-
+# browser()
       rv$data_original <- rv$data_temp |>
         dplyr::select(input$import_var) |>
         default_parsing()
@@ -7847,6 +7877,11 @@ server <- function(input, output, session) {
     }
   )
 
+  output$data_info_import <- shiny::renderUI({
+    shiny::req(rv$data_original)
+    data_description(rv$data_original)
+  })
+
 
   shiny::observeEvent(rv$data_original, {
     if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
@@ -7911,6 +7946,17 @@ server <- function(input, output, session) {
     modal_update_variables("modal_variables", title = "Update and select variables")
   )
 
+  output$data_info <- shiny::renderUI({
+    shiny::req(data_filter())
+    data_description(data_filter())
+  })
+
+  output$data_info_regression <- shiny::renderUI({
+    shiny::req(regression_vars())
+    shiny::req(rv$list$data)
+    data_description(rv$list$data[regression_vars()])
+  })
+
 
   #########  Create factor
 
@@ -8131,40 +8177,25 @@ server <- function(input, output, session) {
 
   ## Keep these "old" selection options as a simple alternative to the modification pane
 
-  output$include_vars <- shiny::renderUI({
+
-    columnSelectInputStat(
+  output$regression_vars <- shiny::renderUI({
-      inputId = "include_vars",
+    columnSelectInput(
+      inputId = "regression_vars",
       selected = NULL,
       label = "Covariables to include",
       data = rv$data_filtered,
-      multiple = TRUE
+      multiple = TRUE,
     )
-
-    # shiny::selectizeInput(
-    #   inputId = "include_vars",
-    #   selected = NULL,
-    #   label = "Covariables to include",
-    #   choices = colnames(rv$data_filtered),
-    #   multiple = TRUE
-    # )
   })
 
   output$outcome_var <- shiny::renderUI({
-    columnSelectInputStat(
+    columnSelectInput(
       inputId = "outcome_var",
       selected = NULL,
       label = "Select outcome variable",
       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({
@@ -8198,16 +8229,16 @@ server <- function(input, output, session) {
 
   ## Collected regression variables
   regression_vars <- shiny::reactive({
-    if (is.null(input$include_vars)) {
+    if (is.null(input$regression_vars)) {
       out <- colnames(rv$data_filtered)
     } else {
-      out <- unique(c(input$include_vars, input$outcome_var))
+      out <- unique(c(input$regression_vars, input$outcome_var))
     }
     return(out)
   })
 
   output$strat_var <- shiny::renderUI({
-    columnSelectInputStat(
+    columnSelectInput(
       inputId = "strat_var",
       selected = "none",
       label = "Select variable to stratify baseline",
@@ -8217,27 +8248,6 @@ server <- function(input, output, session) {
         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
-    # )
   })
 
 
@@ -8267,7 +8277,7 @@ server <- function(input, output, session) {
       # shiny::reactive(rv$data_original),
       # data_filter(),
       # input$strat_var,
-      # input$include_vars,
+      # input$regression_vars,
       # input$complete_cutoff,
       # input$add_p
       input$act_eval
@@ -8276,48 +8286,16 @@ server <- function(input, output, session) {
       shiny::req(input$strat_var)
       shiny::req(rv$list$data)
 
-      data_tbl1 <- rv$list$data
+      # data_tbl1 <- rv$list$data
 
-      if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) {
+      shiny::withProgress(message = "Creating the table. Hold on for a moment..", {
-        by.var <- NULL
+        rv$list$table1 <- create_baseline(
-      } else {
+          rv$list$data,
-        by.var <- input$strat_var
+          by.var = input$strat_var,
-      }
+          add.p = input$add_p == "yes",
-
+          add.overall = TRUE
-      ## 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 |>
-        baseline_table(
-          fun.args =
-            list(
-              by = by.var
         )
-        ) |>
+      })
-        (\(.x){
-          if (!is.null(by.var)) {
-            .x |> gtsummary::add_overall()
-          } else {
-            .x
-          }
-        })() |>
-        (\(.x){
-          if (input$add_p == "yes" & !is.null(by.var)) {
-            .x |>
-              gtsummary::add_p() |>
-              gtsummary::bold_p()
-          } else {
-            .x
-          }
-        })()
-
-      # gtsummary::as_kable(rv$list$table1) |>
-      #   readr::write_lines(file="./www/_table1.md")
     }
   )
 
@@ -8416,9 +8394,9 @@ server <- function(input, output, session) {
           #   .x$model
           # })
         },
-        warning = function(warn) {
+        # warning = function(warn) {
-          showNotification(paste0(warn), type = "warning")
+        #   showNotification(paste0(warn), type = "warning")
-        },
+        # },
         error = function(err) {
           showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err")
         }
@@ -8441,9 +8419,9 @@ server <- function(input, output, session) {
             purrr::pluck("Multivariable") |>
             performance::check_model()
         },
-        warning = function(warn) {
+        # warning = function(warn) {
-          showNotification(paste0(warn), type = "warning")
+        #   showNotification(paste0(warn), type = "warning")
-        },
+        # },
         error = function(err) {
           showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err")
         }

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: 9994253
 url: https://agdamsbo.shinyapps.io/freesearcheR/
 version: 1

inst/apps/FreesearchR/server.R

@@ -160,11 +160,12 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     eventExpr = list(
-      input$import_var
+      input$import_var,
+      input$complete_cutoff
     ),
     handlerExpr = {
       shiny::req(rv$data_temp)
-
+# browser()
       rv$data_original <- rv$data_temp |>
         dplyr::select(input$import_var) |>
         default_parsing()
@@ -184,6 +185,11 @@ server <- function(input, output, session) {
     }
   )
 
+  output$data_info_import <- shiny::renderUI({
+    shiny::req(rv$data_original)
+    data_description(rv$data_original)
+  })
+
 
   shiny::observeEvent(rv$data_original, {
     if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
@@ -248,6 +254,17 @@ server <- function(input, output, session) {
     modal_update_variables("modal_variables", title = "Update and select variables")
   )
 
+  output$data_info <- shiny::renderUI({
+    shiny::req(data_filter())
+    data_description(data_filter())
+  })
+
+  output$data_info_regression <- shiny::renderUI({
+    shiny::req(regression_vars())
+    shiny::req(rv$list$data)
+    data_description(rv$list$data[regression_vars()])
+  })
+
 
   #########  Create factor
 
@@ -468,40 +485,25 @@ server <- function(input, output, session) {
 
   ## Keep these "old" selection options as a simple alternative to the modification pane
 
-  output$include_vars <- shiny::renderUI({
+
-    columnSelectInputStat(
+  output$regression_vars <- shiny::renderUI({
-      inputId = "include_vars",
+    columnSelectInput(
+      inputId = "regression_vars",
       selected = NULL,
       label = "Covariables to include",
       data = rv$data_filtered,
-      multiple = TRUE
+      multiple = TRUE,
     )
-
-    # shiny::selectizeInput(
-    #   inputId = "include_vars",
-    #   selected = NULL,
-    #   label = "Covariables to include",
-    #   choices = colnames(rv$data_filtered),
-    #   multiple = TRUE
-    # )
   })
 
   output$outcome_var <- shiny::renderUI({
-    columnSelectInputStat(
+    columnSelectInput(
       inputId = "outcome_var",
       selected = NULL,
       label = "Select outcome variable",
       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({
@@ -535,16 +537,16 @@ server <- function(input, output, session) {
 
   ## Collected regression variables
   regression_vars <- shiny::reactive({
-    if (is.null(input$include_vars)) {
+    if (is.null(input$regression_vars)) {
       out <- colnames(rv$data_filtered)
     } else {
-      out <- unique(c(input$include_vars, input$outcome_var))
+      out <- unique(c(input$regression_vars, input$outcome_var))
     }
     return(out)
   })
 
   output$strat_var <- shiny::renderUI({
-    columnSelectInputStat(
+    columnSelectInput(
       inputId = "strat_var",
       selected = "none",
       label = "Select variable to stratify baseline",
@@ -554,27 +556,6 @@ server <- function(input, output, session) {
         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
-    # )
   })
 
 
@@ -604,7 +585,7 @@ server <- function(input, output, session) {
       # shiny::reactive(rv$data_original),
       # data_filter(),
       # input$strat_var,
-      # input$include_vars,
+      # input$regression_vars,
       # input$complete_cutoff,
       # input$add_p
       input$act_eval
@@ -613,48 +594,16 @@ server <- function(input, output, session) {
       shiny::req(input$strat_var)
       shiny::req(rv$list$data)
 
-      data_tbl1 <- rv$list$data
+      # data_tbl1 <- rv$list$data
 
-      if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) {
+      shiny::withProgress(message = "Creating the table. Hold on for a moment..", {
-        by.var <- NULL
+        rv$list$table1 <- create_baseline(
-      } else {
+          rv$list$data,
-        by.var <- input$strat_var
+          by.var = input$strat_var,
-      }
+          add.p = input$add_p == "yes",
-
+          add.overall = TRUE
-      ## 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 |>
-        baseline_table(
-          fun.args =
-            list(
-              by = by.var
         )
-        ) |>
+      })
-        (\(.x){
-          if (!is.null(by.var)) {
-            .x |> gtsummary::add_overall()
-          } else {
-            .x
-          }
-        })() |>
-        (\(.x){
-          if (input$add_p == "yes" & !is.null(by.var)) {
-            .x |>
-              gtsummary::add_p() |>
-              gtsummary::bold_p()
-          } else {
-            .x
-          }
-        })()
-
-      # gtsummary::as_kable(rv$list$table1) |>
-      #   readr::write_lines(file="./www/_table1.md")
     }
   )
 
@@ -753,9 +702,9 @@ server <- function(input, output, session) {
           #   .x$model
           # })
         },
-        warning = function(warn) {
+        # warning = function(warn) {
-          showNotification(paste0(warn), type = "warning")
+        #   showNotification(paste0(warn), type = "warning")
-        },
+        # },
         error = function(err) {
           showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err")
         }
@@ -778,9 +727,9 @@ server <- function(input, output, session) {
             purrr::pluck("Multivariable") |>
             performance::check_model()
         },
-        warning = function(warn) {
+        # warning = function(warn) {
-          showNotification(paste0(warn), type = "warning")
+        #   showNotification(paste0(warn), type = "warning")
-        },
+        # },
         error = function(err) {
           showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err")
         }

inst/apps/FreesearchR/ui.R

@@ -84,6 +84,7 @@ ui_elements <- list(
             shinyWidgets::noUiSliderInput(
               inputId = "complete_cutoff",
               label = NULL,
+              update_on = "change",
               min = 0,
               max = 100,
               step = 5,
@@ -94,7 +95,8 @@ ui_elements <- list(
             shiny::helpText("Filter variables with completeness above the specified percentage."),
             shiny::br(),
             shiny::br(),
-            shiny::uiOutput(outputId = "import_var")
+            shiny::uiOutput(outputId = "import_var"),
+            shiny::uiOutput(outputId = "data_info_import", inline = TRUE)
           )
         ),
         shiny::br(),
@@ -131,10 +133,9 @@ ui_elements <- list(
           fluidRow(
             shiny::column(
               width = 9,
+              shiny::uiOutput(outputId = "data_info", inline = TRUE),
               shiny::tags$p(
-                "Below is a short summary table of the provided data.
+                "Below is a short summary table, on the right you can create data filters."
-              On the right hand side you have the option to create filters.
-              At the bottom you'll find a raw overview of the original vs the modified data."
               )
             )
           ),
@@ -389,6 +390,7 @@ ui_elements <- list(
         # bslib::layout_sidebar(
         #   fillable = TRUE,
         sidebar = bslib::sidebar(
+          shiny::uiOutput(outputId = "data_info_regression", inline = TRUE),
           bslib::accordion(
             open = "acc_reg",
             multiple = FALSE,
@@ -450,7 +452,7 @@ ui_elements <- list(
               ),
               shiny::conditionalPanel(
                 condition = "input.all==1",
-                shiny::uiOutput("include_vars")
+                shiny::uiOutput("regression_vars")
               )
             )
           ),

man/clean_common_axis.Rd

@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data_plots.R
+\name{clean_common_axis}
+\alias{clean_common_axis}
+\title{Extract and clean axis ranges}
+\usage{
+clean_common_axis(p, axis)
+}
+\arguments{
+\item{p}{plot}
+
+\item{axis}{axis. x or y.}
+}
+\value{
+vector
+}
+\description{
+Extract and clean axis ranges
+}

man/create_baseline.Rd

@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/baseline_table.R
+\name{create_baseline}
+\alias{create_baseline}
+\title{Create a baseline table}
+\usage{
+create_baseline(data, ..., by.var, add.p = FALSE, add.overall = FALSE)
+}
+\arguments{
+\item{data}{data}
+
+\item{...}{passed as fun.arg to baseline_table()}
+
+\item{add.p}{add comparison/p-value}
+
+\item{add.overall}{add overall column}
+
+\item{strat.var}{grouping/strat variable}
+}
+\value{
+gtsummary table list object
+}
+\description{
+Create a baseline table
+}
+\examples{
+mtcars |> create_baseline(by.var = "gear", add.p="yes"=="yes")
+}

man/create_log_tics.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/regression_plot.R
+\name{create_log_tics}
+\alias{create_log_tics}
+\title{Create summetric log ticks}
+\usage{
+create_log_tics(data)
+}
+\arguments{
+\item{data}{numeric vector}
+}
+\value{
+numeric vector
+}
+\description{
+Create summetric log ticks
+}
+\examples{
+c(sample(seq(.1, 1, .1), 3), sample(1:10, 3)) |> create_log_tics()
+}

man/data-plots.Rd

@@ -1,11 +1,13 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data_plots.R, R/plot_hbar.R, R/plot_ridge.R,
+% Please edit documentation in R/data_plots.R, R/plot_box.R, R/plot_hbar.R,
-%   R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R
+%   R/plot_ridge.R, R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R
 \name{data-plots}
 \alias{data-plots}
 \alias{data_visuals_ui}
 \alias{data_visuals_server}
 \alias{create_plot}
+\alias{plot_box}
+\alias{plot_box_single}
 \alias{plot_hbars}
 \alias{plot_ridge}
 \alias{sankey_ready}
@@ -20,6 +22,10 @@ data_visuals_server(id, data, ...)
 
 create_plot(data, type, x, y, z = NULL, ...)
 
+plot_box(data, x, y, z = NULL)
+
+plot_box_single(data, x, y = NULL, seed = 2103)
+
 plot_hbars(data, x, y, z = NULL)
 
 plot_ridge(data, x, y, z = NULL, ...)
@@ -56,6 +62,10 @@ ggplot2 object
 
 ggplot2 object
 
+ggplot object
+
+ggplot2 object
+
 ggplot2 object
 
 data.frame
@@ -71,6 +81,10 @@ Data correlations evaluation module
 
 Wrapper to create plot based on provided type
 
+Beautiful box plot(s)
+
+Create nice box-plots
+
 Nice horizontal stacked bars (Grotta bars)
 
 Plot nice ridge plot
@@ -85,6 +99,11 @@ Beatiful violin plot
 }
 \examples{
 create_plot(mtcars, "plot_violin", "mpg", "cyl")
+mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
+mtcars |>
+  default_parsing() |>
+  plot_box(x = "mpg", y = "cyl", z = "gear")
+mtcars |> plot_box_single("mpg","cyl")
 mtcars |> plot_hbars(x = "carb", y = "cyl")
 mtcars |> plot_hbars(x = "carb", y = NULL)
 mtcars |>

man/data_description.Rd

@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers.R
+\name{data_description}
+\alias{data_description}
+\title{Ultra short data dascription}
+\usage{
+data_description(data)
+}
+\arguments{
+\item{data}{}
+}
+\value{
+character vector
+}
+\description{
+Ultra short data dascription
+}
+\examples{
+data.frame(
+  sample(1:8, 20, TRUE),
+  sample(c(1:8, NA), 20, TRUE)
+) |> data_description()
+}

man/data_type.Rd

@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/regression_model.R
+\name{data_type}
+\alias{data_type}
+\title{Data type assessment}
+\usage{
+data_type(data)
+}
+\arguments{
+\item{data}{data}
+}
+\value{
+outcome type
+}
+\description{
+Data type assessment
+}
+\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()
+}

man/outcome_type.Rd

@@ -1,22 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/regression_model.R
-\name{outcome_type}
-\alias{outcome_type}
-\title{Outcome data type assessment}
-\usage{
-outcome_type(data)
-}
-\arguments{
-\item{data}{data}
-}
-\value{
-outcome type
-}
-\description{
-Outcome data type assessment
-}
-\examples{
-mtcars |>
-  default_parsing() |>
-  lapply(outcome_type)
-}

man/regression_model.Rd

@@ -154,11 +154,14 @@ broom::tidy(ls$model)
 broom::tidy(m)
 }
 \dontrun{
-gtsummary::trial |> regression_model_uv(
+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()
+  ) |>
+  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()
 }

man/remove_na_attr.Rd

@@ -17,5 +17,7 @@ Remove NA labels
 }
 \examples{
 ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label"))
-ds |> remove_na_attr() |> str()
+ds |>
+  remove_na_attr() |>
+  str()
 }

man/subset_types.Rd

@@ -4,7 +4,7 @@
 \alias{subset_types}
 \title{Easily subset by data type function}
 \usage{
-subset_types(data, types, type.fun = outcome_type)
+subset_types(data, types, type.fun = data_type)
 }
 \arguments{
 \item{data}{data}
@@ -21,6 +21,6 @@ Easily subset by data type function
 }
 \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)
 }