R/misc.R

In pipeComp: pipeComp pipeline benchmarking framework

#' checkPipelinePackages
#' 
#' Checks whether the packages required by a pipeline and its alternative 
#' methods are available.
#'
#' @param alternatives A named list of alternative parameter values
#' @param pipDef An object of class `PipelineDefinition`.
#'
#' @return Logical.
#' @export
#' 
#' @importFrom utils installed.packages
#' @examples
#' checkPipelinePackages(list(argument1="mean"), scrna_pipeline())
checkPipelinePackages <- function(alternatives, pipDef=NULL){
  fns <- unlist(alternatives[ vapply( alternatives, FUN=is.character, 
                                      FUN.VALUE=logical(1) ) ])
  fns <- lapply(fns, FUN=function(x){
    if(exists(x) && is.function(get(x))) return(get(x))
    ""
  })
  fns <- paste(unlist(fns),collapse="\n")
  if(!is.null(pipDef)){
    fns <- paste(fns, paste(stepFn(pipDef, type="functions"), collapse="\n"), 
                 paste(stepFn(pipDef, type="evaluation"), collapse="\n"))
  }
  pkg <- gregexpr("library\\(([[:alnum:]])+\\)", fns)
  pkg <- unique(regmatches(fns, pkg)[[1]])
  pkg <- gsub("\\)","",gsub("^library\\(","",pkg))
  pkg <- gsub('"',"",pkg)
  misspkg <- setdiff(pkg, row.names(installed.packages()))
  if(length(misspkg)>0) message("The following packages appear to be missing:",
       paste(misspkg, collapse=", "))
  return(length(misspkg)==0)
}



#' parsePipNames
#' 
#' Parses the names of analyses performed through `runPipeline` to extract a 
#' data.frame of parameter values (with decent classes).
#'
#' @param x The names to parse, or a data.frame with the names to parse as 
#' row.names. All names are expected to contain the same parameters.
#' @param setRowNames Logical; whether to set original names as row.names of
#' the output data.frame (default FALSE)
#' @param addcolumns An optional data.frame of `length(x)` rows to cbind to the
#' output.
#'
#' @return A data.frame
#' 
#' @importFrom utils type.convert
#' @export
#'
#' @examples
#' my_names <- c("param1=A;param2=5","param1=B;param2=0")
#' parsePipNames(my_names)
parsePipNames <- function(x, setRowNames=FALSE, addcolumns=NULL){
  if(is.data.frame(x) || is.matrix(x)){
    if(!is.null(addcolumns)){
      addcolumns <- cbind(x,addcolumns)
    }else{
      addcolumns <- x
    }
    x <- row.names(x)
  }
  x2 <- lapply(strsplit(x,";"),FUN=function(x) x)
  if(length(unique(vapply(x2, length, numeric(1))))>1) 
    stop("The different names do not have the same number of components.")
  n <- vapply(strsplit(x2[[1]],"="),FUN=function(x) x[1], character(1))
  y <- vapply(strsplit(unlist(x2),"="),FUN=function(x) x[2], character(1))
  y <- as.data.frame(matrix(y, ncol=length(n), byrow=TRUE))
  colnames(y) <- n
  for(i in seq_len(ncol(y))) y[[i]] <- type.convert(y[[i]])
  if(setRowNames) row.names(y) <- x
  if(!is.null(addcolumns)){
    row.names(addcolumns) <- NULL
    y <- cbind(y,addcolumns)
  }
  y
}

# run function `x` on object `o`; if there is no function `x`, run `alt` passing
# `x` as second argument
.runf <- function(x, o, alt=NULL, ...){
  if(exists(x) && is.function(get(x))){
    return(get(x)(o, ...))
  }else{
    if(is.null(alt)) stop("Function '",x,"' not found in environment!")
    return(alt(o, x, ...))
  }
}


#' buildCombMatrix
#' 
#' Builds a matrix of parameter combinations from a list of alternative values.
#'
#' @param alt A named list of alternative parameter values
#' @param returnIndexMatrix Logical; whether to return a matrix of indices, 
#' rather than a data.frame of factors.
#'
#' @return a matrix or data.frame
#' @export
#'
#' @examples
#' buildCombMatrix(list(param1=LETTERS[1:3], param2=1:2))
buildCombMatrix <- function(alt, returnIndexMatrix=FALSE){
  eg <- as.matrix(expand.grid(lapply(rev(alt), FUN=seq_along)))
  eg <- eg[,seq(ncol(eg),1)]
  if(returnIndexMatrix) return(eg)
  eg <- as.data.frame(eg)
  for(f in names(alt)){
    eg[,f] <- factor(alt[[f]][eg[,f]], levels=alt[[f]])
  }
  eg
}

.checkCombMatrix <- function(eg, alt){
  if(is.null(dim(eg))) 
    stop("`eg` should be a matrix or data.frame of indices or factors")
  if(!all(names(alt) %in% colnames(eg))) 
    stop("The columns of `eg` do not correspond to the arguments.")
  eg <- eg[,names(alt)]
  if(!is.matrix(eg) || !is.numeric(eg)){
    for(f in colnames(eg)){
      if(is.character(eg[,f])) eg[,f] <- factor(eg[,f])
      if(is.factor(eg[,f])){
        if(!all(levels(eg[,f])==alt[[f]])) 
          stop("If `eg` contains factors, the levels should be identical to 
                 the values of the corresponding element of `alternatives`")
        eg[,f] <- as.numeric(eg[,f])
      }
    }
  }
  if(any(is.na(eg))) stop("Final `eg` contains missing values!")
  .sortcols(eg)
}

.sortcols <- function(x){
  xi <- x[,ncol(x)]
  for(i in seq(ncol(x)-1,1)) xi <- xi+max(xi)*x[,i]
  x[order(xi),]
}

#' getQualitativePalette
#'
#' Returns a qualitative color palette of the given size. If less than 23 colors
#'  are required, the colors are based on Paul Tol's palettes. If more, the 
#'  `randomcoloR` package is used.
#'
#' @param nbcolors A positive integer indicating the number of colors
#'
#' @return A vector of colors
#'
#' @export
#' @importFrom randomcoloR distinctColorPalette
#' @examples
#' getQualitativePalette(5)
getQualitativePalette <- function(nbcolors){
  nbcolors <- round(nbcolors)
  switch(as.character(nbcolors),
         "1"=c("#4477AA"),
         "2"=c("#4477AA", "#CC6677"),
         "3"=c("#4477AA", "#DDCC77", "#CC6677"),
         "4"=c("#4477AA", "#117733", "#DDCC77", "#CC6677"),
         "5"=c("#332288", "#88CCEE", "#117733", "#DDCC77", "#CC6677"),
         "6"=c("#332288", "#88CCEE", "#117733", "#DDCC77", "#CC6677","#AA4499"),
         "7"=c("#332288", "#88CCEE", "#44AA99", "#117733", "#DDCC77", "#CC6677",
               "#AA4499"),
         "8"=c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77",
               "#CC6677","#AA4499"),
         "9"=c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77",
               "#CC6677", "#882255", "#AA4499"),
         "10"=c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", 
                "#DDCC77", "#661100", "#CC6677", "#882255", "#AA4499"),
         "11"=c("#332288", "#6699CC", "#88CCEE", "#44AA99", "#117733", 
                "#999933", "#DDCC77", "#661100", "#CC6677", "#882255", 
                "#AA4499"),
         "12"=c("#332288", "#6699CC", "#88CCEE", "#44AA99", "#117733", 
                "#999933", "#DDCC77", "#661100", "#CC6677", "#AA4466", 
                "#882255", "#AA4499"),
         "13"=c("#882E72", "#B178A6", "#1965B0", "#5289C7", "#7BAFDE", 
                "#4EB265", "#90C987", "#CAE0AB", "#F7EE55", "#F6C141", 
                "#F1932D", "#E8601C", "#DC050C"),
         "14"=c("#882E72", "#B178A6", "#D6C1DE", "#1965B0", "#5289C7", 
                "#7BAFDE", "#4EB265", "#90C987", "#CAE0AB", "#F7EE55", 
                "#F6C141", "#F1932D", "#E8601C", "#DC050C"),
         "15"=c("#114477", "#4477AA", "#77AADD", "#117755", "#44AA88", 
                "#99CCBB", "#777711", "#AAAA44", "#DDDD77", "#771111", 
                "#AA4444", "#DD7777", "#771144", "#AA4477", "#DD77AA"),
         "16"=c("#114477", "#4477AA", "#77AADD", "#117755", "#44AA88", 
                "#99CCBB", "#777711", "#AAAA44", "#DDDD77", "#771111", 
                "#AA4444", "#DD7777", "#771144", "#AA4477", "#DD77AA", "black"),
         distinctColorPalette(nbcolors)
  )
}


.getTrueLabelsFromNames <- function(x){
  if(is.null(names(x))) return(NULL)
  tl <- vapply(strsplit(names(x),".",fixed=TRUE), FUN.VALUE=character(1),
               FUN=function(x) x[[1]])
  names(tl) <- names(x)
  tl
}

#' farthestPoint
#'
#' Identifies the point farthest from a line passing through by the first and 
#' last points. Used for automatization of the elbow method.
#'
#' @param y Monotonically inscreasing or decreasing values
#' @param x Optional x coordinates corresponding to `y` (defaults to seq)
#'
#' @return The value of `x` farthest from the diagonal.
#' @export
#'
#' @examples
#' y <- 2^(10:1)
#' plot(y)
#' x <- farthestPoint(y)
#' points(x,y[x],pch=16)
farthestPoint <- function(y, x=NULL){
  if(is.null(x)) x <- seq_len(length(y))
  d <- apply( cbind(x,y), 1, 
              a=c(1,y[1]), b=c(length(y),rev(y)[1]), 
              FUN=function(y, a, b){
                v1 <- a-b
                v2 <- y-a
                abs(det(cbind(v1,v2)))/sqrt(sum(v1*v1))
              })
  order(d,decreasing=TRUE)[1]
}