540 lines
13 KiB
R
540 lines
13 KiB
R
#' @include ROBITools.R
|
|
#' @include s3objects.R
|
|
#' @import ROBITaxonomy
|
|
NULL
|
|
|
|
require(ROBITaxonomy)
|
|
|
|
#
|
|
# FOR THE DEVELOPPER : we have to check that the code doesn't relies on the
|
|
# fact that the xx@samples$sample column is not always
|
|
# identical to the rownames(xx@samples)
|
|
|
|
setClassUnion("characterOrNULL",c("character","NULL"))
|
|
setClassUnion("matrixOrfactorL",c("matrix","factor"))
|
|
|
|
#
|
|
# We specialize data.frame in two subclasses motus.frame and samples.frame
|
|
# for this we add to function insuring the type checking and the cast from
|
|
# data.frame
|
|
#
|
|
|
|
is.motus.frame= function(x) any(class(x)=="motus.frame")
|
|
is.samples.frame= function(x) any(class(x)=="samples.frame")
|
|
|
|
as.motus.frame= function(x) {
|
|
if (! is.data.frame(x))
|
|
stop("only cast from data.frame is allowed")
|
|
if (! is.motus.frame(x))
|
|
x = addS3Class(x,"motus.frame")
|
|
|
|
return(x)
|
|
}
|
|
|
|
|
|
as.samples.frame= function(x) {
|
|
if (! is.data.frame(x))
|
|
stop("only cast from data.frame is allowed")
|
|
if (! is.samples.frame(x))
|
|
x = addS3Class(x,"samples.frame")
|
|
return(x)
|
|
}
|
|
|
|
samples.frame=as.samples.frame
|
|
motus.frame=as.motus.frame
|
|
|
|
as.factor.or.matrix = function(x) {
|
|
if (is.matrix(x))
|
|
return(x)
|
|
|
|
if (is.factor(x)){
|
|
if (length(dim(x))!=2)
|
|
stop('Just factor with two dimensions are allowed')
|
|
return(x)
|
|
}
|
|
|
|
if (!is.data.frame(x))
|
|
stop('Just matrix, 2D factor and data.frame can be casted')
|
|
|
|
tps = sapply(x,class)
|
|
allna = sapply(x, function(y) all(is.na(y)))
|
|
|
|
if (all(tps==tps[[1]] | allna)) {
|
|
tps = tps[[1]]
|
|
}
|
|
else
|
|
stop('all the column of the data.frame must have the same type')
|
|
|
|
tps = tps[[1]]
|
|
|
|
x = as.matrix(x)
|
|
dx = dim(x)
|
|
if (tps=='factor')
|
|
x = factor(x)
|
|
dim(x)=dx
|
|
|
|
return(x)
|
|
}
|
|
|
|
#' DNA metabarcoding experiment description class
|
|
#'
|
|
#' A S4 class describing a DNA metabarcoding experiment. It groups
|
|
#' three data frames describing samples, motus and occurrences of
|
|
#' MOTUs per sample
|
|
#'
|
|
#'@section Slots:
|
|
#' \describe{
|
|
#' \item{\code{reads}:}{Matrix of class \code{"numeric"},
|
|
#' containing the counts of reads per samples
|
|
#' \itemize{
|
|
#' \item{1 samples per line}
|
|
#' \item{1 sequence per column}
|
|
#' }
|
|
#' }
|
|
#'
|
|
#' \item{\code{samples}:}{Object of class \code{"data.frame"}, describing samples
|
|
#' \itemize{
|
|
#' \item{1 samples per line}
|
|
#' \item{1 property per column}
|
|
#' }
|
|
#' }
|
|
#'
|
|
#' \item{\code{motus}:}{Object of class \code{"data.frame"}, describing MOTUs (sequences)
|
|
#' \itemize{
|
|
#' \item{1 MOTU per line}
|
|
#' \item{1 property per column}
|
|
#' }
|
|
#' }
|
|
#'
|
|
#' \item{\code{layers}:}{Object of class \code{"list"}, containing a set of data layers
|
|
#' linking motus and samples. Each element of the list is a matrix
|
|
#' of the same size than the \code{read} slot with
|
|
#' \itemize{
|
|
#' \item{1 samples per line}
|
|
#' \item{1 sequence per column}
|
|
#' }
|
|
#' }
|
|
#'
|
|
#' \item{\code{scount}:}{Object of class \code{"integer"}, containing the count of sample}
|
|
#'
|
|
#' \item{\code{mcount}:}{Object of class \code{"integer"}, containing the count of MOTUs}
|
|
#'
|
|
#' \item{\code{sample.margin}:}{Vector of class \code{"numeric"}, describing the total count of
|
|
#' sequence per sample. By default this slot is set by applying sum
|
|
#' to the reads data.frame lines}
|
|
#'
|
|
#' \item{\code{taxonomy}:}{Object of class \code{"taxonomy.obitools"}, linking the DNA metabarcoding
|
|
#' experiment to a taxonomy}
|
|
#'
|
|
#' \item{\code{taxid}:}{Vector of class \code{"character"}, list of MOTUs' attributes to manage as taxid}
|
|
#' }
|
|
#'
|
|
#' @seealso \code{\link{taxonomy.obitools}},
|
|
#' @name metabarcoding.data
|
|
#' @rdname metabarcoding-data-class
|
|
#' @keywords DNA metabarcoding
|
|
#' @author Eric Coissac
|
|
#' @exportClass metabarcoding.data
|
|
|
|
setClass("metabarcoding.data",
|
|
|
|
|
|
#
|
|
# Attribute declaration
|
|
#
|
|
|
|
representation(reads = "matrix",
|
|
samples = "data.frame",
|
|
motus = "data.frame",
|
|
layers = "list",
|
|
scount = "integer",
|
|
mcount = "integer",
|
|
sample.margin = "numeric",
|
|
taxonomy = "obitools.taxonomyOrNULL",
|
|
taxid = "characterOrNULL"
|
|
),
|
|
|
|
#
|
|
# Check object structure
|
|
#
|
|
|
|
validity = function(object) {
|
|
|
|
## object : nom reserve !
|
|
|
|
#
|
|
# Check that reads / samples and motus data.frames
|
|
# have compatible sizes
|
|
#
|
|
# reads line count = samples line count
|
|
# reads column count = motus line count
|
|
|
|
rsize = dim(object@reads)
|
|
ssize = dim(object@samples)
|
|
msize = dim(object@motus)
|
|
csize = length(object@sample.margin)
|
|
|
|
if (rsize[1] != ssize[1] &
|
|
rsize[2] != msize[1] &
|
|
rsize[1] != csize)
|
|
return(FALSE)
|
|
|
|
|
|
# if no layer, object is ok
|
|
|
|
if (length(object@layers)==0)
|
|
return(TRUE)
|
|
|
|
# otherwise we check the size of each layer as we
|
|
# did for reads
|
|
|
|
return(! any(sapply(object@layers,
|
|
function(l) any(dim(l)!=c(ssize[1],msize[1])))))
|
|
|
|
}
|
|
)
|
|
|
|
|
|
|
|
#
|
|
#' metabarcoding.data constructor
|
|
#'
|
|
#' @docType methods
|
|
#' @rdname initialize-methods
|
|
#' @aliases initialize-methods,metabarcoding.data
|
|
setMethod("initialize",
|
|
"metabarcoding.data",
|
|
function(.Object, reads,samples,motus,
|
|
taxonomy=NULL,taxid=NULL,
|
|
sample.margin=NA,
|
|
layers=list()) {
|
|
|
|
rn = rownames(reads)
|
|
cn = colnames(reads)
|
|
|
|
.Object@reads <- reads
|
|
|
|
# .Object@samples <- as.samples.frame(samples)
|
|
.Object@samples <- samples
|
|
row.names(.Object@samples) = rn
|
|
|
|
#.Object@motus <- as.motus.frame(motus)
|
|
.Object@motus <- motus
|
|
row.names(.Object@motus) = cn
|
|
|
|
|
|
# Set colnames and rownames to each layers
|
|
layers = lapply(layers, function(x) {colnames(x)=cn
|
|
rownames(x)=rn
|
|
return(x)})
|
|
.Object@layers <- layers
|
|
|
|
# Precompute sample count and motu count
|
|
|
|
.Object@scount = dim(.Object@samples)[1]
|
|
.Object@mcount = dim(.Object@motus)[1]
|
|
|
|
.Object@taxonomy = taxonomy
|
|
.Object@taxid = taxid
|
|
|
|
if (is.null(sample.margin))
|
|
.Object@sample.margin = rowSums(reads)
|
|
else
|
|
.Object@sample.margin = sample.margin
|
|
|
|
names(.Object@sample.margin) = rn
|
|
|
|
validObject(.Object) ## valide l'objet
|
|
|
|
return(.Object)
|
|
})
|
|
|
|
|
|
#
|
|
# metabarcoding.data getters
|
|
#
|
|
|
|
#' @export
|
|
setGeneric("reads", function(obj) {
|
|
return(standardGeneric("reads"))
|
|
})
|
|
|
|
#' Extracts the matrix describing MOTUs abondances
|
|
#'
|
|
#' Extract the the matrix describing MOTUs abondances (read counts)
|
|
#' from a \code{\link{metabarcoding.data}} instance.
|
|
#'
|
|
#' @param obj a \code{\link{metabarcoding.data}} instance
|
|
#' @return a matrix containing data about reads
|
|
#'
|
|
#' @examples
|
|
#' # load termite data set from the ROBITools sample data
|
|
#' data(termes)
|
|
#'
|
|
#' # Extract the matrix describing MOTUs abondances
|
|
#' d = reads(termes)
|
|
#'
|
|
#' head(d)
|
|
#'
|
|
#' @seealso \code{\link{metabarcoding.data}},
|
|
#' \code{\link{motus}}, \code{\link{samples}}
|
|
#'
|
|
#' @docType methods
|
|
#' @rdname read-methods
|
|
#' @aliases read-methods,metabarcoding.data
|
|
#' @author Eric Coissac
|
|
#'
|
|
setMethod("reads", "metabarcoding.data", function(obj) {
|
|
return(obj@reads)
|
|
})
|
|
|
|
|
|
# get samples data.frames
|
|
|
|
#' @export
|
|
setGeneric("samples", function(obj) {
|
|
return(standardGeneric("samples"))
|
|
})
|
|
|
|
#' Extracts the samples description data.frame
|
|
#'
|
|
#' Extract the sample description data.frame from a
|
|
#' \code{\link{metabarcoding.data}} instance.
|
|
#'
|
|
#' @param obj a \code{\link{metabarcoding.data}} instance
|
|
#' @return a data.frame containing data about sample
|
|
#'
|
|
#' @examples
|
|
#' # load termite data set from the ROBITools sample data
|
|
#' data(termes)
|
|
#'
|
|
#' # Extract the data frame describing samples
|
|
#' d = samples(termes)
|
|
#'
|
|
#' head(d)
|
|
#'
|
|
#' @seealso \code{\link{metabarcoding.data}},
|
|
#' \code{\link{motus}}, \code{\link{reads}}
|
|
#'
|
|
#' @docType methods
|
|
#' @rdname samples-methods
|
|
#' @aliases samples-methods,metabarcoding.data
|
|
#' @author Eric Coissac
|
|
#'
|
|
setMethod("samples", "metabarcoding.data", function(obj) {
|
|
return(obj@samples)
|
|
})
|
|
|
|
|
|
#' @export
|
|
setGeneric("motus", function(obj) {
|
|
return(standardGeneric("motus"))
|
|
})
|
|
|
|
#' Extracts the MOTU descriptions \code{data.frame}
|
|
#'
|
|
#' Extract the MOTUs description \code{data.frame} from a
|
|
#' \code{\link{metabarcoding.data}} instance.
|
|
#'
|
|
#' @param obj a \code{\link{metabarcoding.data}} instance
|
|
#' @return a data.frame containing data about MOTU
|
|
#'
|
|
#' @examples
|
|
#' # load termite data set from the ROBITools sample data
|
|
#' data(termes)
|
|
#'
|
|
#' # Extract the data.frame describing MOTUs
|
|
#' d = motus(termes)
|
|
#'
|
|
#' head(d)
|
|
#'
|
|
#' @seealso \code{\link{metabarcoding.data}},
|
|
#' \code{\link{reads}}, \code{\link{samples}}
|
|
#'
|
|
#' @docType methods
|
|
#' @rdname motu-methods
|
|
#' @aliases motu-methods,metabarcoding.data
|
|
#'
|
|
setMethod("motus", "metabarcoding.data", function(obj) {
|
|
return(obj@motus)
|
|
})
|
|
|
|
|
|
# get sample count
|
|
|
|
setGeneric("sample.count", function(obj) {
|
|
return(standardGeneric("sample.count"))
|
|
})
|
|
|
|
setMethod("sample.count", "metabarcoding.data", function(obj) {
|
|
return(obj@scount)
|
|
})
|
|
|
|
# get motu count
|
|
|
|
setGeneric("motu.count", function(obj) {
|
|
return(standardGeneric("motu.count"))
|
|
})
|
|
|
|
setMethod("motu.count", "metabarcoding.data", function(obj) {
|
|
return(obj@mcount)
|
|
})
|
|
|
|
# dim method
|
|
|
|
setMethod("dim", "metabarcoding.data", function(x) {
|
|
return(c(x@scount,x@mcount))
|
|
})
|
|
|
|
|
|
setMethod('[', "metabarcoding.data", function(x,i=NULL,j=NULL,...,drop=TRUE) {
|
|
|
|
# special case if samples are not specified (dimension 1)
|
|
if (!hasArg(i))
|
|
i = 1:x@scount
|
|
|
|
# special case if motus are not specified (dimension 2)
|
|
if (!hasArg(j))
|
|
j = 1:x@mcount
|
|
|
|
# special case if the layer attribut is specified
|
|
args = list(...)
|
|
|
|
if (!is.null(args$layer))
|
|
return(x[[args$layer]][i,j])
|
|
|
|
#####################
|
|
#
|
|
# normal case
|
|
#
|
|
|
|
r = x@reads[i,j,drop=FALSE]
|
|
|
|
if (sum(dim(r) > 1)==2 | ! drop)
|
|
{
|
|
|
|
# we do the selection on the motus and samples description data.frame
|
|
|
|
m = x@motus[j,,drop=FALSE]
|
|
s = x@samples[i,,drop=FALSE]
|
|
|
|
# we do the selection on each layers
|
|
l = lapply(x@layers,function(l) l[i,j,drop=FALSE])
|
|
|
|
newdata = copy.metabarcoding.data(x, reads=r, samples=s, motus=m, layers=l)
|
|
}
|
|
else
|
|
{
|
|
newdata = as.numeric(x@reads[i,j])
|
|
}
|
|
|
|
return(newdata)
|
|
|
|
})
|
|
|
|
setMethod('[<-', "metabarcoding.data",
|
|
function (x, i, j, ..., value) {
|
|
if (!hasArg(i))
|
|
i = 1:x@scount
|
|
|
|
if (!hasArg(j))
|
|
j = 1:x@mcount
|
|
|
|
args = list(...)
|
|
|
|
if (is.null(args$layer))
|
|
x@reads[i, j]=value
|
|
else
|
|
|
|
x[[args$layer]][i,j]=value
|
|
|
|
return(x)
|
|
})
|
|
|
|
|
|
|
|
#################################################
|
|
#
|
|
# User interface function to create
|
|
# metabarcoding.data objects
|
|
#
|
|
#################################################
|
|
|
|
#'@export
|
|
metabarcoding.data = function(reads,samples,motus,
|
|
taxonomy=NULL,taxid=NULL,
|
|
sample.margin=NULL,
|
|
layers=list()) {
|
|
rd = new('metabarcoding.data',
|
|
reads=reads,
|
|
samples=samples,
|
|
motus=motus,
|
|
taxonomy=taxonomy,
|
|
taxid=taxid,
|
|
sample.margin=sample.margin,
|
|
layers=layers
|
|
)
|
|
|
|
return(rd)
|
|
}
|
|
|
|
copy.metabarcoding.data = function(data,
|
|
reads=NULL,
|
|
samples=NULL,motus=NULL,
|
|
taxonomy=NULL,taxid=NULL,
|
|
sample.margin=NULL,
|
|
layers=NULL) {
|
|
|
|
|
|
|
|
if (is.null(reads))
|
|
reads = data@reads
|
|
|
|
if (is.null(samples))
|
|
samples = data@samples
|
|
|
|
if (is.null(motus))
|
|
motus = data@motus
|
|
|
|
if (is.null(taxonomy))
|
|
taxonomy = data@taxonomy
|
|
|
|
if (is.null(taxid))
|
|
taxid = data@taxid
|
|
|
|
if (is.null(sample.margin))
|
|
sample.margin = data@sample.margin
|
|
|
|
if (is.null(layers))
|
|
layers = data@layers
|
|
|
|
|
|
rd = new('metabarcoding.data',
|
|
reads=reads,
|
|
samples=samples,
|
|
motus=motus,
|
|
taxonomy=taxonomy,
|
|
taxid=taxid,
|
|
sample.margin=sample.margin,
|
|
layers=layers
|
|
)
|
|
|
|
return(rd)
|
|
}
|
|
|
|
#' @export
|
|
setGeneric('rownames')
|
|
|
|
#' @export
|
|
setMethod("rownames", "metabarcoding.data", function(x, do.NULL = TRUE, prefix = "col") {
|
|
return(rownames(x@reads,do.NULL,prefix))
|
|
})
|
|
|
|
#' @export
|
|
setGeneric('colnames')
|
|
|
|
#' @export
|
|
setMethod("colnames", "metabarcoding.data", function(x, do.NULL = TRUE, prefix = "col") {
|
|
return(colnames(x@reads,do.NULL,prefix))
|
|
})
|