#' @include RNAmodR.R
#' @include SequenceData-class.R
#' @include SequenceDataSet-class.R
NULL
#' @name SequenceDataList-class
#' @aliases SequenceDataList
#'
#' @title The SequenceDataList class
#'
#' @description
#' The \code{SequenceDataList} class is used to hold \code{SequenceData} or
#' \code{SequenceDataSet} objects as its elements. It is derived from the
#' \code{\link[S4Vectors:List-class]{List}} class.
#'
#' The \code{SequenceDataList} is used to hold data from different sets of
#' aligned reads. This allows multiple methods to be aggregated into one
#' modification detection strategy. Annotation and sequence data must be the
#' same for all elements, however the bam files can be different.
#'
#' @param ... The elements to be included in the \code{SequenceDataList}.
#'
#' @return a \code{SequenceDataList}
#'
#' @examples
#' data(psd,package="RNAmodR")
#' data(e5sd,package="RNAmodR")
#' sdl <- SequenceDataList(SequenceDataSet(psd,e5sd),e5sd)
NULL
#' @rdname SequenceDataList-class
#' @export
setClass("SequenceDataList",
contains = "List",
slots = c(listData = "list"),
prototype = list(elementType = "SD_or_SDS"))
setClassUnion("SD_or_SDS_or_SDL",
c("SequenceData", "SequenceDataSet", "SequenceDataList"))
# show method ------------------------------------------------------------------
#' @rdname SequenceData-functions
setMethod("show", "SequenceDataList",
function(object)
{
lo <- length(object)
cat(classNameForDisplay(object), " of length ", lo,
"\n", sep = "")
})
# parallel_slot_names ----------------------------------------------------------
#' @rdname RNAmodR-internals
setMethod("parallel_slot_names", "SequenceDataList",
function(x) c("listData", callNextMethod())
)
# constructors -----------------------------------------------------------------
.SequenceDataList <- function(Class, listData, ..., check = FALSE){
new2(Class, listData = listData, ..., check = check)
}
# not exported. Only used internally
new_SequenceDataList_from_list <- function(Class, x, ..., mcols){
if (!extends(Class, "SequenceDataList")){
stop("class ", Class, " must extend SequenceDataList")
}
if (!is.list(x)){
stop("'x' must be a list")
}
proto <- new(Class)
ans_elementType <- elementType(proto)
if (is(S4Vectors::mcols(proto, use.names = FALSE), "DataFrame")){
mcols <- S4Vectors:::make_zero_col_DataFrame(length(x))
}
extends_elementType <- vapply(x,
function(xi){
extends(class(xi), ans_elementType)
},
logical(1))
if (!all(extends_elementType)){
stop("All elements in 'x' must be ", ans_elementType, " objects")
}
# check that all sequences and annotation information are the same
if(!.compare_element_metadata(x,"ranges")){
stop("Annotation data of all SequenceDataList elements are not equal.",
call. = FALSE)
}
if(!.compare_element_metadata(x,"sequences")){
stop("Sequence data of all SequenceDataList elements are not equal.",
call. = FALSE)
}
# class name as default names
if(is.null(names(x))){
names(x) <- vapply(x,class,character(1))
f <- vapply(x,is,logical(1),"SequenceDataSet")
if(any(f)){
names(x)[f] <- vapply(x[f],
function(xi){
paste0(vapply(xi,class,character(1)),collapse="_")
},
character(1))
}
}
#
if (missing(mcols)){
return(.SequenceDataList(Class, listData = x, ..., check = FALSE))
}
.SequenceDataList(Class, listData = x, ..., elementMetadata = mcols,
check = FALSE)
}
#' @rdname SequenceDataList-class
#' @export
SequenceDataList <- function(...){
new_SequenceDataList_from_list("SequenceDataList", list(...))
}
# Validity ---------------------------------------------------------------------
.valid.SequenceDataList.listData <- function(x){
elementTypeX <- elementType(x)
if (!all(vapply(as.list(x),
function(xi) extends(class(xi), elementTypeX),
logical(1)))){
classes <- getClass("SD_or_SDS")
if(isClassUnion(classes)){
classes <- paste(names(classes@subclasses), collapse = " or ")
} else {
classes <- classes@className
}
return(paste("the 'listData' slot must be a list containing ",
classes, " objects"))
}
if(!.compare_element_metadata(x,"ranges")){
return("Annotation data is not equal.")
}
if(!.compare_element_metadata(x,"sequences")){
return("Sequence data is not equal.")
}
NULL
}
.valid.SequenceDataSet <- function(x){
c(.valid.SequenceDataSet.listData(x),
unlist(lapply(x,validObject)))
}
.valid.SequenceDataList <- function(x){
c(.valid.SequenceDataList.listData(x),
unlist(lapply(x,validObject)))
}
S4Vectors::setValidity2("SequenceDataList", .valid.SequenceDataList)
# unlisting --------------------------------------------------------------------
#
# For DataFrameList dim is deprecated. Therefore additional check included
setMethod("unlist", "SequenceDataList",
function (x, recursive = TRUE, use.names = TRUE)
{
if (!isTRUEorFALSE(use.names))
stop("'use.names' must be TRUE or FALSE")
if (length(x) == 0L) {
elt_type <- elementType(x)
if (isVirtualClass(elt_type))
return(NULL)
return(new(elt_type))
}
xx <- unname(as.list(x))
if(is(xx[[1L]],"DataFrameList")){
dmnsn <- dims(xx[[1L]])
} else {
dmnsn <- dim(xx[[1L]])
}
if (length(dmnsn) < 2L) {
unlisted_x <- do.call(c, xx)
}
else {
unlisted_x <- do.call(rbind, xx)
}
if (use.names)
unlisted_x <- set_unlisted_names(unlisted_x, x)
unlisted_x
}
)
# classNameForDisplay ----------------------------------------------------------
setMethod("classNameForDisplay", "SequenceDataList",
function(x) "SequenceDataList")
# Subsetting -------------------------------------------------------------------
#' @rdname RNAmodR-internals
setMethod("getListElement", "SequenceDataList",
function(x, i, exact = TRUE)
getListElement(x@listData, i, exact = exact)
)
# looping ----------------------------------------------------------------------
setMethod("lapply", "SequenceDataList",
function(X, FUN, ...) lapply(as.list(X), match.fun(FUN), ...)
)
# coercion ---------------------------------------------------------------------
# forth and ...
setAs("SequenceDataList", "list", function(from) as.list(from))
.as.list.SequenceDataList <- function(x, use.names = TRUE)
{
if (!isTRUEorFALSE(use.names)){
stop("'use.names' must be TRUE or FALSE")
}
ans <- x@listData
if (!use.names){
names(ans) <- NULL
}
ans
}
setMethod("as.list", "SequenceDataList", .as.list.SequenceDataList)
# ... back
setAs("list", "SequenceDataList",
function(from){
new_SequenceDataList_from_list("SequenceDataList", from)
})
setAs("ANY", "SequenceDataList",
function(from) {
as(as.list(from),"SequenceDataList")
})
# additional accessors ---------------------------------------------------------
#' @rdname SequenceData-functions
#' @export
setMethod(f = "bamfiles",
signature = signature(x = "SequenceDataList"),
definition = function(x){
ans <- do.call(S4Vectors::SimpleList, lapply(x, bamfiles))
names(ans) <- names(x@listData)
ans
})
#' @rdname SequenceData-functions
#' @export
setMethod(f = "conditions",
signature = signature(object = "SequenceDataList"),
definition = function(object){
ans <- S4Vectors::SimpleList(lapply(object,conditions))
ans
})
#' @rdname SequenceData-functions
#' @export
setMethod(f = "names",
signature = signature(x = "SequenceDataList"),
definition = function(x){
names(x[[1L]])
})
#' @rdname SequenceData-functions
#' @export
setMethod(f = "ranges",
signature = signature(x = "SequenceDataList"),
definition = function(x){
ranges(x[[1L]])
})
#' @rdname SequenceData-functions
#' @export
setMethod(f = "replicates",
signature = signature(x = "SequenceDataList"),
definition = function(x){
ans <- S4Vectors::SimpleList(lapply(x,replicates))
ans
})
#' @rdname SequenceData-functions
#' @export
setMethod(f = "seqinfo",
signature = signature(x = "SequenceDataList"),
definition = function(x){
seqinfo(x[[1L]])
})
#' @rdname SequenceData-functions
#' @export
setMethod(f = "seqtype",
signature = signature(x = "SequenceDataList"),
definition = function(x){seqtype(x[[1L]])})
#' @rdname SequenceData-functions
#' @export
setReplaceMethod(f = "seqtype",
signature = signature(x = "SequenceDataList"),
definition = function(x, value){
as(lapply(x,`seqtype<-`,value),"SequenceDataList")
})
#' @rdname SequenceData-functions
#' @export
setMethod(f = "sequences",
signature = signature(x = "SequenceDataList"),
definition = function(x){
sequences(x[[1L]])
})
# aggregate --------------------------------------------------------------------
#' @rdname aggregate
#' @export
setMethod("aggregate",
signature = c(x = "SequenceDataList"),
function(x, condition = "Treated"){
ans <- do.call(S4Vectors::SimpleList,
lapply(x, aggregate, condition = condition))
names(ans) <- names(x@listData)
ans
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.