R/nexml.R

In xu-hong/rphenoscape: Semantically Rich Phenotypic Traits from the Phenoscape Knowledgebase

#' Drop parts of a nexml object
#'
#' @name nexml_drop
#' @description
#' `nexml_drop_otu` drops OTUs (taxa) from a [nexml][RNeXML::nexml] object.
#' Currently none of the OTUs to be dropped can be used in a tree that's part
#' of the `nexml` object. If they are, first drop the OTUs from the tree(s)
#' (for example, using [drop.tip()][ape::drop.tip] from package "ape"), then
#' replace the tree(s). Dropping OTUs will not only drop them from the OTUs
#' block, but will also drop matrix rows that referenced the OTUs to be dropped.
#' This may in turn leave some characters unused. Therefore, it is recommended
#' to drop unused characters afterwards.
#'
#' @param nexml the [nexml][RNeXML::nexml] object from which to drop parts
#' @param filter logical, or a function returning a logical. If the latter,
#'   it will be passed the list of selected values for filtering (see parameter
#'   `at`), and any additional parameters (see `...`). The logical vector selects
#'   the list elements to drop from the given block (see `block`).
#' @param at character, selects the values for filtering if `filter` is a
#'   function. If `NA` (the default), a list of the respective objects (`otu`
#'   and `char`, respectively) are passed. If a string and the value matches
#'   a slot of the objects (such as "id", "label"), a list of those slot values
#'   is passed. Otherwise, it is assumed to be a metadata property for those
#'   objects, and a list of the respective metadata values is selected (with
#'   `NA` for objects that do not have a matching metadata annotation).
#' @param block integer, the respective block index (for OTUs and character
#'   blocks, respectively).
#' @param ... for `nexml_drop_otu` and `nexml_drop_char`, additional parameters
#'   to be passed on to the filter function.
#'
#'   For `is_unused_char` and `is_unused_otu`, if used outside of serving as
#'   value for the `filter` parameter, a parameter `characters` with
#'   the characters block (or list thereof), and/or a parameter `nexml` with the
#'   nexml object, must be provided. If only `nexml` is passed, all characters
#'   blocks is assumed.
#'
#'   `is_unused_otu` also accepts `ignoreTrees` (default is `FALSE`). If set to
#'   `TRUE`, trees will be ignored for determining whether an OTU is unused.
#'   Otherwise, if `nexml` is _not_ passed to `is_unused_otu`, a warning will be
#'   issued that it cannot check trees for determining the use of OTUs.
#' @return The functions for dropping components return a [nexml][RNeXML::nexml]
#'   object with the filtered components dropped.
#'
#'   `is_unused_char` returns a logical vector with TRUE for each `char`
#'   (character) object that is not used in the matrix (or matrices) of the
#'   characters block(s), and FALSE  otherwise.
#'
#'   `is_unused_otu` returns a logical vector with TRUE for each `otu`
#'   object that is not used in either the matrix (or matrices) of the characters
#'   block(s), or, unless `ignoreTrees = TRUE`, for a node of a tree, and FALSE
#'   otherwise.
#' @examples
#' nex <- RNeXML::nexml_read(system.file("examples", "ontotrace-result.xml", package = "rphenoscape"))
#' # drop by label matching
#' nexml_drop_otu(nex, filter = function(x) grepl(" sp.", x), at = "label")
#'
#' # can pipe dropping and then removing potentially unused characters or OTUs:
#' library(dplyr)
#' nexml_drop_char(nex, filter = function(x) grepl("pelvic", x), at = "label") %>%
#'   nexml_drop_otu(filter = is_unused_otu)
#'
#' \dontrun{
#' nex <- get_ontotrace_data(taxon = "Ictaluridae",
#'                           entity = "fin", variable_only = FALSE)
#' # ontotrace results store VTO IRIs in dwc:taxonID annotations:
#' nexml_drop_otu(nex,
#'                filter = function(x) !is_descendant("Ictalurus", x),
#'                at = "dwc:taxonID") %>%
#'   nexml_drop_char(filter = is_unused_char)
#' # anatomy IRIs are in obo:IAO_0000219 ("denotes") annotations:
#' nexml_drop_char(nex,
#'                filter = function(x)
#'                  !is_descendant("paired fin", x, includeRels = "part_of"),
#'                at = "obo:IAO_0000219") %>%
#'   nexml_drop_otu(filter = is_unused_otu)
#' }
#' @rdname nexml_drop
#' @importFrom methods new slot
#' @importClassesFrom RNeXML nexml
#' @export
nexml_drop_otu <- function(nexml, filter, at = NA, block = 1, ...) {
  if (length(nexml@otus) < block) {
    warning("nexml object does not have OTUs block ", block, call. = FALSE)
    return(nexml)
  }

  otus <- nexml@otus[[block]]@otu
  if (length(otus) > 0) {
    toDrop <- nexml_filter_items(nexml, otus, filter, at, ...)
    ids_to_rm <- sapply(otus, slot, name = "id")[toDrop]
    if (length(ids_to_rm) > 0) {
      # ensure there is no tree using these
      if (length(nexml@trees) > 0) {
        otus_used <- sapply(nexml@trees, slot, name = "otus")
        node_otus <- c()
        for (trees in nexml@trees[otus_used == nexml@otus[[block]]@id]) {
          otu_list <- lapply(
            trees@tree,
            function(tree) sapply(tree@node,
                                  function(node)
                                    if (length(node@otu) > 0) node@otu else NA))
          node_otus <- c(node_otus, unlist(otu_list))
        }
        node_otus <- node_otus[!is.na(node_otus)]
        if (any(node_otus %in% ids_to_rm)) {
          stop("One or more of the OTUs to be removed are used in at least one tree, ",
               "First drop these from the tree(s).", call. = FALSE)
        }
      }
      # remove matrix rows referring to these
      charblocks <- sapply(nexml@characters,
                           function(x) x@otus == nexml@otus[[block]]@id)
      bls <- seq(1, length(nexml@characters))[charblocks]
      for (bl in bls) {
        row_otus <- sapply(nexml@characters[[bl]]@matrix@row, slot, name = "otu")
        nexml@characters[[bl]]@matrix@row <-
          new("ListOfrow",
              nexml@characters[[bl]]@matrix@row[! (row_otus %in% ids_to_rm)])
      }
      # drop the otus from the otus block
      nexml@otus[[block]]@otu <- new("ListOfotu", otus[!toDrop])

      # record a provenance chain
      nexml <- add_provenance_record(nexml)
    }
  }
  nexml
}

#' @description
#' `nexml_drop_char` drops characters from a [nexml][RNeXML::nexml] object. Note
#' that dropping characters may make some OTUs unused if they result in empty
#' rows and empty rows are pruned (see parameter `pruneRows`). It is therefore
#' recommended to drop unused OTUs afterwards.
#'
#' @param pruneStates logical, whether to also prune (i.e., drop) states that
#'   are no longer used after dropping the selected characters. The default is
#'   TRUE.
#' @param pruneRows logical, whether to also prune (i.e., drop) matrix rows
#'   that have become empty (i.e., have no cells left) after dropping the
#'   selected characters. The default is TRUE.
#' @rdname nexml_drop
#' @export
nexml_drop_char <- function(nexml, filter, at = NA, block = 1, ...,
                            pruneStates = TRUE, pruneRows = TRUE) {
  if (length(nexml@characters) < block) {
    warning("nexml object does not have characters block ", block, call. = FALSE)
    return(nexml)
  }
  
  chars <- nexml@characters[[block]]@format@char
  rows <- nexml@characters[[block]]@matrix@row
  isMod <- FALSE # track whether the object gets modified
  if (length(chars) > 0) {
    toDrop <- nexml_filter_items(nexml, chars, filter, at, ...)
    ids_to_rm <- sapply(chars, slot, name = "id")[toDrop]
    if (length(ids_to_rm) > 0) {
      # remove matrix cells referring to these
      rows <- lapply(
        rows,
        function(row) {
          chars_used <- sapply(row@cell, slot, name = "char")
          row@cell <- new("ListOfcell", row@cell[! (chars_used %in% ids_to_rm)])
          row
        })
      # drop the characters from the characters block
      nexml@characters[[block]]@format@char <- new("ListOfchar", chars[!toDrop])
      isMod <- TRUE
    }
  }
  # prune unused states if requested
  if (pruneStates) {
    states <- nexml@characters[[block]]@format@states
    statesIds <- sapply(states, slot, name = "id")
    statesUsed <- lapply(nexml@characters[[block]]@format@char, slot, name = "states")
    statesUsed <- unique(unlist(statesUsed))
    toKeep <- statesIds %in% statesUsed
    if (! all(toKeep)) {
      nexml@characters[[block]]@format@states <- new("ListOfstates", states[toKeep])
      isMod <- TRUE
    }
  }
  # prune rows with no cells if requested
  if (pruneRows && length(rows) > 0) {
    toKeep <- sapply(rows, function(x) length(x@cell)) > 0
    if (! all(toKeep)) {
      rows <- rows[toKeep]
      isMod <- TRUE
    }
  }
  # replace list of rows if there is a change
  if (isMod) {
    nexml@characters[[block]]@matrix@row <- new("ListOfrow", rows)
    # record a provenance chain
    nexml <- add_provenance_record(nexml)
  }

  nexml
}

#' @importFrom RNeXML get_metadata_values
#' @importFrom methods slotNames slot
nexml_filter_items <- function(nexml, items, filter, at = NA, ...) {
  if (is.function(filter)) {
    if (is.character(at)) {
      # is it a slot of the item?
      if (at %in% slotNames(items[[1]])) {
        at <- sapply(items, slot, name = at)
      } else {
        # treat as a metadata property
        at <- sapply(items,
                     function(x) {
                       vals <- get_metadata_values(nexml, annotated = x, props = at)
                       vals[1]
                     })
      }
      toKeep <- filter(at, ...)
    } else
      toKeep <- filter(items, ...)
  } else
    toKeep <- filter

  toKeep
}

#' @description
#' `is_unused_char` is a filter function for `nexml_drop_char` for dropping
#' unused characters.
#' @param charList a list of `char` objects. This will be passed as the values
#'   to filter on.
#' @rdname nexml_drop
#' @importFrom methods is slot
#' @importClassesFrom RNeXML nexml
#' @export
is_unused_char <- function(charList, ...) {
  argList <- list(...)
  characters <- argList$characters
  nexml <- argList$nexml
  if (is.null(characters) && is.null(nexml)) {
    # extract the nexml object (from which we can get characters blocks) from the
    # invocation
    origArgs <- as.list(sys.call((-1)))
    nexml <- origArgs$nexml
    if (is.null(nexml)) nexml <- origArgs[[2]]
    nex <- eval(nexml, parent.frame(1))
    # if unsuccessful go back to parent of nexml_drop_XXX()
    if (is.null(nex)) nex <- eval(nexml, parent.frame(3))
    nexml <- nex
  }
  if (is.null(characters)) {
    if (is.null(nexml))
      stop("Either parameter 'characters' or 'nexml' must be provided.")
    if (! is(nexml, "nexml"))
      stop("Object designated as nexml is not of class 'nexml'.")
    characters <- nexml@characters
  }
  if (! is.list(characters)) characters <- list(characters)
  charids <- sapply(charList, slot, name = "id")
  chars_used <- lapply(
    characters,
    function(charbl)
      lapply(charbl@matrix@row,
             function(x) sapply(x@cell, slot, name = "char")))
  chars_used <- unique(unlist(chars_used))
  ! (charids %in% chars_used)
}

#' @description
#' `is_unused_otu` is a filter function for `nexml_drop_otu` for dropping
#' unused OTUs.
#' @param otuList a list of `otu` objects. This will be passed as the values
#'   to filter on.
#' @rdname nexml_drop
#' @importFrom methods is slot
#' @importClassesFrom RNeXML nexml
#' @export
is_unused_otu <- function(otuList, ...) {
  argList <- list(...)
  characters <- argList$characters
  nexml <- argList$nexml
  if (is.null(nexml)) {
    # extract the nexml object from invocation of parent
    origArgs <- as.list(sys.call((-1)))
    nexml <- origArgs$nexml
    if (is.null(nexml)) nexml <- origArgs[[2]]
    nex <- eval(nexml, parent.frame(1))
    # if unsuccessful go back to parent of nexml_drop_XXX()
    if (is.null(nex)) nex <- eval(nexml, parent.frame(3))
    nexml <- nex
  }
  if (is.null(characters)) {
    if (is.null(nexml))
      stop("Either parameter 'characters' or 'nexml' must be provided.")
    if (! is(nexml, "nexml"))
      stop("Object designated as nexml is not of class 'nexml'.")
    characters <- nexml@characters
  }
  if (! is.list(characters)) characters <- list(characters)
  otuids <- sapply(otuList, slot, name = "id")
  otus_used <- lapply(
    characters,
    function(charbl) sapply(charbl@matrix@row, slot, name = "otu"))
  otus_used <- unlist(otus_used)
  ignoreTrees <- argList$ignoreTrees
  if (is.null(ignoreTrees)) ignoreTrees <- FALSE
  if (! (ignoreTrees || is(nexml, "nexml")))
    warning("Missing 'nexml' parameter, or value not of class 'nexml'. ",
            "Cannot check OTUs against trees.")
  else if (! (ignoreTrees || length(nexml@trees) == 0)) {
    node_otus <- lapply(
      nexml@trees,
      function(trees)
        lapply(trees@tree,
        function(tree) sapply(tree@node,
                              function(node)
                                if (length(node@otu) > 0) node@otu else NA)))
    node_otus <- unlist(node_otus)
    node_otus <- node_otus[!is.na(node_otus)]
    otus_used <- c(otus_used, node_otus)
  }

  otus_used <- unique(otus_used)
  ! (otuids %in% otus_used)
}

#' Generate and add provenance record to nexml
#'
#' If the content of a [nexml][RNeXML::nexml] object is modified, this
#' function can add a provenance record documenting the modification.
#' The provenance documentation is added to the toplevel metadata (i.e.,
#' at the ["nexml" level][RNeXML::get_metadata]).
#'
#' At present, for each invocation this implementation will do the following:
#' 1. If the top-level metadata for the nexml object contains
#'    `dc:description` annotations(s), they are moved to being nested
#'    within a `dcterms:provenance` annotation, and prefixed with
#'    "Original description:".
#' 2. A `dcterms:provenance` annotation is added, with nested properties
#'    `dc:creator` (see parameter `creator`), `dcterms:modified` (current
#'    time), and `dc:description`. The latter gives the command to document,
#'    see parameter `cmd`.
#' 3. A provenance record using [Prov-O](https://www.w3.org/TR/prov-o/)
#'    (a W3C recommendation) nested within `prov:wasGeneratedBy` is added.
#'    In RDF Turtle representation, the record would have the following structure
#'    (cf. [obo:IAO_0000591](http://purl.obolibrary.org/obo/IAO_0000591)):
#'    ```ttl
#'    :nexml prov:wasGeneratedBy [
#'      prov:endedAtTime "2019-06-20 15:09:08 GMT" ;
#'      prov:wasAssociatedWith [
#'        a obo:IAO_0000591 ;
#'        dc:title "rphenoscape" ;
#'        dcterms:hasVersion "<rphenoscape version>" ;
#'      ] ;
#'      prov:wasAssociatedWith [
#'        a prov:Person ;
#'        foaf:name "<creator>" ;
#'      ] ;
#'      prov:used [
#'        prov:value "<modifying command>" ;
#'      ] ;
#'    ] .
#'    ```
#' @param nexml the [nexml][RNeXML::nexml] object to which to add provenance
#'    documentation
#' @param cmd character, the command (such as a function invocation) to document
#'    in the provenance record. If `NA` (the default), the invocation of the
#'    function calling this one will be used as the command.
#' @param creator character, a value identifying the person running the
#'    software. The default is the system's `USER` environment variable.
#' @return A [nexml][RNeXML::nexml] object with provenance records added.
#' @importFrom utils packageName packageVersion
#' @importFrom RNeXML meta add_meta get_namespaces expand_prefix
#' @importClassesFrom RNeXML nexml
#' @export
add_provenance_record <- function(nexml, cmd = NA, creator = Sys.getenv("USER")) {
  now <- format(Sys.time(), tz = "GMT", usetz = TRUE)
  # if present, move original description to a provenance record
  metaProps <- sapply(nexml@meta, RNeXML::slot, name = "property")
  ns = get_namespaces(nexml)
  isDescr <- sapply(
    metaProps,
    function(x) expand_prefix(x, ns) == expand_prefix("dc:description", ns))
  if (any(isDescr)) {
    provRecs <- lapply(
      nexml@meta[isDescr],
      function(descr) {
        meta("dcterms:provenance",
             children = c(
               meta("dc:description",
                    paste("Original description:", descr@content))))
      })
    nexml@meta <- new("ListOfmeta", nexml@meta[! isDescr])
    nexml@meta <- c(nexml@meta, provRecs)
  }
  # generate a representation of the modifying operation if not provided
  if (is.na(cmd)) cmd <- paste0(format(sys.call(-1)), collapse = "\n")
  # we create two provenance records documenting the modification, one
  # using only Dublin Core vocabulary, and one using W3C's Prov-O vocabulary
  prov <- meta("dcterms:provenance",
               children = c(
                 meta("dcterms:modified", now),
                 meta("dc:creator", creator),
                 meta("dc:description", paste("Modified with:", cmd))))
  provO <- meta("prov:wasGeneratedBy",
                children = c(
                  meta("prov:endedAtTime", now),
                  meta("prov:wasAssociatedWith",
                       children = c(
                         meta(rel = "rdf:type", href = "obo:IAO_0000591"),
                         meta("dc:title", packageName()),
                         meta("dcterms:hasVersion",
                              as.character(packageVersion(packageName())))
                       )),
                  meta("prov:used", children = c(meta("prov:value", cmd))),
                  meta("prov:wasStartedBy",
                       children = c(
                         meta(rel = "rdf:type", href = "prov:Person"),
                         meta("foaf:name", creator)
                       ))
                ))
  nexml <- add_meta(c(prov, provO),
                    nexml = nexml,
                    namespaces = c(prov = "http://www.w3.org/ns/prov#",
                                   foaf = "http://xmlns.com/foaf/0.1/",
                                   obo = "http://purl.obolibrary.org/obo/",
                                   rdf = "http://www.w3.org/1999/02/22-rdf-syntax-ns#"))
  nexml
}


#' Obtains a character-state matrix from a nexml object
#'
#' @param nex a [nexml][RNeXML::nexml-class] object
#' @param otus_id logical, default TRUE, return a column with the otus block id.
#' @param states_as_labels logical, default FALSE, when TRUE returns states as labels instead of symbols.
#'   One can also use [state_symbols2labels()] to translate symbols to labels later.
#' @param verbose logical, default FALSE, If TRUE, messages informing about steps is printed.
#'
#' @return data.frame: The character-state matrix. The first column (taxa) contains taxon ids.
#' The second column (otu) contains otu ids. When the otus_id parameter is TRUE the third column (otus) will
#' contain otu block ids. The remaining columns are named for each anatomical label in the dataset and 
#' contain the associated state values.
#'
#' @seealso [get_char_matrix_meta()] to retrieve metadata for a nexml object.
#' @examples
#' # applied to a (synthetic) Ontotrace matrix:
#' nex <- get_ontotrace_data(taxon = c("Ictalurus", "Ameiurus"), entity = "fin spine")
#' get_char_matrix(nex, otus_id = FALSE)
#' 
#' # applied to a data matrix for a study
#' slist <- get_studies(taxon = "Ictalurus australis", entity = "fin spine")
#' nex <- get_study_data(slist$id[1])[[1]]
#' # for brevity show only 6 character data columns and first 5 rows
#' get_char_matrix(nex, otus_id = FALSE)[1:5,1:8]
#' # same, but states as labels (this can take a while)
#' get_char_matrix(nex, otus_id = FALSE, states_as_labels = TRUE)
#' 
#' @importFrom RNeXML get_characters
#' @export
get_char_matrix <- function(nex, otus_id = TRUE, states_as_labels = FALSE, verbose = FALSE) {
  
  m <- get_characters(nex, rownames_as_col = TRUE,
                      otu_id = TRUE, otus_id = otus_id)
  if (states_as_labels) {
    metacols = c(1,2)
    if (otus_id) metacols <- c(metacols, 3)
    state_symbols2labels(nex, charmat = m, metacolumns = metacols)
  } else
    m
}

#' Translates state symbols to labels in a character matrix
#'
#' Translates a character matrix using symbols for states to one using labels
#' instead. The character matrix must have been obtained from a [nexml][RNeXML::nexml-class]
#' object, usually using [get_char_matrix()], and the nexml object is required
#' for the translation.
#'
#' If state labels are missing for some characters, a warning will be issued.
#' If the nexml object has no state labels at all, a warning will be issued and
#' no translation will be attempted. If a symbol cannot be matched to a state
#' definition in the nexml object, or if the matching state definition does not
#' give a label for the state, the symbol will not be translated.
#'
#' @note If the nexml object contains multiple character matrices, currently the character labels
#' must be distinct between them.
#' @param nex the [nexml][RNeXML::nexml-class] object from which the character matrix was obtained
#' @param charmat the character matrix (as a data.frame, usually obtained using [get_char_matrix()])
#' @param metacolumns the indexes of the columns in the matrix that contain metadata (such as taxa,
#'   identifiers, etc), not character states. If not all of these columns are before all character
#'   columns, then the returned matrix will move all of them to the front. The default is the first
#'   two columns.
#' @return
#' A data.frame of the character matrix, with cells as state labels instead of symbols, and rows
#' and columns in the same order as the input matrix (see parameter `metacolumns` for a possible exception).
#' The data types of the columns may change as a result of translation, and even if no translation
#' can take place (due to missing state labels) (although in the absence of translation a numeric
#' type column should still have a numeric type).
#' @examples
#' # obtain a (synthetic) Ontotrace matrix:
#' nex <- get_ontotrace_data(taxon = c("Ictalurus", "Ameiurus"), entity = "fin spine")
#' m <- get_char_matrix(nex, otus_id = FALSE)
#' # by default it uses symbols
#' m
#' # translate symbols to labels without having to re-obtain the matrix
#' state_symbols2labels(nex, m)
#' # if we obtained the matrix with otus_id, then we have one more metadata column
#' m <- get_char_matrix(nex, otus_id = TRUE)
#' state_symbols2labels(nex, m, metacolumns = c(1,2,3))
#'
#' @importFrom dplyr inner_join  "%>%"
#' @export
state_symbols2labels <- function(nex, charmat, metacolumns = c(1,2)) {
  # create lookup tables for character ID (by column name), state symbol, and polymorphic symbol
  states <- 
    (get_level(nex, "characters/format/states/state")[, c("symbol", "label", "state", "states", "characters")]
     %>% dplyr::inner_join(get_level(nex, "characters/format/char"),
                           by = c("states" = "states", "characters" = "characters"),
                           suffix = c(".state", ".char")))
  # if there are no labels, there's nothing to be done
  if (all(is.na(states$label.state))) {
    warning("No state labels present in nexml object, cannot translate symbols", call. = FALSE)
    return(charmat)
  }
  if (any(is.na(states$label.state))) {
    warning("One or more discrete state(s) lack(s) labels, cannot translate corresponding symbols", call. = FALSE)
  }
  polymorph <- data.frame()
  polymorp_mems <- get_level(nex, "characters/format/states/polymorphic_state_set/member")
  if (nrow(polymorp_mems) > 0)
    polymorph <- dplyr::inner_join(polymorp_mems,
                                   get_level(nex, "characters/format/states/polymorphic_state_set"),
                                   by = c("polymorphic_state_set" = "polymorphic_state_set",
                                          "states" = "states",
                                          "characters" = "characters"))

  # utility function for translating one column
  # (where first row is the column name, i.e., character)
  translate_symbol <- function(col, charname) {
    # find character matching column (character) name / label
    states_for_char <- states[states$label.char == charname, ]
    if (nrow(states_for_char) == 0)
      states_for_char <- states[states$char == charname, ]
    # map symbols to labels using the match table
    sapply(col, function(x) {
      if(!is.na(x)) {
        labl <- states_for_char$label.state[states_for_char$symbol == x]
        if ((length(labl) == 0) && (nrow(polymorph) > 0)) {
          # if we can't match the symbol, try it as a polymorphic state symbol
          state_members <- polymorph[polymorph$symbol == x
                                     & polymorph$characters %in% states_for_char$characters, ]
          labl <- paste(states_for_char$label.state[states_for_char$state %in% state_members$state
                                                    & states_for_char$states %in% state_members$states],
                        collapse = " and ")
        }
        # if state symbol can't be matched or if label is missing, fall back to symbol
        if (length(labl) == 0 || is.na(labl))
          x
        else
          labl
      } else
        NA
    })
  }

  # create a modified matrix where the metadata columns are removed
  mat <- if (length(metacolumns) == 0)
    charmat
  else
    charmat[, -metacolumns]

  # translate each column using the utility function, convert to data.frame
  ret <- as.data.frame(mapply(translate_symbol, mat, colnames(mat)), stringsAsFactors = FALSE)
  # return after combining with the metadata columns
  return(cbind(charmat[, metacolumns], ret))
}

#' Obtains taxa and character metadata from a nexml object
#'
#' @param nex a [nexml][RNeXML::nexml-class] object
#'
#' @return A list of two data frames. The first list item, `id_taxa`, contains
#' a data frame with columns label, href (taxon IRI), otu (OTU ID) and otus (OTUs block ID) columns. The second list item,
#' `id_entities`, contains a data frame with columns label, href (character ID), and char (character ID in NeXML document).
#' For nexml objects obtained with [get_ontotrace_data()] the href column will contain the entity term IRI
#' rather than the character ID, and the char column will contain the entity term ID (the term IRI without the
#' HTTP path prefix).
#'
#' @examples
#' # apply to (synthetic) Ontotrace data matrix
#' nex <- get_ontotrace_data(taxon = c("Ictalurus", "Ameiurus"), entity = "fin spine")
#' get_char_matrix_meta(nex)
#'
#' # apply to data matrix from a study
#' slist <- get_studies(taxon = "Ictalurus australis", entity = "fin spine")
#' nex <- get_study_data(slist$id[1])[[1]]
#' metadata <- get_char_matrix_meta(nex)
#' # for brevity show only first 5 rows
#' metadata$id_taxa[1:5,]
#' metadata$id_entities[1:5,]
#'
#' @importFrom RNeXML get_taxa get_metadata get_level
#' @importFrom dplyr filter inner_join select rename "%>%"
#' @export
get_char_matrix_meta <- function(nex) {
  
  # NULLing out : for the R CMD CHECK
  property <- label <- href <- otu <- otus.x <- char <- NULL
  
  id_taxa <- get_taxa(nex)
  id_taxa_meta <- get_metadata(nex, "otu")
  
  id_taxa <- (id_taxa_meta
              %>% filter(property == meta_attr_taxon)
              %>% inner_join(id_taxa, by = c("otu" = "otu"))
              %>% select(label, href, otu, otus.x)
              %>% rename(otus = otus.x))
  
  id_entities <- get_level(nex, "characters/format/char")
  id_entities_meta <- get_metadata(nex, level="characters/format/char")
  
  id_entities <- (id_entities_meta
                  %>% filter(property == meta_attr_entity)
                  %>% inner_join(id_entities, by = c("char" = "char"))
                  %>% select(label, href, char))
  
  m_re <- list(id_taxa = id_taxa,
               id_entities = id_entities)
  
  return(m_re)
}