#setMethod("head", signature("nexml"), function(x, n=6L, ...){
# write.nexml(x, "tmp123.xml")
# txt <- readLines("tmp123.xml", n=n)
# unlink("tmp123.xml")
# cat(txt, "\n")
#})
#setMethod("tail", signature("nexml"), function(x, n=6L, ...){
# write.nexml(x, "tmp123.xml")
# txt <- readLines("tmp123.xml", n=-n)
# unlink("tmp123.xml")
# cat(txt, "\n")
#})
setMethod("show", signature("nexml"), function(object){
s <- summary(object)
tr_block_counts <- ""
if (s$nblocks["trees"] > 0) {
tr_block_counts <-
paste0(sapply(1:s$nblocks["trees"],
function(i)
paste("\t block", i, "contains",
s$ntrees[i], "phylogenetic tree(s)")),
collapse = "\n")
tr_block_counts <- paste0("where:\n", tr_block_counts)
}
m_block_counts <- ""
if (s$nblocks["characters"] > 0) {
m_block_counts <-
paste0(
sapply(1:s$nblocks["characters"],
function(i) {
p1 <- paste("\t block", i, "defines", s$ncharacters[i])
if (endsWith(object@characters[[i]]@`xsi:type`, "ContinuousCells"))
p1 <- paste(p1, "continuous character(s)")
else {
p1 <- paste(p1, "standard/discrete character(s),")
if (is.na(s$nstates[1, i]))
p1 <- paste(p1, "no state definitions")
else {
p1 <- paste(p1, "with")
if (s$nstates["Min.", i] == s$nstates["Max.", i])
p1 <- paste(p1, s$nstates["Max.", i], "states each")
else
p1 <- paste(p1, s$nstates["Min.", i], "to", s$nstates["Max.", i], "states")
p1 <- paste(p1,
"\n\t and ",
sum(s$nnonstdstatedefs[i,]),
"polymorphic or uncertain state(s) defined")
}
}
paste(p1,
"\n\t matrix", i, "has", s$nmatrixrows[i], "row(s)")
}),
collapse = "\n")
m_block_counts <- paste0("where:\n", m_block_counts)
}
cat(paste("A nexml object representing:\n",
"\t", s$nblocks["trees"], "phylogenetic tree block(s),",
tr_block_counts, "\n",
"\t", s$nblocks["characters"], "character block(s),",
m_block_counts, "\n",
"\t", sum(s$notus), "taxonomic units in", s$nblocks["otus"], "block(s)",
"\n Taxa:\t", paste(head(get_taxa(object)$label), collapse = ", "), "..."))
cat("\n Metadata annotations:",
paste0("\n\t", s$nmeta$nexml, " at top level"),
sapply(names(s$nmeta)[-1],
function(el)
if (length(s$nmeta[[el]]) == 0)
""
else
paste0("\n\t",
sapply(1:length(s$nmeta[[el]]),
function(i) paste(s$nmeta[[el]][i], "in block", i)),
" at ", el, " level", collapse = "")))
# description if provided
descr <- get_metadata_values(object, props = "dc:description")
if (all(!is.null(descr)) && any(nchar(descr) > 0))
cat("\n\n", paste(descr, collapse = "\n"), sep = "")
# authors if provided
creator <- get_metadata_values(object, props = "dc:creator")
if (all(!is.null(creator)) && any(nchar(creator) > 0))
cat("\n\nAuthor(s):", paste(creator, collapse = ", "))
# license if provided
lic <- get_license(object)
if (! is.na(lic))
cat("\n\nLicense:", lic)
cat("\n\nNeXML generated by", object@generator, "using",
"schema version:", object@version,
"\nSize:", capture.output(print(object.size(object), units="auto")), "\n")
})
# FIXME: consider showing author/title/citation information if available?
#' Summary method for nexml objects
#'
#' Generates a list of various counts of the major elements that comprise a
#' [nexml][nexml-class] object, such as number of different kinds of blocks,
#' characters, states, OTUs (taxa), etc.
#'
#' The [show][methods::show] method uses this summary for pretty-printing a
#' summary of the NeXML object, but it can be used on its own as well, in
#' particular for quick inspection of key properties of a NeXML file.
#' @param object the [nexml][nexml-class] object
#' @return A list with the following elements:
#' - `nblocks` the number of trees, otus, and characters blocks
#' - `ncharacters` the number of characters in each characters block
#' - `nstates` summary statistics of the number of character states per state set
#' defined for each characters block
#' - `nnonstdstatedefs` the number of polymorphic and uncertain states defined
#' for each character block
#' - `nmatrixrows` the number of rows in the matrix for each character block
#' - `ntrees` the number of trees contained in each trees block
#' - `notus` the number of OTUs defined in each OTUs block
#' - `nmeta` a list of the number of the number of metadata annotations at
#' several levels, specifically:
#' * `nexml` at the top (nexml) level
#' * `otu` at the OTU level, for each OTUs block
#' * `char` at the character level, for each characters block
#' * `state` at the character state level, for each characters block
#' @examples
#' nex <- nexml_read(system.file("examples", "comp_analysis.xml", package = "RNeXML"))
#' s <- summary(nex)
#' # number of major blocks:
#' s$nblocks
#'
#' # each characters block defines 1 character:
#' s$ncharacters
#'
#' # summary stats of states per character (for morphological matrices there is
#' # typically one state set per character)
#' s$nstates # note that first block is of continuous type, so no stats there
#'
#' # pretty-printed summary:
#' nex # this is the same as show(nex)
#' @aliases summary.nexml
#' @export
setMethod("summary", signature("nexml"), function(object){
# number of blocks of trees, OTUs, characters
s <- list(
nblocks = c(trees = length(object@trees),
otus = length(object@otus),
characters = length(object@characters))
)
# number of characters per character block
nc <- sapply(object@characters, function(bl) length(bl@format@char))
if (length(nc) > 0)
names(nc) <- paste0("block.", seq(1, length(object@characters)))
else
nc <- as.integer(nc)
s$ncharacters <- nc
# number of states per character
ns <- sapply(object@characters,
function(bl) {
if (length(bl@format@states) == 0) {
bogusSumm <- summary(c(0))
NAs <- rep(NA, times = length(bogusSumm))
names(NAs) <- names(bogusSumm)
NAs
} else
summary(sapply(bl@format@states, function(x) length(x@state)))
})
if (length(dim(ns)) >= 2)
colnames(ns) <- paste0("block.", seq(1, length(object@characters)))
else
ns <- as.integer(ns)
s$nstates <- ns
# number of state sets with polymorphic and uncertain states
# (Note that morphological matrices typically define 1 state set for each
# character, but molecular matrices will usually only define 1 state set.
# Hence, the number of state sets may or may not say something about the
# number of characters.)
nsp <- sapply(object@characters,
function(bl)
if (length(bl@format@states) == 0)
NA
else
sapply(bl@format@states,
function(x) length(x@polymorphic_state_set)))
if (length(dim(nsp)) > 0)
nsp <- apply(nsp, 2, function(x) sum(x > 0))
nsu <- sapply(object@characters,
function(bl)
if (length(bl@format@states) == 0)
NA
else
sapply(bl@format@states,
function(x) length(x@uncertain_state_set)))
if (length(dim(nsu)) > 0)
nsu <- apply(nsu, 2, function(x) sum(x > 0))
s$nnonstdstatedefs <- matrix(c(nsp, nsu), ncol = 2, nrow = length(nsp), byrow = FALSE)
colnames(s$nnonstdstatedefs) <- c("polymorphic", "uncertain")
if (length(s$nnonstdstatedefs[, 1]) > 0)
row.names(s$nnonstdstatedefs) <- paste0("block.", seq(1, length(object@characters)))
# number of rows per matrix
nr <- sapply(object@characters, function(bl) length(bl@matrix@row))
if (length(nr) > 0)
names(nr) <- paste0("block.", seq(1, length(object@characters)))
else
nr <- as.integer(nr)
s$nmatrixrows <- nr
# number of trees per trees block
nt <- sapply(object@trees, function(bl) length(bl@tree))
if (length(nt) > 0)
names(nt) <- paste0("block.", seq(1, length(object@trees)))
else
nt <- as.integer(nt)
s$ntrees <- nt
# number of OTUs per OTUs block
ntaxa <- sapply(object@otus, function(bl) length(bl@otu))
if (length(ntaxa) > 0)
names(ntaxa) <- paste0("block.", seq(1, length(object@otus)))
else
ntaxa <- as.integer(ntaxa)
s$notus <- ntaxa
# number of metadata annotations
nmeta <- list(
nexml = length(get_all_meta(object)),
otu = sapply(object@otus,
function(bl) sum(sapply(bl@otu,
function(x) length(get_all_meta(x))))),
char = sapply(object@characters,
function(bl) sum(sapply(bl@format@char,
function(x) length(get_all_meta(x))))),
state = sapply(object@characters,
function(bl)
if (length(bl@format@states) == 0)
0
else
sum(unlist(
sapply(bl@format@states,
function(st)
sapply(st@state,
function(x) length(get_all_meta(x)))))))
)
for (elem in names(nmeta)[-1]) {
if (length(nmeta[[elem]]) > 0) {
if (elem %in% c("char", "state"))
bltype <- "characters"
else
bltype <- "otus"
names(nmeta[[elem]]) <- paste0("block.", seq(1, length(slot(object, bltype))))
} else {
nmeta[[elem]] <- as.integer(nmeta[[elem]])
}
}
s$nmeta <- nmeta
s
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.