miga-base 0.7.26.0 → 0.7.26.1

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

@@ -0,0 +1,184 @@
+#' 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

@@ -0,0 +1,135 @@
+#' 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

@@ -0,0 +1,154 @@
+#' 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);
+}