Back to Index

Level One

• Reference Link: https://www.dfhcc.harvard.edu/events/?month=2&year=2021

plot(1:10)

hist(rnorm(100))

Insert File into HTML

library(Wu)
dt <- data.table(
  x = rnorm(100)
, y = factor(sample(c("A", "B", "C"), size = 100, replace = TRUE), levels = c("A", "B", "C"))
, z = rnorm(100)*5
, sex = factor(sample(x = c("F", "M"), size = 100, replace = TRUE), levels = c("F", "M"))
, trt = factor(sample(x = c("Case", "Control"), size = 100, replace = TRUE), levels = c("Case", "Control"))
)



label(dt$x) <- "X_Label"
label(dt$sex) <- "Sex"

Vars <- c("x", "y", "z", "sex")
factorVars <- c("y", "sex")


combine_list <- function(lst){
  s <- names(lst)
  ind <- split(seq_along(s), s)
  ind <- unlist(lapply(ind, function(l){l[[1]]}))
  invisible(lst[sort(ind)])
}



get_tbl1 <- function(...){
  lst <- as.list(match.call())[-1]
  args <- list(
    vars = Vars
  , factorVars = factorVars
  , test = FALSE
  , includeNA = TRUE
  , smd = TRUE
  , addOverall = FALSE
  )
  args <- c(lst, args, formals(CreateTableOne, envir = environment(CreateTableOne)))
  args <- combine_list(args)
  if (trimws(args$strata) %in% c("")){args$addOverall = FALSE} else {args$addOverall = TRUE}
  invisible(do.call(CreateTableOne, args))
}

t <- get_tbl1(data = dt, strata = "trt", test = TRUE)



fmt_tbl1 <- function(...){
  lst <- as.list(match.call())[-1]
  args <- list(
    printToggle = FALSE
  , catDigits = 1
  , conDigits = 2
  , pDigits = 3
  , showAllLevels = TRUE
  , smd = TRUE
  , missing = TRUE
  , varLabels = TRUE
  )
  args <- combine_list(c(lst, args))
  rtn <- do.call(tableone:::print.TableOne, args)
  rtn <- as.data.table(cbind(rownames(rtn), rtn))
  colnames(rtn)[1] <- "Variable"
  invisible(rtn)
}

t2 <- fmt_tbl1(t, pDigits = 5, missing = FALSE)

t2 %>% prt()

tbl1 <- function(...){
  lst <- as.list(match.call())[-1]
  args <- list(
    vars = Vars
  , factorVars = factorVars
  , test = FALSE
  , includeNA = TRUE
  , smd = TRUE
  , addOverall = FALSE
  )
  args <- c(lst, args, formals(CreateTableOne, envir = environment(CreateTableOne)))
  args <- combine_list(args)
  args <- args[names(args) %in% names(formals(CreateTableOne))]
  if (trimws(args$strata) %in% c("")){args$addOverall = FALSE} else {args$addOverall = TRUE}
  tableone_t <- do.call(CreateTableOne, args)
  fx <- tableone:::print.TableOne 
  args2 <- list(
    printToggle = FALSE
  , catDigits = 1
  , contDigits = 2
  , pDigits = 3
  , showAllLevels = TRUE
  , smd = TRUE
  , missing = TRUE
  , varLabels = TRUE
  )
  args <- combine_list(c(lst, args2))
  args <- args[names(args) %in% names(formals(fx))]
  rtn <- do.call(tableone:::print.TableOne, c(list(x = tableone_t), args))
  rtn <- as.data.table(cbind(rownames(rtn), rtn))
  colnames(rtn)[1] <- "Variable"
  rownames(rtn) <- NULL
  invisible(rtn)
}


tbl1n <- function(...){
  lst <- as.list(match.call())[-1]
  for (i in seq_along(Vars)){
  var <- Vars[i]
  if (var %in% factorVars) {
    ti <- do.call(tbl1, c(lst, vars = var, factorVars = var))
    }else{
      ti_1 <- do.call(tbl1, c(lst, vars = var, factorVars = NULL))
      ti_2 <- do.call(tbl1, c(lst, vars = var, factorVars = NULL, nonnormal = var))
      ti_3 <- do.call(tbl1, c(lst, vars = var, factorVars = NULL, nonnormal = var, minMax = TRUE))
      ti <- rbind(ti_1, ti_2[-1, ], ti_3[-1, ])
      ti$level <- gsub("^(.+)( )(\\(me)(.+)(\\))$", "\\3\\4\\5", ti$Variable, perl = TRUE)
      ti$level <- gsub("^\\((.+)\\)$", "\\1", ti$level, perl = TRUE)
      ti$Variable <- gsub("^(.+)( )(\\(me)(.+)(\\))$", "\\1", ti$Variable, perl = TRUE)
      ti$Variable[-c(1:2)] <- ""
    }
  if (i %in% c(1)) {
    rtn <- ti
  }else{
    rtn <- rbind(rtn, ti[-1, ])
  }
  }
  rownames(rtn) <- NULL
  invisible(rtn)
  }

ttt <- tbl1n(data = dt, strata = "trt", test = TRUE, pDigits = 5, catDigits = 3, contDigits = 4)


tt <- tbl1(data = dt, strata = "trt", test = TRUE, pDigits = 4, catDigits = 2, contDigits = 3)


tn <-  tbl1(data = dt, strata = "trt", test = TRUE, vars = c("x"))

ttt %>% prt()

attach_docx <- function(obj, file = "table1.docx"){
  flextable::flextable(obj) %>% flextable::save_as_docx(path = file)
  xfun::embed_file(file)
}

attach_docx(ttt)

attach_csv(ttt)

## library(officer)
## library(flextable)
## flextable::set_flextable_defaults(digits = 5)
## t2 %>% flextable() %>% save_as_docx(path = "table1.docx")

## xfun::embed_file('table1.docx')

Add a copy icon on the rmarkdown chunk

opts_chunk$set(class.source='klippy')
klippy::klippy(position = c('top', left)
             , tooltip_message = 'Click to copy'
             , tooltip_success = 'Done')

Level Four

R sessionInfo

sessionInfo()

R version 4.2.0 (2022-04-22) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04.3 LTS

Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0

locale: [1] LC_CTYPE=C.UTF-8 LC_NUMERIC=C LC_TIME=C.UTF-8
[4] LC_COLLATE=C.UTF-8 LC_MONETARY=C.UTF-8 LC_MESSAGES=C.UTF-8
[7] LC_PAPER=C.UTF-8 LC_NAME=C LC_ADDRESS=C
[10] LC_TELEPHONE=C LC_MEASUREMENT=C.UTF-8 LC_IDENTIFICATION=C

attached base packages: [1] stats graphics grDevices utils datasets methods base

other attached packages: [1] Wu_0.0.0.9000 flexdashboard_0.5.2 lme4_1.1-29
[4] Matrix_1.4-0 mgcv_1.8-38 nlme_3.1-152
[7] png_0.1-7 scales_1.2.0 nnet_7.3-16
[10] labelled_2.9.1 kableExtra_1.3.4 plotly_4.10.0
[13] gridExtra_2.3 ggplot2_3.3.6 DT_0.23
[16] tableone_0.13.2 magrittr_2.0.3 lubridate_1.8.0
[19] dplyr_1.0.9 plyr_1.8.7 data.table_1.14.2
[22] rmdformats_1.0.4 knitr_1.39

loaded via a namespace (and not attached): [1] webshot_0.5.3 httr_1.4.3 tools_4.2.0 bslib_0.3.1
[5] utf8_1.2.2 R6_2.5.1 DBI_1.1.2 lazyeval_0.2.2
[9] colorspace_2.0-3 withr_2.5.0 tidyselect_1.1.2 compiler_4.2.0
[13] cli_3.3.0 rvest_1.0.2 flextable_0.7.2 xml2_1.3.3
[17] officer_0.4.3 bookdown_0.27 sass_0.4.1 proxy_0.4-27
[21] systemfonts_1.0.4 stringr_1.4.0 digest_0.6.29 minqa_1.2.4
[25] rmarkdown_2.14 svglite_2.1.0 base64enc_0.1-3 pkgconfig_2.0.3
[29] htmltools_0.5.3 fastmap_1.1.0 highr_0.9 htmlwidgets_1.5.4 [33] rlang_1.0.4 rstudioapi_0.13 jquerylib_0.1.4 generics_0.1.3
[37] zoo_1.8-10 jsonlite_1.8.0 zip_2.2.0 Rcpp_1.0.9
[41] munsell_0.5.0 fansi_1.0.3 gdtools_0.2.4 lifecycle_1.0.1
[45] stringi_1.7.8 yaml_2.3.5 MASS_7.3-54 grid_4.2.0
[49] forcats_0.5.1 lattice_0.20-45 haven_2.5.0 splines_4.2.0
[53] hms_1.1.1 klippy_0.0.0.9500 pillar_1.8.0 uuid_1.1-0
[57] boot_1.3-28 glue_1.6.2 evaluate_0.15 mitools_2.4
[61] vctrs_0.4.1 nloptr_2.0.3 gtable_0.3.0 purrr_0.3.4
[65] tidyr_1.2.0 assertthat_0.2.1 xfun_0.31 mime_0.12
[69] survey_4.1-1 e1071_1.7-11 class_7.3-19 survival_3.2-13
[73] viridisLite_0.4.0 tibble_3.1.8 ellipsis_0.3.2