more pugixml functions

[JanMarvin]

The following matches a few xml2 functions used in mschart. Not sure if we really have a need for any of this, but I was curious what is used and not currently supported by us. We have a couple of functions that provide similar things, but a) I've only implemented nesting of 3 nodes (mschart requires more).

// xml_find_node
// @param node xml_node a child is searched in
// @param child the xml_node to search
// @param pointer bool if pointer should be returned
// @param escapes bool if escapes should be used
// @export
// [[Rcpp::export]]
SEXP xml_find_node(XPtrXML node, std::string chld) {

  struct Local {
    Local(std::string chld) {this->chld = chld;}

    // // find attribute
    // bool operator()(pugi::xml_attribute attr) const {
    //   return strcmp(attr.name(), "e") == 0;
    // }

    bool operator()(pugi::xml_node node) const {
      std::string xml_name = node.name();
      return xml_name.compare(chld.c_str()) == 0;
    }

    std::string chld;
  };

  unsigned int pugi_format_flags = pugi_format(node);
  pugi::xml_node found = node->find_node(Local(chld));
  // could return the value instead

  std::ostringstream oss;
  found.print(oss, " ", pugi_format_flags);
  SEXP name = Rcpp::wrap(Rcpp::String(oss.str()));

  Rcpp::CharacterVector out = Rcpp::wrap(Rcpp::String(found.path()));
  out.attr("names") = name;

  return out;
}

// xml_remove_child
// @param node xml_node a child is searched in
// @param path the xpath to the node to remove
// @param pointer bool if pointer should be returned
// @export
// [[Rcpp::export]]
SEXP xml_remove_child(XPtrXML node, std::string path, bool pointer) {

  unsigned int pugi_format_flags = pugi_format(node);

  pugi::xml_node got = node->select_node(path.c_str()).node();
  node->select_node(path.c_str()).parent().remove_child(got);

  if (pointer) {
    return (node);
  } else {
    std::ostringstream oss;
    node->print(oss, " ", pugi_format_flags);
    return Rcpp::wrap(Rcpp::String(oss.str()));
  }
}

// xml_replace_node
// @param node xml_node a child is searched in
// @param child the xml_node to search
// @param pointer bool if pointer should be returned
// @param escapes bool if escapes should be used
// @export
// [[Rcpp::export]]
SEXP xml_replace_child(XPtrXML node, std::string path, std::string replacement, bool escapes, bool pointer) {


  // pugi::parse_default without escapes flag
  unsigned int pugi_parse_flags = pugi::parse_cdata | pugi::parse_wconv_attribute | pugi::parse_ws_pcdata | pugi::parse_eol;
  if (escapes) pugi_parse_flags |= pugi::parse_escapes;

  unsigned int pugi_format_flags = pugi_format(node);

  pugi::xml_node got = node->select_node(path.c_str()).node();

  pugi::xml_document rplcmnt;
  pugi::xml_parse_result result = rplcmnt.load_string(replacement.c_str(), pugi_parse_flags);

  // check if result is a valid xml_node
  if (result) {
    node->select_node(path.c_str()).parent().insert_copy_after(rplcmnt.first_child(), got);
  } else {
    Rf_error("oops");
  }
  node->select_node(path.c_str()).parent().remove_child(got);

  if (pointer) {
    return (node);
  } else {
    std::ostringstream oss;
    node->print(oss, " ", pugi_format_flags);
    return Rcpp::wrap(Rcpp::String(oss.str()));
  }
}

library(openxlsx2)

xml_str <- "<a><b><c><d><e/><f/></d></c></b></a>"

# xml <- xml2::read_xml(xml_str)
# 
# xml_remove(xml_find_first(xml, "//e"))
# 
# tmp <- tempfile(fileext = ".xml")
# write_xml(xml, tmp)
# openxlsx2::read_xml(tmp)

# xml2::xml_find_first
openxlsx2:::xml_find_node(openxlsx2::read_xml(xml_str), "e")
#>         <e/> 
#> "/a/b/c/d/e"

# xml2::xml-remove
openxlsx2:::xml_remove_child(
  openxlsx2::read_xml(xml_str),
  openxlsx2:::xml_find_node(openxlsx2::read_xml(xml_str), "e"),
  FALSE
)
#> [1] "<a><b><c><d><f/></d></c></b></a>"

# xml2::xml_replace
openxlsx2:::xml_replace_child(
  openxlsx2::read_xml(xml_str),
  openxlsx2:::xml_find_node(openxlsx2::read_xml(xml_str), "e"),
  "<k/>",
  FALSE,
  FALSE
)
#> [1] "<a><b><c><d><k/><f/></d></c></b></a>"

# xml2::attr<-
openxlsx2:::xml_replace_child(
  openxlsx2::read_xml(xml_str),
  openxlsx2:::xml_find_node(openxlsx2::read_xml(xml_str), "e"),
  xml_attr_mod(
    names(openxlsx2:::xml_find_node(openxlsx2::read_xml(xml_str), "e")),
    c("val" = "1")
    ),
  FALSE,
  FALSE
)
#> [1] "<a><b><c><d><e val=\"1\"/><f/></d></c></b></a>"

[JanMarvin]

Function to reorder xml children

// [[Rcpp::export]]
SEXP xml_order_children1(XPtrXML node, std::string child, const std::vector<int>& order, bool pointer) {

    uint32_t pugi_format_flags = pugi_format(node);

    pugi::xml_node root = node->child(child.c_str());

    std::vector<pugi::xml_node> children;
    for (pugi::xml_node child : root.children()) {
        if (child.type() == pugi::node_element) {
            children.push_back(child);
        }
    }

    if (order.size() != children.size()) {
        Rcpp::stop("Order size (%d) does not match the number of children (%d).",
                   order.size(), children.size());
    }

    std::vector<pugi::xml_node> reordered_children(order.size());
    for (size_t i = 0; i < order.size(); ++i) {
        if (order[i] < 0 || static_cast<size_t>(order[i]) >= children.size()) {
            Rcpp::stop("Invalid order index: %d", order[i]);
        }
        reordered_children[i] = children[order[i]];
    }

    root.remove_children();

    for (const auto& child : reordered_children) {
        root.append_copy(child);
    }

    if (pointer) {
        return node;
    } else {
        std::ostringstream oss;
        root.print(oss, " ", pugi_format_flags);
        return Rcpp::wrap(Rcpp::String(oss.str()));
    }
}

#' order xml children in node
#' @param xml_node an xml structure
#' @param level the xml root
#' @param order the wanted order as numeric
#' @param pointer pointer
#' @param ... additional arguments passed to `read_xml()`
#' @examples
#' xml <- "<a><b/><c/><d/></a>"
#' xml_order_children(xml, "a", c(3, 2, 1))
#' @export
xml_order_children <- function(xml_node, level, order, pointer = FALSE, ...) {

  if (missing(xml_node) || missing(level) || missing(order))
    stop("need xml_node, level, and order")

  if (!inherits(xml_node, "pugi_xml")) xml_node <- read_xml(xml_node, ...)
  assert_class(level, "character")

  if (!xml_node_name(xml_node) %in% level)
    stop("level not found")

  order <- order - 1L

  xml_order_children1(node = xml_node, child = level, order = order, pointer = pointer)

}

test_that("xml_order_children works", {
  xml <- "<a><b/><c/><d/></a>"
  exp <- "<a><d/><c/><b/></a>"
  got <- xml_order_children(xml, "a", c(3, 2, 1))
  expect_equal(exp, got)

  got <- xml_order_children(xml, "a", c(3, 2, 1), pointer = TRUE)
  expect_equal(TRUE, inherits(got, "pugi_xml"))

  expect_error(xml_order_children(xml, "b", c(3, 2, 1)), "level not found")
  expect_error(xml_order_children(xml, "a", c(2, 1)), "does not match the number of children")
  expect_error(xml_order_children(xml, "a", c(2, 1, 0)), "Invalid order index")
  expect_error(xml_order_children(xml, c(2, 1, 0)), "need xml_node, level, and order")
})