miga-base 1.2.15.2 → 1.2.15.4

data/utils/enveomics/enveomics.R/R/barplot.R

@@ -1,184 +0,0 @@
-#' Enveomics: Barplot
-#' 
-#' Creates nice barplots from tab-delimited tables.
-#'
-#' @param x Can be either the input data or the path to the file containing 
-#' the table. 
-#' \itemize{
-#'    \item{If it contains the data, it must be a data frame or an
-#'    object coercible to a data frame.} 
-#'    \item{If it is a path, it must point to a
-#'    tab-delimited file containing a header (first row) and row names 
-#'    (first column).}
-#'    }
-#' @param sizes  A numeric vector containing the real size of the samples
-#' (columns) in the same order of the input table. If set, the values are
-#' assumed to be 100\%. Otherwise, the sum of the columns is used.
-#' @param top Maximum number of categories to display. Any additional
-#' categories will be listed as "Others".
-#' @param colors.per.group Number of categories in the first two saturation 
-#' groups of colors. The third group contains the remaining categories if 
-#' needed.
-#' @param bars.width Width of the barplot with respect to the legend.
-#' @param legend.ncol Number of columns in the legend.
-#' @param other.col Color of the "Others" category.
-#' @param add.trend Controls if semi-transparent areas are to be plotted
-#' between the bars to connect the regions (trend regions).
-#' @param organic.trend Controls if the trend regions are to be smoothed 
-#' (curves). By default, trend regions have straight edges. If \code{TRUE}, 
-#' forces \code{add.trend=TRUE}.
-#' @param sort.by Any function that takes a numeric vector and returns a
-#' numeric scalar. This function is applied to each row, and the resulting
-#' values are used to sort the rows (decreasingly). Good options include: 
-#' \code{sd, min, max, mean, median}.
-#' @param min.report Minimum percentage to report the value in the plot.
-#' Any value above 100 indicates that no values are to be reported.
-#' @param order Controls how the rows should be ordered. 
-#' \itemize{
-#'    \item{If \code{NULL} 
-#'    (default), \code{sort.by} is applied per row and the results are 
-#'    sorted decreasingly.}
-#'    \item{If \code{NA}, no sorting is performed, i.e., the original
-#'    order is respected.}
-#'    \item{If a vector is provided, it is assumed to be the 
-#'    custom order to be used (either by numeric index or by row names).}
-#'    }
-#' @param col Colors to use. If provided, overrides the variables \code{top}
-#' and \code{colors.per.group}, but \code{other.col} is still used if the 
-#' vector is insufficient for all the rows. An additional palette is available with
-#' \code{col='coto'} (contributed by Luis (Coto) Orellana).
-#' @param ... Any additional parameters to be passed to barplot.
-#' 
-#' @author Luis M. Rodriguez-R [aut, cre]
-#' 
-#' @examples
-#' # Load data
-#' data("phyla.counts", package="enveomics.R", envir=environment())
-#' # Create a barplot sorted by variance with organic trends
-#' enve.barplot(
-#'     phyla.counts, # Counts of phyla in four sites
-#'     sizes=c(250,100,75,200), # Total sizes of the datasets of each site
-#'     bars.width=2, # Decrease from default, so the names are fully displayed
-#'     organic.trend=TRUE, # Nice curvy background
-#'     sort.by=var # Sort by variance across sites
-#'     )
-#'
-#' @export
-
-enve.barplot <- function(
-  x,
-  sizes,
-  top=25,
-  colors.per.group=9,
-  bars.width=4,
-  legend.ncol=1,
-  other.col='#000000',
-  add.trend=FALSE,
-  organic.trend=FALSE,
-  sort.by=median,
-  min.report=101,
-  order=NULL,
-  col,
-  ...
-){
-  
-  # Read input
-  if(is.character(x)){
-    c <- read.table(x, sep='\t', header=TRUE, row.names=1, quote='',
-                    comment.char='')
-  }else{
-    c <- as.data.frame(x)
-  }
-  if(missing(sizes)) sizes = colSums(c)
-  p <- c
-  for (i in 1:ncol(c)) p[, i] <- c[, i]*100/sizes[i]
-  if(top > nrow(p)) top = nrow(p)
-  
-  # Sort
-  if(is.null(order[1])){
-    p <- p[order(apply(p, 1, sort.by)), ]
-  }else if(is.na(order[1])){
-    
-  }else{
-    p <- p[order, ]
-  }
-  if(organic.trend) add.trend=TRUE
-  
-  # Colors
-  if(is.null(top)) top <- nrow(p)
-  if(missing(col)){
-    color.col <- rainbow(min(colors.per.group, top), s=1, v=4/5)
-    if(top > colors.per.group) color.col <- c(color.col,
-                                              rainbow(min(colors.per.group*2, top)-colors.per.group, s=3/4, v=3/5))
-    if(top > colors.per.group*2) color.col <- c(color.col,
-                                                rainbow(top-colors.per.group*2, s=1, v=1.25/4))
-  }else if(length(col)==1 & col[1]=="coto"){
-    color.col <- c("#5BC0EB","#FDE74C","#9BC53D","#E55934","#FA7921","#EF476F",
-                   "#FFD166","#06D6A0","#118AB2","#073B4C","#264653","#2A9D8F",
-                   "#E9C46A","#F4A261","#E76F51")
-    color.col <- head(color.col, n=nrow(p))
-    top <- length(color.col)
-  }else{
-    color.col <- col
-    color.col <- tail(color.col, n=nrow(p))
-    top <- length(color.col)
-  }
-  
-  # Plot
-  layout(matrix(1:2, nrow=1), widths=c(bars.width,1))
-  mar <- par('mar')
-  par(mar=c(5,4,4,0)+0.1)
-  mp <- barplot(as.matrix(p),
-                col=rev(c(color.col, rep(other.col, nrow(p)-length(color.col)))),
-                border=NA,space=ifelse(add.trend,ifelse(organic.trend,0.75,0.5),0.2), ...)
-  if(add.trend || min.report < max(p)){
-    color.alpha <- enve.col.alpha(c(color.col, other.col), 1/4)
-    if(top < nrow(p)){
-      cf <- colSums(p[1:(nrow(p)-top), ])
-    }else{
-      cf <- rep(0, ncol(p))
-    }
-    for(i in (nrow(p)-top+1):nrow(p)){
-      f <- as.numeric(p[i, ])
-      cf <- as.numeric(cf + f)
-      if(nrow(p)-i < top){
-        if(organic.trend){
-          spc <- 0.5
-          x <- c(mp[1]-spc)
-          y1 <- c(cf[1]-f[1])
-          y2 <- c(cf[1])
-          for(j in 2:ncol(p)){
-            x <- c(x, seq(mp[j-1]+spc, mp[j]-spc, length.out=22))
-            y1 <- c(y1, cf[j-1]-f[j-1],
-                    (tanh(seq(-2.5,2.5,length.out=20))/2+.5)*
-                      ((cf[j]-f[j])-(cf[j-1]-f[j-1]))+(cf[j-1]-f[j-1]), cf[j]-f[j])
-            y2 <- c(y2, cf[j-1],
-                    (tanh(seq(-2.5,2.5,length.out=20))/2+.5)*
-                      (cf[j]-cf[j-1])+(cf[j-1]), cf[j])
-          }
-          x <- c(x, mp[length(mp)]+spc)
-          y1 <- c(y1, cf[length(cf)]-f[length(f)])
-          y2 <- c(y2, cf[length(cf)])
-          polygon(c(x, rev(x)), c(y1, rev(y2)), col=color.alpha[nrow(p)-i+1],
-                  border=NA)
-        }else if(add.trend){
-          x <- rep(mp, each=2)+c(-0.5,0.5)
-          if(add.trend) polygon(c(x, rev(x)),
-                                c(rep(cf-f, each=2), rev(rep(cf, each=2))),
-                                col=color.alpha[nrow(p)-i+1], border=NA)
-        }
-        text(mp, cf-f/2, ifelse(f>min.report, signif(f, 3), ''), col='white')
-      }
-    }
-  }
-  
-  # Legend
-  par(mar=rep(0,4)+0.1)
-  plot(1, t='n', bty='n', xlab='', ylab='', xaxt='n', yaxt='n')
-  nam <- rownames(p[nrow(p):(nrow(p)-top+1), ])
-  if(top < nrow(p)) nam <- c(nam,
-                             paste('Other (',nrow(p)-length(color.col),')', sep=''))
-  legend('center', col=c(color.col, other.col), legend=nam, pch=15, bty='n',
-         pt.cex=2, ncol=legend.ncol)
-  par(mar=mar)
-}

data/utils/enveomics/enveomics.R/R/cliopts.R

@@ -1,135 +0,0 @@
-#' Enveomics: Cliopts
-#' 
-#' Generates nicely formatted command-line interfaces for functions 
-#' (\strong{closures} only).
-#'
-#' @param fx Function for which the interface should be generated.
-#' @param rd_file (Optional) .Rd file with the standard documentation of 
-#' the function.
-#' @param positional_arguments (Optional) Number of \strong{positional} 
-#' arguments passed to \code{\link[optparse]{parse_args}} 
-#' (package: \pkg{optparse}).
-#' @param usage (Optional) Usage passed to \code{\link[optparse]{OptionParser}} 
-#' (package: \pkg{optparse}).
-#' @param mandatory Mandatory arguments.
-#' @param vectorize Arguments of the function to vectorize (comma-delimited).
-#' If numeric, use also \code{number}.
-#' @param ignore Arguments of the function to ignore.
-#' @param number Force these arguments as numerics. Useful for numeric
-#' vectors (see \code{vectorize}) or arguments with no defaults.
-#' @param defaults Defaults to use instead of the ones provided by the 
-#' formals.
-#' @param o_desc Descriptions of the options. Help from \code{rd} is ignored
-#' for arguments present in this list.
-#' @param p_desc Description Description of the function. Help from \code{rd} 
-#' is ignored for the function description unless this value is an empty string.
-#' 
-#' @return Returns a list with keys: 
-#' \itemize{
-#'    \item{\code{options}, a named list with the values for the function's 
-#'    arguments} 
-#'    \item{\code{args}, a vector with zero or more strings containing the
-#'    positional arguments}}
-#'
-#' @author Luis M. Rodriguez-R [aut, cre]
-#'
-#' @export
-
-enve.cliopts <- function(
-  fx,
-  rd_file,
-  positional_arguments,
-  usage,
-  mandatory=c(),
-  vectorize=c(),
-  ignore=c(),
-  number=c(),
-  defaults=list(),
-  o_desc=list(),
-  p_desc=""
-){
-  
-  #= Load stuff
-  if(!suppressPackageStartupMessages(
-    requireNamespace("optparse", quietly=TRUE)))
-    stop("Package 'optparse' is required.")
-  requireNamespace("tools", quietly=TRUE)
-  if(missing(positional_arguments)) positional_arguments <- FALSE
-  if(missing(usage)) usage <- "usage: %prog [options]"
-  
-  #= Get help (if any)
-  if(!missing(rd_file)){
-    rd <- tools::parse_Rd(rd_file)
-    for(i in 1:length(rd)){
-      tag <- attr(rd[[i]],'Rd_tag')
-      if(tag=="\\description" && p_desc==""){
-        p_desc <- paste("\n\t",as.character(rd[[i]]),sep='')
-      }else if(tag=="\\arguments"){
-        for(j in 1:length(rd[[i]])){
-          if(length(rd[[i]][[j]])==2){
-            name <- as.character(rd[[i]][[j]][[1]])
-            if(length(o_desc[[name]])==1) next
-            desc <- as.character(rd[[i]][[j]][[2]])
-            o_desc[[name]] <- paste(gsub("\n","\n\t\t",desc), collapse='')
-          }
-        }
-      }
-    }
-  }
-  
-  #= Set options
-  o_i <- 0
-  opts <- list()
-  f <- formals(fx)
-  if(length(defaults)>0){
-    for(i in 1:length(defaults)) f[[names(defaults)[i]]] <- defaults[[i]]
-  }
-  for(i in names(f)){
-    if(i=="..." || i %in% ignore) next
-    o_i <- o_i + 1
-    flag <- gsub("\\.","-",i)
-    
-    optopt <- list(help="")
-    if(length(o_desc[[i]])==1) optopt$help <- o_desc[[i]]
-    if(!is.null(f[[i]]) && !suppressWarnings(is.na(f[[i]])) && is.logical(f[[i]])){
-      optopt$opt_str <- paste(ifelse(f[[i]], "--no-", "--"), flag, sep='')
-      optopt$action  <- ifelse(f[[i]], "store_false", "store_true")
-    }else{
-      optopt$opt_str <- paste("--", flag, sep='')
-      optopt$action  <- "store"
-      optopt$help <- paste(optopt$help, "\n\t\t[",
-                           ifelse(i %in% mandatory, "** MANDATORY", "default %default"),
-                           ifelse(i %in% vectorize, ", separate values by commas", ""),
-                           "].", sep="")
-    }
-    if(!is.name(f[[i]])){
-      optopt$default <- f[[i]]
-      optopt$metavar <- class(f[[i]])
-    }
-    if(i %in% number) optopt$metavar <- "NUMERIC"
-    optopt$dest <- i
-    
-    opts[[o_i]] <- do.call(optparse::make_option, optopt)
-  }
-  opt <- optparse::parse_args(
-    optparse::OptionParser(option_list=opts, description=p_desc, usage=usage),
-    positional_arguments=positional_arguments)
-  
-  #= Post-hoc checks
-  if(length(opt[['options']])==0) opt <- list(options=opt, args=c())
-  for(i in mandatory){
-    if(length(opt$options[[i]])==0) stop('Missing mandatory argument: ',i)
-  }
-  for(i in vectorize){
-    if(length(opt$options[[i]])==1)
-      opt$options[[i]] <- strsplit(opt$options[[i]],",")[[1]]
-  }
-  for(i in number){
-    if(length(opt$options[[i]])>0)
-      opt$options[[i]] <- as.numeric(opt$options[[i]])
-  }
-  opt$options$help <- NULL
-  
-  return(opt)
-}
-

data/utils/enveomics/enveomics.R/R/df2dist.R

@@ -1,154 +0,0 @@
-#' Enveomics: Data Frame to Dist
-#' 
-#' Transform a dataframe (or coercible object, like a table) into a
-#' \strong{dist} object.
-#' 
-#' @param x A dataframe (or coercible object) with at least three columns:
-#' \enumerate{
-#'    \item ID of the object 1, 
-#'    \item ID of the object 2, and 
-#'    \item distance between the two objects.}
-#' @param obj1.index Index of the column containing the ID of the object 1.
-#' @param obj2.index Index of the column containing the ID of the object 2.
-#' @param dist.index Index of the column containing the distance.
-#' @param default.d Default value (for missing values).
-#' @param max.sim If not zero, assumes that the values are similarity
-#' (not distance) and this is the maximum similarity (corresponding to 
-#' distance 0). Applies transformation: 
-#' \eqn{distance = (max.sim - values)/max.sim.}
-#' 
-#' @return Returns a \strong{dist} object.
-#' 
-#' @author Luis M. Rodriguez-R [aut, cre]
-#' 
-#' @export
-
-enve.df2dist <- function(
-  x,
-  obj1.index = 1,
-  obj2.index = 2,
-  dist.index = 3,
-  default.d = NA,
-  max.sim = 0
-){
-  x <- as.data.frame(x)
-  a <- as.character(x[, obj1.index])
-  b <- as.character(x[, obj2.index])
-  d <- as.double(x[, dist.index])
-  if(max.sim != 0) d <- (max.sim - d) / max.sim
-  ids <- unique(c(a,b))
-  m <- matrix(default.d,
-    nrow = length(ids), ncol = length(ids), dimnames = list(ids, ids))
-  diag(m) <- 0.0
-  m[cbind(a,b)] <- d
-  m <- pmin(m, t(m), na.rm = TRUE)
-  return(as.dist(m))
-}
-
-#' Enveomics: Data Frame to Dist (Group)
-#' 
-#' Transform a dataframe (or coercible object, like a table) into a 
-#' \strong{dist} object, where there are 1 or more distances between each pair 
-#' of objects.
-#' 
-#' @param x A dataframe (or coercible object) with at least three columns:
-#' \enumerate{
-#'    \item ID of the object 1, 
-#'    \item ID of the object 2, and 
-#'    \item distance between the two objects.}
-#' @param obj1.index Index of the column containing the ID of the object 1.
-#' @param obj2.index Index of the column containing the ID of the object 2.
-#' @param dist.index Index of the column containing the distance.
-#' @param summary Function summarizing the different distances between the 
-#' two objects.
-#' @param empty.rm Remove rows with empty or \code{NA} groups.
-#' 
-#' @return Returns a \strong{dist} object.
-#'
-#' @author Luis M. Rodriguez-R [aut, cre]
-#' 
-#' @export
-
-enve.df2dist.group <- function(
-  x,
-  obj1.index=1,
-  obj2.index=2,
-  dist.index=3,
-  summary=median,
-  empty.rm=TRUE
-){
-  x <- as.data.frame(x);
-  if(empty.rm) x <- x[ !(is.na(x[,obj1.index]) | is.na(x[,obj2.index]) | x[,obj1.index]=='' | x[,obj2.index]==''), ]
-  a <- as.character(x[, obj1.index]);
-  b <- as.character(x[, obj2.index]);
-  d <- as.double(x[, dist.index]);
-  ids <- unique(c(a,b));
-  if(length(ids)<2) return(NA);
-  m <- matrix(NA, nrow=length(ids), ncol=length(ids), dimnames=list(ids, ids));
-  diag(m) <- 0
-  for(i in 2:length(ids)){
-    id.i <- ids[i];
-    for(j in 1:(i-1)){
-      id.j <- ids[j];
-      d.ij <- summary(c( d[ a==id.i & b==id.j], d[ b==id.i & a==id.j] ));
-      m[id.i, id.j] <- d.ij;
-      m[id.j, id.i] <- d.ij;
-    }
-  }
-  return(as.dist(m));
-}
-
-#' Enveomics: Data Frame to Dist (List)
-#' 
-#' Transform a dataframe (or coercible object, like a table)
-#' into a \strong{dist} object.
-#' 
-#' @param x A dataframe (or coercible object) with at least three columns:
-#' \enumerate{
-#'    \item ID of the object 1, 
-#'    \item ID of the object 2, and 
-#'    \item distance between the two objects.}
-#' @param groups Named array where the IDs correspond to the object IDs,
-#' and the values correspond to the group.
-#' @param obj1.index Index of the column containing the ID of the object 1.
-#' @param obj2.index Index of the column containing the ID of the object 2.
-#' @param dist.index Index of the column containing the distance.
-#' @param empty.rm Remove incomplete matrices.
-#' @param ... Any other parameters supported by
-#' \code{\link{enve.df2dist.group}}.
-#' 
-#' @return Returns a \strong{list} of \strong{dist} objects.
-#'
-#' @author Luis M. Rodriguez-R [aut, cre]
-#' 
-#' @export
-
-enve.df2dist.list <- function(
-  x,
-  groups,
-  obj1.index=1,
-  obj2.index=2,
-  dist.index=3,
-  empty.rm=TRUE,
-  ...
-){
-  x <- as.data.frame(x);
-  a <- as.character(x[, obj1.index]);
-  b <- as.character(x[, obj2.index]);
-  d <- as.numeric(x[, dist.index]);
-  ids.all <- unique(c(a,b));
-  l <- list();
-  same_group <- groups[a]==groups[b];
-  same_group <- ifelse(is.na(same_group), FALSE, TRUE);
-  for(group in unique(groups)){
-    ids <- ids.all[ groups[ids.all]==group ];
-    if(length(ids)>1 & group!=""){
-      x.sub <- x[ same_group & (groups[a]==group) & (groups[b]==group), ]
-      if(nrow(x.sub)>0){
-        d.g <- enve.df2dist(x.sub, obj1.index, obj2.index, dist.index, ...);
-        if(!empty.rm | !any(is.na(d.g))) l[[ group ]] <- d.g;
-      }
-    }
-  }
-  return(l);
-}