IN_PROGRESS: Mutating/Creating nodes

.gitignore

@@ -6,3 +6,4 @@ src/*.so
 src/*.dll
 src/*.a
 src/Makevars
+inst/doc

.travis.yml

@@ -1,6 +1,8 @@
 language: R
 cache: packages
 
+github_packages: jimhester/covr
+
 addons:
   apt:
     packages:

DESCRIPTION

@@ -21,7 +21,11 @@ LinkingTo: Rcpp (>= 0.11.4.6),
 Suggests:
     testthat,
     curl,
-    covr
+    covr,
+    knitr,
+    rmarkdown,
+    magrittr
 SystemRequirements: libxml2: libxml2-dev (deb), libxml2-devel (rpm)
 License: GPL (>= 2)
 RoxygenNote: 5.0.1
+VignetteBuilder: knitr

NAMESPACE

@@ -1,6 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method("[",xml_nodeset)
+S3method("xml_attr<-",xml_node)
+S3method("xml_attr<-",xml_nodeset)
+S3method("xml_attrs<-",xml_node)
+S3method("xml_attrs<-",xml_nodeset)
+S3method("xml_name<-",xml_node)
+S3method("xml_name<-",xml_nodeset)
+S3method("xml_text<-",xml_node)
+S3method("xml_text<-",xml_nodeset)
 S3method(as.character,xml_document)
 S3method(as.character,xml_missing)
 S3method(as.character,xml_node)
@@ -26,6 +34,11 @@ S3method(write_xml,xml_document)
 S3method(write_xml,xml_missing)
 S3method(write_xml,xml_node)
 S3method(write_xml,xml_nodeset)
+S3method(xml_add_child,xml_document)
+S3method(xml_add_child,xml_node)
+S3method(xml_add_child,xml_nodeset)
+S3method(xml_add_sibling,xml_node)
+S3method(xml_add_sibling,xml_nodeset)
 S3method(xml_attr,xml_missing)
 S3method(xml_attr,xml_node)
 S3method(xml_attr,xml_nodeset)
@@ -57,6 +70,10 @@ S3method(xml_parent,xml_node)
 S3method(xml_parent,xml_nodeset)
 S3method(xml_path,xml_node)
 S3method(xml_path,xml_nodeset)
+S3method(xml_remove_node,xml_node)
+S3method(xml_remove_node,xml_nodeset)
+S3method(xml_replace,xml_node)
+S3method(xml_replace,xml_nodeset)
 S3method(xml_text,xml_missing)
 S3method(xml_text,xml_node)
 S3method(xml_text,xml_nodeset)
@@ -65,6 +82,10 @@ S3method(xml_type,xml_node)
 S3method(xml_type,xml_nodeset)
 S3method(xml_url,xml_missing)
 S3method(xml_url,xml_node)
+export("xml_attr<-")
+export("xml_attrs<-")
+export("xml_name<-")
+export("xml_text<-")
 export(as_list)
 export(html_structure)
 export(read_html)
@@ -75,6 +96,8 @@ export(url_parse)
 export(url_relative)
 export(url_unescape)
 export(write_xml)
+export(xml_add_child)
+export(xml_add_sibling)
 export(xml_attr)
 export(xml_attrs)
 export(xml_children)
@@ -87,11 +110,16 @@ export(xml_find_one)
 export(xml_has_attr)
 export(xml_length)
 export(xml_name)
+export(xml_new_document)
 export(xml_ns)
 export(xml_ns_rename)
 export(xml_parent)
 export(xml_parents)
 export(xml_path)
+export(xml_remove_node)
+export(xml_replace)
+export(xml_root)
+export(xml_set_namespace)
 export(xml_siblings)
 export(xml_structure)
 export(xml_text)

R/RcppExports.R

@@ -17,18 +17,30 @@ doc_format <- function(x) {
     .Call('xml2_doc_format', PACKAGE = 'xml2', x)
 }
 
-doc_write <- function(x, path) {
-    invisible(.Call('xml2_doc_write', PACKAGE = 'xml2', x, path))
+doc_write <- function(x, path, format) {
+    invisible(.Call('xml2_doc_write', PACKAGE = 'xml2', x, path, format))
 }
 
 doc_root <- function(x) {
     .Call('xml2_doc_root', PACKAGE = 'xml2', x)
 }
 
+doc_has_root <- function(x) {
+    .Call('xml2_doc_has_root', PACKAGE = 'xml2', x)
+}
+
 doc_url <- function(x) {
     .Call('xml2_doc_url', PACKAGE = 'xml2', x)
 }
 
+doc_new <- function(version) {
+    .Call('xml2_doc_new', PACKAGE = 'xml2', version)
+}
+
+doc_set_root <- function(doc, root) {
+    .Call('xml2_doc_set_root', PACKAGE = 'xml2', doc, root)
+}
+
 libxml2_version <- function() {
     .Call('xml2_libxml2_version', PACKAGE = 'xml2')
 }
@@ -41,10 +53,22 @@ doc_namespaces <- function(doc) {
     .Call('xml2_doc_namespaces', PACKAGE = 'xml2', doc)
 }
 
+ns_lookup_uri <- function(doc, node, uri) {
+    .Call('xml2_ns_lookup_uri', PACKAGE = 'xml2', doc, node, uri)
+}
+
+ns_lookup <- function(doc, node, prefix) {
+    .Call('xml2_ns_lookup', PACKAGE = 'xml2', doc, node, prefix)
+}
+
 node_name <- function(node, nsMap) {
     .Call('xml2_node_name', PACKAGE = 'xml2', node, nsMap)
 }
 
+node_set_name <- function(node, value) {
+    invisible(.Call('xml2_node_set_name', PACKAGE = 'xml2', node, value))
+}
+
 node_text <- function(node, trim) {
     .Call('xml2_node_text', PACKAGE = 'xml2', node, trim)
 }
@@ -57,6 +81,14 @@ node_attrs <- function(node, nsMap) {
     .Call('xml2_node_attrs', PACKAGE = 'xml2', node, nsMap)
 }
 
+node_set_attr <- function(node, name, value, nsMap) {
+    invisible(.Call('xml2_node_set_attr', PACKAGE = 'xml2', node, name, value, nsMap))
+}
+
+node_remove_attr <- function(node, name, nsMap) {
+    invisible(.Call('xml2_node_remove_attr', PACKAGE = 'xml2', node, name, nsMap))
+}
+
 node_format <- function(doc, node, format = TRUE, indent = 0L) {
     .Call('xml2_node_format', PACKAGE = 'xml2', doc, node, format, indent)
 }
@@ -97,6 +129,54 @@ node_type <- function(node) {
     .Call('xml2_node_type', PACKAGE = 'xml2', node)
 }
 
+node_set_content <- function(node, content) {
+    invisible(.Call('xml2_node_set_content', PACKAGE = 'xml2', node, content))
+}
+
+node_append_content <- function(node, content) {
+    invisible(.Call('xml2_node_append_content', PACKAGE = 'xml2', node, content))
+}
+
+node_add_child <- function(parent, cur, copy) {
+    .Call('xml2_node_add_child', PACKAGE = 'xml2', parent, cur, copy)
+}
+
+node_prepend_sibling <- function(cur, elem, copy) {
+    .Call('xml2_node_prepend_sibling', PACKAGE = 'xml2', cur, elem, copy)
+}
+
+node_append_sibling <- function(cur, elem, copy) {
+    .Call('xml2_node_append_sibling', PACKAGE = 'xml2', cur, elem, copy)
+}
+
+node_replace <- function(old, cur, copy) {
+    .Call('xml2_node_replace', PACKAGE = 'xml2', old, cur, copy)
+}
+
+node_remove <- function(cur, free) {
+    invisible(.Call('xml2_node_remove', PACKAGE = 'xml2', cur, free))
+}
+
+node_new <- function(name) {
+    .Call('xml2_node_new', PACKAGE = 'xml2', name)
+}
+
+node_new_ns <- function(name, ns) {
+    .Call('xml2_node_new_ns', PACKAGE = 'xml2', name, ns)
+}
+
+node_null <- function() {
+    .Call('xml2_node_null', PACKAGE = 'xml2')
+}
+
+node_set_namespace_uri <- function(doc, node, uri) {
+    invisible(.Call('xml2_node_set_namespace_uri', PACKAGE = 'xml2', doc, node, uri))
+}
+
+node_set_namespace_prefix <- function(doc, node, prefix) {
+    invisible(.Call('xml2_node_set_namespace_prefix', PACKAGE = 'xml2', doc, node, prefix))
+}
+
 #' Convert between relative and absolute urls.
 #'
 #' @param x A character vector of urls relative to that base

R/classes.R

@@ -47,8 +47,10 @@ xml_document <- function(doc) {
 #' @export
 print.xml_document <- function(x, width = getOption("width"), max_n = 20, ...) {
   cat("{xml_document}\n")
-  cat("<", xml_name(x), ">\n", sep = "")
-  show_nodes(xml_children(x), width = width, max_n = max_n)
+  if (inherits(x, "xml_node")) {
+    cat("<", xml_name(x), ">\n", sep = "")
+    show_nodes(xml_children(x), width = width, max_n = max_n)
+  }
 }
 
 #' @export
@@ -117,6 +119,7 @@ show_nodes <- function(x, width = getOption("width"), max_n = 20) {
   if (trunc) {
     cat("...\n")
   }
+  invisible()
 }
 
 

R/utils.R

@@ -1 +1,13 @@
 `%||%` <- function(a, b) if (is.null(a)) b else a
+
+is_named <- function(x) {
+  all(has_names(x))
+}
+has_names <- function(x) {
+  nms <- names(x)
+  if (is.null(nms)) {
+    rep(FALSE, length(x))
+  } else {
+    !(is.na(nms) | nms == "")
+  }
+}

R/xml_attr.R

@@ -1,9 +1,11 @@
 #' Retrieve an attribute.
 #'
 #' \code{xml_attrs()} retrieves all attributes values as a named character
-#' vector. \code{xml_attr()} retrieves the value of single attribute. If the
-#' attribute doesn't exist, it will return \code{default}, which defaults to
-#' \code{NA}. \code{xml_has_attr()} tests if an attribute is present.
+#' vector, \code{xml_attrs() <-} sets all attribute values. \code{xml_attr()}
+#' retrieves the value of single attribute and \code{xml_attr() <-} modifies
+#' its value. If the attribute doesn't exist, it will return \code{default},
+#' which defaults to \code{NA}. \code{xml_has_attr()} tests if an attribute is
+#' present.
 #'
 #' @inheritParams xml_name
 #' @param attr Name of attribute to extract.
@@ -79,7 +81,9 @@ xml_has_attr <- function(x, attr, ns = character()) {
 
 #' @export
 #' @rdname xml_attr
-xml_attrs <- function(x, ns = character()) UseMethod("xml_attrs")
+xml_attrs <- function(x, ns = character()) {
+  UseMethod("xml_attrs")
+}
 
 #' @export
 xml_attrs.xml_missing <- function(x, ns = character()) {
@@ -95,3 +99,78 @@ xml_attrs.xml_node <- function(x, ns = character()) {
 xml_attrs.xml_nodeset <- function(x, ns = character()) {
   lapply(x, xml_attrs, ns = ns)
 }
+
+#' @param value character vector of new value.
+#' @rdname xml_attr
+#' @export
+`xml_attr<-` <- function(x, attr, ns = character(), value) {
+  UseMethod("xml_attr<-")
+}
+
+#' @export
+`xml_attr<-.xml_node` <- function(x, attr, ns = character(), value) {
+  if (is.null(value)) {
+    node_remove_attr(x$node, name = attr, nsMap = ns)
+  } else {
+    node_set_attr(x$node, name = attr, nsMap = ns, value)
+  }
+  x
+}
+
+#' @export
+`xml_attr<-.xml_nodeset` <- function(x, attr, ns = character(), value) {
+  lapply(x, `xml_attr<-`, attr = attr, ns = ns, value = value)
+  x
+}
+
+#' @rdname xml_attr
+#' @export
+`xml_attrs<-` <- function(x, ns = character(), value) {
+  UseMethod("xml_attrs<-")
+}
+
+#' @export
+`xml_attrs<-.xml_node` <- function(x, ns = character(), value) {
+  if (!is_named(value)) {
+    stop("`value` must be a named character vector or `NULL`", call. = FALSE)
+  }
+
+  attrs <- names(value)
+
+  current_attrs <- names(xml_attrs(x, ns = ns))
+
+  existing <- intersect(current_attrs, attrs)
+  new <- setdiff(attrs, current_attrs)
+  removed <- setdiff(current_attrs, attrs)
+
+  # replace existing attributes and add new ones
+  Map(function(attr, val) {
+      xml_attr(x, attr, ns) <- val
+  }, attr = c(existing, new), value[c(existing, new)])
+
+
+  # Remove attributes which no longer exist
+  Map(function(attr) {
+    xml_attr(x, attr, ns) <- NULL
+  }, attr = removed)
+
+  x
+}
+
+#' @export
+`xml_attrs<-.xml_nodeset` <- function(x, ns = character(), value) {
+  if (!is.list(ns)) {
+     ns <- list(ns)
+  }
+  if (!is.list(value)) {
+     value <- list(value)
+  }
+  if (!all(vapply(value, is_named, logical(1)))) {
+    stop("`value` must be a list of named character vectors")
+  }
+
+  Map(`xml_attrs<-`, x, ns, value)
+
+  x
+}
+

R/xml_children.R

@@ -95,3 +95,11 @@ xml_length.xml_nodeset <- function(x, only_elements = TRUE) {
 
   vapply(x, node_length, onlyNode = only_elements, FUN.VALUE = integer(1))
 }
+
+#' @export
+#' @rdname xml_children
+xml_root <- function(x) {
+  stopifnot(inherits(x, "xml_node") || inherits(x, "xml_document"))
+
+  xml_document(x$doc)
+}