~ubuntu-branches/debian/stretch/r-cran-rnexml/stretch

« back to all changes in this revision

Viewing changes to R/concatenate_nexml.R

  • Committer: Package Import Robot
  • Author(s): Andreas Tille
  • Date: 2016-04-08 13:58:39 UTC
  • Revision ID: package-import@ubuntu.com-20160408135839-ilq08z8v8p414qpn
Tags: upstream-2.0.6
ImportĀ upstreamĀ versionĀ 2.0.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
 
 
2
#' Concatenate nexml files 
 
3
#' 
 
4
#' Concatenate nexml files 
 
5
#' @param x,... nexml objects to be concatenated, e.g. from 
 
6
#'  \code{\link{write.nexml}} or \code{\link{read.nexml}}. 
 
7
#'  Must have unique ids on all elements
 
8
#' @param recursive  logical.  If 'recursive = TRUE', the function recursively
 
9
#'        descends through lists (and pairlists) combining all their
 
10
#'        elements into a vector. (Not implemented).  
 
11
#' @return a concatenated nexml file
 
12
#' @examples 
 
13
#' \dontrun{
 
14
#' f1 <- system.file("examples", "trees.xml", package="RNeXML")
 
15
#' f2 <- system.file("examples", "comp_analysis.xml", package="RNeXML")
 
16
#' nex1 <- read.nexml(f1)
 
17
#' nex2 <- read.nexml(f2)
 
18
#' nex <- c(nex1, nex2)
 
19
#' }
 
20
setMethod("c", 
 
21
          signature("nexml"), 
 
22
          function(x, ..., recursive = FALSE){
 
23
              elements = list(x, ...)
 
24
              nexml <- new("nexml")
 
25
  ## Check that ids are unique
 
26
  if(!do.call(unique_ids,elements))
 
27
    stop("ids are not unique across nexml files. 
 
28
          Consider regenerating ids")
 
29
  else {
 
30
 
 
31
  nexml@otus <- new("ListOfotus", 
 
32
                    unlist(lapply(elements, 
 
33
                                  function(n) n@otus), 
 
34
                           recursive=FALSE))
 
35
  nexml@characters <- new("ListOfcharacters", 
 
36
                    unlist(lapply(elements, 
 
37
                                  function(n) n@characters), 
 
38
                           recursive=FALSE))
 
39
  nexml@trees <- new("ListOftrees", 
 
40
                    unlist(lapply(elements, 
 
41
                                  function(n) n@trees), 
 
42
                           recursive=FALSE))
 
43
  }
 
44
  nexml
 
45
})
 
46
 
 
47
get_ids <- function(nexml){
 
48
  doc <- xmlDoc(as(nexml, "XMLInternalNode"))
 
49
  out <- unname(xpathSApply(doc, "//@id"))
 
50
  free(doc)
 
51
  out
 
52
}
 
53
 
 
54
unique_ids <- function(...){
 
55
  set <- list(...)
 
56
  counts <- table(unlist(lapply(set, get_ids)))
 
57
  !any(counts > 1)
 
58
}
 
59