#' #' Combines two p-values with the method of Stouffer (Stouffer et. al, 1949) #' #' @param pValues1 vector of first p-values #' @param pValues2 vector of second p-values, has to have the same length as first vector #' @return vector of combined p-values #' stoufferCombine <- function(pValues1, pValues2) { # build a matrix of pairwise p values x <- matrix(cbind(pValues1, pValues2), ncol=2) # add a little to pValues of 0 x[x==0] <- 1e-30 # now we can use apply to iterate over the rows, always combining two p values ret <- as.numeric(apply(x, 1, function(xx) { ret <- pnorm(sum(qnorm(abs(xx))) / sqrt(length(abs(xx)))) ret <- ret * prod(sign(xx)) })) # set all NaNs to 0, this can just happen if one pVlaue was 0, so all should be 0 ret[is.nan(ret)] <- 0 return(ret) } #' #' Combines two p-values with the method of Stouffer (Stouffer et. al, 1949) #' this version is vectorized and therewith faster #' #' @param pValues1 vector of first p-values #' @param pValues2 vector of second p-values, has to have the same length as first vector #' @return vector of combined p-values #' stoufferCombineVectorized <- function(pValues1, pValues2) { # build a matrix of pairwise p values x <- matrix(cbind(pValues1, pValues2), ncol=2) # add a little to pValues of 0 x[x==0] <- 1e-30 ret <- pnorm(rowSums(qnorm(abs(x))) / sqrt(ncol(x))) # add a minus if the cor p value was negative ret <- ret * ifelse(rowSums(x<0)>0, -1, 1) # set all NaNs to 0, this can just happen if one pVlaue was 0, so all should be 0 ret[is.nan(ret)] <- 0 return(ret) } #' #' function to create adjacency matrices of #' the correlations and the matches of the prediction #' data bases #' 0: no connection #' 1: sign. pos. correlation #' 2: sign. pos. correlation + confirmed by target pred. database #' -1, 2: same with negative correlation #' #' the function is a wrapper around combMatrices #' #' @param correlationList list of cor elements, lists with a cors and a pcors matrix as given by multi.cor.test #' @param predictMatrix a matrix with precition p-values, the rownames must match the rownames of the pcors matrix, likewise the colnames #' @param cor.value a cutoff for the correlation #' @param cor.p.value the significance level for correlations #' @param pred.p.value the significance level for predictions #' @mode how should correlations and predictions be combined, according to categories or combine the p-values #' @param combFunction: in case of category equal "pvalue" the comBFunction, default to NULL, in this case the pvalue are just multiplied #' @return a matrix with either categories (-2, -1, 0, 1, 2) or combined p-values, in latter case a minus indicates a negative correlation #' assembleAdjMatrices <- function(correlationList, predictMatrix, cor.value=NULL, cor.p.value=0.05, pred.p.value=0.05, mode="category", combFunction=NULL) { if(!(mode %in% c("category", "pvalue"))) { stop("Mode must be either 'category' or 'pvalue'.") } cat ("Build adjacency matrices ... \n\n") #' create a new list with the same names as the correlation list #' and the dbMatch list adjMatrices <- vector("list", length=length(correlationList)) names(adjMatrices) <- names(correlationList) #' for every element in the list we #' construct the adj. matrix for (i in names(adjMatrices)) { #' nice print, where we are :) cat("Processing:",i, "...\n") #' get adjcency matrix for the current group (coded by the name i) adjMatrices[[i]] <- combMatrices(correlationList[[i]], predictMatrix, cor.value, cor.p.value, pred.p.value, mode, combFunction) } cat("Finished to build the adjacency matrices!\n\n") return(adjMatrices) } #' #' same function as above, but the predictions are given as a table with colnames 'mirna', 'gene', and 'pvalue' #' assembleAdjMatricesTable <- function(correlationList, predictTable, cor.value=NULL, cor.p.value=0.05, pred.p.value=0.05, mode="category", combFunction=NULL) { # predict tabel must contain columns mirna, gene and pvalue if(!all(c("mirna", "gene", "pvalue") %in% colnames(predictTable))) { stop("The table with the target prediction must contain columns 'mirna', 'gene' and pvalue") } if(!(mode %in% c("category", "pvalue"))) { stop("Mode must be either 'category' or 'pvalue'.") } # writing the prediction table to a matrix cat("Creating a matrix from the prediction table ... ") predMatrix <- predictTable2Matrix(predictTable) cat("Done!\n") cat("Build adjacency matrices ... \n\n") #' create a new list with the same names as the correlation list #' and the dbMatch list adjMatrices <- vector("list", length=length(correlationList)) names(adjMatrices) <- names(correlationList) #' for every element in the list we #' construct the adj. matrix for (i in names(adjMatrices)) { #' nice print, where we are :) cat("Processing:",i, "...\n") #' get adjcency matrix for the current group (coded by the name i) adjMatrices[[i]] <- combMatrices(correlationList[[i]], predMatrix, cor.value, cor.p.value, pred.p.value, mode, combFunction) } cat("Finished to build the adjacency matrices!\n\n") return(adjMatrices) } #' #' PlotDistributions #' #' plots the distribution of correlation coefficients and p values and chosen cut points #' PlotDistributions <- function(correlation.list, cor.value=NULL, p.value=0.05) { for (i in names(correlation.list)) { # plot correlations if a cutoff is given if(!is.null(cor.value)) { dens <- density(correlation.list[[i]]$cors) plot(dens, main=paste("Distribution of correlations:", i)) abline(v=cor.value, col="red") abline(v=-cor.value, col="red") } # plot correlation p values dens <- density(correlation.list[[i]]$pcors) plot(dens, main=paste("Distribution of p values:", i)) abline(v=p.value, col="red") } } #' #' combMatrices #' helper function to create an adjacency matrix from a correlation element and a prediction table #' #' @param correlationElement a list with two matrices cors and pcors cominf from function multi.cor.test #' combMatrices <- function(correlationElement, predictMatrix, cor.value=NULL, cor.p.value=0.05, pred.p.value=0.05, mode="category", combFunction=NULL, strict=F) { # check for the names of the correlation element if(!all(c("cors", "pcors") %in% names(correlationElement))) { stop("The correlation element must contain a matrix 'cors' and 'pcors'.") } # both have to be matrices with the same colnames and rownames if (!(is.array(correlationElement$cors) && is.array(correlationElement$pcors))) { stop("'cors' and 'pcors' have to be matrices.") } if(any(rownames(correlationElement$cors) != rownames(correlationElement$pcors)) || any(colnames(correlationElement$pcors) != colnames(correlationElement$pcors))) { stop("Matrices 'cors' and 'pcors' must contain the same elements (rownames and colnames).") } # first the category mode # the interactions will be represented by the 5 categories: -2, -1, 0, 1, 2 if(mode=="category") { # set a p value for the correlation if no cor.value and no p vlue was given # to build the categories we need a p value if(is.null(cor.value) & is.null(cor.p.value)) { cor.p.value <- 0.05 } # build the adj. matrix with the pcors and the cors # if cor.value is given abs(cors) cor.value otherwise pcors < p.value -> 1 # cors detemines sign if (!is.null(cor.value)) { adjMatrix <- (abs(correlationElement$cors) > cor.value) * sign(correlationElement$cors) } else { adjMatrix <- (correlationElement$pcors < cor.p.value) * sign(correlationElement$cors) } # find the overlap between the correlations and the predictions rows <- intersect(rownames(adjMatrix), rownames(predictMatrix)) cols <- intersect(colnames(adjMatrix), colnames(predictMatrix)) # create temporary matrix of the prediction db matrix # form a hit to 2 and no hit to 1 if (is.null(pred.p.value)) { ttt <- 2*(predictMatrix[rows, cols]!=-1) ttt[ttt==0] <- 1 } else { # now we have to check two requirements # 1) unequal -1 and # 2) smaller pred.p.value ttt <- 2*(predictMatrix[rows, cols]!=-1 & predictMatrix[rows, cols] < pred.p.value) ttt[ttt==0] <- 1 } # this temp. matrix can now multiplied to the adjMatrix adjMatrix[rows, cols] <- adjMatrix[rows, cols] * ttt # filter out miRNAs and genes with no connections adjMatrix <- adjMatrix[rowSums(adjMatrix!=0)>0, colSums(adjMatrix!=0)>0] cat("Dimension: ", nrow(adjMatrix), "x", ncol(adjMatrix), "\n", sep="") cat("No. of -2:",sum(adjMatrix==-2),"\n") cat("No. of -1:",sum(adjMatrix==-1),"\n") cat("No. of 0:",sum(adjMatrix==0),"\n") cat("No. of 1:",sum(adjMatrix==1),"\n") cat("No. of 2:",sum(adjMatrix==2),"\n\n") # return the result return(adjMatrix) } else if(mode=="pvalue") { # if a bound for the p value of the correlation is given, just have p values below this in the list if(!is.null(cor.p.value)) { if(strict) { # if strict # create the adjacency matrix using only miRNAs and genes # present in the correlation matrix as well as in the prediction matrix rows <- intersect(rownames(correlationElement$pcors), rownames(predictMatrix)) cols <- intersect(colnames(correlationElement$pcors), colnames(predictMatrix)) # create matrix with dimensiosn of the intersection rows and cols adjMatrix <- matrix(NA, nrow=length(rows), ncol=length(cols)) rownames(adjMatrix) <- rows colnames(adjMatrix) <- cols # adapt correlation matrices cors <- correlationElement$cors[rows, cols] pcors <- correlationElement$pcors[rows, cols] # fill the adjacency matrix adjMatrix[pcors < cor.p.value] <- pcors[pcors < cor.p.value] * sign(cors[pcors < cor.p.value]) # now fill the NAs with 1, so a good pvalue in the prediction might good adjMatrix[is.na(adjMatrix)] <- 1 } else { # if non strict use all elements from the correlation matrices # regardless if they are present in the prediction matrix # create the adjacency matrix of NAs with the same dimensions as the correlation matrices adjMatrix <- matrix(NA, nrow=nrow(correlationElement$pcors), ncol=ncol(correlationElement$pcors)) rownames(adjMatrix) <- rownames(correlationElement$pcors) colnames(adjMatrix) <- colnames(correlationElement$pcors) # fill the adjacency matrix adjMatrix[correlationElement$pcors < cor.p.value] <- correlationElement$pcors[correlationElement$pcors < cor.p.value] * sign(correlationElement$cors[correlationElement$pcors < cor.p.value]) # now fill the NAs with 1, so a good pvalue in the prediction might good adjMatrix[is.na(adjMatrix)] <- 1 } } else { # if no cor.p.value is given all pvalues from the correlations are used if(strict) { # if strict use only the intersecting rows and cols of the correlation and prediction matrix rows <- intersect(rownames(correlationElement$pcors), rownames(predictMatrix)) cols <- intersect(colnames(correlationElement$pcors), colnames(predictMatrix)) # fill adjacency matrix adjMatrix <- correlationElement$pcors[rows, cols] * sign(correlationElement$cors[rows, cols]) } else { # if no p value is given all correlations are taken adjMatrix <- correlationElement$pcors * sign(correlationElement$cors) } } # find the intersect to the prediction matrix rows <- intersect(rownames(adjMatrix), rownames(predictMatrix)) cols <- intersect(colnames(adjMatrix), colnames(predictMatrix)) cat("Common rows: ", length(rows), "/", nrow(adjMatrix),"\n", sep="") cat("Common cols: ", length(cols), "/", ncol(adjMatrix),"\n\n", sep="") # if no p value for the prediction is fiven take all if (is.null(pred.p.value)) { # take the intersect with the correlations ttt <- predictMatrix[rows, cols] # -1 indicates that the interaction wasn't found in miRBase # turn this into one, so nothing changes for multiplication, # for stouffer methods it indicates a pvalue of one ttt[ttt==-1] <- 1 } else { ttt <- predictMatrix[rows, cols] # nopw set all entries meeting both criteria to 1 ttt[ttt==-1 | ttt >= pred.p.value] <- 1 } # now combine the pValues of both sources if(is.null(combFunction)) { # in case no combination function is given just multiply the pValues adjMatrix[rows, cols] <- adjMatrix[rows, cols] * ttt } else { #use the combination function adjMatrix[rows, cols] <- combFunction(as.numeric(adjMatrix[rows, cols]), as.numeric(ttt)) } # filter out miRNAs and genes with no connections adjMatrix <- adjMatrix[rowSums(adjMatrix!=1 | is.na(adjMatrix))>0, colSums(adjMatrix!=1 | is.na(adjMatrix))>0] # return the result return(adjMatrix) } } #' #' predictTable2Matrix #' helper function to transform a table with miRNAs and predicted targets to a matrix structure #' Thereby the gene column will become the rows, the mirna column the columns, and the pvalue column the entries #' #' @param predictTable: the predictions ion table format #' @param geneColumn: the name of the columns with the gene identifiers #' @param miRNAColumn: the name of the column with the miRNA identifiers #' @param valColumn: the name of the column containing the values used in the matrix (e.g. pvalue or score of the prediction) #' @param sep: a seperator used during the transformation, must not be contained in the identiefiers #' @param combFunction function to used when there are several binding sites of one miRNA to one gene with different p-values, default to min #' @return: the predictions in matrix format, rows are genes, columns are miRNAs #' predictTable2Matrix <- function(predictTable, geneColumn="gene", miRNAColumn="mirna", valColumn="pvalue", sep="@", combFunction=min) { # get the entries for the genes and the miRNAs genes <- as.character(predictTable[,geneColumn]) miRNAs <- as.character(predictTable[,miRNAColumn]) # check for NAs if(any(is.na(genes))) { stop("Some of the genes are NA. This shouldn't happen.") } if(any(is.na(miRNAs))) { stop("Some of the miRNAs are NA. This shouldn't happen.") } # create a matrix predMatrix <- matrix(-1, nrow=length(unique(genes)), ncol=length(unique(miRNAs))) rownames(predMatrix) <- unique(genes) colnames(predMatrix) <- unique(miRNAs) # take care of multiple entries mirna, gene with different pValues # at first check for multiple entries if (nrow(unique(predictTable[,c(miRNAColumn, geneColumn)])) != nrow(predictTable)) { # use @ as a the default seperator, this should not be used in gene names index <- paste(predictTable[,miRNAColumn], predictTable[,geneColumn], sep=sep) ttt <- tapply(predictTable[,valColumn], factor(index, levels=unique(index)), combFunction) # get the names back and split it tt <- strsplit(names(ttt), sep) mirna <- as.character(unlist(lapply(tt, function(xx) xx[[1]]))) gene <- as.character(unlist(lapply(tt, function(xx) xx[[2]]))) val <- unlist(ttt) predictTable <- data.frame(mirna, gene, val) colnames(predictTable) <- c(miRNAColumn, geneColumn, valColumn) } # fill matrix rows <- match(predictTable[,geneColumn], rownames(predMatrix), nomatch=0) cols <- match(predictTable[,miRNAColumn], colnames(predMatrix), nomatch=0) predMatrix[cbind(rows, cols)] <- predictTable[,valColumn] # return the matrix return(predMatrix) } #' #' function to create the difference #' matrices tumor-normal and normal-tumor #' that is only edged in the graph that #' can bee observed only in tumor or normal #' buildDiffMatrix <- function(adjMatrices, source1, source2, target1, target2) { if(!all(c(source1, source2) %in% names(adjMatrices))) { stop("Not all source matrices are in the list!") } cat("Build the difference matrices ...\n") # get the adjacency matrices adjMatrixS1 <- adjMatrices[[source1]] adjMatrixS2 <- adjMatrices[[source2]] # find common genes and miRNAs in both matrices # only theses rows and columns can be compared # and are of interest cols <- intersect(colnames(adjMatrixS1), colnames(adjMatrixS2)) rows <- intersect(rownames(adjMatrixS1), rownames(adjMatrixS2)) # use the selected rows and columns to extract the sub-matrices # from s1 and s2 s1Intersect <- adjMatrixS1[rows, cols] s2Intersect <- adjMatrixS2[rows, cols] # get these entries which are equal in both sub-matrices index <- s1Intersect==s2Intersect # set these entries to zero in both matrices # NOTE: 2 in one matrix and 1 in the other (same with -2 and -1) cannot happen # now we have only entries != 0 which are unique in tumor and mucosa s1Intersect[index] <- 0 s2Intersect[index] <- 0 # build a matrix tumorOnly from the original adjacency matrix # containing the sub-matrix with entries 0 where it was equal # to the mucosa sub matrix adjMatrixT1 <- adjMatrixS1 adjMatrixT1[rows, cols] <- s1Intersect # contruct the new matrix mucosaOnly the very same way we did for # tumorOnly adjMatrixT2 <- adjMatrixS2 adjMatrixT2[rows, cols] <- s2Intersect # check if there is any connection left in both matrices if (any(adjMatrixT1!=0)) { # filter out miRNAs and genes which have no connections any more adjMatrixT1 <- adjMatrixT1[rowSums(adjMatrixT1!=0)>0,] adjMatrixT1 <- adjMatrixT1[,colSums(adjMatrixT1!=0)>0] if(!any(adjMatrixT1)){ adjMatrixT1 <- NULL } } else { adjMatrixT1 <- NULL } # check if there is any connection left in both matrices if (any(adjMatrixT2!=0)) { # filter out miRNAs and genes which have no connections any more adjMatrixT2 <- adjMatrixT2[rowSums(adjMatrixT2!=0)>0,] adjMatrixT2 <- adjMatrixT2[,colSums(adjMatrixT2!=0)>0] if(!any(adjMatrixT2)){ adjMatrixT2 <- NULL } } else { adjMatrixT2 <- NULL } # now we have two adjancency matrices containing entries # which are not present in the opposite group adjMatrices[[target1]] <- adjMatrixT1 adjMatrices[[target2]] <- adjMatrixT2 cat("Done!\n\n") return(adjMatrices) } #' #' BuildCommonMatrix #' #' function which finds entries in two adjacency matrices which are common #' and build a new adjacency matrix with only these entries #' BuildCommonMatrix <- function(adj.matrices, source1, source2, target) { if(!all(c(source1, source2) %in% names(adj.matrices))) { stop("Not all source matrices are in the list!") } cat("Build the common matrix", target, "...\n") # get the adjacency matrices s1 <- adj.matrices[[source1]] s2 <- adj.matrices[[source2]] # find common genes and miRNAs in both matrices # only theses rows and columns can be compared # and are of interest cols <- intersect(colnames(s1), colnames(s2)) rows <- intersect(rownames(s1), rownames(s2)) # use the selected rows and columns to extract the sub-matrices # from s1 and s2 s1.intersect <- s1[rows, cols] s2.intersect <- s2[rows, cols] # get these entries which are equal in both sub-matrices index <- s1.intersect==s2.intersect # set all other entries in s1.intersect to zero # after that s1.intersect holds only values common in both matrices s1.intersect[!index] <- 0 # check if there is any connection left if (any(s1.intersect!=0)) { # filter out miRNAs and genes which have no connections any more s1.intersect <- s1.intersect[rowSums(s1.intersect!=0)>0,] s1.intersect <- s1.intersect[,colSums(s1.intersect!=0)>0] if(!any(s1.intersect)){ s1.intersect <- NULL } } else { s1.intersect <- NULL } # now we have one adjancency matrices containing entries # common on both groups adj.matrices[[target]] <- s1.intersect cat("Done!\n\n") return(adj.matrices) } #' #' compute the correlation of the rows! #' of two matrices, therefore the number of cols #' have to be equal #' multi.cor.test <- function(matrix1, matrix2, alternative="two.sided", p.adjust="BH") { df=ncol(matrix1)-2 if(df+2 != ncol(matrix2)) stop("Matrices need to have same number of columns") cors=cor(t(matrix2), t(matrix1)) pcors=pt(sqrt(df) * cors / sqrt(1 - cors^2), df) pcors = switch(alternative, "less" = pcors, "greater" = 1 - pcors, "two.sided" = 2 * pmin(pcors, 1 - pcors)) pcors = matrix(p.adjust(pcors, method=p.adjust), ncol=ncol(pcors)) return(list(cors=cors, pcors=pcors)) } #' #' calcCoxBoostError #' #' @param time the time vector of the events #' @param status the vector indicating the event status. 1 means a tru event, 0 means censoring #' @param exps the expression matrix, columns are samples, rows are features #' @param n.samples the number of samples used for error estimation #' @param sample.method the method used for sampling #' @param sample.indices a list with samople indiced in case sample.method is "manual" #' @param cv.steps the number of steps for the inner CV used to determine M #' @param either F for no parallel excution or a number > 1 indicating the number of cpus used for parallel execution #' @param seed the seed used for random number generator (e.g. for sampling) #' @param title an optional title used in the diagnostic perr plots #' @param penalty the penalty used for the classifier #' @param pendistmat an optional matrix describing the connections of the features #' @param pred.mat an optinal matrix with target predictions used to build the pendistmat in every sample (avoids overfitting) #' @param mirna.index describes the row index of the first miRNA in the expression matrix assuming 1->index-1 are genes and index->nrow(exps) are miRNAs. Only needed if pred.mat is given and CalcCoxBoostError <- function(time, status, exps, n.samples=5, sample.method="cv", sample.indices=NULL, cv.steps=5, parallel=F, seed=321, title=NULL, penalty, pendistmat=NULL, pred.matrix=NULL, mirna.index=NULL, adj.direction=NULL, ...) { stopifnot(require(peperr)) if(!parallel || parallel==1) { parallel <- F cpus <- 1 } else { cpus <- parallel parallel <- T } # change stepsize.factor for Coxboost if pendistmat is given if(!is.null(pendistmat)) { fit.fun=fit.CoxBoost args.fit=c(list(penalty=penalty, pendistmat=pendistmat, stepsize.factor=0.9), list(...)) complexity=complexity.mincv.CoxBoost args.complexity=list(penalty=penalty,K=cv.steps, pendistmat=pendistmat, stepsize.factor=0.9) load.list = extract.fun(list(fit.CoxBoost, complexity.mincv.CoxBoost)) cat("using coxboost with pendistmat and stepsize 0.9\n") } else if (!is.null(pred.matrix)) { fit.fun=FitCoxBoost args.fit=c(list(penalty=penalty, index=mirna.index, pred.matrix=pred.matrix, adj.direction=adj.direction, stepsize.factor=0.9), list(...)) complexity=CVCoxBoost args.complexity=list(penalty=penalty,K=cv.steps, index=mirna.index, pred.matrix=pred.matrix, adj.direction=adj.direction, stepsize.factor=0.9) load.list = extract.fun(list(FitCoxBoost, CVCoxBoost, multi.cor.test, CreateGraphMatrix, combMatrices)) cat("using coxboost with prediction matrix and stepsize 0.9\n") } else { fit.fun=fit.CoxBoost args.fit=c(list(penalty=penalty), list(...)) complexity=complexity.mincv.CoxBoost args.complexity=list(penalty=penalty,K=cv.steps) load.list = extract.fun(list(fit.CoxBoost, complexity.mincv.CoxBoost)) } # set argument indices if sample.indices are given if(sample.method=="manual" && !is.null(sample.indices)) { indices <- sample.indices cat("Using predifined samples.\n") } else { indices <- resample.indices(n=length(time), method=sample.method, sample.n=n.samples) cat("Using", sample.method, "with", n.samples, "samples.\n") } # compute the peperr object peperr.object <- peperr(response=Surv(time, status), x=t(exps), fit.fun=fit.fun, args.fit=args.fit, complexity=complexity, args.complexity=args.complexity, indices=indices, trace=TRUE, debug=FALSE, parallel=parallel, cpus=cpus, load.list=load.list, seed=seed) if(!is.null(title)) { main <- c(title, paste("Boosting steps:",peperr.object$selected.complexity)) } else { main <- paste("Boosting steps:",peperr.object$selected.complexity) } # Diagnostic plots plot(peperr.object$attribute, perr(peperr.object)[1,], type="l", col="blue", xlab="Evaluation time points", ylab="Prediction error",main=main) return(peperr.object) } #' #' FeatureFit #' #' fits a CoxBoost Model with a given penalty and stepno to get a list of features important for prediction #' FeatureFit <- function(time, status, exps, adj.matrix=NULL, penalty, stepno, mapping=NULL, ...) { stopifnot(require(CoxBoost)) # set stepsize.factor if an graph matrix is given if(!is.null(adj.matrix)) { stepsize.factor <- 0.9 } else { stepsize.factor <- 1 } # fit the model with the optimal number of boosting steps coxboost.fit <- CoxBoost(time=time, status=status, x=t(exps), pendistmat=adj.matrix, penalty=penalty, stepno=stepno, stepsize.factor=stepsize.factor, ...) # extract the features features <- coxboost.fit$xnames[coxboost.fit$coefficients[coxboost.fit$stepno+1,]!=0] # assemble the features to a data frame and add Gene Symbols for teh genes if a mapping is given if(!is.null(mapping)) { m <- match(features,mapping[,1]) genes <- mapping[m,2] genes[is.na(m)] <- features[is.na(m)] #features <- genes } else{ genes <- features } feature.data.frame <- data.frame(id=features, name=genes, coefficient=coxboost.fit$coefficients[coxboost.fit$stepno+1,coxboost.fit$coefficients[coxboost.fit$stepno+1,]!=0]) # return the results return(list(fit=coxboost.fit, features=feature.data.frame)) } #' #' ErrorFit #' #' evaluates the errors for a CoxBoost setting #' uses function CalcBoostError #' ErrorFit <- function(time, status, exps, adj.matrix=NULL, runs=10, seed1, seed2, cpus=5, ...) { if(CheckSeeds(seed1, seed2, runs)) { stop("Seed vectors a smaller than the number of runs!") } # create a vector to hold the fits err <- vector("list", runs) # start fitting for (i in 1:runs) { # get the prediction error set.seed(seed2[i]) err[[i]] <- CalcCoxBoostError(time=time, status=status, exps=exps, pendistmat=adj.matrix, seed=seed2[i], parallel=cpus, ...) } # return result return(err) } #' #' CheckSeeds #' #' helper function to check the length of both seed vectors (the vectors holding the seeds for the random number generator) #' CheckSeeds <- function(seed1, seed2, runs) { return(length(seed1) < runs || length(seed2) < runs) } #' #' CreateSeeds #' #' helper function to create seed vectors of a given length CreateSeeds <- function(runs=100) { # create vectors seed1 <- round(runif(runs, max=1000)) seed2 <- round(runif(runs, max=1000)) # return result return(list(seed1=seed1, seed2=seed2)) } #' #' GetOptimalPenalty #' #' computes the optimal penalty and step number for a given CoxBoost setting #' GetOptimalPenalty <- function(time, status, exps, adj.matrix=NULL,minstepno=100, cpus=3, ...) { require(CoxBoost) # set stepsize.factor if an graph matrix is given if(!is.null(adj.matrix)) { stepsize.factor <- 0.9 } else { stepsize.factor <- 1 } # finds optimal penalty and stepno coxboost.cv <- optimCoxBoostPenalty(time=time,status=status,x=t(exps), minstepno=minstepno, trace=TRUE, multicore=cpus, pendistmat=adj.matrix, stepsize.factor=stepsize.factor, ...) penalty <- coxboost.cv$penalty stepno <- coxboost.cv$cv.res$optimal.step # return results return(list(penalty=penalty, stepno=stepno)) } #' #' GetOptimalStepno #' #' computes the optimal number of boosting steps for a given penalty and CoxBoost setting #' GetOptimalStepno <- function(time, status, exps, adj.matrix=NULL, penalty, cpus=3, ...) { # set stepsize.factor if an graph matrix is given if(!is.null(adj.matrix)) { stepsize.factor <- 0.9 } else { stepsize.factor <- 1 } # use cv.CoxBoost to get the optimal number of boosting steps coxboost.cv <- cv.CoxBoost(time=time, status=status, x=t(exps), trace=T, multicore=cpus, penalty=penalty, pendistmat=adj.matrix, stepsize.factor=stepsize.factor, ...) stepno <- coxboost.cv$optimal.step # return result return(stepno) } #' #' restrictFeatures #' #' restrict the features in the expressionMatrix1 and expressionMatrix2 by the features used in the rows and cols #' of the adjacency matrix #' restrictFeatures <- function(adjMatrix, expressionMatrix1, expressionMatrix2) { feat1 <- rownames(adjMatrix) feat2 <- colnames(adjMatrix) m <- match(feat1, rownames(expressionMatrix1), nomatch=0) if(all(m==0)) { error("Features in adjacency matrix cannot be found in expression matrix 1!") } expressionMatrix1 <- expressionMatrix1[m,] m <- match(feat2, rownames(expressionMatrix2), nomatch=0) if(all(m==0)) { error("Features in adjacency matrix cannot be found in expression matrix 2!") } expressionMatrix2 <- expressionMatrix2[m,] # combine expression matrices colNames <- intersect(colnames(expressionMatrix1), colnames(expressionMatrix2)) if(length(colNames)==0) { error("Both expression matrices have no samples in common!") } exps <- rbind(expressionMatrix1[,colNames], expressionMatrix2[,colNames]) # return the combined expression matrix return(exps) } #' #' filterAjacencyMatrix #' filterAdjacencyMatrix <- function(adjMatrix, pValue=0.05) { rows <- rowSums(adjMatrix < pValue) > 0 adjMatrix <- adjMatrix[rows,] cols <- colSums(adjMatrix < pValue) >0 adjMatrix <- adjMatrix[cols,] return(adjMatrix) } #' #' Helper function creatig #' CreateSampleIndices <- function(samples, status) { sample.indices <- list() sample.indices[["sample.index"]] <- samples sample.indices[["not.in.sample"]] <- lapply(samples, function(xx) setdiff(1:length(status), xx)) return(sample.indices) } #' #' Compute the 632 estimator from single bootsrap runs #' CalcErrorEstimator <- function(err, error.type="632") { if(is.list(err)) { # get infiormation about the number of samplings (bootstrap or cv) # the number of time points # number of samples and time points is similar for all elements of the error list n.samples <- length(err[[1]]$sample.error) time.points <- err[[1]]$attribute # choose the first full apparent error, it is dependent from the complexity value (e.g. number of steps) which changes from run to run, therefore take the first entry in the list full.apparent <- err[[1]]$full.apparent # extract sample error an create a matrix from it # ncol: n.samples*runs # nrow: number of time points sample.error <- matrix(unlist(lapply(err, "[[", "sample.error")), nrow=length(time.points), ncol=n.samples*length(err)) } else if (inherits(err, "peperr")) { # get infiormation about the number of samplings (bootstrap or cv) # the number of time points n.samples <- length(err$sample.error) time.points <- err$attribute # get errors full.apparent <- err$full.apparent sample.error <- matrix(unlist(err$sample.error), nrow=length(time.points), ncol=n.samples) } # calculate the prediction error if (error.type=="632") { prediction.error <- .632*sample.error+.368*as.numeric(full.apparent) } else { return(NULL) } # return result return(prediction.error) } #' #' small helper function to extract the points from a list or a single peperr object #' ExtractTimePoints <- function(err, name="attribute") { if(inherits(err, "peperr")) { return(err[[name]]) } else if (is.list(err)) { return(err[[1]][[name]]) } } #' #' Function to compute IPEC #' CalcIPEC <- function(err, ...) { # requires peperr, for the ipec function require(peperr) # calculate the 632 estimation of the prediction error curve prederr <- CalcErrorEstimator(err, ...) # calculate ipec and return return(ipec(t(prederr), eval.times=ExtractTimePoints(err))) } #' #' Helper Function to create the adjacency matrix of the bipartite graph #' CreateGraphMatrix <- function(mirna.exp, gene.exp, pred.matrix, direction) { # requires Matrix package stopifnot(require(Matrix)) # get correlations cor.matrix <- multi.cor.test(mirna.exp, gene.exp) # combine correlations and predictions adj.matrix <- abs(combMatrices(cor.matrix, pred.matrix, mode="pvalue", cor.p.value=NULL, pred.p.value=NULL, combFunction=stoufferCombineVectorized)) # build graph matrix adj.matrix <- Matrix(1-adj.matrix, sparse=T) adj.matrix <- completeMatrix(adj.matrix, zeroElement=0, direction=direction) # return final matrix return(adj.matrix) } #' #' New fit function for CoxBoost for use in peperr #' calculates the correlations and adj matrix new for every bootstrap sample to avoid overfitting #' #' @param response the response, in this case a Surv object (time and status) #' @param x the covariate matrix, rows are samples, columns features #' @param index the index of the first miRNA in x (needed to separate both matrices) #' @param pred.matrix the target predictions #' @param adj.direction the type of direction the adjacency matrix is built #' @param stepsize.factor teh stepsize factor used in CoxBoost #' @param ... further arguments to CoxBoost #' FitCoxBoost <- function(response, x, cplx, index, pred.matrix, adj.direction, stepsize.factor=0.9, ...){ require(CoxBoost) require(Matrix) # get time and status time <- response[,"time"] status <- response[,"status"] # get expression matrices gene.exp <- t(x[,1:(index-1)]) mirna.exp <- t(x[,index:ncol(x)]) # combine with stouffer and create cat("FitCoxBoost: Creating Graph ... \n") adj.matrix <- CreateGraphMatrix(mirna.exp, gene.exp, pred.matrix, adj.direction) cat("FitCoxBoost: finished Graph ... \n") # do the actual fit cat("FitCoxBoost: Getting fit ... \n") res <- CoxBoost(time, status, x, stepno=cplx, pendistmat=adj.matrix, stepsize.factor=stepsize.factor, ...) cat("FitCoxBoost: finished!\n\n") # return the fit return(res) } #' #' CoxIntegrate #' #' fit function for the coxboost algorthm, that computes the bipartite graph #' CVCoxBoost <- function(response, x, full.data, index, pred.matrix, adj.direction, stepsize.factor=0.9, ...) { # load CoxBoost package require(CoxBoost) # get the response time <- response[,"time"] status <- response[,"status"] # get expression matrices gene.exp <- t(x[,1:(index-1)]) mirna.exp <- t(x[,index:ncol(x)]) # get graph matrix cat("CVCoxBoost: Creating Graph ... \n") adj.matrix <- CreateGraphMatrix(mirna.exp, gene.exp, pred.matrix, adj.direction) cat("CVCoxBoost: finished Graph ... \n") # do the inner CV cat("CVCoxBoost: Get optimal step number ... \n") cv.res <- cv.CoxBoost(time=time, status=status, x=x, pendistmat=adj.matrix, stepsize.factor=stepsize.factor, trace=T, ...) cat("CVCoxBoost: finished!\n\n") # retrieve and return the optimal number of steps min.cv <- cv.res$optimal.step return(min.cv) } #' #' function to create an adjacency list based on an adjacency matrix, correlations and predictions #' @param adjMatrix the adjacency matrix containing the mapping miRNA <-> gene #' @param corMatrix #' createAdjList <- function(adjMatrix, corMatrix=NULL, pcorMatrix=NULL, predMatrix=NULL, geneMapping=NULL, idColumn="transcriptClusterID", geneSymbolColumn="geneSymbol") { # create initial list from the adjacency matrix adjacencyList = data.frame(miRNA=rep(colnames(adjMatrix), each=nrow(adjMatrix)), genes=rep(rownames(adjMatrix), times=ncol(adjMatrix))) # add the values from the adjMatrix adjacencyList <- cbind(adjacencyList, data.frame(interactionType=as.integer(adjMatrix))) # add the information from the cor matrix if(!is.null(corMatrix)) { # match the colnames(miRNA) of the adjacency matrix against the correlation matrix, get cols <- match(colnames(adjMatrix), colnames(corMatrix), nomatch=0) rows <- match(rownames(adjMatrix), rownames(corMatrix), nomatch=0) # check for missing miRNAs and genes if(any(c(cols, rows)==0)) { stop("Not all miRNA or genes in the adjMatrix can be found in the cor/pcor matrix!") } # subset the cor matrix corMatrix <- corMatrix[rows, cols] # add the correlations dim(corMatrix) <- NULL adjacencyList <- cbind(adjacencyList, data.frame(correlations=corMatrix)) } # add the information from the pcor matrix if(!is.null(pcorMatrix)) { # match the colnames(miRNA) of the adjacency matrix against the correlation matrix, get cols <- match(colnames(adjMatrix), colnames(pcorMatrix), nomatch=0) rows <- match(rownames(adjMatrix), rownames(pcorMatrix), nomatch=0) # check for missing miRNAs and genes if(any(c(cols, rows)==0)) { stop("Not all miRNA or genes in the adjMatrix can be found in the pcor/pcor matrix!") } # subset the two matrices pcorMatrix <- pcorMatrix[rows, cols] # add the p values for the correlations dim(pcorMatrix) <- NULL adjacencyList <- cbind(adjacencyList, data.frame(pValueCorrelations=pcorMatrix)) } # do the same with the prediction matrix if(!is.null(predMatrix)) { # allow NAs in the match not every hit has to be in the prediction matrix cols <- match(colnames(adjMatrix), colnames(predMatrix)) rows <- match(rownames(adjMatrix), rownames(predMatrix)) # get the subset of the prediction matrix, introduce NA if nothing was found predMatrix <- predMatrix[rows, cols] # add the miRBase p values dim(predMatrix) <- NULL adjacencyList <- cbind(adjacencyList, data.frame(pValuePredictions=predMatrix)) } # add the gene symbols if (!is.null(geneMapping)) { # check for colnames if(!all(c(idColumn, geneSymbolColumn) %in% colnames(geneMapping))) { stop("The given 'idColumn' and/or 'geneSymbolColumn' is not in the gene mapping.'") } # match the native IDs to gene identifiers (e.g. gene symbols) m <- match(as.character(adjacencyList$genes), geneMapping[,idColumn]) # how many IDs couldn't be mapped if(any(is.na(m))) { cat(sum(is.na(m)),idColumn,"could not be associated to",geneSymbolColumn,". Introducing NAs.\n") } # complete adjacency list with gene identifiers adjacencyList <- cbind(adjacencyList, data.frame(geneSymbols=as.character(geneMapping[m,geneSymbolColumn]))) } # take out the 0 adjacencyList <- adjacencyList[adjacencyList[,"interactionType"]!=0,] return(adjacencyList) } #' #' complete adjacency matrix of a bipartite graph #' #' @param B matrix to be completed #' @param zeroElement which element to use as a 'zero' element, default to 1 #' @param direction should the matrix be build symmetric, if set to FALSE directected edges from rows to columns are assummed #' completeMatrix <- function(B, zeroElement=1, symmetric=T, direction=c("symmetric", "rows2cols", "cols2rows")) { # requires package Matrix stopifnot(require(Matrix)) # check direction arguments if(!all(direction %in% c("symmetric", "rows2cols", "cols2rows"))) { stop("Argument 'direction' must be either 'symmetric', 'rows2cols', or 'cols2rows'.") } # usually the matrix is build with direction rows -> cols # if otherwise we have to use the transpose from B if(direction=="cols2rows") { B <- t(B) } A <- Matrix(zeroElement, ncol=nrow(B), nrow=nrow(B)) A <- cBind(A, B) gc() if (direction=="symmetric") { A <- rBind(A, cBind(t(B), Matrix(zeroElement, ncol=ncol(B), nrow=ncol(B)))) } else { A <- rBind(A, Matrix(zeroElement, ncol=(ncol(B)+nrow(B)), nrow=ncol(B))) } gc() rownames(A) <- c(rownames(B), colnames(B)) colnames(A) <- c(rownames(B), colnames(B)) return(A) }