R/utils.R

In prostarproteomics/DAPAR: Tools for the Differential Analysis of Proteins Abundance with R

#' @title xxx
#' @description xxx
#' @param set1 xxx
#' @param set2 xxx
#' 
#' @return xxx
#' 
#' @examples
#' is.subset('a', letters)
#' is.subset(c('a', 'c', 't'), letters)
#' is.subset(c('a', 3, 't'), letters)
#' is.subset(3, letters)
#' 
#' @export
#' 
is.subset <- function(set1, set2)
  length(intersect(set1, set2)) > 0 && length(set1) == length(intersect(set1, set2))





#' @title Loads packages
#' 
#' @description Checks if a package is available to load it
#' 
#' @param ll.deps A `character()` vector which contains packages names
#' 
#' @examples 
#' pkgs.require('DAPAR')
#' 
#' @export
#' 
#' @author Samuel Wieczorek
#' 
pkgs.require <- function(ll.deps){
    lapply(ll.deps, function(x) {
        if (!requireNamespace(x, quietly = TRUE)) {
            stop(paste0("Please install ", x, ": BiocManager::install('", x, "')"))
        }
    })
}



#' @title Returns the contains of the slot processing  of an object of
#' class \code{MSnSet}
#'
#' @param  obj An object (peptides) of class \code{MSnSet}.
#'
#' @return The slot processing of obj@processingData
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package="DAPARdata")
#' getProcessingInfo(Exp1_R25_pept)
#'
#' @export
#'
getProcessingInfo <- function(obj) {
    return(obj@processingData@processing)
}


#' @title Returns the contains of the slot processing  of an object of
#' class \code{MSnSet}
#'
#' @param  obj An object (peptides) of class \code{MSnSet}.
#'
#' @return The slot processing of obj@processingData
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package="DAPARdata")
#' Xshared <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs", FALSE)
#' Xunique <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs", TRUE)
#' ll.X <- list(matWithSharedPeptides = Xshared, 
#' matWithUniquePeptides = Xunique)
#' Exp1_R25_pept <- SetMatAdj(Exp1_R25_pept, ll.X)
#' ll.X <- GetMatAdj(Exp1_R25_pept)
#'
#' @export
#'
GetMatAdj <- function(obj) {
    if (GetTypeofData(obj) != "peptide") {
        warning("This function is only available for a peptide dataset.")
    }
    return(obj@experimentData@other$matAdj)
}


#' @title Record the adjacency matrices in a slot of the
#' dataset  of class \code{MSnSet}
#'
#' @param  obj An object (peptides) of class \code{MSnSet}.
#'
#' @param X A list of two adjacency matrices
#'
#' @return NA
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package="DAPARdata")
#' Xshared <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs", FALSE)
#' Xunique <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs", TRUE)
#' ll.X <- list(matWithSharedPeptides = Xshared, 
#' matWithUniquePeptides = Xunique)
#' Exp1_R25_pept <- SetMatAdj(Exp1_R25_pept, ll.X)
#'
#' @export
#'
SetMatAdj <- function(obj, X) {
    if (GetTypeofData(obj) != "peptide") {
        stop("This function is only available for a peptide dataset. Abort.")
    }
    obj@experimentData@other$matAdj <- X
    return(obj)
}


#' @title Returns the contains of the slot processing  of an object of
#' class \code{MSnSet}
#'
#' @param  obj An object (peptides) of class \code{MSnSet}.
#'
#' @return A list of connected components
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package="DAPARdata")
#' Xshared <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs",  FALSE)
#' Xunique <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs", TRUE)
#' ll.X <- list(matWithSharedPeptides = Xshared, 
#' matWithUniquePeptides = Xunique)
#' Exp1_R25_pept <- SetMatAdj(Exp1_R25_pept, ll.X)
#' ll1 <- get.pep.prot.cc(GetMatAdj(Exp1_R25_pept)$matWithSharedPeptides)
#' ll2 <- get.pep.prot.cc(
#' GetMatAdj(Exp1_R25_pept)$matWithUniquePeptides)
#' cc <- list(allPep = ll1, onlyUniquePep = ll2)
#' Exp1_R25_pept <- SetCC(Exp1_R25_pept, cc)
#' ll.cc <- GetCC(Exp1_R25_pept)
#'
#' @export
#'
GetCC <- function(obj) {
    if (GetTypeofData(obj) != "peptide") {
        warning("This function is only available for a peptide dataset.")
    }
    return(obj@experimentData@other$CC)
}


#' @title Returns the connected components
#'
#' @param  obj An object (peptides) of class \code{MSnSet}.
#'
#' @param cc The connected components list
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package='DAPARdata')
#' Xshared <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs", FALSE)
#' Xunique <- BuildAdjacencyMatrix(Exp1_R25_pept[seq_len(100)], 
#' "Protein_group_IDs", TRUE)
#' ll.X <- list(matWithSharedPeptides = Xshared, 
#' matWithUniquePeptides = Xunique)
#' Exp1_R25_pept <- SetMatAdj(Exp1_R25_pept, ll.X)
#' ll1 <- get.pep.prot.cc(GetMatAdj(Exp1_R25_pept)$matWithSharedPeptides)
#' ll2 <- get.pep.prot.cc(
#' GetMatAdj(Exp1_R25_pept)$matWithUniquePeptides)
#' cc <- list(allPep = ll1, onlyUniquePep = ll2)
#' Exp1_R25_pept <- SetCC(Exp1_R25_pept, cc)
#'
#' @export
#' 
#' @return xxx
#'
SetCC <- function(obj, cc) {
    if (GetTypeofData(obj) != "peptide") {
        stop("This function is only available for a peptide dataset. Abort.")
    }
    obj@experimentData@other$CC <- cc
    return(obj)
}



#' Returns the number of empty lines in a matrix.
#'
#' @title Returns the number of empty lines in the data
#'
#' @param qData A matrix corresponding to the quantitative data.
#'
#' @return An integer
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package="DAPARdata")
#' qData <- Biobase::exprs(Exp1_R25_pept)
#' getNumberOfEmptyLines(qData)
#'
#' @export
#'
#'
getNumberOfEmptyLines <- function(qData) {
    n <- sum(apply(is.na(as.matrix(qData)), 1, all))
    return(n)
}


#' @title xxxx
#'
#' @description
#' xxxx
#'
#' @param obj xxx
#'
#' @export
#' 
#' @examples 
#' data(Exp1_R25_pept, package="DAPARdata")
#' GetTypeofData(Exp1_R25_pept)
#' 
#' @return xxx
#'
GetTypeofData <- function(obj) {
    if (!is.null(obj)) {
        obj@experimentData@other$typeOfData
    } else {
        NULL
    }
}


#' @title xxxx
#'
#' @description
#' xxxx
#'
#' @param obj xxx
#'
#' @export
#' 
#' @examples 
#' data(Exp1_R25_pept, package="DAPARdata")
#' GetKeyId(Exp1_R25_pept)
#' 
#' @return xxx
#'
GetKeyId <- function(obj) {
    if (!is.null(obj)) {
        obj@experimentData@other$keyId
    } else {
        NULL
    }
}


#' @title Returns the possible number of values in lines in the data
#'
#' @param obj An object of class \code{MSnSet}
#'
#' @param type xxxxxxx
#'
#' @return An integer
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package="DAPARdata")
#' getListNbValuesInLines(Exp1_R25_pept, "WholeMatrix")
#'
#' @export
#'
#'
getListNbValuesInLines <- function(obj, type) {
    if (missing(obj)) {
        stop("'obj' is required")
    } else if (is.null(obj)) {
        stop("'obj' is NULL.")
    }

    if (missing(type)) {
        stop("'type' is required")
    } else if (!(type %in% MetacellFilteringScope())) {
        stop(paste0("'type' must be one of the following values: ", 
            paste0(MetacellFilteringScope(), collapse = " ")))
    }

    data <- GetMetacell(obj)
    conds <- Biobase::pData(obj)$Condition

    ll <- switch(type,
        WholeLine = NULL,
        WholeMatrix = seq(0, ncol(data)),
        AllCond = seq(0, min(unlist(lapply(unique(conds), 
            function(x) length(which(conds == x)))))),
        AtLeastOneCond = seq(0, min(unlist(lapply(unique(conds), 
            function(x) length(which(conds == x))))))
    )

    return(ll)
}




#' @title Gets the conditions indices.
#' 
#' @description 
#' Returns a list for the two conditions where each slot is a vector of
#' indices for the samples.
#'
#'
#' @param conds A vector of strings containing the column "Condition" of
#' the \code{Biobase::pData()}.
#'
#' @param cond1 A vector of Conditions (a slot in the \code{Biobase::pData()} 
#' table) for the condition 1.
#'
#' @param cond2 A vector of Conditions (a slot in the \code{Biobase::pData()} 
#' table) for the condition 2.
#'
#' @return A list with two slots \code{iCond1} and \code{iCond2} containing
#' respectively the indices of samples in the \code{Biobase::pData()} table 
#' of the dataset.
#'
#' @author Florence Combes, Samuel Wieczorek
#'
#' @examples
#' data(Exp1_R25_pept, package="DAPARdata")
#' conds <- Biobase::pData(Exp1_R25_pept)[, "Condition"]
#' getIndicesConditions(conds, "25fmol", "10fmol")
#'
#' @export
#'
getIndicesConditions <- function(conds, cond1, cond2) {
    indCondition1 <- indCondition2 <- NULL

    for (i in seq_len(length(cond1))) {
        indCondition1 <- c(
            indCondition1,
            which(conds == cond1[i])
        )
    }
    for (i in seq_len(length(cond2))) {
        indCondition2 <- c(
            indCondition2,
            which(conds == cond2[i])
        )
    }

    return(list(iCond1 = indCondition1, iCond2 = indCondition2))
}


#' @title Customised contextual menu of highcharts plots
#'
#' @param hc A highcharter object
#'
#' @param filename The filename under which the plot has to be saved
#'
#' @return A contextual menu for highcharts plots
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' library("highcharter")
#' hc <- highchart()
#' hc_chart(hc, type = "line")
#' hc_add_series(hc, data = c(29, 71, 40))
#' my_hc_ExportMenu(hc, filename = "foo")
#'
#' @export
#'
my_hc_ExportMenu <- function(hc, filename) {
    hc_exporting(hc,
        enabled = TRUE,
        filename = filename,
        buttons = list(
            contextButton = list(
                menuItems = list("downloadPNG", "downloadSVG", "downloadPDF")
            )
        )
    )
}




#' @title Customised resetZoomButton of highcharts plots
#'
#' @param hc A highcharter object
#'
#' @param chartType The type of the plot
#'
#' @param zoomType The type of the zoom (one of "x", "y", "xy", "None")
#'
#' @return A highchart plot
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' library("highcharter")
#' hc <- highchart()
#' hc_chart(hc, type = "line")
#' hc_add_series(hc, data = c(29, 71, 40))
#' my_hc_ExportMenu(hc, filename = "foo")
#'
#' @export
#'
my_hc_chart <- function(hc, chartType, zoomType = "None") {
    hc %>%
        hc_chart(
            type = chartType,
            zoomType = zoomType,
            showAxes = TRUE,
            resetZoomButton = list(
                position = list(
                    align = "left",
                    verticalAlign = "top"
                )
            )
        )
}





#' @title Retrieve the indices of non-zero elements in sparse matrices
#'
#' @description
#' This function retrieves the indices of non-zero elements in sparse matrices
#' of class dgCMatrix from package Matrix. This function is largely inspired
#' from the package \code{RINGO}
#'
#' @param x A sparse matrix of class dgCMatrix
#'
#' @return A two-column matrix
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' library(Matrix)
#' mat <- Matrix(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1),
#'     nrow = 5, byrow = TRUE,
#'     sparse = TRUE
#' )
#' res <- nonzero(mat)
#'
#' @export
#'
nonzero <- function(x) {
    ## function to get a two-column matrix containing the indices of the
    ### non-zero elements in a "dgCMatrix" class matrix

    stopifnot(inherits(x, "dgCMatrix"))
    if (all(x@p == 0)) {
        return(matrix(0,
            nrow = 0, ncol = 2,
            dimnames = list(character(0), c("row", "col"))
        ))
    }
    res <- cbind(x@i + 1, rep(seq(dim(x)[2]), diff(x@p)))
    colnames(res) <- c("row", "col")
    res <- res[x@x != 0, , drop = FALSE]
    return(res)
}




#' @title Customised contextual menu of highcharts plots
#'
#' @param hc A highcharter object
#'
#' @param filename The filename under which the plot has to be saved
#'
#' @return A contextual menu for highcharts plots
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' library("highcharter")
#' hc <- highchart()
#' hc_chart(hc, type = "line")
#' hc_add_series(hc, data = c(29, 71, 40))
#' dapar_hc_ExportMenu(hc, filename = "foo")
#'
#' @export
#'
#' @import highcharter
#'
dapar_hc_ExportMenu <- function(hc, filename) {
    hc_exporting(hc,
        enabled = TRUE,
        filename = filename,
        buttons = list(
            contextButton = list(
                menuItems = list("downloadPNG", "downloadSVG", "downloadPDF")
            )
        )
    )
}






#' @title Customised resetZoomButton of highcharts plots
#'
#' @param hc A highcharter object
#'
#' @param chartType The type of the plot
#'
#' @param zoomType The type of the zoom (one of "x", "y", "xy", "None")
#'
#' @param width xxx
#'
#' @param height xxx
#'
#' @return A highchart plot
#'
#' @author Samuel Wieczorek
#'
#' @examples
#' library("highcharter")
#' hc <- highchart()
#' hc <- dapar_hc_chart(hc, chartType = "line", zoomType = "x")
#' hc_add_series(hc, data = c(29, 71, 40))
#'
#' @export
#'
#' @import highcharter
#'
dapar_hc_chart <- function(hc, 
    chartType, 
    zoomType = "None", 
    width = 0, 
    height = 0
    ) {
    hc %>%
        hc_chart(
            type = chartType,
            zoomType = zoomType,
            showAxes = TRUE,
            width = width,
            height = height,
            resetZoomButton = list(
                position = list(
                    align = "left",
                    verticalAlign = "top"
                )
            )
        )
}