fixed outdated fn

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: PhyloRBF
-Version: 1.1.3
-Date: 2022-08-01
+Version: 1.1.4
+Date: 2024-02-19
 Title: PhyloRBF
 Authors@R: c(
     person("Vinh", "Tran", role = c("aut", "cre"), email = "[email protected]"),
@@ -13,10 +13,10 @@ Depends: R (>= 4.1.0)
 Encoding: UTF-8
 biocViews: Software, Visualization, DataRepresentation, MultipleComparison, FunctionalPrediction
 Imports:
-    BiocStyle, colourpicker, data.table, DT, energy, ggplot2, RCurl, shinyBS,
-    shinyjs, shinycssloaders, PhyloProfile (>= 1.6.4)
-RoxygenNote: 7.2.0
+    ape, BiocStyle, colourpicker, data.table, DT, energy, ggplot2, RCurl, 
+    shinyBS, shinyjs, shinycssloaders, PhyloProfile (>= 1.6.4)
+RoxygenNote: 7.2.3
 Suggests:
-    knitr, rmarkdown, testthat, ape, bioDist, Biostrings, 
+    knitr, rmarkdown, testthat, bioDist, Biostrings, 
     gridExtra, pbapply, RColorBrewer, shiny, OmaDB, plyr, xml2, zoo
 VignetteBuilder: knitr

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(createRootedTreeCr)
 export(dataCustomizedPlotCr)
 export(dataMainPlotCr)
 export(getInputTaxaNameCr)
@@ -8,6 +9,7 @@ export(getSelectedTaxonNamesCr)
 export(getTaxonomyMatrixCr)
 export(heatmapPlottingCr)
 export(highlightProfilePlotCr)
+export(reduceProfileCr)
 export(runPhyloRBF)
 export(sortInputTaxaCr)
 import(BiocStyle)
@@ -19,4 +21,6 @@ import(ggplot2)
 import(shinyBS)
 import(shinycssloaders)
 import(shinyjs, except = colourInput)
+importFrom(ape,as.phylo)
+importFrom(ape,root)
 importFrom(colourpicker,colourInput)

R/createProfilePlot.R

@@ -13,9 +13,6 @@
 #' @import data.table
 #' @author Vinh Tran {[email protected]}
 #' @seealso \code{\link{filterProfileData}}
-#' @examples
-#' data("superTaxonProfile", package="PhyloProfile")
-#' dataMainPlotCr(superTaxonProfile)
 
 dataMainPlotCr <- function(dataHeat = NULL){
     if (is.null(dataHeat)) stop("Input data cannot be NULL!")
@@ -74,11 +71,6 @@ dataMainPlotCr <- function(dataHeat = NULL){
 #' @return A dataframe contains data for plotting the customized profile.
 #' @author Vinh Tran {[email protected]}
 #' @seealso \code{\link{filterProfileData}}
-#' @examples
-#' data("superTaxonProfile", package="PhyloProfile")
-#' selectedTaxa <- c("Mammalia", "Saccharomycetes", "Insecta")
-#' selectedSeq <- "all"
-#' dataCustomizedPlotCr(superTaxonProfile, selectedTaxa, selectedSeq)
 
 dataCustomizedPlotCr <- function(
         dataHeat = NULL, selectedTaxa = "all", selectedSeq = "all"
@@ -154,33 +146,6 @@ dataCustomizedPlotCr <- function(
 #' @import ggplot2
 #' @author Vinh Tran {[email protected]}
 #' @seealso \code{\link{dataMainPlotCr}}, \code{\link{dataCustomizedPlotCr}}
-#' @examples
-#' data("superTaxonProfile", package="PhyloProfile")
-#' plotDf <- dataMainPlotCr(superTaxonProfile)
-#' plotParameter <- list(
-#'     "xAxis" = "taxa",
-#'     "var1ID" = "FAS_FW",
-#'     "var2ID"  = "FAS_BW",
-#'     "midVar1" = 0.5,
-#'     "midColorVar1" =  "#FFFFFF",
-#'     "lowColorVar1" =  "#FF8C00",
-#'     "highColorVar1" = "#4682B4",
-#'     "midVar2" = 1,
-#'     "midColorVar2" =  "#FFFFFF",
-#'     "lowColorVar2" = "#CB4C4E",
-#'     "highColorVar2" = "#3E436F",
-#'     "paraColor" = "#07D000",
-#'     "xSize" = 8,
-#'     "ySize" = 8,
-#'     "legendSize" = 8,
-#'     "mainLegend" = "top",
-#'     "dotZoom" = 0,
-#'     "xAngle" = 60,
-#'     "guideline" = 0,
-#'     "colorByGroup" = FALSE
-#' )
-#'
-#' heatmapPlottingCr(plotDf, plotParameter, "species")
 
 heatmapPlottingCr <- function(data = NULL, parm = NULL, rank = "species"){
     if (is.null(data)) stop("Input data cannot be NULL!")
@@ -301,7 +266,7 @@ heatmapPlottingCr <- function(data = NULL, parm = NULL, rank = "species"){
 
 #' Highlight gene and/or taxon of interest on the phylogenetic profile plot
 #' @export
-#' @usage highlightProfilePlotCr(data = NULL, plotParameter = NULL, 
+#' @usage highlightProfilePlotCr(data = NULL, plotParameter = NULL,
 #'     taxonHighlight = "none", rankName = "species", geneHighlight = "none")
 #' @param data dataframe for plotting the heatmap phylogentic profile (either
 #' full or subset profiles)

R/parsePhyloProfile.R

@@ -160,6 +160,84 @@ getSelectedTaxonNamesCr <- function(
     }
 }
 
+#' taxa2dist
+#' @param x taxa matrix
+#' @param varstep var-step
+#' @param check check
+#' @param labels labels
+#' @return a distance matrix
+#' @author function from taxize library
+
+taxa2dist <- function(x, varstep = FALSE, check = TRUE, labels) {
+    rich <- apply(x, 2, function(taxa) length(unique(taxa)))
+    S <- nrow(x)
+    if (check) {
+        keep <- rich < S & rich > 1
+        rich <- rich[keep]
+        x <- x[, keep]
+    }
+    i <- rev(order(rich))
+    x <- x[, i]
+    rich <- rich[i]
+    if (varstep) {
+        add <- -diff(c(nrow(x), rich, 1))
+        add <- add/c(S, rich)
+        add <- add/sum(add) * 100
+    }
+    else {
+        add <- rep(100/(ncol(x) + check), ncol(x) + check)
+    }
+    if (!is.null(names(add)))
+        names(add) <- c("Base", names(add)[-length(add)])
+    if (!check)
+        add <- c(0, add)
+    out <- matrix(add[1], nrow(x), nrow(x))
+    for (i in seq_len(ncol(x))) {
+        out <- out + add[i + 1] * outer(x[, i], x[, i], "!=")
+    }
+    out <- stats::as.dist(out)
+    attr(out, "method") <- "taxa2dist"
+    attr(out, "steps") <- add
+    if (missing(labels)) {
+        attr(out, "Labels") <- rownames(x)
+    }
+    else {
+        if (length(labels) != nrow(x))
+            warning("Labels are wrong: needed ", nrow(x), " got ",
+                    length(labels))
+        attr(out, "Labels") <- as.character(labels)
+    }
+    if (!check && any(out <= 0))
+        warning("you used 'check=FALSE' and some distances are zero
+                -- was this intended?")
+    out
+}
+
+#' Create rooted tree from a taxonomy matrix
+#' @export
+#' @param df data frame contains taxonomy matrix used for generating tree
+#' (see distDf in example)
+#' @param rootTaxon taxon used for rooting the taxonomy tree
+#' @importFrom ape as.phylo
+#' @importFrom ape root
+#' @return A rooted taxonomy tree as an object of class "phylo".
+#' @author Vinh Tran {[email protected]}
+
+createRootedTreeCr <- function(df, rootTaxon = NULL){
+    if (missing(df)) return("No taxonomy matrix given!")
+    # calculate distance matrix
+    taxdis <- tryCatch(taxa2dist(df), error = function(e) e)
+    # create tree
+    tree <- ape::as.phylo(stats::hclust(taxdis))
+    # root tree
+    if (missing(rootTaxon)) rootTaxon = tree$tip.label[1]
+    if (!(rootTaxon %in% tree$tip.label)) rootTaxon = tree$tip.label[1]
+    tree <- ape::root(tree, outgroup = rootTaxon, resolve.root = TRUE)
+    # return
+    return(tree)
+}
+
+
 #' Sort list of (super)taxa based on a selected reference (super)taxon
 #' @usage sortInputTaxaCr(taxonIDs = NULL, rankName, refTaxon = NULL,
 #'     taxaTree = NULL)
@@ -201,7 +279,7 @@ sortInputTaxaCr <- function(
         distDf <- subset(Dt, select = -c(ncbiID, fullName))
         row.names(distDf) <- distDf$abbrName
         distDf <- distDf[, -1]
-        taxaTree <- PhyloProfile::createRootedTree(
+        taxaTree <- createRootedTreeCr(
             distDf, as.character(repTaxon$abbrName)
         )
     } else
@@ -243,3 +321,61 @@ sortInputTaxaCr <- function(
     sortedOut$category <- as.factor(sortedOut$category)
     return(sortedOut)
 }
+
+
+#' Reduce the filtered profile data into supertaxon level
+#' @description Reduce data of the processed phylogenetic profiles from input
+#' taxonomy rank into supertaxon level (e.g. from species to phylum)
+#' @param filteredProfile dataframe contains the filtered profiles (see
+#' ?parseInfoProfile, ?filterProfileData and ?filteredProfile)
+#' @return A reduced dataframe contains only profile data for the selected
+#' supertaxon rank. This dataframe contains only supertaxa and their value
+#' (mVar1 & mVar2) for each gene.
+#' @author Vinh Tran {[email protected]}
+#' @export
+
+reduceProfileCr <- function(filteredProfile) {
+    if (is.null(filteredProfile)) stop("Profile data cannot be NULL!")
+
+    # check if working with the lowest taxonomy rank; 1 for NO; 0 for YES
+    flag <- 1
+    if (length(unique(levels(as.factor(filteredProfile$numberSpec)))) == 1) {
+        if (unique(levels(as.factor(filteredProfile$numberSpec))) == 1) {
+            superDfExt <- filteredProfile[, c(
+                "geneID", "supertaxon", "supertaxonID",
+                "var1", "presSpec", "category", "orthoID", "var2", "paralog"
+            )]
+            flag <- 0
+        }
+    }
+    if (flag == 1) {
+        # get representative orthoID that has m VAR1 for each supertaxon
+        mOrthoID <- filteredProfile[, c(
+            "geneID", "supertaxon", "var1", "mVar1", "orthoID", "presSpec"
+        )]
+        mOrthoID <- subset(mOrthoID, mOrthoID$var1 == mOrthoID$mVar1)
+        colnames(mOrthoID) <- c(
+            "geneID", "supertaxon", "var1", "mVar1", "orthoID", "presSpec"
+        )
+        mOrthoID <- mOrthoID[!is.na(mOrthoID$orthoID), ]
+        mOrthoID <- mOrthoID[, c("geneID", "supertaxon", "orthoID", "presSpec")]
+        mOrthoID <- mOrthoID[!duplicated(mOrthoID[, seq_len(2)]), ]
+        # get data set for PhyloProfile plotting (contains only supertaxa info)
+        superDf <- subset(filteredProfile, select = c(
+            "geneID", "supertaxon", "supertaxonID",
+            "mVar1", "category", "mVar2", "paralog"
+        ))
+        superDf <- superDf[!duplicated(superDf), ]
+        superDfExt <- merge(
+            superDf, mOrthoID, by = c("geneID", "supertaxon"), all.x = TRUE
+        )
+        superDfExt <- superDfExt[, c(
+            "geneID", "supertaxon", "supertaxonID",
+            "mVar1", "presSpec", "category", "orthoID", "mVar2", "paralog"
+        )]
+        # rename mVar to var
+        names(superDfExt)[names(superDfExt) == "mVar1"] <- "var1"
+        names(superDfExt)[names(superDfExt) == "mVar2"] <- "var2"
+    }
+    return(superDfExt)
+}

inst/PhyloProfile/server.R

@@ -512,7 +512,7 @@ shinyServer(function(input, output, session) {
     # * heatmap data input -----------------------------------------------------
     dataHeat <- reactive({
         req(filteredDataHeat())
-        dataHeat <- reduceProfile(filteredDataHeat())
+        dataHeat <- PhyloRBF::reduceProfileCr(filteredDataHeat())
         return(dataHeat)
     })