r-lib · hadley · Nov 2, 2023 · Aug 23, 2023 · Aug 23, 2023 · Aug 23, 2023
diff --git a/R/utils.R b/R/utils.R
@@ -80,3 +80,14 @@ xml2_example <- function(path = NULL) {
     system.file("extdata", path, package = "xml2", mustWork = TRUE)
   }
 }
+
+sample_nodeset <- function() {
+  x <- read_xml("<body>
+    <p>Some <b>text</b>.</p>
+    <p>Some <i>other</i>.</p>
+    <p>No bold text</p>
+    </body>")
+
+  children <- xml_children(x)
+  xml_find_first(children, ".//b|.//i")
+}
diff --git a/R/xml_name.R b/R/xml_name.R
@@ -28,7 +28,7 @@ xml_name.xml_missing <- function(x, ns = character()) {
 
 #' @export
 xml_name.xml_nodeset <- function(x, ns = character()) {
-  vapply(x, xml_name, ns = ns, FUN.VALUE = character(1))
+  .Call(nodeset_name, x, ns)
 }
 
 #' @export

diff --git a/R/xml_text.R b/R/xml_text.R
@@ -34,15 +34,24 @@ xml_text.xml_missing <- function(x, trim = FALSE) {
 xml_text.xml_node <- function(x, trim = FALSE) {
   res <- .Call(node_text, x$node)
   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))
+  res <- .Call(nodeset_text, x)
+
+  if (isTRUE(trim)) {
+    res <- trim_text(res)
+  }
+  res
+}
+
+trim_text <- function(x) {
+  x <- sub("^[[:space:]\u00a0]+", "", x)
+  sub("[[:space:]\u00a0]+$", "", x)
 }
 
 #' @rdname xml_text
@@ -109,7 +118,7 @@ xml_double.xml_node <- function(x) {
 
 #' @export
 xml_double.xml_nodeset <- function(x) {
-  vapply(x, xml_double, numeric(1))
+  as.numeric(xml_text(x))
 }
 
 #' @export
@@ -135,5 +144,5 @@ xml_integer.xml_node <- function(x) {
 
 #' @export
 xml_integer.xml_nodeset <- function(x) {
-  vapply(x, xml_integer, integer(1))
+  as.integer(xml_text(x))
 }
diff --git a/R/xml_type.R b/R/xml_type.R
@@ -22,7 +22,7 @@ xml_type.xml_node <- function(x) {
 
 #' @export
 xml_type.xml_nodeset <- function(x) {
-  types <- vapply(x, function(x) .Call(node_type, x$node), integer(1))
+  types <- .Call(nodeset_type, x)
   xmlElementType[types]
 }
 

diff --git a/src/init.c b/src/init.c
@@ -38,6 +38,7 @@ extern SEXP node_copy(SEXP);
 extern SEXP node_has_children(SEXP, SEXP);
 extern SEXP node_length(SEXP, SEXP);
 extern SEXP node_name(SEXP, SEXP);
+extern SEXP nodeset_name(SEXP, SEXP);
 extern SEXP node_new(SEXP);
 extern SEXP node_new_dtd(SEXP, SEXP, SEXP, SEXP);
 extern SEXP node_new_ns(SEXP, SEXP);
@@ -57,7 +58,9 @@ extern SEXP node_set_namespace_prefix(SEXP, SEXP, SEXP);
 extern SEXP node_set_namespace_uri(SEXP, SEXP, SEXP);
 extern SEXP node_siblings(SEXP, SEXP);
 extern SEXP node_text(SEXP);
+extern SEXP nodeset_text(SEXP);
 extern SEXP node_type(SEXP);
+extern SEXP nodeset_type(SEXP);
 extern SEXP node_write_character(SEXP, SEXP, SEXP);
 extern SEXP node_write_connection(SEXP, SEXP, SEXP, SEXP);
 extern SEXP node_write_file(SEXP, SEXP, SEXP, SEXP);
@@ -103,6 +106,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"node_has_children",         (DL_FUNC) &node_has_children,         2},
     {"node_length",               (DL_FUNC) &node_length,               2},
     {"node_name",                 (DL_FUNC) &node_name,                 2},
+    {"nodeset_name",              (DL_FUNC) &nodeset_name,              2},
     {"node_new",                  (DL_FUNC) &node_new,                  1},
     {"node_new_dtd",              (DL_FUNC) &node_new_dtd,              4},
     {"node_new_ns",               (DL_FUNC) &node_new_ns,               2},
@@ -122,7 +126,9 @@ static const R_CallMethodDef CallEntries[] = {
     {"node_set_namespace_uri",    (DL_FUNC) &node_set_namespace_uri,    3},
     {"node_siblings",             (DL_FUNC) &node_siblings,             2},
     {"node_text",                 (DL_FUNC) &node_text,                 1},
+    {"nodeset_text",              (DL_FUNC) &nodeset_text,              1},
     {"node_type",                 (DL_FUNC) &node_type,                 1},
+    {"nodeset_type",              (DL_FUNC) &nodeset_type,              1},
     {"node_write_character",      (DL_FUNC) &node_write_character,      3},
     {"node_write_connection",     (DL_FUNC) &node_write_connection,     4},
     {"node_write_file",           (DL_FUNC) &node_write_file,           4},

diff --git a/src/xml2_node.cpp b/src/xml2_node.cpp
@@ -37,6 +37,36 @@ extern "C" SEXP node_name(SEXP node_sxp, SEXP nsMap) {
   END_CPP
 }
 
+// [[export]]
+extern "C" SEXP nodeset_name(SEXP node_sxp, SEXP nsMap) {
+  BEGIN_CPP
+
+  int n = Rf_xlength(node_sxp);
+
+  SEXP out = PROTECT(Rf_allocVector(STRSXP, n));
+
+  for (int i = 0; i < n; ++i) {
+    SEXP node_sxp_i = VECTOR_ELT(node_sxp, i);
+
+    if (Rf_inherits(node_sxp_i, "xml_node")) {
+      SEXP node_field_i = VECTOR_ELT(node_sxp_i, 0);
+      XPtrNode node_i(node_field_i);
+      std::string name_i = nodeName(node_i.checked_get(), nsMap);
+      SET_STRING_ELT(out, i, Rf_mkCharLenCE(name_i.c_str(), name_i.size(), CE_UTF8));
+    } else if (Rf_inherits(node_sxp_i, "xml_missing")) {
+      SET_STRING_ELT(out, i, NA_STRING);
+    } else {
+      // xml_nodeset can't appear
+      Rf_error("Unexpected node type");
+    }
+  }
+
+  UNPROTECT(1);
+  return out;
+
+  END_CPP
+}
+
 // [[export]]
 extern "C" SEXP node_set_name(SEXP node_sxp, SEXP value) {
   BEGIN_CPP
@@ -57,6 +87,36 @@ extern "C" SEXP node_text(SEXP node_sxp) {
   END_CPP
 }
 
+// [[export]]
+extern "C" SEXP nodeset_text(SEXP node_sxp) {
+  BEGIN_CPP
+
+  int n = Rf_xlength(node_sxp);
+
+  SEXP out = PROTECT(Rf_allocVector(STRSXP, n));
+
+  for (int i = 0; i < n; ++i) {
+    SEXP node_sxp_i = VECTOR_ELT(node_sxp, i);
+
+    if (Rf_inherits(node_sxp_i, "xml_node")) {
+      SEXP node_field_i = VECTOR_ELT(node_sxp_i, 0);
+      XPtrNode node_i(node_field_i);
+      SEXP text_i = Xml2String(xmlNodeGetContent(node_i.checked_get())).asRString();
+      SET_STRING_ELT(out, i, text_i);
+    } else if (Rf_inherits(node_sxp_i, "xml_missing")) {
+      SET_STRING_ELT(out, i, NA_STRING);
+    } else {
+      // xml_nodeset can't appear
+      Rf_error("Unexpected node type");
+    }
+  }
+
+  UNPROTECT(1);
+  return out;
+
+  END_CPP
+}
+
 bool hasPrefix(std::string lhs, std::string rhs) {
   if (lhs.length() > rhs.length()) {
     return false;
@@ -584,6 +644,36 @@ extern "C" SEXP node_type(SEXP node_sxp) {
   END_CPP
 }
 
+// [[export]]
+extern "C" SEXP nodeset_type(SEXP node_sxp) {
+  BEGIN_CPP
+
+  int n = Rf_xlength(node_sxp);
+
+  SEXP out = PROTECT(Rf_allocVector(INTSXP, n));
+
+  for (int i = 0; i < n; ++i) {
+    SEXP node_sxp_i = VECTOR_ELT(node_sxp, i);
+
+    if (Rf_inherits(node_sxp_i, "xml_node")) {
+      SEXP node_field_i = VECTOR_ELT(node_sxp_i, 0);
+      XPtrNode node_i(node_field_i);
+      INTEGER(out)[i] = node_i->type;
+    } else if (Rf_inherits(node_sxp_i, "xml_missing")) {
+      INTEGER(out)[i] = NA_INTEGER;
+    } else {
+      // xml_nodeset can't appear
+      Rf_error("Unexpected node type");
+    }
+  }
+
+  UNPROTECT(1);
+  return out;
+
+  END_CPP
+}
+
+
 // [[export]]
 extern "C" SEXP node_copy(SEXP node_sxp) {
   BEGIN_CPP

diff --git a/tests/testthat/_snaps/xml_name.md b/tests/testthat/_snaps/xml_name.md
@@ -0,0 +1,4 @@
+# error if missing ns spec
+
+    Couldn't find prefix for url http://bar.com
+
diff --git a/tests/testthat/test-xml_missing.R b/tests/testthat/test-xml_missing.R
@@ -33,7 +33,6 @@ test_that("xml_missing methods return properly for all S3 methods", {
   expect_equal(xml_parent(mss), xml_missing())
   expect_equal(xml_path(mss), NA_character_)
   expect_equal(xml_text(mss), NA_character_)
-  expect_equal(xml_type(mss), NA_character_)
   expect_equal(xml_url(mss), NA_character_)
 })
 

diff --git a/tests/testthat/test-xml_name.R b/tests/testthat/test-xml_name.R
@@ -1,3 +1,13 @@
+test_that("xml_name() returns the name", {
+  x <- sample_nodeset()
+
+  expect_equal(xml_name(x[[1]]), "b")
+  expect_equal(xml_name(x[[2]]), "i")
+  expect_equal(xml_name(x[[3]]), NA_character_)
+
+  expect_equal(xml_name(x), c("b", "i", NA_character_))
+})
+
 test_that("qualified names returned when ns given", {
   x <- read_xml(test_path("ns-multiple-default.xml"))
   ns <- xml_ns(x)
@@ -12,7 +22,7 @@ test_that("error if missing ns spec", {
   ns <- xml_ns(x)[1]
 
   bars <- xml_children(xml_children(x))
-  expect_error(xml_name(bars, ns), "Couldn't find prefix")
+  expect_snapshot_error(xml_name(bars, ns))
 })
 
 test_that("xml_name<- modifies the name", {

diff --git a/tests/testthat/test-xml_nodeset.R b/tests/testthat/test-xml_nodeset.R
@@ -67,7 +67,6 @@ test_that("methods work on empty nodesets", {
   expect_output(xml_structure(empty), NA)
 
   expect_identical(xml_text(empty), character())
-  expect_identical(xml_type(empty), character())
   expect_identical(xml_url(empty), character())
 })
 

diff --git a/tests/testthat/test-xml_text.R b/tests/testthat/test-xml_text.R
@@ -6,22 +6,10 @@ test_that("xml_text returns only text without markup", {
   expect_identical(xml_text(xml_children(x)), "bold!")
 })
 
-test_that("xml_text returns only text without markup", {
-  x <- read_xml("<p>This is some text. This is <b>bold!</b></p>")
-
-  expect_identical(xml_text(x), "This is some text. This is bold!")
-
-  expect_identical(xml_text(xml_children(x)), "bold!")
-})
-
 test_that("xml_text works properly with xml_nodeset objects", {
-  x <- read_xml("<x>This is some text. <x>This is some nested text.</x></x>")
-
-  expect_identical(xml_text(x), "This is some text. This is some nested text.")
-
   expect_identical(
-    xml_text(xml_find_all(x, "//x")),
-    c("This is some text. This is some nested text.", "This is some nested text.")
+    xml_text(sample_nodeset()),
+    c("text", "other", NA)
   )
 })
 
@@ -47,6 +35,12 @@ test_that("xml_text trims whitespace if requested, including non-breaking spaces
     xml_text(x, trim = TRUE),
     "Some text \u20ac"
   )
+
+  x2 <- read_html("<body><p>   Some text &euro;  &nbsp;</p><p>  and more &euro; text   &nbsp;</body>")
+  expect_identical(
+    xml_text(xml_find_all(x2, ".//p"), trim = TRUE),
+    c("Some text \u20ac", "and more \u20ac text")
+  )
 })
 
 test_that("xml_integer() returns an integer vector", {

diff --git a/tests/testthat/test-xml_type.R b/tests/testthat/test-xml_type.R
@@ -0,0 +1,11 @@
+test_that("multiplication works", {
+  x <- sample_nodeset()
+
+  expect_equal(xml_type(x[[1]]), "element")
+  expect_equal(xml_type(x[[3]]), NA_character_)
+
+  expect_equal(xml_type(x), c("element", "element", NA))
+
+  empty <- xml_children(x)
+  expect_identical(xml_type(empty), character())
+})