Multiwgcna playbase part

NAMESPACE

@@ -191,7 +191,6 @@ export(is_logged)
 export(isanumber)
 export(itercluster_louvain)
 export(justGSEA)
-export(labels2rainbow)
 export(lasagna.create_from_pgx)
 export(lasagna.create_model)
 export(lasagna.plot3D)
@@ -241,6 +240,7 @@ export(mofa.get_prefix)
 export(mofa.intNMF)
 export(mofa.log1s)
 export(mofa.merge_data)
+export(mofa.merge_data2)
 export(mofa.plot_all_factortraits)
 export(mofa.plot_biplot)
 export(mofa.plot_centrality)
@@ -563,23 +563,41 @@ export(validate_samples)
 export(visPrint)
 export(visplot.PCSF)
 export(wgcna.compute)
+export(wgcna.computeConsensusGeneStats)
+export(wgcna.computeConsensusMatrix)
+export(wgcna.computeDistinctMatrix)
+export(wgcna.compute_multiomics)
 export(wgcna.filterColors)
+export(wgcna.getConsensusGeneStats)
 export(wgcna.getGeneStats)
-export(wgcna.labels2colors)
+export(wgcna.getModuleCrossGenes)
+export(wgcna.plotConsensusOverlapHeatmap)
+export(wgcna.plotConsensusSampleDendroAndColors)
 export(wgcna.plotDendroAndColors)
+export(wgcna.plotDendroAndTraitCorrelation)
+export(wgcna.plotDendroAndTraitCorrelation_multi)
 export(wgcna.plotEigenGeneAdjacencyHeatmap)
 export(wgcna.plotEigenGeneClusterDendrogram)
 export(wgcna.plotEigenGeneGraph)
 export(wgcna.plotFeatureUMAP)
+export(wgcna.plotGeneNetwork)
 export(wgcna.plotLabeledCorrelationHeatmap)
 export(wgcna.plotMDS)
 export(wgcna.plotMMvsGS)
+export(wgcna.plotModuleHeatmap)
 export(wgcna.plotModuleHubGenes)
 export(wgcna.plotModuleSignificance)
 export(wgcna.plotModuleTraitHeatmap)
+export(wgcna.plotMultiEigengeneCorrelation)
+export(wgcna.plotPowerAnalysis)
+export(wgcna.plotPowerAnalysis_multi)
+export(wgcna.plotPreservationModuleTraits)
+export(wgcna.plotPreservationSummaries)
 export(wgcna.plotSampleDendroAndColors)
 export(wgcna.plotTOM)
+export(wgcna.plotTopModules)
 export(wgcna.runConsensusWGCNA)
+export(wgcna.runPreservationWGCNA)
 export(wikipathview)
 export(wrapHyperLink)
 export(write.gmt)

R/gset-fisher.r

@@ -104,7 +104,8 @@ gset.fisher2 <- function(genes.up, genes.dn, genesets, background = NULL,
 gset.fisher <- function(genes, genesets, background = NULL,
                         fdr = 0.05, mc = TRUE, sort.by = "zratio", nmin = 3,
                         min.genes = 15, max.genes = 500, method = "fast.fisher",
-                        check.background = TRUE, common.genes = TRUE, verbose = 1) {
+                        check.background = TRUE, common.genes = TRUE,
+                        no.pass=NA, verbose = 1) {
   if (is.null(background)) {
     background <- unique(unlist(genesets))
     if (verbose > 0) {
@@ -221,6 +222,11 @@ gset.fisher <- function(genes, genesets, background = NULL,
     stop("unknown method")
   }
 
+  ## replace NA values
+  if(any(is.na(pv))) {
+    pv[is.na(pv)] <- no.pass
+  }
+
   ## compute q-value
   qv <- rep(NA, length(pv))
   qv <- stats::p.adjust(pv, method = "fdr")

R/pgx-annot.R

@@ -1194,25 +1194,40 @@ getHumanOrtholog.biomart <- function(organism, symbols, verbose = 1) {
 #' }
 #' @import data.table
 #' @export
-probe2symbol <- function(probes, annot_table, query = c("symbol", "gene_name"),
+probe2symbol <- function(probes, annot_table, query = "symbol", 
                          key = NULL, fill_na = FALSE) {
-  # Prepare inputs
+
+  # Prepare inputs. add extra matching columns.
   annot_table <- cbind(rownames = rownames(annot_table), annot_table)
+  id.cols <- intersect(c("feature","gene_name","symbol"),colnames(annot_table))
+  if(length(id.cols)>0) {
+    stripped_annot <- apply(annot_table[,id.cols,drop=FALSE],2,function(a) sub("^[A-Za-z]+:","",a))
+    ##colnames(stripped_annot) <- paste0(colnames(stripped_annot),"_stripped")
+    annot_table <- cbind(annot_table, stripped_annot)
+  }
+
   probes1 <- setdiff(probes, c(NA, ""))
   if (is.null(key) || !key %in% colnames(annot_table)) {
     key <- which.max(apply(annot_table, 2, function(a) sum(probes1 %in% a)))
   }
   if (is.null(key)) {
-    stop("[probe2symbol] FATAL. could not get key column.")
+    message("[probe2symbol] FATAL. could not get key column.")
+    return(NULL)
   }
 
-  # match query
-  ii <- match(probes, annot_table[, key])
-  query <- intersect(query, colnames(annot_table))
+  query <- head(intersect(query, colnames(annot_table)),1)
   if (length(query) == 0) {
-    stop("ERROR. no symbol column.")
+    message("ERROR. no symbol column.")
+    return(NULL)
   }
-  query_col <- annot_table[ii, query[1]]
+
+  # fall back on old gene_name
+  if(query=="symbol" && !"symbol" %in% colnames(annot_table) &&
+       "gene_name" %in% colnames(annot_table)) query <- "gene_name"
+
+  # match query
+  ii <- match(probes, annot_table[, key])
+  query_col <- annot_table[ii, query]
 
   # Deal with NA
   if (fill_na) {

R/pgx-deconv.R

@@ -500,7 +500,6 @@ pgx.deconvolution <- function(X, ref,
     dbg("WARNING:: pgx.deconvolution: is X really counts? (not logarithmic)\n")
   }
 
-
   ## clean up matrix, remove duplicate names
   mat <- as.matrix(X)
   rownames(mat) <- gsub(".*:", "", rownames(mat)) ## strip prefix
@@ -565,12 +564,14 @@ pgx.deconvolution <- function(X, ref,
       source(CIBERSORT.code)
       stime <- system.time(
         # The f CIBERSORT is likely from CIBERSORT package but better confirm
-        ##        try(ciber.out <- CIBERSORT(ref, mat, perm = 0, QN = FALSE))
+        ## try(ciber.out <- CIBERSORT(ref, mat, perm = 0, QN = FALSE))
+        NULL
       )
     }
     if (has.ciber2) {
       stime <- system.time(
-        ##        try(ciber.out <- CIBERSORT::cibersort(ref, mat, perm = 0, QN = FALSE))
+        ## try(ciber.out <- CIBERSORT::cibersort(ref, mat, perm = 0, QN = FALSE))
+        NULL
       )
     }
     if (!is.null(ciber.out)) {

R/pgx-functions.R

@@ -436,7 +436,7 @@ rowmean <- function(X, group = rownames(X), reorder = TRUE) {
   } else {
     ## slower but safer. also for sparse matrix.
     newX <- tapply(1:nrow(X), group, function(i) {
-      Matrix::colMeans(X[i, , drop = FALSE], na.rm = TRUE)
+      Matrix::colMeans(X[i, ,drop = FALSE], na.rm = TRUE)
     })
     newX <- do.call(rbind, newX)
     if (reorder) {
@@ -1483,6 +1483,9 @@ filterProbes <- function(annot, genes) {
 #' @export
 rename_by2 <- function(counts, annot_table, new_id = "symbol",
                        na.rm = TRUE, unique = TRUE, keep.prefix = FALSE) {
+
+  ##new_id="symbol";na.rm=TRUE;unique=TRUE;keep.prefix=FALSE
+
   ## add rownames
   annot_table$rownames <- rownames(annot_table)
   annot_table$rownames2 <- sub("^[A-Za-z]+:", "", rownames(annot_table)) ## strip prefix
@@ -1509,6 +1512,9 @@ rename_by2 <- function(counts, annot_table, new_id = "symbol",
   from_id <- names(which.max(probe_match))
   from_id
 
+  if(new_id=="symbol" && !"symbol" %in% colnames(annot_table) &&
+    "gene_name" %in% colnames(annot_table)) new_id <- "gene_name"
+
   ## dummy do-noting return
   if (new_id == from_id) {
     sel <- which(probes %in% annot_table[,from_id])
@@ -1524,39 +1530,31 @@ rename_by2 <- function(counts, annot_table, new_id = "symbol",
   keep.prefix <- (keep.prefix && all(grepl(":", probes)))
 
   from <- annot_table[, from_id]
-  if (!any(duplicated(from)) || unique) {
-    ii <- match(probes, from)
-    if (keep.prefix) {
-      dt <- mofa.get_prefix(probes)
-      new.name <- annot_table[ii, new_id]
-      new.name <- paste0(dt, ":", new.name)
-    } else {
-      new.name <- annot_table[ii, new_id]
-    }
+  ##  if (!any(duplicated(from)) || unique) {
+  ii <- match(probes, from)
+  if (keep.prefix) {
+    dt <- mofa.get_prefix(probes)
+    new.name <- annot_table[ii, new_id]
+    new.name <- paste0(dt, ":", new.name)
   } else {
-    ## map probes to 'from' vector but retains duplicated entries in
-    ## 'from'
-    to <- lapply(probes, function(p) which(from == p))
-    ii <- lapply(1:length(to), function(i) rep(i, length(to[[i]])))
-    counts <- counts[unlist(ii), , drop = FALSE]
-    if (keep.prefix) {
-      dt <- mofa.get_prefix(unlist(to))
-      new.name <- annot_table[unlist(to), new_id]
-      new.name <- paste0(dt, ":", new.name)
-    } else {
-      new.name <- annot_table[unlist(to), new_id]
-    }
+    new.name <- annot_table[ii, new_id]
   }
   rownames(counts) <- new.name
 
-  # Take out rows without name
+  # Remove rows with missing name
   if (na.rm) {
     counts <- counts[!rownames(counts) %in% c("", "NA", NA), , drop = FALSE]
   }
-  # Sum columns of rows with the same gene symbol
-  ##  if (unique) rownames(counts) <- make_unique(rownames(counts))
-  if (unique) {
-    counts <- rowmean(counts, rownames(counts))
+
+  # Average columns of rows with the same gene symbol
+  ndup <- sum(duplicated(rownames(counts)))
+  if (unique && ndup>0) {
+    rowdup <- rownames(counts)[which(duplicated(rownames(counts)))]
+    ii <- which( rownames(counts) %in% rowdup )
+    nodup.counts <- rowmean(counts[ii,,drop = FALSE], rownames(counts)[ii])
+    rown <- unique(rownames(counts))
+    counts <- rbind( counts[-ii,,drop=FALSE], nodup.counts )
+    counts <- counts[rown,] 
   }
 
   if (type == "vector") {
@@ -1575,6 +1573,9 @@ rename_by <- function(counts, annot_table, new_id = "symbol", unique = TRUE) {
   if (is.vector(counts)) {
     probes <- names(counts)
   }
+
+  if(new_id=="symbol" && !"symbol" %in% colnames(annot_table) &&
+    "gene_name" %in% colnames(annot_table)) new_id <- "gene_name"
   symbol <- annot_table[probes, new_id]
 
   # Guard against NA
@@ -2329,6 +2330,29 @@ expandPhenoMatrix <- function(M, drop.ref = TRUE, keep.numeric = FALSE, check =
 }
 
 
+#' Collapses an expanded (binarized) trait matrix to its original
+#' categorical phenotype with levels. Colnames must be "pheno1=A",
+#' "pheno1=B" etc.
+#'
+#' @export
+collapseTraitMatrix <- function(Y) {
+  if(sum(grepl("=",colnames(Y))) < 2) return(Y)
+  is.cat <- grepl("=",colnames(Y))
+  M <- Y[,which(!is.cat),drop=FALSE]  
+  categories <- unique(sub("=.*","",colnames(Y)[which(is.cat)]))
+  y=categories[1]
+  for(y in categories) {
+    ii <- which(sub("=.*","",colnames(Y)) == y)
+    Y1 <- Y[,ii]
+    colnames(Y1) <- sub(".*=","",colnames(Y1))
+    m1 <- colnames(Y1)[max.col(Y1)]
+    M <- cbind(M, m1)
+    colnames(M)[ncol(M)] <- y
+  }
+  return(M)
+}
+
+
 #' @title P-value for Pearson's Correlation Coefficient
 #'
 #' @description This function calculates the p-value for Pearson's correlation coefficient.