O for the 'NeXML' Format

#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
})