modifications to ui and using DT for tables

R/helpers.R

@@ -118,7 +118,11 @@ dummy_Imports <- function() {
     MASS::as.fractions(),
     broom::augment(),
     broom.helpers::all_categorical(),
-    here::here()
+    here::here(),
+    cardx::all_of(),
+    parameters::ci(),
+    DT::addRow(),
+    bslib::accordion()
     )
   #https://github.com/hadley/r-pkgs/issues/828
   }

R/regression_model.R

@@ -1,4 +1,4 @@
-#' Print a flexible baseline characteristics table
+#' Create a regression model programatically
 #'
 #' @param data data set
 #' @param fun Name of function as character vector or function to use for model creation.
@@ -7,6 +7,7 @@
 #' @param auto.mode Make assumptions on function dependent on outcome data format. Overwrites other arguments.
 #' @param formula.str Formula as string. Passed through 'glue::glue'. If given, 'outcome.str' and 'vars' are ignored. Optional.
 #' @param args.list List of arguments passed to 'fun' with 'do.call'.
+#' @param ... ignored for now
 #'
 #' @importFrom stats as.formula
 #'
@@ -36,7 +37,8 @@ regression_model <- function(data,
                              formula.str = NULL,
                              args.list = NULL,
                              fun = NULL,
-                             vars = NULL) {
+                             vars = NULL,
+                             ...) {
   if (!is.null(formula.str)) {
     if (formula.str == "") {
       formula.str <- NULL
@@ -61,9 +63,18 @@ regression_model <- function(data,
 
   # Formatting character variables as factor
   # Improvement should add a missing vector to format as NA
-  data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor))
+  data <- data |>
+    purrr::map(\(.x){
+      if (is.character(.x)) {
+        suppressWarnings(REDCapCAST::as_factor(.x))
+      } else {
+        .x
+      }
+    }) |>
+    dplyr::bind_cols()
+
+  if (is.null(fun)) auto.mode <- TRUE
 
-  # browser()
   if (auto.mode) {
     if (is.numeric(data[[outcome.str]])) {
       fun <- "stats::lm"
@@ -101,5 +112,93 @@ regression_model <- function(data,
   # Recreating the call
   # out$call <-  match.call(definition=eval(parse(text=fun)), call(fun, data = 'data',formula = as.formula(formula.str),args.list))
 
+  class(out) <- c("webresearch_model", class(out))
+  return(out)
+}
+
+#' Create a regression model programatically
+#'
+#' @param data data set
+#' @param fun Name of function as character vector or function to use for model creation.
+#' @param vars character vector of variables to include
+#' @param outcome.str Name of outcome variable. Character vector.
+#' @param args.list List of arguments passed to 'fun' with 'do.call'.
+#' @param ... ignored for now
+#'
+#' @importFrom stats as.formula
+#'
+#' @return object of standard class for fun
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' gtsummary::trial |>
+#'   regression_model_uv(outcome.str = "age")
+#' gtsummary::trial |>
+#'   regression_model_uv(
+#'     outcome.str = "age",
+#'     fun = "stats::lm",
+#'     args.list = NULL
+#'   )
+#' gtsummary::trial |> regression_model_uv(
+#'   outcome.str = "trt",
+#'   fun = "stats::glm",
+#'   args.list = list(family = stats::binomial(link = "logit"))
+#' )
+#' }
+regression_model_uv <- function(data,
+                                outcome.str,
+                                args.list = NULL,
+                                fun = NULL,
+                                vars = NULL,
+                                ...) {
+  if (!is.null(vars)) {
+    data <- data |>
+      dplyr::select(dplyr::all_of(
+        unique(c(outcome.str, vars))
+      ))
+  }
+
+  if (is.null(args.list)) {
+    args.list <- list()
+  }
+
+  if (is.null(fun)) {
+    if (is.numeric(data[[outcome.str]])) {
+      fun <- "stats::lm"
+    } else if (is.factor(data[[outcome.str]])) {
+      if (length(levels(data[[outcome.str]])) == 2) {
+        fun <- "stats::glm"
+        args.list <- list(family = stats::binomial(link = "logit"))
+      } else if (length(levels(data[[outcome.str]])) > 2) {
+        fun <- "MASS::polr"
+        args.list <- list(
+          Hess = TRUE,
+          method = "logistic"
+        )
+      } else {
+        stop("The provided output variable only has one level")
+      }
+    } else {
+      stop("Output variable should be either numeric or factor for auto.mode")
+    }
+  }
+
+  assertthat::assert_that("character" %in% class(fun),
+    msg = "Please provide the function as a character vector."
+  )
+
+  out <- names(data)[!names(data) %in% outcome.str] |>
+    purrr::map(\(.var){
+      do.call(
+        regression_model,
+        c(
+          list(data = data[match(c(outcome.str,.var),names(data))]),
+          list(outcome.str=outcome.str),
+          list(args.list=args.list)
+        )
+      )
+    })
+
   return(out)
 }

R/regression_table.R

@@ -1,13 +1,16 @@
 #' Create table of regression model
 #'
-#' @param data regression model
+#' @param x regression model
 #' @param args.list list of arguments passed to 'fun'.
 #' @param fun function to use for table creation. Default is "gtsummary::tbl_regression".
+#' @param ... passed to methods
 #'
 #' @return object of standard class for fun
 #' @export
+#' @name regression_table
 #'
 #' @examples
+#' \dontrun{
 #' gtsummary::trial |>
 #'   regression_model(
 #'     outcome.str = "stage",
@@ -29,14 +32,82 @@
 #'     args.list = list(family = binomial(link = "logit"))
 #'   ) |>
 #'   regression_table()
-regression_table <- function(data, args.list = NULL, fun = "gtsummary::tbl_regression") {
+#' gtsummary::trial |>
+#'   regression_model_uv(
+#'     outcome.str = "trt",
+#'     fun = "stats::glm",
+#'     args.list = list(family = stats::binomial(link = "logit"))
+#'   ) |>
+#'   regression_table()
+#' gtsummary::trial |>
+#'   regression_model_uv(
+#'     outcome.str = "stage",
+#'     args.list = list(family = stats::binomial(link = "logit"))
+#'   ) |>
+#'   regression_table()
+#'
+#' list(
+#'   "Univariable" = regression_model_uv,
+#'   "Multivariable" = regression_model
+#' ) |>
+#'   lapply(\(.fun){
+#'     do.call(
+#'       .fun,
+#'       c(
+#'         list(data = gtsummary::trial),
+#'         list(outcome.str = "stage")
+#'       )
+#'     )
+#'   }) |>
+#'   purrr::map(regression_table) |>
+#'   tbl_merge()
+#'   }
+regression_table <- function(x, ...) {
+  UseMethod("regression_table")
+}
 
-  if (any(c(length(class(data))!=1, class(data)!="lm"))){
-    if (!"exponentiate" %in% names(args.list)){
-      args.list <- c(args.list,list(exponentiate=TRUE))
+#' @rdname regression_table
+#' @export
+regression_table.list <- function(x, ...) {
+  x |>
+    purrr::map(\(.m){
+      regression_table(x = .m, ...) |>
+        gtsummary::add_n()
+    }) |>
+    gtsummary::tbl_stack()
+}
+
+#' @rdname regression_table
+#' @export
+regression_table.webresearch_model <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") {
+  # Stripping custom class
+  class(x) <- class(x)[class(x) != "webresearch_model"]
+
+  if (any(c(length(class(x)) != 1, class(x) != "lm"))) {
+    if (!"exponentiate" %in% names(args.list)) {
+      args.list <- c(args.list, list(exponentiate = TRUE))
     }
   }
 
-  out <- do.call(getfun(fun), c(list(x = data), args.list))
-  out |> gtsummary::add_glance_source_note()
+  out <- do.call(getfun(fun), c(list(x = x), args.list))
+  out |>
+    gtsummary::add_glance_source_note() # |>
+  # gtsummary::bold_p()
+}
+
+
+#' A substitue to gtsummary::tbl_merge, that will use list names for the tab
+#' spanner names.
+#'
+#' @param data gtsummary list object
+#'
+#' @return gt summary list object
+#' @export
+#'
+tbl_merge <- function(data) {
+  if (is.null(names(data))) {
+    data |> gtsummary::tbl_merge()
+  } else {
+    data |> gtsummary::tbl_merge(tab_spanner = names(data))
+  }
 }

R/shiny_webResearch.R

@@ -14,7 +14,7 @@
 shiny_webResearch <- function(data = NULL, ...) {
   appDir <- system.file("apps", "data_analysis", package = "webResearch")
   if (appDir == "") {
-    stop("Could not find example directory. Try re-installing `webResearch`.", call. = FALSE)
+    stop("Could not find the app directory. Try re-installing `webResearch`.", call. = FALSE)
   }
 
   G <- .GlobalEnv
@@ -22,13 +22,3 @@ shiny_webResearch <- function(data = NULL, ...) {
   a <- shiny::runApp(appDir = appDir, ...)
   return(invisible(a))
 }
-
-
-#' Wrapping nav_spacer to avoid errors on dependencies when packaging
-#'
-#' @return bslib object
-#' @export
-#'
-panel_space <- function() {
-  bslib::nav_spacer()
-}