R/write-jplace.R

In GuangchuangYu/treeio: Base Classes and Functions for Phylogenetic Tree Input and Output

##' Export \code{jplace} object to jplace file. 
##' @title write.jplace
##' @param x a jplace object.
##' @param outfile the output file name
##' @export
##' @examples
##' jp <- system.file("extdata", "sample.jplace", package="treeio")
##' tr1 <- read.jplace(jp)
##' outfile <- tempfile()
##' write.jplace(tr1, outfile)
##' tr2 <- read.jplace(outfile)
##' tr2
write.jplace <- function(x, outfile){
  if (!inherits(x, 'jplace')){
      cli::cli_abort("The {.fn write.jplace} only works with {.cls {'jplace'}} class now, but a {.cls {class(x)}} class was provided.")
  }
  fields <- setdiff( colnames(x@placements), c('name', 'node') )
  
  placements.char <- .obtain.placement.char(x@placements, fields)

  fields.char <- paste0('["',paste0(fields, collapse='","'),'"]')
  
  out <- file(outfile, "w")
  
  writeLines("{", out)
  
  tree.char <- paste0('\t"tree": "', x@treetext, '",')
  
  writeLines(tree.char, out)
  
  writeLines(paste0('\t"placements": ', placements.char, ','), out)
  
  writeLines('\t"metadata": {"info": "generated by treeio package"},', out)
  
  writeLines(paste0('\t"version": ', x@info$version, ","), out)
  
  writeLines(paste0('\t"fields": ', fields.char), out)
  
  writeLines("\n}", out)
  
  close(out)

}

.obtain.placement.char <- function(placements, fields){
  rlang::check_installed('tidyr', 'for the `write.jplace()`.')
  placements.char <- placements |>
                     dplyr::select(-"node") |>
                     tidyr::nest(p=! .data$name) |>
                     dplyr::rename(n='name') |>
                     jsonlite::toJSON()

  pattern <- paste0(paste0("\"", fields, "\":"), collapse="|")
  placements.char <- gsub(pattern, "", placements.char)
  placements.char <- placements.char %>%
      chartr("{}", "[]", .) %>%
      gsub("\\],\\[\"n","\\},\\{\"n",.) %>%
      sub("^\\[\\[", "[{",.) %>%
      sub("\\]\\]$","}]",.)

  return(placements.char)
}