Fix sstable.baseline

.gitignore

@@ -2,3 +2,4 @@
 .Rhistory
 .RData
 .Ruserdata
+R/.depricated.R

.vscode/settings.json

@@ -0,0 +1,3 @@
+{
+    "vim.useSystemClipboard": true
+}

DESCRIPTION

@@ -1,23 +1,55 @@
 Package: C306
 Type: Package
 Title: Collection of useful R codes for data analysis from the Biostatistics group at OUCRU
-Version: 0.1.2
+Version: 0.1.5-240715
 Author: Lam Phung Khanh
-Maintainer: Lam Phung Khanh <phungkhanhlam@gmail.com>
+Maintainer@R: 
+    c(
+        person(
+            given = "Khanh Lam",
+            family = "Phung",
+            role = c("author", "maintainer"),
+            email = "phungkhanhlam@gmail.com"),
+        person(
+            given = "Huu Khanh Trinh",
+            family = "Dong"
+            role = "maintainer",
+            email = "trindhk@oucru.org"),
+        person(
+            given = "Biostatistic Group",
+            role = "maintainer",
+            email = "biostatistics@oucru.org"
+        )
+    )
 Description: Collection of useful R codes for data analysis from the Biostatistics group at OUCRU
     Use four spaces when indenting paragraphs within the Description.
 License: The MIT License (MIT)
 Encoding: UTF-8
 LazyData: true
-Imports: lubridate,
+Depends: 
+    data.table,
+    dplyr,
+    R (>= 4.1)
+Imports:
+    Hmisc,
+    stringi,
+    lubridate,
     car,
     readxl,
-    dplyr,
     flextable,
     officer,
+    tidyr,
+    rlang,
+    purrr,
+    formula.tools,
+    eventglm,
+    ggplot2,
+    survminer,
+    ggsurvfit,
     survival,
-    tidyr
-RoxygenNote: 6.1.1
+    aod
+RoxygenNote: 7.3.2
 Suggests: knitr,
-    rmarkdown
+    rmarkdown,
+    huxtable
 VignetteBuilder: knitr

NAMESPACE

@@ -1,20 +1,86 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[",subgroup_logist_summary)
+S3method("ref_lv<-",factor)
+S3method(as_sstable,default)
+S3method(as_sstable,list)
+S3method(as_sstable,logist_summary)
+S3method(as_sstable,overlap_summary)
+S3method(as_sstable,subgroup_logist_summary)
+S3method(explicit,lm)
+S3method(gg_boxcox,default)
+S3method(gg_boxcox,formula)
+S3method(gg_boxcox,lm)
+S3method(mutate_f,data.frame)
+S3method(mutate_f,data.table)
+S3method(mutate_f,grouped_df)
+S3method(mutate_f,tbl)
+S3method(print,logist_summary)
+S3method(print,ss_tbl)
+S3method(print,subgroup_logist_summary)
+S3method(rbind,ss_ae)
+S3method(rbind,ss_baseline)
+S3method(rbind,ss_obj)
+S3method(rbind,ss_survcomp)
+S3method(ref_lv,factor)
 S3method(simple_recode,data.frame)
 S3method(simple_recode,default)
+S3method(simple_relevel,data.frame)
+S3method(simple_relevel,default)
+S3method(ss_flextable,default)
+S3method(ss_flextable,list)
+S3method(ss_flextable,ss_obj)
+S3method(ss_huxtable,default)
+S3method(ss_huxtable,list)
+S3method(summarise_f,data.frame)
+S3method(summarise_f,data.table)
+S3method(summarise_f,grouped_df)
+S3method(summarise_f,tbl)
+S3method(t,subgroup_logist_summary)
+export("ref_lv<-")
+export(as_sstable)
 export(contSummary)
 export(convert.info)
 export(createProject)
+export(createProject2)
+export(explicit)
+export(ft_sstheme)
 export(getlabel)
+export(gg_ajsurvplot)
+export(gg_ajsurvplot2)
+export(gg_boxcox)
+export(ggsurvfit2)
+export(ht_theme_kable)
+export(ht_theme_markdown)
 export(import.info)
 export(inspect.data)
 export(labAE)
+export(logist_summary)
+export(mutate_f)
 export(myformat.data)
+export(pct)
+export(ref_lv)
 export(simple_recode)
+export(simple_relevel)
+export(simple_sort)
+export(ss_body)
+export(ss_flextable)
+export(ss_format)
+export(ss_header)
+export(ss_huxtable)
+export(ss_section)
+export(ss_template)
 export(sstable.ae)
 export(sstable.baseline)
+export(sstable.baseline.edit)
 export(sstable.survcomp)
 export(sstable.survcomp.subgroup)
+export(subgroup_effect)
+export(summarise_f)
+export(tidy_competingevent)
+export(tidy_survfit2)
 import(dplyr)
+import(ggplot2)
 import(survival)
 import(tidyr)
+importFrom(data.table,":=")

R/.gitignore

@@ -0,0 +1 @@
+.depricated.R

R/checking.R

@@ -65,14 +65,17 @@ inspect.data <- function (data, info, id, check_missing = c(TRUE, FALSE), plot =
                     lapply(X = 1:ncol(data),
                            FUN = function(x) {
                              tmpdata <- data[, x]
+                             tmprow <- seq_len(nrow(data))
                              if ("condition" %in% names(info)) {
                                if (!is.na(info$condition[x])) {
                                  ## match variable name is condition
                                  tmpcondition <- find_match_correct_var_final(cond = info$condition[x], realvar = names(data))
                                  tmpdata <- eval(parse(text = paste0("subset(data,", tmpcondition, ")[, x]")))
+                                 tmprow <- with(data, which(eval(parse(text=tmpcondition))))
                                }
                              }
                              inspect.each(x = tmpdata,
+                                          id = tmprow,
                                           varname = info$varname[x],
                                           value = info$value[x],
                                           type = info$type[x],
@@ -94,8 +97,11 @@ inspect.data <- function (data, info, id, check_missing = c(TRUE, FALSE), plot =
     N <- nrow(data)
     for (i in (1:length(info$varname))) {
       tmpdata <- data[, names(data)[tolower(names(data)) == tolower(info$varname[i])]]
-      tmplabel <- substr(gsub(pattern = "[\x01-\x1f\x7f-\xff:]", replacement = "",
-                              x = info$label[i]), start = 1, stop = 30)
+      # tmplabel <- substr(gsub(pattern = "[\x01-\x1f\x7f-\xff:]", replacement = "",
+      #                         x = info$label[i]), start = 1, stop = 30)
+      tmplabel <- substr(stringi::stri_trans_general(
+        info$label[i],
+        id="Latin-ASCII"), start=1, stop=30) |> gsub("?", "", x=_, fixed=TRUE)
       if (length(na.omit(tmpdata)) == 0) {
         plot(x = 1:10, y = 1:10,
              main = paste(info$varname[i], "\n (", tmplabel, ")", " \n (", info$type[i], ")", sep = ""),
@@ -109,8 +115,12 @@ inspect.data <- function (data, info, id, check_missing = c(TRUE, FALSE), plot =
           x <- barplot(table(tmpdata),
                        main = paste(info$varname[i], "\n (", tmplabel, ")", " \n (", info$type[i], ", N=", N, ", missing=", nNA, ")", sep = ""),
                        xaxt = "n")
-          labs <- substr(gsub(pattern = "[\x01-\x1f\x7f-\xff:]", replacement = "",
-                              x = names(table(tmpdata))), start = 1, stop = 10)
+          # labs <- substr(gsub(pattern = "[\x01-\x1f\x7f-\xff:]", replacement = "",
+          #                     x = names(table(tmpdata))), start = 1, stop = 10)
+          labs <- substr(gsub(pattern = "?", replacement = "", fixed=TRUE,
+                              x = stringi::stri_trans_general(
+                                names(table(tmpdata)),
+                                id="Latin-ASCII")), start = 1, stop = 10)
           text(cex = 1, x = x, y = 0, labs, xpd = TRUE, srt = 45, adj = 1)
         }
         else {
@@ -137,25 +147,25 @@ inspect.data <- function (data, info, id, check_missing = c(TRUE, FALSE), plot =
   }
 }
 
-inspect.each <- function (x, varname, type, value = NA, check_missing = TRUE) {
+inspect.each <- function (x, id, varname, type, value = NA, check_missing = TRUE) {
   tmp <- NULL
   if (check_missing) {
     if (anyNA(x) | any(as.character(x) == "")) {
-      tmp <- rbind(tmp, data.frame(index = which(is.na(x) |
-                                                   as.character(x) == ""), error = paste("Missing value for",
+      tmp <- rbind(tmp, data.frame(index = id[is.na(x) |
+                                                   as.character(x) == ""], error = paste("Missing value for",
                                                                                          varname)))
     }
   }
   if (type == "numeric" & (!is.na(value) & value != "")) {
     range <- as.numeric(unlist(strsplit(value, split = ";")))
     if (any(x < range[1] & !is.na(x))) {
-      tmp <- rbind(tmp, data.frame(index = which(!is.na(x) &
-                                                   x < range[1]), error = paste("Out of range:",
+      tmp <- rbind(tmp, data.frame(index = id[!is.na(x) &
+                                                   x < range[1]], error = paste("Out of range:",
                                                                                 varname, "<", range[1])))
     }
     if (any(x > range[2] & !is.na(x))) {
-      tmp <- rbind(tmp, data.frame(index = which(!is.na(x) &
-                                                   x > range[2]), error = paste("Out of range:",
+      tmp <- rbind(tmp, data.frame(index = id[!is.na(x) &
+                                                   x > range[2]], error = paste("Out of range:",
                                                                                 varname, ">", range[2])))
     }
   }
@@ -165,8 +175,8 @@ inspect.each <- function (x, varname, type, value = NA, check_missing = TRUE) {
                     USE.NAMES = FALSE)
     if (any(!x %in% range & !is.na(x))) {
       xx <- x[!is.na(x) & !x %in% range]
-      tmp <- rbind(tmp, data.frame(index = which(!is.na(x) &
-                                                   !x %in% range), error = paste("Out of range:",
+      tmp <- rbind(tmp, data.frame(index = id[!is.na(x) &
+                                                   !x %in% range], error = paste("Out of range:",
                                                                                  varname, "=", xx)))
     }
   }

R/createProject.R

@@ -24,4 +24,27 @@ createProject <- function(dir, structure = c("OUCRU_RCT_wInterim")){
   # inform
   cat(paste("Project", basename(dir), "was created in", dirname(dir), "\n", sep = " "))
 }
+#' @export
+createProject2 <- function(dir, structure = c("Project")){
+  ## to create project directory
+  ## initial version: 23 July 2015
+
+  if (length(structure) > 1) {structure <- "Project"}
 
+  ## create destination folder
+  dir.create(dir)
+
+  ## copy folder structure into destination folder
+  file.copy(from = file.path(system.file(package = "C306"), "structure", structure, "."),
+            to = dir, recursive = TRUE)
+  file.rename(from = file.path(dir, "Analysis"), to = file.path(dir, paste0(basename(dir), "_Analysis")))
+  file.rename(from = file.path(dir, "Published"), to = file.path(dir, paste0(basename(dir), "_Published")))
+
+  ## populate workflowr
+  if ("workflowr" %in% rownames(installed.packages())) {
+    workflowr::wflow_start(file.path(dir, paste0(basename(dir), "_Published")), existing = TRUE, overwrite = TRUE)
+  }
+
+  # inform
+  cat(paste("Project", basename(dir), "was created in", dirname(dir), "\n", sep = " "))
+}

R/explicit.R

@@ -0,0 +1,54 @@
+#' Transform an object to its explicit form
+#' @description A function to transform an object to its explicit form if possible
+#' @param x An object
+#' @seealso \link{explicit.lm}
+#' @export
+explicit <- function(x, ...){
+  UseMethod('explicit')
+}
+
+#' Transform a model to its explicit form
+#' @description
+#' A function to transform an lm model formula to its explicit form.
+#' This is useful when you want to use stats::drop1 to drop additional terms in interaction models.
+#' @param fit An object of class "lm"
+#' @examples
+#' iris.model <- lm(Sepal.Width ~ Sepal.Length*Petal.Width, data=iris)
+#' explicit(iris.model)
+#' @return A model with explicit formula
+#' @seealso \link[stats]{add1}
+#' @export
+explicit.lm <- function(fit){
+  ._explicit_lm(fit, data = data, .meta = FALSE)
+  # if (length(data)) new_fit$call$data <- rlang::sym(deparse(substitute(data)))
+  # new_fit
+}
+
+._explicit_lm <- function(lm, .meta = FALSE, ...)
+{
+  formula <- formula(lm)
+  mf <- match.call(expand.dots = FALSE)
+  m <- match(c("lm", "data", "weights", "na.action",
+               "offset"), names(mf), 0L)
+  mf <- mf[c(1, m)]
+  mf$drop.unused.levels <- TRUE
+  # browser()
+  mf[[1L]] <- as.name("model.frame")
+  names(mf)[2L] <- "formula"
+  mf <- eval(mf, parent.frame())
+  y <- model.response(mf)
+  x <- model.matrix(lm)
+  new_data <- cbind(mf, model.matrix(lm)[,!colnames(x) %in% c('(Intercept)', colnames(mf)), drop=FALSE])
+  x_names <- paste0('`', gsub('(^`)|(`$)', '', colnames(x)[-1]), '`')
+  names(x_names) <- colnames(x)[-1]
+  # browser()
+  new_fml <- formula(call('~',
+                          parse(text = paste(x_names,
+                                             collapse = '+'),
+                                keep.source = FALSE)[[1L]]
+                          ))
+  new_lm <- update(lm, new_fml, data = new_data)
+  new_lm$call$data <- lm$call$data
+  if (.meta) attr(new_lm, 'name.map') <- structure(names(x_names), names = unname(x_names))
+  return(new_lm)
+}