R/helpers.R
e4a547d8
 #' @title Dataframe getter for \code{qualityRange} function.
 #' @name getDataQualityRange
 #' @aliases getDataQualityRange
 #' @description
1374c99a
 #' This method is a wrapper to retrieve a specific \code{\link{SummarizedExperiment}} given a \code{k} value from
e4a547d8
 #' the object returned by \code{\link{qualityRange}} function.
 #'
 #' @param data The object returned by \code{\link{qualityRange}} function.
 #' @param k The desired \code{k} cluster.
 #'
1374c99a
 #' @return The \code{\link{SummarizedExperiment}} that contains information about the selected \code{k} cluster.
e4a547d8
 #'
 #' @examples
 #' # Using example data from our package
72826b66
 #' data("ontMetrics")
 #' qualityRangeData <- qualityRange(ontMetrics, k.range=c(3,5), getImages = FALSE)
e4a547d8
 #' # Getting dataframe that contains information about k=5
1374c99a
 #' k5Data = getDataQualityRange(qualityRangeData, 5)
e4a547d8
 #'
 getDataQualityRange <- function(data, k) {
   dataNames = names(data)
   # From, e.g, k_4 to 4
cc5aa8e2
   kValues = sapply(strsplit(dataNames, split='_', fixed=TRUE), function(x) (x[2]))
e4a547d8
   kValues = as.integer(kValues)
72826b66
   kValues.length = length(kValues)
e4a547d8
   if (k >= kValues[1] && k <= kValues[kValues.length]) {
     column = paste("k_", k, sep="")
1374c99a
 
e4a547d8
     return(data[[column]])
   } else {
     error=paste("Selected k (",k,") is not in the range of k.range ["
                 , kValues[1], ",", kValues[kValues.length], "]", sep="")
     stop(error)
   }
 }
 
72826b66
 ###############################
 ## Package local environment/variables ##
 ###############################
 
 pkg.env <- new.env()
 pkg.env$m.stab.global = NULL
c3727865
 pkg.env$m.stab.global.csv = NULL
72826b66
 pkg.env$m.global = NULL
 pkg.env$e.global = NULL
 pkg.env$estable = NULL
 pkg.env$names.index = NULL
 pkg.env$names.metr = NULL
c3727865
 pkg.env$seed = 13606
580e6faa
 pkg.env$cbi = c("kmeans", "clara", "clara_pam", "hclust", "pamk", "pamk_pam") # Supported CBIs
72826b66
 
 
e4a547d8
 #####################
 ## Private methods ##
 #####################
 
 # Source: http://r.789695.n4.nabble.com/Suppressing-output-e-g-from-cat-td859876.html
 # Supresses the output messages of a function 'x'
 quiet <- function(x) {
   sink(tempfile())
   on.exit(sink())
   invisible(force(x))
 }
 
 isString <- function(str) {
   if (is.character(str) & length(str) > 0) {
     return(TRUE)
   }
   error=paste("Input parameter '", str, "' is not a string", sep="")
   stop(error)
 }
 
 ## Inserts a newrow to existingDF at position r
 insertRow <- function(existingDF, newrow, r) {
   existingDF[seq(r+1,nrow(existingDF)+1),] <- existingDF[seq(r,nrow(existingDF)),]
   existingDF[r,] <- newrow
   existingDF
 }
 
 ## Checks if k is in range [2,15]
 checkKValue <- function(k) {
   if (k < 2 || k > 15) {
     stop("k value is not in range [2,15]")
   }
 }
 
 checkDirectory <- function(path) {
   if (is.null(path) || !dir.exists(path)) {
     error <- paste("Invalid path '", path, "'. Directory does not exists or it is not a directory", sep="")
     stop(error)
   }
   if (!endsWith(path, "/")) {
     path <- paste(path, "/", sep="")
   }
   return(path)
 }
1374c99a
 
d6c32180
 sample.range <- function(x) {diff(range(x))}
 sample.min <- function(x) {min(x)}
 
1374c99a
 # data: One dataframe, thus one assay
 createSE <- function(data) {
45c94462
   se = SummarizedExperiment(assays = data.matrix(data),
fe3257d3
           colData = MultiAssayExperiment::DataFrame(metrics = colnames(data)))
1374c99a
   return(se)
 }
 
fe3257d3
 # data: A list of SummarizedExperiment objects (ExperimentList)
1374c99a
 createSEList <- function(data) {
   if (!is.list(data)) {
     stop("Input variable is not a list")
   }
   if (length(data) == 0) {
     stop("Input variable is an empty list")
   }
   length = length(names(data))
   seList <- list()
   for (i in 1:length) {
     cur.data <- data[[i]]
120cc8df
     dataMatrix <- as.matrix(cur.data)
580e6faa
     #cat("DataMatrix '", names(data)[i], "'\n")
     #print(dataMatrix)
c3727865
     if (is.na(dataMatrix[1, "Metric"])) { # Metrics are NA? At least the first one
       dataMatrix[,1] <- cur.data$Metric
     }
 
1374c99a
     se <- createSE(dataMatrix)
     seList <- c(seList, se)
   }
   names(seList) <- names(data)
fe3257d3
   expList <- ExperimentList(seList)
   return(expList)
1374c99a
 }
580e6faa
 
 ## Returns a cluterboot interface (CBI) depending on the input string,
 ## with its specific function parameters in an list as in:
 ## list("method" = CBI Method, "args" = Lit of Specific arguments for this CBI)
 helperGetCBI <- function(cbi=pkg.env$cbi, krange) {
   cbi <- match.arg(cbi)
   switch(cbi,
          kmeans={
            args = list("krange" = krange)
            return(list("method" = kmeansCBI, "args" = args))
          },
          clara={
            args = list("k" = krange, "usepam"=FALSE)
            return(list("method" = claraCBI, "args" = args))
          },
          clara_pam={
            args = list("k" = krange, "usepam"=TRUE)
            return(list("method" = claraCBI, "args" = args))
          },
          hclust={
            args = list("k" = krange, "method"="ward.D2")
            return(list("method" = hclustCBI, "args" = args))
          },
          pamk={
            args = list("k" = krange, "usepam"=FALSE, criterion="asw")
            return(list("method" = pamkCBI, "args" = args))
          },
          pamk_pam={
            args = list("k" = krange, "usepam"=TRUE, criterion="asw")
            return(list("method" = pamkCBI, "args" = args))
          },
          {
            error=paste("Input CBI '", cbi, "' is not defined in the package", sep="")
            stop(error)
          }
   )
 }
55e0b3e9
 # Remove rows from a dataframe 'df' where for a certain column the row provides 'NA' value
 removeNAValues <- function(df, verbose=TRUE) {
   rowNames = df[[1]]
   affected = which(rowSums(is.na(df)) > 0)
   if (verbose && length(affected) > 0) {
     message("Warning: There are rows with NA values. I will remove these...")
   }
   for (row_i in affected) {
     if (verbose) {
       message("Row '", rowNames[row_i], "' was removed. NA values found in columns:")
     }
     for (column in colnames(df)) {
       naDetected = is.na(df[row_i, column])
       if (verbose && naDetected) {
         message("- '", column,"' ")
       }
     }
   }
   df <- na.omit(df)
   if (verbose) {
     message("")
   }
   return (df)
 }
 
 # Basic stats of a dataframe
 dfStats <- function(df) {
   message("Data loaded.\n",
           "Number of rows: ", nrow(df), "\n",
           "Number of columns: ", ncol(df), "\n\n"
   )
 }
 
580e6faa
 #' @title Get supported CBIs in evaluomeR.
 #' @aliases evaluomeRSupportedCBI
 #' @description
 #' A vector of supported CBIs available in evaluomeR.
 #'
 #' @return A String vector.
 #'
 #' @examples
 #' supportedCBIs <- evaluomeRSupportedCBI
 #'
 evaluomeRSupportedCBI <- function() {
   return(pkg.env$cbi)
 }