Replace S3 dispatch by C implementation

NAMESPACE

@@ -71,15 +71,6 @@ S3method(xml_add_parent,xml_nodeset)
 S3method(xml_add_sibling,xml_missing)
 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)
-S3method(xml_attrs,xml_missing)
-S3method(xml_attrs,xml_node)
-S3method(xml_attrs,xml_nodeset)
-S3method(xml_double,xml_missing)
-S3method(xml_double,xml_node)
-S3method(xml_double,xml_nodeset)
 S3method(xml_find_all,xml_missing)
 S3method(xml_find_all,xml_node)
 S3method(xml_find_all,xml_nodeset)
@@ -95,25 +86,13 @@ S3method(xml_find_lgl,xml_nodeset)
 S3method(xml_find_num,xml_missing)
 S3method(xml_find_num,xml_node)
 S3method(xml_find_num,xml_nodeset)
-S3method(xml_integer,xml_missing)
-S3method(xml_integer,xml_node)
-S3method(xml_integer,xml_nodeset)
-S3method(xml_length,xml_missing)
-S3method(xml_length,xml_node)
-S3method(xml_length,xml_nodeset)
-S3method(xml_name,xml_missing)
-S3method(xml_name,xml_node)
-S3method(xml_name,xml_nodeset)
 S3method(xml_ns,xml_document)
 S3method(xml_ns,xml_missing)
 S3method(xml_ns,xml_node)
 S3method(xml_ns,xml_nodeset)
 S3method(xml_parent,xml_missing)
 S3method(xml_parent,xml_node)
 S3method(xml_parent,xml_nodeset)
-S3method(xml_path,xml_missing)
-S3method(xml_path,xml_node)
-S3method(xml_path,xml_nodeset)
 S3method(xml_remove,xml_missing)
 S3method(xml_remove,xml_node)
 S3method(xml_remove,xml_nodeset)
@@ -132,12 +111,6 @@ S3method(xml_set_attrs,xml_nodeset)
 S3method(xml_set_name,xml_missing)
 S3method(xml_set_name,xml_node)
 S3method(xml_set_name,xml_nodeset)
-S3method(xml_text,xml_missing)
-S3method(xml_text,xml_node)
-S3method(xml_text,xml_nodeset)
-S3method(xml_type,xml_missing)
-S3method(xml_type,xml_node)
-S3method(xml_type,xml_nodeset)
 S3method(xml_url,xml_missing)
 S3method(xml_url,xml_node)
 S3method(xml_url,xml_nodeset)

R/xml_attr.R

@@ -60,31 +60,7 @@
 #' xml_attrs(doc) <- c("b:id" = "one", "f:id" = "two", "id" = "three")
 #' xml_set_attrs(doc, c("b:id" = "one", "f:id" = "two", "id" = "three"))
 xml_attr <- function(x, attr, ns = character(), default = NA_character_) {
-  UseMethod("xml_attr")
-}
-
-#' @export
-xml_attr.xml_missing <- function(x, attr, ns = character(), default = NA_character_) {
-  default
-}
-
-#' @export
-xml_attr.xml_node <- function(x, attr, ns = character(),
-                              default = NA_character_) {
-  .Call(node_attr, x$node, attr, as.character(default), ns)
-}
-
-#' @export
-xml_attr.xml_nodeset <- function(x, attr, ns = character(),
-                                 default = NA_character_) {
-  vapply(
-    x,
-    xml_attr,
-    attr = attr,
-    default = default,
-    ns = ns,
-    FUN.VALUE = character(1)
-  )
+  .Call(node_attr, x, attr, as.character(default), ns)
 }
 
 #' @export
@@ -96,22 +72,7 @@ xml_has_attr <- function(x, attr, ns = character()) {
 #' @export
 #' @rdname xml_attr
 xml_attrs <- function(x, ns = character()) {
-  UseMethod("xml_attrs")
-}
-
-#' @export
-xml_attrs.xml_missing <- function(x, ns = character()) {
-  NA_character_
-}
-
-#' @export
-xml_attrs.xml_node <- function(x, ns = character()) {
-  .Call(node_attrs, x$node, nsMap = ns)
-}
-
-#' @export
-xml_attrs.xml_nodeset <- function(x, ns = character()) {
-  lapply(x, xml_attrs, ns = ns)
+  .Call(node_attrs, x, nsMap = ns)
 }
 
 #' @param value character vector of new value.

R/xml_children.R

@@ -100,26 +100,7 @@ xml_parent.xml_nodeset <- function(x) {
 #' @export
 #' @rdname xml_children
 xml_length <- function(x, only_elements = TRUE) {
-  UseMethod("xml_length")
-}
-
-#' @export
-xml_length.xml_missing <- function(x, only_elements = TRUE) {
-  0L
-}
-
-#' @export
-xml_length.xml_node <- function(x, only_elements = TRUE) {
-  .Call(node_length, x$node, only_elements)
-}
-
-#' @export
-xml_length.xml_nodeset <- function(x, only_elements = TRUE) {
-  if (length(x) == 0) {
-    return(0L)
-  }
-
-  vapply(x, xml_length, only_elements = only_elements, FUN.VALUE = integer(1))
+  .Call(node_length, x, only_elements)
 }
 
 #' @export

R/xml_name.R

@@ -18,22 +18,7 @@
 #' z <- xml_children(y)
 #' xml_name(xml_children(y))
 xml_name <- function(x, ns = character()) {
-  UseMethod("xml_name")
-}
-
-#' @export
-xml_name.xml_missing <- function(x, ns = character()) {
-  NA_character_
-}
-
-#' @export
-xml_name.xml_nodeset <- function(x, ns = character()) {
-  vapply(x, xml_name, ns = ns, FUN.VALUE = character(1))
-}
-
-#' @export
-xml_name.xml_node <- function(x, ns = character()) {
-  .Call(node_name, x$node, ns)
+  .Call(node_name, x, ns)
 }
 
 #' Modify the (tag) name of an element

R/xml_path.R

@@ -10,20 +10,5 @@
 #' x <- read_xml("<foo><bar><baz /></bar><baz /></foo>")
 #' xml_path(xml_find_all(x, ".//baz"))
 xml_path <- function(x) {
-  UseMethod("xml_path")
-}
-
-#' @export
-xml_path.xml_missing <- function(x) {
-  NA_character_
-}
-
-#' @export
-xml_path.xml_node <- function(x) {
-  .Call(node_path, x$node)
-}
-
-#' @export
-xml_path.xml_nodeset <- function(x) {
-  vapply(x, xml_path, FUN.VALUE = character(1))
+  .Call(node_path, x)
 }

R/xml_text.R

@@ -22,27 +22,16 @@
 #' xml_integer(xml_find_all(x, "//@x"))
 #' @export
 xml_text <- function(x, trim = FALSE) {
-  UseMethod("xml_text")
-}
-
-#' @export
-xml_text.xml_missing <- function(x, trim = FALSE) {
-  NA_character_
-}
-
-#' @export
-xml_text.xml_node <- function(x, trim = FALSE) {
-  res <- .Call(node_text, x$node)
+  res <- .Call(node_text, x)
   if (isTRUE(trim)) {
-    res <- sub("^[[:space:]\u00a0]+", "", res)
-    res <- sub("[[:space:]\u00a0]+$", "", res)
+    res <- trim_text(res)
   }
   res
 }
 
-#' @export
-xml_text.xml_nodeset <- function(x, trim = FALSE) {
-  vapply(x, xml_text, trim = trim, FUN.VALUE = character(1))
+trim_text <- function(x) {
+  x <- sub("^[[:space:]\u00a0]+", "", x)
+  sub("[[:space:]\u00a0]+$", "", x)
 }
 
 #' @rdname xml_text
@@ -94,46 +83,11 @@ xml_text.xml_nodeset <- function(x, trim = FALSE) {
 #' @rdname xml_text
 #' @export
 xml_double <- function(x) {
-  UseMethod("xml_double")
-}
-
-#' @export
-xml_double.xml_missing <- function(x) {
-  NA_real_
-}
-
-#' @export
-xml_double.xml_node <- function(x) {
   as.numeric(xml_text(x))
 }
 
-#' @export
-xml_double.xml_nodeset <- function(x) {
-  vapply(x, xml_double, numeric(1))
-}
-
-#' @export
-xml_integer <- function(x) {
-  UseMethod("xml_integer")
-}
-
-#' @export
-xml_integer.xml_missing <- function(x) {
-  NA_integer_
-}
-
 #' @rdname xml_text
 #' @export
 xml_integer <- function(x) {
-  UseMethod("xml_integer")
-}
-
-#' @export
-xml_integer.xml_node <- function(x) {
   as.integer(xml_text(x))
 }
-
-#' @export
-xml_integer.xml_nodeset <- function(x) {
-  vapply(x, xml_integer, integer(1))
-}

R/xml_type.R

@@ -7,22 +7,7 @@
 #' xml_type(x)
 #' xml_type(xml_contents(x))
 xml_type <- function(x) {
-  UseMethod("xml_type")
-}
-
-#' @export
-xml_type.xml_missing <- function(x) {
-  NA_character_
-}
-
-#' @export
-xml_type.xml_node <- function(x) {
-  xmlElementType[.Call(node_type, x$node)]
-}
-
-#' @export
-xml_type.xml_nodeset <- function(x) {
-  types <- vapply(x, function(x) .Call(node_type, x$node), integer(1))
+  types <- .Call(node_type, x)
   xmlElementType[types]
 }
 

inst/include/xml2_types.h

@@ -5,6 +5,24 @@
 #define R_NO_REMAP
 #include <Rinternals.h>
 
+enum NodeType {
+  missing = 1,
+  node = 2,
+  nodeset = 3,
+};
+
+inline const NodeType getNodeType(SEXP x) {
+  if (Rf_inherits(x, "xml_node")) {
+    return(NodeType::node);
+  } else if (Rf_inherits(x, "xml_nodeset")) {
+    return(NodeType::nodeset);
+  } else if (Rf_inherits(x, "xml_missing")) {
+    return(NodeType::missing);
+  } else {
+    Rf_error("Unexpected node type");
+  }
+}
+
 template <typename T> class XPtr {
   protected:
   SEXP data_;