Table 1 All Variables

RPackageSource/DESCRIPTION

@@ -13,12 +13,13 @@ Description: This R package support all cohort-specific analyses of the COMETS
     reflects the number of major revision and 4th level for bug fixes.
 Depends: R (>= 3.5.0)
 Imports: readxl, rio, dplyr, plyr, plotly, tidyr, heatmaply, stringr,
-        data.table, caret, subselect, broom, psych, MASS, ppcor,
+        data.table, caret, broom, psych, MASS, ppcor,
         survival
 Suggests: Hmisc, knitr, testthat, rmarkdown, RaMP
 VignetteBuilder: knitr
 License: GPL-3
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
+Encoding: UTF-8
 NeedsCompilation: no
 URL: http://comets-analytics.org/
 BugReports: https://github.com/CBIIT/nci-webtools-comets-analytics/issues

RPackageSource/NAMESPACE

@@ -48,7 +48,6 @@ importFrom(stats,pt)
 importFrom(stats,qnorm)
 importFrom(stats,relevel)
 importFrom(stringr,str_locate)
-importFrom(subselect,trim.matrix)
 importFrom(survival,Surv)
 importFrom(survival,clogit)
 importFrom(survival,coxph)

RPackageSource/R/02_getModelData.R

@@ -64,7 +64,7 @@ getModelData <-  function(readData,
                           offvar       = NULL,
                           timevar      = NULL,
                           groupvar     = NULL,
-			  where        = NULL,
+                          where        = NULL,
                           exposurerefs = NULL) {
 
   rowvars   <- outcomes
@@ -283,6 +283,10 @@ getModelData <-  function(readData,
   if (!is.null(acovs)) covlist <- c(covlist, acovs)
   if (!is.null(scovs)) covlist <- c(covlist, scovs)
   covlist <- c(covlist, wgtcov, offcov, timecov, groupcov)
+
+  # Store all variables before subsetting
+  all_vars <- colnames(readData$subjdata)
+
   varMap  <- NULL
   if (length(wgtvar) || length(offvar)) {
     varMap        <- c(wgtvar, offvar)
@@ -360,7 +364,9 @@ getModelData <-  function(readData,
   allvsall        = allvsall,
   varMap          = varMap,
   options         = options,
-  exposurerefs    = exposurerefs
+  exposurerefs    = exposurerefs,
+  all_vars        = all_vars,
+  all_data        = readData$subjdata
   )
 
   ret[[runModel.getWarningsListName()]] <- rem.obj

RPackageSource/R/03_runModel.R

@@ -33,18 +33,18 @@
 #' obj <- runModel(modeldata,exmetabdata, cohortLabel="DPP")
 #' @export
 
-runModel <- function(modeldata, metabdata, cohortLabel="", op=NULL, writeTofile=FALSE) {
+runModel <- function(modeldata, metabdata, cohortLabel="", op=NULL, writeTofile=FALSE, all_vars=FALSE) {
 
   ret <- try(myrunModel(modeldata, metabdata, cohortLabel=cohortLabel, 
-                        op=op, writeTofile=writeTofile), silent=FALSE)
+                        op=op, writeTofile=writeTofile, all_vars=all_vars), silent=FALSE)
   if (("try-error" %in% class(ret)) || !isValidReturnObj(ret)) { 
     lab <- modeldata[["modlabel", exact=TRUE]]
     ret <- getResListFromError(ret, lab)
   }
   ret
 }
 
-myrunModel <- function(modeldata, metabdata, cohortLabel="", op=NULL, writeTofile=FALSE) {
+myrunModel <- function(modeldata, metabdata, cohortLabel="", op=NULL, writeTofile=FALSE, all_vars=FALSE) {
 
   ptm <- base::proc.time() # start processing time
 
@@ -66,8 +66,8 @@ myrunModel <- function(modeldata, metabdata, cohortLabel="", op=NULL, writeTofil
 
   ret       <- runModel.start(modeldata, metabdata, op)
   ret       <- runModel.checkRetlist(ret, op) 
-  ret       <- runModel.addMetabCols(ret, metabdata, op)
-  ret       <- runModel.getTable1(ret, modeldata, op) 
+  ret <- runModel.addMetabCols(ret, metabdata, op)
+  ret       <- runModel.getTable1(ret, modeldata, op, all_vars) 
   ret       <- runModel.getInfoDF(ret, modeldata, metabdata, op) 
   ret       <- runModel.dupMetabHarmIds(ret, metabdata, op)
 
@@ -87,7 +87,7 @@ myrunModel <- function(modeldata, metabdata, cohortLabel="", op=NULL, writeTofil
 runModel.dupMetabHarmIds <- function(ret, metabdata, op) {
 
   ids <- metabdata[[dupMetabHarmIds(), exact=TRUE]]
-  if (!length(ids)) return(ret)
+  if (!length(na.omit(ids))) return(ret)
   idstr     <- paste0(ids, collapse=", ")
   nm        <- runModel.getWarningsListName()
   obj       <- ret[[nm, exact=TRUE]]

RPackageSource/R/imports.R

@@ -16,7 +16,6 @@
 #' @importFrom broom glance tidy
 #' @importFrom stats cor
 #' @importFrom MASS ginv
-#' @importFrom subselect trim.matrix
 #' @importFrom survival coxph Surv clogit strata
 #' @importFrom stringr str_locate
 #' @importFrom utils sessionInfo untar unzip read.table

RPackageSource/R/internalFunctions.r

@@ -759,3 +759,37 @@ addMetabInfo <- function(corrlong, modeldata, metabdata) {
 
 } # END: addMetabInfo
 
+
+
+
+
+# ---------------------------------------------------------------------------
+# trim.matrix function (from subselect)--------------------------------------
+# ---------------------------------------------------------------------------
+#' This function removes variables that cause the input design matrix to be ill-conditionned. The function was copied direclty from the package as a quickfix: https://cran.r-project.org/src/contrib/Archive/subselect/subselect_0.15.5.tar.gz 
+#' @keywords internal
+#' @param mat correlation matrix
+#' @param totalval totalval
+
+trim.matrix <- function(mat,tolval=10*.Machine$double.eps)
+{
+  p <- dim(mat)[2]
+  matindices <- 1:p                  
+  mat.eig <- eigen(mat,symmetric=TRUE)
+  discard <- rep(FALSE,p)
+  newmat <- mat
+  newmatindices <- matindices        
+  while(mat.eig$values[p]/mat.eig$values[1] < tolval)
+  {
+    int <- as.numeric(newmatindices[order(abs(mat.eig$vectors[,p]),decreasing=TRUE)[1]])   
+    discard[int] <- TRUE
+    newmat <- mat[!discard,!discard]
+    newmatindices <- matindices[!discard]   
+    p <- p-1
+    mat.eig <- eigen(newmat,symmetric=TRUE)   
+  }
+  size <- dim(newmat)[2]
+  output <- list(newmat,as.numeric(matindices[discard]),colnames(mat)[discard],size)   
+  names(output) <- c("trimmedmat","numbers.discarded","names.discarded","size")
+  output
+}

RPackageSource/R/options.R

@@ -76,7 +76,7 @@
 #'             are removed by computing the correlation matrix 
 #'             \code{cor_matrix = cor(design_matrix, method=check.cor.method)}. \cr
 #'          4. If \code{check.illCond} is TRUE, then the function
-#'          \code{subselect::trim.matrix} is applied 
+#'          \code{trim.matrix} is applied 
 #'             to the correlation matrix to determine if additional
 #'             columns will be removed. \cr \cr
 #' If \code{check.design} is TRUE, then steps 2-4 are repeated each time an exposure

RPackageSource/R/runModel_checks.R

@@ -110,7 +110,7 @@ runModel.checkDesignMatCols <- function(dmat, op, rem.obj=NULL, varMap=NULL,
   # check for ill conditioned square matrix for cor 
   if ((ncol(dmat) > 2) && (op$check.illCond)) {
     if (is.null(corMat)) corMat <- stats::cor(dmat[, -1, drop=FALSE], method=method)
-    rem <- subselect::trim.matrix(corMat)
+    rem <- trim.matrix(corMat)
     rem <- rem$names.discarded
     if (length(rem)) {
       rem.obj <- runModel.addRemVars(rem.obj, rem, varSet, "ill conditioned",

RPackageSource/R/table1.R

@@ -1,7 +1,6 @@
-runModel.getTable1 <- function(ret, modeldata, op) {
-
+runModel.getTable1 <- function(ret, modeldata, op, all_vars) {
   if (!is.list(ret)) return(ret)
-  tab1 <- try(getTable1(modeldata, op), silent=TRUE)
+  tab1 <- try(getTable1(modeldata, op, all_vars), silent=TRUE)
   if (!("try-error" %in% class(tab1))) {
     ret[[getTable1DfName()]] <- tab1
   }
@@ -25,11 +24,20 @@ getTable1ColNames <- function() {
        ov0=ov0, ov1=ov1)
 }
 
-getTable1 <- function(modeldata, op) {
-
+getTable1 <- function(modeldata, op, all_vars) {
   modeldata <- table1_getVars(modeldata)
-  vars      <- c("rcovs", "ccovs", "acovs", 
-                 "timecov", "groupcov", "wgtcov", "offcov")
+  if (all_vars) {
+    modeldata$all_vars <- modeldata$all_vars[!grepl("\\.\\.\\.", modeldata$all_vars)]
+    vars <- c(
+      "rcovs", "all_vars", "acovs",
+      "timecov", "groupcov", "wgtcov", "offcov"
+    )
+  } else {
+    vars <- c(
+      "rcovs", "ccovs", "acovs",
+      "timecov", "groupcov", "wgtcov", "offcov"
+    )
+  }
   nms       <- c("outcome", "exposure", "adjustment", 
                  "time", "group", "weight", "offset")
   yv        <- modeldata[["rcovs", exact=TRUE]]
@@ -89,14 +97,18 @@ getTable1 <- function(modeldata, op) {
   row <- 0
   for (strat in 1:nstrata) {
     strata <- stratlist[strat]
-    tmp    <- stratvec %in% strata
-    data   <- (modeldata$gdta)[tmp, , drop=FALSE] 
+    tmp <- stratvec %in% strata
+    if (all_vars) {
+      data <- modeldata$all_data[tmp, , drop = FALSE]
+    } else {
+      data <- (modeldata$gdta)[tmp, , drop=FALSE] 
+    }
     yeq0   <- data[, yv, drop=TRUE] %in% 0 
     yeq1   <- data[, yv, drop=TRUE] %in% 1
     #stratS <- table1_getStratStr(sv, strata)
 
     for (i in 1:tot) {
-      var     <- allvars[i]
+      var <- allvars[i]
       mtype   <- allmtypes[i]
       catvec  <- rep("", ncatCols)
       contvec <- rep(NA, ncontCols)

RPackageSource/vignettes/cometsvignette.Rmd

@@ -131,7 +131,7 @@ This diplay requires at least 2 rows and 2 columns in the correlation matrix.
 
 ```{r, eval=T}
 exmodeldata<-RcometsAnalytics::getModelData(exmetabdata,modelspec = "Interactive",exposures = c("bmi_grp","age"))
-excorrdata  <- RcometsAnalytics::runModel(exmodeldata,exmetabdata,"DPP")
+excorrdata  <- RcometsAnalytics::runModel(exmodeldata,exmetabdata,"DPP", all_vars = FALSE)
 RcometsAnalytics::showHClust(excorrdata, showticklabels=FALSE)
 ```