@@ -21,6 +21,7 @@ export(available)

 export(calcCVperformance)

 export(calcExternalPerformance)

 export(chosenFeatureNames)

+export(colCoxTests)

 export(crossValidate)

 export(distribution)

 export(edgesToHubNetworks)

@@ -90,7 +91,6 @@ import(grid)

 import(methods)

 import(utils)

 importFrom(S4Vectors,as.data.frame)

-importFrom(S4Vectors,combineRows)

 importFrom(S4Vectors,do.call)

 importFrom(S4Vectors,mcols)

 importFrom(dplyr,mutate)

@@ -81,6 +81,26 @@ fastCox <- function(X, y, learnind, criterion, ...) {

 # equivalent to genefilter::rowttests for the cox model.  This is much faster

 # than calling coxph for each row of a ##igh-dimensional matrix.

+

+######################################

+######################################

+#' A function to perform fast cox proportional hazard model tests

+#'

+#' @param x matrix with variables as columns.

+#' @param y matrix with first column as time and second column as event.

+#' @param option whether to use the fast or slow method.

+#'

+#' @return CrossValParams object

+#' @export

+#'

+#' @examples

+#' data(asthma)

+#' time <- ppois(nrow(measurements),100)

+#' status <- sample(c(0,1), nrow(measurements), replace = TRUE)

+#' x = measurements

+#' y = cbind(time, status)

+#' output <- colCoxTests(x, y, "fast")

+#' @export

 colCoxTests <- function(X, y, option = c("fast", "slow"), ...) {

   option <- match.arg(option)

   if (identical(option, "fast")) {

@@ -1,3 +1,152 @@

+# Operates on an input data frame, to extract the outcome column(s) and return

+# a list with the table of covariates in one element and the outcome in another.

+# The outcome need to be removed from the data table before predictor training!

+.splitDataAndOutcome <- function(measurements, outcome, restrict = NULL)

+{ # DataFrame's outcome variable can be character or factor, so it's a bit involved.

+  if(is.character(outcome) && length(outcome) > 3 && length(outcome) != nrow(measurements))

+    stop("'outcome' is a character variable but has more than one element. Either provide a\n",

+         "       one to three column names or a factor of the same length as the number of samples.")

+

+  ## String specifies the name of a single outcome column, typically a class.

+  if(is.character(outcome) && length(outcome) == 1)

+  {

+    outcomeColumn <- match(outcome, colnames(measurements))

+    if(is.na(outcomeColumn))

+      stop("Specified column name of outcome is not present in the data table.")

+    outcome <- measurements[, outcomeColumn]

+    measurements <- measurements[, -outcomeColumn, drop = FALSE]

+    # R version 4 and greater no longer automatically casts character columns to factors because stringsAsFactors

+    # is FALSE by default, so it is more likely to be character format these days. Handle it.

+    if(class(outcome) != "factor") # Assume there will be no ordinary regression prediction tasks ... for now.

+      outcome <- factor(outcome)

+  }

+  

+  # survival's Surv constructor has two inputs for the popular right-censored data and

+  # three inputs for less-common interval data.

+  if(is.character(outcome) && length(outcome) %in% 2:3)

+  {

+    outcomeColumns <- match(outcome, colnames(measurements))

+    if(any(is.na(outcomeColumns)))

+      stop("Specified column names of outcome is not present in the data table.")

+    outcome <- measurements[, outcomeColumns]

+    measurements <- measurements[, -outcomeColumns, drop = FALSE]

+  }

+  

+  if(is(outcome, "factor") && length(outcome) > 3 & length(outcome) < nrow(measurements))

+    stop("The length of outcome is not equal to the number of samples.")

+  

+  ## A vector of characters was input by the user. Ensure that it is a factor.

+  if(is.character(outcome) & length(outcome) == nrow(measurements))

+    outcome <- factor(outcome)

+  

+  # Outcome has columns, so it is tabular. It is inferred to represent survival data.

+  if(!is.null(ncol(outcome)) && ncol(outcome) %in% 2:3)

+  {

+    # Assume that event status is in the last column (second for two columns, third for three columns)

+    numberEventTypes <- length(unique(outcome[, ncol(outcome)]))

+    # Could be one or two kinds of events. All events might be uncensored or censored

+    # in a rare but not impossible scenario.

+    if(numberEventTypes > 2)

+      stop("Number of distinct event types in the last column exceeds 2 but must be 1 or 2.")

+      

+    if(ncol(outcome) == 2) # Typical, right-censored survival data.

+      outcome <- survival::Surv(outcome[, 1], outcome[, 2])

+    else # Three columns. Therefore, counting process data.

+      outcome <- survival::Surv(outcome[, 1], outcome[, 2], outcome[, 3])

+  }

+  

+  if(!is.null(restrict))

+  {

+    isDesiredClass <- sapply(measurements, function(column) is(column, restrict))

+    measurements <- measurements[, isDesiredClass, drop = FALSE]

+    if(ncol(measurements) == 0)

+      stop(paste("No features are left after restricting to", restrict, "but at least one must be."))

+  }

+

+  list(measurements = measurements, outcome = outcome)

+}

+

+# Function to convert a MultiAssayExperiment object into a flat DataFrame table, to enable it

+# to be used in typical model building functions.

+# Returns a list with a covariate table and and outcome vector/table, or just a covariate table

+# in the case the input is a test data set.

+.MAEtoWideTable <- function(measurements, targets = NULL, outcomeColumns = NULL, restrict = "numeric")

+{

+  if(is.null(targets))

+    stop("'targets' is not specified but must be.")

+  if(is.null(outcomeColumns))

+    stop("'outcomeColumns' is not specified but must be.")    

+  if(!all(targets %in% c(names(measurements), "sampleInfo")))

+    stop("Some table names in 'targets' are not assay names in 'measurements' or \"sampleInfo\".")

+  sampleInfoColumns <- colnames(MultiAssayExperiment::colData(measurements))

+  if(!missing(outcomeColumns) & !all(outcomeColumns %in% sampleInfoColumns))

+    stop("Not all column names specified by 'outcomeColumns' found in sample information table.")  

+

+  if("sampleInfo" %in% targets)

+  {

+    targets <- targets[targets != "sampleInfo"]

+    sampleInfoColumnsTrain <- sampleInfoColumns

+  } else {

+    sampleInfoColumnsTrain <- NULL

+  }

+  

+  if(length(targets) > 0)

+  {

+    measurements <- measurements[, , targets]

+  

+    # Get all desired measurements tables and sample information columns (other than the columns representing outcome).

+    # These form the independent variables to be used for making predictions with.

+    # Variable names will have names like RNA:BRAF for traceability.

+    dataTable <- MultiAssayExperiment::wideFormat(measurements, colDataCols = union(sampleInfoColumnsTrain, outcomeColumns), check.names = FALSE, collapse = ':')

+    rownames(dataTable) <- dataTable[, "primary"]

+    S4Vectors::mcols(dataTable)[, "sourceName"] <- gsub("colDataCols", "sampleInfo", S4Vectors::mcols(dataTable)[, "sourceName"])

+    colnames(S4Vectors::mcols(dataTable))[1] <- "assay"

+  

+    # Sample information variable names not included in column metadata of wide table but only as row names of it.

+    # Create a combined column named "feature" which has feature names of the assays as well as the sample information.

+    S4Vectors::mcols(dataTable)[, "feature"] <- as.character(S4Vectors::mcols(dataTable)[, "rowname"])

+    missingIndices <- is.na(S4Vectors::mcols(dataTable)[, "feature"])

+    S4Vectors::mcols(dataTable)[missingIndices, "feature"] <- colnames(dataTable)[missingIndices]

+    

+    # Finally, a column annotation recording variable name and which table it originated from for all of the source tables.

+    S4Vectors::mcols(dataTable) <- S4Vectors::mcols(dataTable)[, c("assay", "feature")]

+  } else { # Must have only been sample information data.

+    dataTable <- MultiAssayExperiment::colData(measurements)

+  }

+  if(!is.null(outcomeColumns)) outcome <- dataTable[, outcomeColumns]

+  

+  if(!is.null(restrict))

+  {

+    isDesiredClass <- sapply(dataTable, function(column) is(column, restrict))

+    dataTable <- dataTable[, isDesiredClass, drop = FALSE]

+    if(ncol(dataTable) == 0)

+      stop(paste("No features are left after restricting to", restrict, "but at least one must be."))

+  }

+

+  # Only return independent variables in dataTable for making classifications with.

+  # "primary" column is auto-generated by sample information table row names and a duplicate.

+  dropColumns <- na.omit(match(c("primary", outcomeColumns), colnames(dataTable)))

+  if(length(dropColumns) > 0) dataTable <- dataTable[, -dropColumns]

+  

+  # Training data table and outcome for training data.

+  if(!is.null(outcomeColumns))

+      list(dataTable = dataTable, outcome = outcome)

+  else # Only test data table for test data input.

+    dataTable

+}

+

+# For classifiers which use one single function for inputting a training and a testing table,

+# and work only for the numeric data type, this checks whether the training and testing tables 

+# both have the same set of features and there are at least some numeric features to use,

+# after they have been filtered by another function which splits the covariates and the outcome from the input.

+.checkVariablesAndSame <- function(trainingMatrix, testingMatrix)

+{

+  if(ncol(trainingMatrix) == 0) # Filtering of table removed all columns, leaving nothing to classify with.

+    stop("No variables in data tables specified by \'targets\' are numeric.")

+  else if(ncol(trainingMatrix) != ncol(testingMatrix))

+    stop("Training data set and testing data set contain differing numbers of features.")  

+}

+

 # Creates two lists of lists. First has training samples, second has test samples for a range

 # of different cross-validation schemes.

 #' @import utils

@@ -106,6 +255,7 @@

   tuneParams <- modellingParams@selectParams@tuneParams

   performanceType <- tuneParams[["performanceType"]]

   topNfeatures <- tuneParams[["nFeatures"]]

+  tuneMode <- ifelse("tuneMode" %in% names(tuneParams), tuneParams[["tuneMode"]], crossValParams@tuneMode)

   tuneParams <- tuneParams[-match(c("performanceType", "nFeatures"), names(tuneParams))] # Only used as evaluation metric.

   # Make selectParams NULL, since we are currently doing selection and it shouldn't call

@@ -132,17 +282,17 @@

       do.call(featureRanking, paramList)

     })

-    if(attr(featureRanking, "name") == "previousSelection") # Actually selection not ranking.

+    if(featureRanking@generic == "previousSelection") # Actually selection not ranking.

       return(list(NULL, rankings[[1]], NULL))

-    if(crossValParams@tuneMode == "none") # No parameters to choose between.

+    if(tuneMode == "none") # Actually selection not ranking.

         return(list(NULL, rankings[[1]], NULL))

     tuneParamsTrain <- list(topN = topNfeatures)

     tuneParamsTrain <- append(tuneParamsTrain, modellingParams@trainParams@tuneParams)

     tuneCombosTrain <- expand.grid(tuneParamsTrain, stringsAsFactors = FALSE)  

     modellingParams@trainParams@tuneParams <- NULL

-    allPerformanceTables <- lapply(rankings, function(rankingsVariety)

+    bestPerformers <- sapply(rankings, function(rankingsVariety)

     {

       # Creates a matrix. Columns are top n features, rows are varieties (one row if None).

       performances <- sapply(1:nrow(tuneCombosTrain), function(rowIndex)

@@ -182,22 +332,20 @@

        })

         bestOne <- ifelse(betterValues == "lower", which.min(performances)[1], which.max(performances)[1])

-        list(data.frame(tuneCombosTrain, performance = performances), bestOne)

+        c(bestOne, performances[bestOne])

       })

-      tablesBestMetrics <- sapply(allPerformanceTables, function(tableIndexPair) tableIndexPair[[1]][tableIndexPair[[2]], "performance"])

-      tunePick <- ifelse(betterValues == "lower", which.min(tablesBestMetrics)[1], which.max(tablesBestMetrics)[1])

+      tunePick <- ifelse(betterValues == "lower", which.min(bestPerformers[2, ])[1], which.max(bestPerformers[2, ])[1])

       if(verbose == 3)

          message("Features selected.")

-      tuneDetails <- allPerformanceTables[[tunePick]] # List of length 2.

+      tuneRow <- tuneCombosTrain[bestPerformers[1, tunePick], , drop  = FALSE]

+      if(ncol(tuneRow) > 1) tuneDetails <- tuneRow[, -1, drop = FALSE] else tuneDetails <- NULL

       rankingUse <- rankings[[tunePick]]

-      selectionIndices <- rankingUse[1:(tuneDetails[[1]][tuneDetails[[2]], "topN"])]

+      selectionIndices <- rankingUse[1:tuneRow[, "topN"]]

-      names(tuneDetails) <- c("tuneCombinations", "bestIndex")

-      colnames(tuneDetails[[1]])[ncol(tuneDetails[[1]])] <- performanceType

       list(ranked = rankingUse, selected = selectionIndices, tune = tuneDetails)

     } else if(is.list(featureRanking)) { # It is a list of functions for ensemble selection.

       featuresIndiciesLists <- mapply(function(selector, selParams)

@@ -240,7 +388,8 @@

       list(NULL, selectionIndices, NULL)

     } else { # Previous selection

-      selectedFeatures <- list(NULL, selectionIndices, NULL)

+      selectedFeatures <- 

+      list(NULL, selectionIndices, NULL)

     }

 }

@@ -256,10 +405,10 @@

 # Code to create a function call to a training function. Might also do training and testing

 # within the same function, so test samples are also passed in case they are needed.

-.doTrain <- function(measurementsTrain, outcomeTrain, measurementsTest, outcomeTest, crossValParams, modellingParams, verbose)

+.doTrain <- function(measurementsTrain, outcomeTrain, measurementsTest, outcomeTest, modellingParams, verbose)

 {

-  tuneDetails <- NULL

-  if(!is.null(modellingParams@trainParams@tuneParams) && is.null(modellingParams@selectParams))

+  tuneChosen <- NULL

+  if(!is.null(modellingParams@trainParams@tuneParams) && is.null(modellingParams@selectParams@tuneParams))

   {

     performanceType <- modellingParams@trainParams@tuneParams[["performanceType"]]

     modellingParams@trainParams@tuneParams <- modellingParams@trainParams@tuneParams[-match("performanceType", names(modellingParams@trainParams@tuneParams))]

@@ -271,16 +420,16 @@

       modellingParams@trainParams@otherParams <- c(modellingParams@trainParams@otherParams, as.list(tuneCombos[rowIndex, ]))

       if(crossValParams@tuneMode == "Resubstitution")

       {

-        result <- runTest(measurementsTrain, outcomeTrain, measurementsTrain, outcomeTrain,

+        result <- runTest(measurementsTrain, outcomeTrain, measurementsTest, outcomeTest,

                           crossValParams = NULL, modellingParams,

                           verbose = verbose, .iteration = "internal")

         predictions <- result[["predictions"]]

         if(class(predictions) == "data.frame")

-          predictedOutcome <- predictions[, colnames(predictions) %in% c("class", "risk")]

+          predictedOutcome <- predictions[, "outcome"]

         else

           predictedOutcome <- predictions

-        calcExternalPerformance(outcomeTrain, predictedOutcome, performanceType)

+        calcExternalPerformance(outcomeTest, predictedOutcome, performanceType)

       } else {

         result <- runTests(measurementsTrain, outcomeTrain,

                            crossValParams, modellingParams,

@@ -289,18 +438,13 @@

         median(performances(result)[[performanceType]])

       }

     })

-    allPerformanceTable <- data.frame(tuneCombos, performances)

-    colnames(allPerformanceTable)[ncol(allPerformanceTable)] <- performanceType

-    

     betterValues <- .ClassifyRenvir[["performanceInfoTable"]][.ClassifyRenvir[["performanceInfoTable"]][, "type"] == performanceType, "better"]

     bestOne <- ifelse(betterValues == "lower", which.min(performances)[1], which.max(performances)[1])

     tuneChosen <- tuneCombos[bestOne, , drop = FALSE]

-    tuneDetails <- list(tuneCombos, bestOne)

-    names(tuneDetails) <- c("tuneCombinations", "bestIndex")

     modellingParams@trainParams@otherParams <- tuneChosen

   }

-    if (!"previousTrained" %in% attr(modellingParams@trainParams@classifier, "name")) 

+  if(modellingParams@trainParams@classifier@generic != "previousTrained")

     # Don't name these first two variables. Some classifier functions might use classesTrain and others use outcomeTrain.

     paramList <- list(measurementsTrain, outcomeTrain)

   else # Don't pass the measurements and classes, because a pre-existing classifier is used.

@@ -315,7 +459,7 @@

   if(verbose >= 2)

     message("Training completed.")  

-  list(model = trained, tune = tuneDetails)

+  list(model = trained, tune = tuneChosen)

 }

 # Creates a function call to a prediction function.

@@ -384,6 +528,15 @@

 # by user-specified values.

 .filterCharacteristics <- function(characteristics, autoCharacteristics)

 {

+  # Remove duplication of values for classifiers that have one function for training and 

+  # one function for prediction.

+  if("Classifier Name" %in% autoCharacteristics[, "characteristic"] && "Predictor Name" %in% autoCharacteristics[, "characteristic"])

+  {

+    classRow <- which(autoCharacteristics[, "characteristic"] == "Classifier Name")

+    predRow <- which(autoCharacteristics[, "characteristic"] == "Predictor Name")

+    if(autoCharacteristics[classRow, "value"] == autoCharacteristics[predRow, "value"])

+      autoCharacteristics <- autoCharacteristics[-predRow, ]

+  }

   # Overwrite automatically-chosen names with user's names.

   if(nrow(autoCharacteristics) > 0 && nrow(characteristics) > 0)

   {

@@ -407,6 +560,36 @@

   plotData

 }

+# Summary of the features used and the total number of them, no matter if they are a simple type

+# or something more complex like Pairs or feature sets.

+.summaryFeatures <- function(measurements)

+{

+  # MultiAssayExperiment has feature details in mcols.

+  if(!is.null(S4Vectors::mcols(measurements)))

+  {

+    originalInfo <- S4Vectors::mcols(measurements)

+    featureNames <- S4Vectors::mcols(measurements)[, "feature"]

+    assays <- unique(S4Vectors::mcols(measurements)[, "assay"])

+    renamedInfo <- S4Vectors::mcols(measurements)

+    renamedAssays <- paste("Assay", seq_along(assays), sep = '')

+    for(assay in assays)

+    {

+      rowsAssay <- which(renamedInfo[, "assay"] == assay)

+      renamedInfo[rowsAssay, "feature"] <- paste("Feature", seq_along(rowsAssay), sep = '')

+      renamedInfo[rowsAssay, "assay"] <- renamedAssays[match(assay, assays)]

+    }

+    featuresInfo <- S4Vectors::DataFrame(originalInfo, renamedInfo)

+    colnames(featuresInfo) <- c("Original Assay", "Original Feature", "Renamed Assay", "Renamed Feature")

+    featuresInfo <- cbind(originalInfo, featuresInfo)

+  } else {

+    originalFeatures <- colnames(measurements)

+    renamedInfo <- paste("Feature", seq_along(measurements), sep = '')

+    featuresInfo <- S4Vectors::DataFrame(originalFeatures, renamedInfo)

+    colnames(featuresInfo) <- c("Original Feature", "Renamed Feature")

+  }

+  featuresInfo

+}

+

 # Function to identify the parameters of an S4 method.

 .methodFormals <- function(f, signature) {

   tryCatch({

@@ -477,53 +660,6 @@

   list(measurementsTrain = measurementsTrain, classesTrain = classesTrain)

 }

-.transformKeywordToFunction <- function(keyword)

-{

-  switch(

-        keyword,

-        "none" = NULL,

-        "diffLoc" = subtractFromLocation

-    )

-}

-

-.selectionKeywordToFunction <- function(keyword)

-{

-  switch(

-        keyword,

-        "none" = NULL,

-        "t-test" = differentMeansRanking,

-        "limma" = limmaRanking,

-        "edgeR" = edgeRranking,

-        "Bartlett" = bartlettRanking,

-        "Levene" = leveneRanking,

-        "DMD" = DMDranking,

-        "likelihoodRatio" = likelihoodRatioRanking,

-        "KS" = KolmogorovSmirnovRanking,

-        "KL" = KullbackLeiblerRanking,

-        "CoxPH" = coxphRanking,

-        "selectMulti" = selectMulti

-    )

-}

-

-.classifierKeywordToParams <- function(keyword)

-{

-    switch(

-        keyword,

-        "randomForest" = RFparams(),

-        "randomSurvivalForest" = RSFparams(),

-        "GLM" = GLMparams(),

-        "elasticNetGLM" = elasticNetGLMparams(),

-        "SVM" = SVMparams(),

-        "NSC" = NSCparams(),

-        "DLDA" = DLDAparams(),

-        "naiveBayes" = naiveBayesParams(),

-        "mixturesNormals" = mixModelsParams(),

-        "kNN" = kNNparams(),

-        "CoxPH" = coxphParams(),

-        "CoxNet" = coxnetParams()

-    )    

-}

-

 .dlda <- function(x, y, prior = NULL){ # Remove this once sparsediscrim is reinstated to CRAN.

   obj <- list()

   obj$labels <- y

new file mode 100644

@@ -0,0 +1,29 @@

+% Generated by roxygen2: do not edit by hand

+% Please edit documentation in R/rankingCoxPH.R

+\name{colCoxTests}

+\alias{colCoxTests}

+\title{A function to perform fast cox proportional hazard model tests}

+\usage{

+colCoxTests(X, y, option = c("fast", "slow"), ...)

+}

+\arguments{

+\item{y}{matrix with first column as time and second column as event.}

+

+\item{option}{whether to use the fast or slow method.}

+

+\item{x}{matrix with variables as columns.}

+}

+\value{

+CrossValParams object

+}

+\description{

+A function to perform fast cox proportional hazard model tests

+}

+\examples{

+data(asthma)

+time <- ppois(nrow(measurements),100)

+status <- sample(c(0,1), nrow(measurements), replace = TRUE)

+x = measurements

+y = cbind(time, status)

+output <- colCoxTests(x, y, "fast")

+}