Commit db6f5d7c authored by Eric Coissac's avatar Eric Coissac

Initial commit

parents
^.*\.Rproj$
^\.Rproj\.user$
.Rproj.user
.Rhistory
.RData
.Ruserdata
Package: ROBITools2
Type: Package
Title: What the Package Does (Title Case)
Version: 0.1.0
Author: Who wrote it
Maintainer: The package maintainer <yourself@somewhere.net>
Description: More about what it does (maybe more than one line)
Use four spaces when indenting paragraphs within the Description.
License: What license is it under?
Encoding: UTF-8
LazyData: true
RoxygenNote: 6.0.1
Imports: tidyverse
Suggests: vegan,
roxygen2,
knitr,
rmarkdown
Collate:
'color.R'
'utils.R'
'robiobject.R'
'dplyr.R'
'fasta.R'
'robimetabar.R'
'taxonomy.R'
'vegan.R'
# Generated by roxygen2: do not edit by hand
S3method("$",robimetabar)
S3method("$<-",robimetabar)
S3method("[",robiobject)
S3method("[[",robimetabar)
S3method("[[<-",robimetabar)
S3method("motus<-",robimetabar)
S3method("samples<-",robimetabar)
S3method(as_tibble,robiobject)
S3method(decostand,"NULL")
S3method(decostand,default)
S3method(decostand,robimetabar)
S3method(dim,robimetabar)
S3method(dimnames,robidata)
S3method(dimnames,robimetabar)
S3method(filter,robiobject)
S3method(motus,robimetabar)
S3method(names,robimetabar)
S3method(samples,robimetabar)
export("motus<-")
export("samples<-")
export(Fasta.reader)
export(build.robimetabar)
export(colors.tol)
export(decostand)
export(ecofind)
export(family)
export(genus)
export(gradient.tol1)
export(gradient.tol2)
export(is.robiobject)
export(is.subcladeof)
export(kingdom)
export(lowest.common.ancestor)
export(make.robiobject)
export(motus)
export(ntaxa)
export(parent)
export(rainbow.tol)
export(rank.list)
export(read.fasta)
export(robiclass)
export(samples)
export(scientificname)
export(species)
export(superkingdom)
export(taxid.list)
export(taxid.max)
export(taxid.min)
export(taxid.validate)
export(taxon.at.rank)
export(taxon.path)
export(taxonomic.rank)
export(unmake.robiobject)
import(dplyr)
import(stringr)
import(tibble)
#' Qualitative color schemes by Paul Tol
#'
#' Provide a set of color palette covenient even for blind color people
#'
#' @param n the minimal number of color you are interested in
#' @param alpha the transparency value between $0$ full transparency
#' and $1$ for opaque colors.
#' @return a character vector containing hexadecimal color codes
#'
#' @examples
#' x = colors.tol(10,0.5)
#' x
#' plot(1:10,1:10,col=x,cex=1:10,pch=16)
#'
#' @see <http://www.sron.nl/~pault/>
#' @export
colors.tol = function(n,alpha=1) {
color.tol = list(
"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"),
"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"),
"18" = c("#771155", "#AA4488", "#CC99BB", "#114477",
"#4477AA", "#77AADD", "#117777", "#44AAAA",
"#77CCCC", "#777711", "#AAAA44", "#DDDD77",
"#774411", "#AA7744", "#DDAA77", "#771122",
"#AA4455", "#DD7788"),
"21" = c("#771155", "#AA4488", "#CC99BB", "#114477",
"#4477AA", "#77AADD", "#117777", "#44AAAA",
"#77CCCC", "#117744", "#44AA77", "#88CCAA",
"#777711", "#AAAA44", "#DDDD77", "#774411",
"#AA7744", "#DDAA77", "#771122", "#AA4455",
"#DD7788")
)
if (n > 21)
stop("Only color schemas with at maximum 21 colors are handled")
limits = as.integer(names(color.tol))
n.tol = as.character(limits[n <= limits][1])
tol = color.tol[[n.tol]]
hex.alpha = toupper(as.hexmode(floor(alpha * 255)))
tol.alpha = paste(tol,hex.alpha,sep="")
return(tol.alpha)
}
#' Colors for variations around 0 (blue-red)
#' @see <http://www.sron.nl/~pault/>
#' @export
gradient.tol1 = function(x,alpha=1) {
rcol = function(x) 0.237 - 2.13*x + 26.92*x**2 - 65.5*x**3 + 63.5*x**4 - 22.36*x**5
gcol = function(x) ((0.572 + 1.524*x - 1.811*x**2)/(1 - 0.291*x + 0.1574*x**2))**2
bcol = function(x) 1/(1.579 - 4.03*x + 12.92*x**2 - 31.4*x**3 + 48.6*x**4 - 23.36*x**5)
return(rgb(rcol(x),gcol(x),bcol(x),alpha))
}
#' Gradient colors,
#' @see <http://www.sron.nl/~pault/>
#'
#' @export
gradient.tol2 = function(x,alpha=1) {
rcol = function(x) (1 - 0.392*(1 + erf((x - 0.869)/ 0.255)))
gcol = function(x) (1.021 - 0.456*(1 + erf((x - 0.527)/ 0.376)))
bcol = function(x) (1 - 0.493*(1 + erf((x - 0.272)/ 0.309)))
return(rgb(rcol(x),gcol(x),bcol(x),alpha))
}
#' Rainbow gradient colors,
#' @see <http://www.sron.nl/~pault/>
#'
#' @export
rainbow.tol = function(x,alpha=1) {
rcol = function(x) (0.472-0.567*x+4.05*x**2)/(1.+8.72*x-19.17*x**2+14.1*x**3)
gcol = function(x) 0.108932-1.22635*x+27.284*x**2-98.577*x**3+163.3*x**4-131.395*x**5+40.634*x**6
bcol = function(x) 1./(1.97+3.54*x-68.5*x**2+243*x**3-297*x**4+125*x**5)
return(rgb(rcol(x),gcol(x),bcol(x),alpha))
}
#' @import dplyr
#' @include robiobject.R
NULL
#' @author Eric Coissac
#' @export
filter.robiobject = function(.data, ...) {
attrib=attributes(.data)
message("filter.robiobject : ",
deparse(attrib))
rep = NextMethod("filter")
return(.set_robiattribs(rep,
attrib = attrib,
set.class=TRUE))
}
\ No newline at end of file
#' @include robiseq.R
#' @import stringr
#'
NULL
#' @author Eric Coissac
#' @export
Fasta.reader = function(con,chunk.size=100000) {
previous.sequence = NULL
previous.header = NULL
headers = character(0)
ids = character(0)
sequences = character(0)
finnished = FALSE
current.seq = 0
read.chunk = function() {
# I read chunk.size lines from the connection
buffer.lines = readLines(con = con,n = chunk.size)
n.lines = length(buffer.lines)
# If I actually read less than chunk.size this means that
# the file is ended
finnished <<- n.lines < chunk.size
# I match the header lines
header.idx = stringr::str_detect(buffer.lines,
"^>")
seq.idx = 0
seq.factor = integer(n.lines)
for (i in seq_len(n.lines)){
if (header.idx[i]) seq.idx = seq.idx + 1
seq.factor[i]=seq.idx
}
# I put the header line on one side
header.lines = buffer.lines[header.idx]
# The sequence lines on the other
header.idx = ! header.idx
sequence.lines = buffer.lines[header.idx]
# Sequence lines bellonging the same sequence are pasted
seq.factor = seq.factor[header.idx]
sequences <<- tapply(X = sequence.lines,
INDEX = seq.factor,
FUN = paste,
collapse="",
simplify = TRUE)
# We have already read the beginning of the sequence
if (! is.null(previous.sequence) && seq.factor[1]==0) {
sequences[1] <<- paste(previous.sequence,sequences[1])
header.lines = append(header.lines,
previous.header,
after = 0)
}
if (! finnished) {
# The file is not finnished, I save the last sequence
n = length(sequences)
previous.header <<- header.lines[n]
previous.sequence <<- sequences[n]
}
else {
# The file is finnished, store NULL
previous.header <<- NULL
previous.sequence <<- NULL
}
# Divide the header in ids and titles
header.lines = stringr::str_split(string = header.lines,
pattern = " ",
n = 2,simplify = TRUE)
ids <<- str_sub(header.lines[,1],2,-1)
headers <<- header.lines[,2]
current.seq <<- 0
}
fasta.iterator = function() {
if (current.seq==length(headers)) {
if (finnished)
return(NULL)
else
read.chunk()
}
current.seq <<- current.seq + 1
return(list(id=ids[current.seq],
header=headers[current.seq],
sequence=sequences[current.seq]))
}
if (is.character(con))
con = file(con[1])
return(fasta.iterator)
}
#' @author Eric Coissac
#' @export
read.fasta = function(con,n=-1L,chunk.size=100000) {
previous.lines = character(0)
continue = TRUE
while(continue) {
str_detect(string, pattern)
}
}
This diff is collapsed.
#' @include utils.R
NULL
.set_robiattribs = function(object,
attrib,
set.class=FALSE) {
# message(".set_robiattribs : ",
# deparse(attrib))
oattrib = attributes(object)
oattrib.names = names(oattrib)
classes = attrib$class
special.attribs = c('dim','row.names','names','dimnames','class')
for (i in seq_along(special.attribs))
if (special.attribs[i] %in% oattrib.names)
attrib[[special.attribs[i]]] = oattrib[[special.attribs[i]]]
else
attrib[[special.attribs[i]]] = NULL
if (set.class) {
rclass = which('robiobject'==classes)
attrib$class = c(classes[1:rclass],
attrib$class)
}
attributes(object)=attrib
return(object)
}
#' @author Eric Coissac
#' @export
is.robiobject = function(object) {
'robiobject' %in% class(object)
}
#' @author Eric Coissac
#' @export
make.robiobject = function(object,
robiclass = 'robiobject') {
if (is.robiobject(object))
object = unmake.robiobject(object)
if (! 'robiobject' %in% robiclass) {
robiclass = c(robiclass,"robiobject")
}
attributes(object)$class = c(robiclass,
class(object))
return(object)
}
#' @author Eric Coissac
#' @export
unmake.robiobject = function(object) {
if (is.robiobject(object)) {
classes = class(object)
nclasses = length(classes)
rclass = which('robiobject'==classes)+1
attributes(object)$class = classes[rclass:nclasses]
if (length(class(object))==1 && is.atomic(object))
class(object)=NULL
}
return(object)
}
#' @author Eric Coissac
#' @export
robiclass = function(object) {
if (is.robiobject(object)) {
classes = class(object)
nclasses = length(classes)
rclass = which('robiobject'==classes)
return(classes[1:rclass])
}
}
#' @author Eric Coissac
#' @export
`[.robiobject` = function(x, ...,drop=FALSE) {
x = unmake.robiobject(x)
rep = x[...,drop=drop]
attrib = attributes(x)
return(make.robiobject(.set_robiattribs(rep,attrib)))
}
#' @author Eric Coissac
#' @export
as_tibble.robiobject = function (x, ...)
{
f = formals(as_tibble.robiobject)
fn= names(f)
call = match.call()
for (i in seq_along(f)) {
if (fn[i]!='...' &&
nzchar(f[[i]]) &&
is.null(call[[fn[i]]])
) call[[fn[i]]] = f[[i]]
}
call[[1]] = quote(as_tibble)
ux=unmake.robiobject(x)
call$x = quote(ux)
rep=eval(call)
return(make.robiobject(rep))
}
\ No newline at end of file
This diff is collapsed.
#'
#' https://stackoverflow.com/questions/11885207/get-all-parameters-as-list
#'
.allargs <- function(orig_values = FALSE) {
# get formals for parent function
parent_formals <- formals(sys.function(sys.parent(n = 1)))
# Get names of implied arguments
fnames <- names(parent_formals)
# Remove '...' from list of parameter names if it exists
fnames <- fnames[-which(fnames == '...')]
# Get currently set values for named variables in the parent frame
args <- evalq(as.list(environment()), envir = parent.frame())
# Get the list of variables defined in '...'
args <- c(args[fnames], evalq(list(...), envir = parent.frame()))
if(orig_values) {
# get default values
defargs <- as.list(parent_formals)
defargs <- defargs[unlist(lapply(defargs, FUN = function(x) class(x) != "name"))]
args[names(defargs)] <- defargs
setargs <- evalq(as.list(match.call())[-1], envir = parent.frame())
args[names(setargs)] <- setargs
}
return(args)
}
has.vegan = suppressMessages(require(vegan,
quietly = TRUE))
# message(has.vegan)
#' @author Eric Coissac
#' @export
decostand = function(x=NULL, method,
MARGIN, range.global,
logbase,
na.rm,
layer = "reads",
...) {
# message("Generic call with class: ",deparse(class(x)))
# message(deparse(match.call()))
UseMethod("decostand",x)
}
#' @author Eric Coissac
#' @export
decostand.default = function(x, method,
MARGIN, range.global,
logbase,
na.rm,
layer,
...) {
call = match.call()
call[[1]]=quote(vegan::decostand)
call$layer=NULL
# message("From decostand.default : ",deparse(call))
eval(call)
}
#' @author Eric Coissac
#' @export
decostand.NULL = function(x, method,
MARGIN, range.global,
logbase,
na.rm,
layer = "reads",
...) {
closure = function(data) {
call$x=quote(data)
eval(call)
}
call = match.call()
call[[1]]=quote(decostand)
return(closure)
}
#' @author Eric Coissac
#' @export
decostand.robimetabar = function(x, method,
MARGIN, range.global,
logbase,
na.rm,
layer="reads",
...) {
call = match.call()
call$x=x[[layer]]
call$layer=NULL
call[[1]]=quote(decostand.default)
# message("ROBIMetabar class: ",deparse(call))
# message(deparse(match.call()))
rep = eval(call)
return(rep)
}
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: ISO-8859-1
RnwWeave: knitr
LaTeX: pdfLaTeX
StripTrailingWhitespace: Yes
BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageRoxygenize: rd,collate,namespace,vignette
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/color.R
\name{colors.tol}
\alias{colors.tol}
\title{Qualitative color schemes by Paul Tol}
\usage{
colors.tol(n, alpha = 1)
}
\arguments{
\item{n}{the minimal number of color you are interested in}
\item{alpha}{the transparency value between $0$ full transparency
and $1$ for opaque colors.}
}
\value{
a character vector containing hexadecimal color codes
}
\description{
Provide a set of color palette covenient even for blind color people
}
\examples{
x = colors.tol(10,0.5)
x
plot(1:10,1:10,col=x,cex=1:10,pch=16)
}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/taxonomy.R
\name{ecofind}
\alias{ecofind}
\title{Returns taxids associated to the names}
\usage{
ecofind(taxonomy, patterns, rank = NULL, alternative = FALSE,
exact = TRUE, case.sensitive = FALSE, drop = TRUE)
}
\arguments{
\item{taxonomy}{an object able to provide a taxonomy.}
\item{patterns}{one or several regular pattern used to select the the taxa.}
\item{rank}{a \code{character} indicating a taxonomic rank. If not \code{NULL}
only taxids correponding to this rank are returned.}
\item{alternative}{A logical value \code{TRUE} or \code{FALSE} indicating
if the function must only look for a scientific name.}
}
\value{
if just one pattern is given, an integer vector is returned with the
corresponding taxids. If a list of patterns is given, the function
returns a list of integer vectors, each vector containing the taxids
corresponding to a pattern. The returned list is in the same order
than the given patern list.
}
\description{
Return the set of taxids having their name matching the given pattern.
}
\author{
Eric Coissac
}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/taxonomy.R
\name{family}
\alias{family}
\title{Extracts the family corresponding to a taxid}
\usage{
family(taxonomy, taxid, name = FALSE, na.rm = TRUE)
}
\arguments{
\item{taxonomy}{an object able to provide a taxonomy.}
\item{taxid}{a vector of taxid to analyse}
\item{name}{A logical value \code{TRUE} or \code{FALSE} indicating
if the method return a taxid or a scientific name.}
}
\value{
\describe{
\item{If \code{name==FALSE}}{the taxid of the corresponding
taxon as an integer or a vector of integers
if the \code{taxid} argument is itself
a vector}
\item{If \code{name==TRUE}}{the scientific name of the corresponding
taxon as a string or a vector of string
if the \code{taxid} argument is itself
a vector}
}
}
\description{
The \code{family} method of \code{\linkS4class{obitools.taxonomy}} class
returns the \emph{taxid} or the scientific name of the family corresponding
to a \emph{taxid}.
}
\author{
Eric Coissac
}
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/taxonomy.R
\name{genus}
\alias{genus}
\title{Extracts the genus corresponding to a taxid}
\usage{
genus(taxonomy, taxid, name = FALSE, na.rm = TRUE)
}
\arguments{
\item{taxonomy}{an object able to provide a taxonomy.}
\item{taxid}{a vector of taxid to analyse}