Fix and improve tests for full object calls

ropensci · Dec 19, 2023 · 7139be0 · 7139be0
1 parent ea1ccc3
commit 7139be0
Show file tree

Hide file tree

Showing 9 changed files with 1,853 additions and 43 deletions.
diff --git a/R/osm_get_objects.R b/R/osm_get_objects.R
@@ -87,22 +87,36 @@ osm_get_objects <- function(osm_type, osm_id, version, full_objects = FALSE,
 
   type_idL <- split(type_id, type_id$type)
 
-  # osm_fetch_objects, osm_version_object
-  # osm_full_object
   if (full_objects) {
     out <- mapply(function(type, ids) {
       if (type %in% c("way", "relation")) {
-        full_obj <- lapply(ids$id, function(id) {
+        full_objL <- lapply(ids$id, function(id) {
           osm_full_object(osm_type = type, osm_id = id, format = format)
         })
-        full_obj <- do.call(rbind, full_obj)
+
+        if (format == "R") {
+          full_obj <- do.call(rbind, full_objL)
+        } else if (format == "xml") {
+          full_obj <- full_objL[[1]]
+
+          full_obj <- xml2::xml_new_root(full_objL[[1]])
+          for (i in seq_len(length(full_objL) - 1)) {
+            for (j in seq_len(xml2::xml_length(full_objL[[i + 1]]))) {
+              xml2::xml_add_child(full_obj, xml2::xml_child(full_objL[[i + 1]], search = j))
+            }
+          }
+        } else if (format == "json") {
+          full_obj <- full_objL[[1]]
+          if (length(full_objL) > 1) {
+            full_obj$elements <- do.call(c, c(list(full_obj$elements), lapply(full_objL[-1], function(x) x$elements)))
+          }
+        }
       } else {
         full_obj <- osm_fetch_objects(osm_type = paste0(type, "s"), osm_ids = ids$id, format = format)
       }
       full_obj
     }, type = names(type_idL), ids = type_idL, SIMPLIFY = FALSE)
   } else { # no full_objects
-
     type_plural <- paste0(names(type_idL), "s") # type in plural for osm_fetch_objects()
 
     if (missing(version)) {
@@ -116,46 +130,85 @@ osm_get_objects <- function(osm_type, osm_id, version, full_objects = FALSE,
     }
   }
 
-  ## Original order
-  ord_ori <- do.call(paste, type_id)
 
-  if (format == "R") {
-    out <- do.call(rbind, out)
-    ord_out <- do.call(paste, out[, intersect(names(type_id), c("type", "id", "version"))])
-    out <- out[match(ord_ori, ord_out), ]
-    rownames(out) <- NULL
+  ## Order objects
 
-    if (tags_in_columns) {
-      out <- tags_list2wide(out)
+  if (full_objects) {
+    # Order by types (node, way, relation)
+
+    if (format == "R") {
+      out <- do.call(rbind, out[intersect(c("node", "way", "relation"), names(ord_out))])
+      out <- rbind(out[out$type == "node", ], out[out$type == "way", ])
+      out <- rbind(out, out[out$type == "relation", ])
+    } else if (format == "xml") {
+      ## TODO: test. Use xml2::xml_find_all()?
+      out <- out[intersect(c("node", "way", "relation"), names(out))]
+      out_ordered <- xml2::xml_new_root(out[[1]])
+      for (i in seq_len(length(out) - 1)) {
+        for (j in seq_len(xml2::xml_length(out[[i + 1]]))) {
+          xml2::xml_add_child(out_ordered, xml2::xml_child(out[[i + 1]], search = j))
+        }
+      }
+      out <- out_ordered
+    } else if (format == "json") {
+      ord_out <- lapply(out, function(x) {
+        vapply(x$elements, function(y) do.call(paste, y[names(type_id)]), FUN.VALUE = character(1))
+      })
+      ord <- unlist(ord_out[intersect(c("node", "way", "relation"), names(ord_out))])
+      ord <- c(ord[grep("^node", ord)], ord[grep("^way", ord)], ord[grep("^relation", ord)])
+      ord <- data.frame(type = gsub("[0-9]+$", "", names(ord)), pos = as.integer(gsub("^[a-z.]+", "", names(ord))))
+      ord$pos[is.na(ord$pos)] <- 1 # for types with only 1 object
+
+      out_ordered <- out[[1]][setdiff(names(out[[1]]), "elements")]
+      out_ordered$elements <- apply(ord, 1, function(x) {
+        out[[x[1]]]$elements[[as.integer(x[2])]]
+      }, simplify = FALSE)
+      out <- out_ordered
     }
-  } else if (format == "xml") {
-    ord_out <- lapply(out, function(x) {
-      out_type_id <- object_xml2DF(x)
-      do.call(paste, out_type_id[, names(type_id)])
-    })
-    ordL <- lapply(ord_out, function(x) match(ord_ori, x))
-    ord <- sort(unlist(ordL))
-    ord <- data.frame(type = gsub("[0-9]+$", "", names(ord)), pos = as.integer(gsub("^[a-z.]+", "", names(ord))))
-
-    out_ordered <- xml2::xml_new_root(out[[ord$type[1]]])
-    xml2::xml_remove(xml2::xml_children(out_ordered))
-    for (i in seq_len(nrow(ord))) {
-      xml2::xml_add_child(out_ordered, xml2::xml_child(out[[ord$type[i]]], search = ord$pos[i]))
+  } else {
+    ## Original order
+
+    ord_ori <- do.call(paste, type_id)
+
+    if (format == "R") {
+      out <- do.call(rbind, out)
+      ord_out <- do.call(paste, out[, intersect(names(type_id), c("type", "id", "version"))])
+      out <- out[match(ord_ori, ord_out), ]
+      rownames(out) <- NULL
+
+      if (tags_in_columns) {
+        out <- tags_list2wide(out)
+      }
+    } else if (format == "xml") {
+      ord_out <- lapply(out, function(x) {
+        out_type_id <- object_xml2DF(x)
+        do.call(paste, out_type_id[, names(type_id)])
+      })
+      ordL <- lapply(ord_out, function(x) match(ord_ori, x))
+      ord <- sort(unlist(ordL))
+      ord <- data.frame(type = gsub("[0-9]+$", "", names(ord)), pos = as.integer(gsub("^[a-z.]+", "", names(ord))))
+      ord$pos[is.na(ord$pos)] <- 1 # for types with only 1 object
+
+      out_ordered <- xml2::xml_new_root(out[[ord$type[1]]])
+      xml2::xml_remove(xml2::xml_children(out_ordered))
+      for (i in seq_len(nrow(ord))) {
+        xml2::xml_add_child(out_ordered, xml2::xml_child(out[[ord$type[i]]], search = ord$pos[i]))
+      }
+      out <- out_ordered
+    } else if (format == "json") {
+      ord_out <- lapply(out, function(x) {
+        vapply(x$elements, function(y) do.call(paste, y[names(type_id)]), FUN.VALUE = character(1))
+      })
+      ordL <- lapply(ord_out, function(x) match(ord_ori, x))
+      ord <- sort(unlist(ordL))
+      ord <- data.frame(type = gsub("[0-9]+$", "", names(ord)), pos = as.integer(gsub("^[a-z.]+", "", names(ord))))
+
+      out_ordered <- out[[1]][setdiff(names(out[[1]]), "elements")]
+      out_ordered$elements <- apply(ord, 1, function(x) {
+        out[[x[1]]]$elements[[as.integer(x[2])]]
+      }, simplify = FALSE)
+      out <- out_ordered
     }
-    out <- out_ordered
-  } else if (format == "json") {
-    ord_out <- lapply(out, function(x) {
-      vapply(x$elements, function(y) do.call(paste, y[names(type_id)]), FUN.VALUE = character(1))
-    })
-    ordL <- lapply(ord_out, function(x) match(ord_ori, x))
-    ord <- sort(unlist(ordL))
-    ord <- data.frame(type = gsub("[0-9]+$", "", names(ord)), pos = as.integer(gsub("^[a-z.]+", "", names(ord))))
-
-    out_ordered <- out[[1]][setdiff(names(out[[1]]), "elements")]
-    out_ordered$elements <- apply(ord, 1, function(x) {
-      out[[x[1]]]$elements[[as.integer(x[2])]]
-    }, simplify = FALSE)
-    out <- out_ordered
   }
 
   return(out)

diff --git a/inst/httptest2/redact.R b/inst/httptest2/redact.R
@@ -13,10 +13,18 @@ function(response) {
     fixed = TRUE
   )
 
+  # xml
   response <- httptest2::gsub_response(
     response,
-    'generator="CGImap 0.8.8 \\([0-9]+ .+.openstreetmap.org\\)" copyright="OpenStreetMap and contributors"',
-    'generator="CGImap 0.8.8 (012345 ******.openstreetmap.org)" copyright="OpenStreetMap and contributors"'
+    'generator="CGImap ([0-9.]+) \\([0-9]+ .+\\.openstreetmap\\.org\\)" copyright="OpenStreetMap and contributors"',
+    'generator="CGImap \\1 (012345 ******.openstreetmap.org)" copyright="OpenStreetMap and contributors"'
+  )
+
+  # json
+  response <- httptest2::gsub_response(
+    response,
+    '"CGImap ([0-9.]+) \\([0-9]+ .+\\.openstreetmap\\.org\\)",',
+    '"CGImap \\1 (012345 ******.openstreetmap.org)",',
   )
 
   return(response)

diff --git a/tests/testthat/mock_full_object/osm.org/api/0.6/nodes-41cde1.xml b/tests/testthat/mock_full_object/osm.org/api/0.6/nodes-41cde1.xml
@@ -0,0 +1,12 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<osm version="0.6" generator="CGImap 0.8.10 (012345 ******.openstreetmap.org)" copyright="OpenStreetMap and contributors" attribution="http://www.openstreetmap.org/copyright" license="http://opendatacommons.org/licenses/odbl/1-0/">
+ <node id="35308286" visible="true" version="17" changeset="140341361" timestamp="2023-08-24T20:19:22Z" user="jmaspons" uid="11725140" lat="42.5189047" lon="2.4565596">
+  <tag k="ele" v="2784.66"/>
+  <tag k="name" v="Pic du Canigou"/>
+  <tag k="name:ca" v="Pic del Canigó"/>
+  <tag k="natural" v="peak"/>
+  <tag k="prominence" v="550"/>
+  <tag k="summit:cross" v="yes"/>
+  <tag k="summit:register" v="no"/>
+ </node>
+</osm>
diff --git a/tests/testthat/mock_full_object/osm.org/api/0.6/way/235744929/full.xml b/tests/testthat/mock_full_object/osm.org/api/0.6/way/235744929/full.xml
@@ -0,0 +1,23 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<osm version="0.6" generator="CGImap 0.8.10 (012345 ******.openstreetmap.org)" copyright="OpenStreetMap and contributors" attribution="http://www.openstreetmap.org/copyright" license="http://opendatacommons.org/licenses/odbl/1-0/">
+ <node id="2438033107" visible="true" version="2" changeset="37791155" timestamp="2016-03-12T21:57:59Z" user="Jose Antonio Fontaneda" uid="2130444" lat="41.3838674" lon="2.1824148"/>
+ <node id="2438033109" visible="true" version="2" changeset="37791155" timestamp="2016-03-12T21:57:59Z" user="Jose Antonio Fontaneda" uid="2130444" lat="41.3836273" lon="2.1822465"/>
+ <node id="2992282983" visible="true" version="2" changeset="37791155" timestamp="2016-03-12T21:58:00Z" user="Jose Antonio Fontaneda" uid="2130444" lat="41.3836295" lon="2.1822400"/>
+ <node id="2992282984" visible="true" version="2" changeset="37791155" timestamp="2016-03-12T21:58:00Z" user="Jose Antonio Fontaneda" uid="2130444" lat="41.3838706" lon="2.1824067"/>
+ <way id="235744929" visible="true" version="7" changeset="115317958" timestamp="2021-12-24T03:46:41Z" user="jmaspons" uid="11725140">
+  <nd ref="2438033107"/>
+  <nd ref="2438033109"/>
+  <nd ref="2992282983"/>
+  <nd ref="2992282984"/>
+  <nd ref="2438033107"/>
+  <tag k="architect" v="Carme Fiol"/>
+  <tag k="barrier" v="wall"/>
+  <tag k="historic" v="memorial"/>
+  <tag k="inscription" v="Al fossar de les moreres no s'hi enterra cap traïdor;fins perdent nostres banderes serà l'urna de l'honor."/>
+  <tag k="name" v="Fossar de les Moreres"/>
+  <tag k="name:ca" v="Fossar de les Moreres"/>
+  <tag k="start_date" v="1989"/>
+  <tag k="wikidata" v="Q2749521"/>
+  <tag k="wikipedia" v="ca:Fossar de les Moreres"/>
+ </way>
+</osm>
diff --git a/tests/testthat/mock_full_object_json/osm.org/api/0.6/nodes.json-41cde1.json b/tests/testthat/mock_full_object_json/osm.org/api/0.6/nodes.json-41cde1.json
@@ -0,0 +1,29 @@
+{
+    "version": "0.6",
+    "generator": "CGImap 0.8.10 (012345 ******.openstreetmap.org)",
+    "copyright": "OpenStreetMap and contributors",
+    "attribution": "http://www.openstreetmap.org/copyright",
+    "license": "http://opendatacommons.org/licenses/odbl/1-0/",
+    "elements": [
+        {
+            "type": "node",
+            "id": 35308286,
+            "lat": 42.5189047,
+            "lon": 2.4565596,
+            "timestamp": "2023-08-24T20:19:22Z",
+            "version": 17,
+            "changeset": 140341361,
+            "user": "jmaspons",
+            "uid": 11725140,
+            "tags": {
+                "ele": "2784.66",
+                "name": "Pic du Canigou",
+                "name:ca": "Pic del Canigó",
+                "natural": "peak",
+                "prominence": "550",
+                "summit:cross": "yes",
+                "summit:register": "no"
+            }
+        }
+    ]
+}