@sjcrh/proteinpaint-server 2.74.2 → 2.75.0

package/utils/regression.R

@@ -127,7 +127,7 @@ benchmark[["buildFormulas"]] <- unbox(paste(round(as.numeric(dtime), 4), attr(dt
 stime <- Sys.time()
 cores <- detectCores()
 if (is.na(cores)) stop("unable to detect number of cores")
-reg_results <- mclapply(X = formulas, FUN = runRegression, regtype = input$regressionType, dat = dat, outcome = input$outcome, mc.cores = cores)
+reg_results <- mclapply(X = formulas, FUN = runRegression, regtype = input$regressionType, dat = dat, outcome = input$outcome, neuroOnc = input$neuroOnc, mc.cores = cores)
 etime <- Sys.time()
 dtime <- etime - stime
 benchmark[["runRegression"]] <- unbox(paste(round(as.numeric(dtime), 4), attr(dtime, "units")))

package/utils/regression.utils.R

@@ -399,7 +399,7 @@ coxRegression <- function(formula, dat) {
 }
 
 # run regression analysis
-runRegression <- function(formula, regtype, dat, outcome) {
+runRegression <- function(formula, regtype, dat, outcome, neuroOnc) {
   id <- formula$id
   # remove samples with NA values in any variable in the formula
   # NOTE: even though regression functions (e.g. lm, glm, etc.)
@@ -439,7 +439,7 @@ runRegression <- function(formula, regtype, dat, outcome) {
     }
   }
   if (length(warns) > 0) results[["warnings"]] <- warns
-  results$coefficients <- formatCoefficients(results$coefficients, results$res, input$regressionType)
+  results$coefficients <- formatCoefficients(results$coefficients, results$res, input$regressionType, fdat, neuroOnc)
   results$type3 <- formatType3(results$type3)
   out <- list("id" = unbox(id), "data" = results[names(results) != "res"])
   return(out)
@@ -612,7 +612,7 @@ build_coef_table <- function(res_summ) {
 }
 
 # reformat the coefficients table
-formatCoefficients <- function(coefficients_table, res, regtype) {
+formatCoefficients <- function(coefficients_table, res, regtype, dat, neuroOnc) {
   # round all columns to 4 significant digits
   coefficients_table <- signif(coefficients_table, 4)
   # add variable and category columns
@@ -637,8 +637,8 @@ formatCoefficients <- function(coefficients_table, res, regtype) {
       if (v2 %in% names(res$xlevels)) {
         clst2 <- res$xlevels[[v2]][-1] # extract categories (without reference category)
       }
-      for (c1 in clst1) {
-        for (c2 in clst2) {
+      for (c2 in clst2) {
+        for (c1 in clst1) {
           cCol <- c(cCol, paste(c1, c2, sep = ":"))
           vCol <- c(vCol, v)
         }
@@ -667,7 +667,44 @@ formatCoefficients <- function(coefficients_table, res, regtype) {
       }
     }
   }
-  coefficients_table <- cbind("Variable" = vCol, "Category" = cCol, coefficients_table)
+  
+  if (regtype == "cox" && !is.null(neuroOnc)) {
+    # neuro-oncology dataset using cox regression
+    # report sample size and event counts of coefficients
+    sCol <- vector(mode = "character")
+    eCol <- vector(mode = "character")
+    for (i in 1:length(vCol)) {
+      v <- vCol[i]
+      c <- cCol[i]
+      if (grepl(":", v, fixed = T)) {
+        # interacting variables
+        # not allowed in neuro-oncology dataset
+        stop("interacting variables not supported")
+      }
+      if (v %in% names(res$xlevels)) {
+        # categorical variable
+        # determine sample size and event count of both ref and non-ref categories
+        # values will be stored in separate columns in the format "ref/nonref"
+        ref <- res$xlevels[[v]][1]
+        m <- table(dat[,"outcome_event"], dat[,v])
+        samplesize_ref <- sum(m[,ref])
+        samplesize_c <- sum(m[,c])
+        sCol <- c(sCol, paste(samplesize_ref, samplesize_c, sep = "/"))
+        eventcnt_ref <- m["1",ref]
+        eventcnt_c <- m["1",c]
+        eCol <- c(eCol, paste(eventcnt_ref, eventcnt_c, sep = "/"))
+      } else {
+        # continuous variable
+        # set sample size and event count to NA
+        sCol <- c(sCol, NA)
+        eCol <- c(eCol, NA)
+      }
+    }
+    coefficients_table <- cbind("Variable" = vCol, "Category" = cCol, "Sample Size (ref/non-ref)" = sCol, "Events (ref/non-ref)" = eCol, coefficients_table)
+  } else {
+    coefficients_table <- cbind("Variable" = vCol, "Category" = cCol, coefficients_table)
+  }
+  
   coefficients_table <- list("header" = colnames(coefficients_table), "rows" = coefficients_table)
   return(coefficients_table)
 }

package/utils/survival.R

@@ -69,11 +69,19 @@ if (length(levels(dat$series)) == 1) {
       estimates <- rbind(estimates, estimates_series)
     }
     # test for difference between survival curves using log-rank test
-    # suppress warnings to prevent warnings when test is done between
-    # curves with no events
-    test <- suppressWarnings(survdiff(Surv(time, status) ~ series, data = dat, subset = dat$series %in% pair))
-    # compute p-value (see: https://www.emilyzabor.com/tutorials/survival_analysis_in_r_tutorial.html#Extracting_information_from_a_survdiff_object)
-    pvalue <- 1 - pchisq(test$chisq, length(test$n) - 1)
+    df <- dat[dat$series %in% pair, c("time", "status")]
+    if (all(apply(df, 2, function(x) length(unique(x)) == 1))) {
+      # survival curves are identical
+      # do not compare curves using survdiff() because it will error out
+      # set pvalue to 1
+      pvalue <- 1
+    } else {
+      # suppress warnings to prevent warnings when test is done between
+      # curves with no events
+      test <- suppressWarnings(survdiff(Surv(time, status) ~ series, data = dat, subset = dat$series %in% pair))
+      # compute p-value (see: https://www.emilyzabor.com/tutorials/survival_analysis_in_r_tutorial.html#Extracting_information_from_a_survdiff_object)
+      pvalue <- 1 - pchisq(test$chisq, length(test$n) - 1)
+    }
     tests[i,] <- c(pair, signif(pvalue, 2))
   }
 }