Initial commit

R/baseline_table.R

@@ -0,0 +1,22 @@
+#' Print a flexible baseline characteristics table
+#'
+#' @param data data set
+#' @param fun.args list of arguments passed to
+#' @param fun function to
+#' @param vars character vector of variables to include
+#'
+#' @return object of standard class for fun
+#' @export
+#'
+#' @examples
+#' mtcars |> baseline_table()
+#' mtcars |> baseline_table(fun.args = list(by = "gear"))
+baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, vars = NULL) {
+  if (!is.null(vars)) {
+    data <- dplyr::select(dplyr::all_of(vars))
+  }
+
+  out <- do.call(fun, c(list(data = data), fun.args))
+  return(out)
+}
+

R/helpers.R

@@ -0,0 +1,110 @@
+#' Wrapper function to get function from character vector referring to function from namespace. Passed to 'do.call()'
+#'
+#' @description
+#' This function follows the idea from this comment: https://stackoverflow.com/questions/38983179/do-call-a-function-in-r-without-loading-the-package
+#' @param x function or function name
+#'
+#' @return function or character vector
+#' @export
+#'
+#' @examples
+#' getfun("stats::lm")
+getfun <- function(x) {
+  if("character" %in% class(x)){
+    if (length(grep("::", x)) > 0) {
+      parts <- strsplit(x, "::")[[1]]
+      requireNamespace(parts[1])
+      getExportedValue(parts[1], parts[2])
+    }
+  }else {
+    x
+  }
+}
+
+#' Wrapper to save data in RDS, load into specified qmd and render
+#'
+#' @param data list to pass to qmd
+#' @param fileformat output format. Ignored if file!=NULL
+#' @param qmd.file qmd file to render. Default is 'here::here("analyses.qmd")'
+#' @param file exact filename (Optional)
+#' @param ... Ignored for now
+#'
+#' @return none
+#' @export
+#'
+write_quarto <- function(data,fileformat,qmd.file=here::here("analyses.qmd"),file=NULL,...){
+  if (is.null(file)){
+    file <- paste0("analyses.",fileformat)
+  }
+  temp <- tempfile(fileext = ".Rds")
+  # write_rds(mtcars, temp)
+  # read_rds(temp)
+  web_data <- data
+  saveRDS(web_data,file=temp)
+
+  quarto::quarto_render(qmd.file,
+                        output_file = file,
+                        execute_params = list(data.file=temp)
+  )
+}
+
+#' Helper to import files correctly
+#'
+#' @param filenames file names
+#'
+#' @return character vector
+#' @export
+#'
+#' @examples
+#' file_extension(list.files(here::here(""))[[2]])[[1]]
+#' file_extension(c("file.cd..ks", "file"))
+file_extension <- function(filenames) {
+  sub(
+    pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "",
+    filenames,
+    perl = TRUE
+  )
+}
+
+#' Flexible file import based on extension
+#'
+#' @param file file name
+#' @param consider.na character vector of strings to consider as NAs
+#'
+#' @return tibble
+#' @export
+#'
+#' @examples
+#' read_input("https://raw.githubusercontent.com/agdamsbo/cognitive.index.lookup/main/data/sample.csv")
+read_input <- function(file, consider.na = c("NA", '""', "")) {
+  ext <- file_extension(file)
+
+  if (ext == "csv") {
+    df <- readr::read_csv(file = file, na = consider.na)
+  } else if (ext %in% c("xls", "xlsx")) {
+    df <- openxlsx2::read_xlsx(file = file, na.strings = consider.na)
+  } else if (ext == "dta") {
+    df <- haven::read_dta(file = file)
+  } else if (ext == "ods") {
+    df <- readODS::read_ods(file = file)
+  } else {
+    stop("Input file format has to be on of:
+             '.csv', '.xls', '.xlsx', '.dta' or '.ods'")
+  }
+
+  df
+}
+
+#' Convert string of arguments to list of arguments
+#'
+#' @description
+#' Idea from the answer: https://stackoverflow.com/a/62979238
+#'
+#' @param string string to convert to list to use with do.call
+#'
+#' @return list
+#' @export
+#'
+argsstring2list <- function(string){
+  eval(parse(text = paste0("list(", string, ")")))
+}

R/regression_model.R

@@ -0,0 +1,99 @@
+#' Print a flexible baseline characteristics table
+#'
+#' @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 auto.mode Make assumptions on function dependent on outcome data format.
+#' @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'.
+#'
+#' @importFrom stats as.formula
+#'
+#' @return object of standard class for fun
+#' @export
+#'
+#' @examples
+#' gtsummary::trial |>
+#'   regression_model(outcome.str = "age")
+#' gtsummary::trial |>
+#'   regression_model(
+#'     outcome.str = "age",
+#'     fun = "stats::lm",
+#'     formula.str = "{outcome.str}~.",
+#'     args.list = NULL
+#'   )
+#' gtsummary::trial |> regression_model(
+#'   outcome.str = "trt",
+#'   fun = "stats::glm",
+#'   args.list = list(family = binomial(link = "logit"))
+#' )
+regression_model <- function(data,
+                             outcome.str,
+                             auto.mode = TRUE,
+                             formula.str = NULL,
+                             args.list = NULL,
+                             fun = NULL,
+                             vars = NULL) {
+  if (!is.null(formula.str)) {
+    formula.str <- glue::glue(formula.str)
+  } else {
+    assertthat::assert_that(outcome.str %in% names(data),
+      msg = "Outcome variable is not present in the provided dataset"
+    )
+    formula.str <- glue::glue("{outcome.str}~.")
+
+    if (!is.null(vars)) {
+      if (outcome.str %in% vars){
+        vars <- vars[vars %in% outcome.str]
+      }
+      data <- data |> dplyr::select(dplyr::all_of(c(vars,outcome.str)))
+    }
+  }
+
+  # 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))
+
+  # browser()
+  if (auto.mode) {
+    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 = 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 <- do.call(
+    getfun(fun),
+    c(
+      list(data = data),
+      list(formula = as.formula(formula.str)),
+      args.list
+    )
+  )
+
+  # Recreating the call
+  # out$call <-  match.call(definition=eval(parse(text=fun)), call(fun, data = 'data',formula = as.formula(formula.str),args.list))
+
+  return(out)
+}

R/regression_table.R

@@ -0,0 +1,40 @@
+#' Create table of regression model
+#'
+#' @param data regression model
+#' @param args.list list of arguments passed to 'fun'.
+#' @param fun function to use for table creation. Default is "gtsummary::tbl_regression".
+#'
+#' @return object of standard class for fun
+#' @export
+#'
+#' @examples
+#' gtsummary::trial |>
+#'   regression_model(
+#'     outcome.str = "stage",
+#'     fun = "MASS::polr"
+#'   ) |>
+#'   regression_table(args.list = list(exponentiate = TRUE))
+#' gtsummary::trial |>
+#'   regression_model(
+#'     outcome.str = "age",
+#'     fun = "stats::lm",
+#'     formula.str = "{outcome.str}~.",
+#'     args.list = NULL
+#'   ) |>
+#'   regression_table()
+#' gtsummary::trial |>
+#'   regression_model(
+#'     outcome.str = "trt",
+#'     fun = "stats::glm",
+#'     args.list = list(family = binomial(link = "logit"))
+#'   ) |>
+#'   regression_table()
+regression_table <- function(data, args.list = NULL, fun = "gtsummary::tbl_regression") {
+
+  if (any(c(length(class(data))!=1, class(data)!="lm"))){
+    args.list <- c(args.list,list(exponentiate=TRUE))
+  }
+
+  out <- do.call(getfun(fun), c(list(x = data), args.list))
+  return(out)
+}