Develop

NAMESPACE

@@ -4,6 +4,7 @@ export(.solve_possible_duplicate_display)
 export(build_ont)
 export(extract_list_edges)
 export(extract_restrictions)
+export(extract_schema_generic)
 export(extract_schema_owl)
 export(extract_schema_void)
 export(local_name)

R/schema_generic.R

@@ -0,0 +1,69 @@
+#' @importFrom dplyr %>% filter transmute distinct
+NULL
+
+
+#' Extract a schema from generic RDF data.
+#'
+#' @param source A SPARQL endpoint URL or a parsed `rdflib` compatible file.
+#' @return A schema list, see `.empty_schema()`.
+#' @export
+extract_schema_generic <- function(source) {
+  schema <- .empty_schema()
+
+  data_classes <- safe_query(source, '
+    SELECT DISTINCT ?class WHERE { ?s a ?class . FILTER(isIRI(?class)) }',
+                             expected_cols = "class")
+
+  data_props <- safe_query(source, '
+    SELECT DISTINCT ?prop WHERE { ?s ?prop ?o . FILTER(isIRI(?prop)) }',
+                           expected_cols = "prop")
+
+  class_labels <- safe_query(source, '
+    PREFIX rdfs: <http://www.w3.org/2000/01/rdf-schema#>
+    SELECT ?class ?label WHERE {
+      ?class rdfs:label ?label .
+      BIND(IF(LANG(?label) = "en" || LANG(?label) = "", 0, 1) AS ?labelRank)
+    } ORDER BY ?class ?labelRank', expected_cols = c("class", "label"))
+
+  prop_labels <- safe_query(source, '
+    PREFIX rdfs: <http://www.w3.org/2000/01/rdf-schema#>
+    SELECT ?prop ?label WHERE {
+      ?prop rdfs:label ?label .
+      BIND(IF(LANG(?label) = "en" || LANG(?label) = "", 0, 1) AS ?labelRank)
+    } ORDER BY ?prop ?labelRank', expected_cols = c("prop", "label"))
+
+  domains <- safe_query(source, '
+    PREFIX rdfs: <http://www.w3.org/2000/01/rdf-schema#>
+    SELECT DISTINCT ?prop ?domain WHERE { ?prop rdfs:domain ?domain . }',
+                        expected_cols = c("prop", "domain"))
+
+  ranges <- safe_query(source, '
+    PREFIX rdfs: <http://www.w3.org/2000/01/rdf-schema#>
+    SELECT DISTINCT ?prop ?range WHERE { ?prop rdfs:range ?range . }',
+                       expected_cols = c("prop", "range"))
+
+  class_label_lookup <- class_labels %>% distinct(class, .keep_all = TRUE)
+  prop_label_lookup  <- prop_labels  %>% distinct(prop, .keep_all = TRUE)
+
+  schema$classes <- data_classes %>%
+    filter(!is.na(class), nzchar(class)) %>%
+    transmute(uri = class,
+              label = class_label_lookup$label[match(class, class_label_lookup$class)]) %>%
+    distinct(uri, .keep_all = TRUE)
+
+  schema$properties <- data_props %>%
+    filter(!is.na(prop), nzchar(prop)) %>%
+    transmute(property = prop,
+              label = prop_label_lookup$label[match(prop, prop_label_lookup$prop)]) %>%
+    distinct(property, .keep_all = TRUE)
+
+  schema$property_domains <- domains %>%
+    filter(!is.na(domain), nzchar(domain)) %>%
+    transmute(property = prop, domain = domain)
+
+  schema$property_ranges <- ranges %>%
+    filter(!is.na(range), nzchar(range)) %>%
+    transmute(property = prop, range = range)
+
+  schema
+}

tests/testthat/test-schema_generic.R

@@ -0,0 +1,56 @@
+test_that("extract_schema_generic infers classes/properties with labels and domains/ranges", {
+  fake_sparql <- function(url, query, timeout = 60) {
+    if (grepl("?s a ?class", query, fixed = TRUE)) {
+      data.frame(class = "http://ex.org/Book", stringsAsFactors = FALSE)
+    } else if (grepl("?s ?prop ?o", query, fixed = TRUE)) {
+      data.frame(prop = "http://ex.org/title", stringsAsFactors = FALSE)
+    } else if (grepl("?class rdfs:label", query, fixed = TRUE)) {
+      data.frame(class = "http://ex.org/Book", label = "Book", stringsAsFactors = FALSE)
+    } else if (grepl("?prop rdfs:label", query, fixed = TRUE)) {
+      data.frame(prop = "http://ex.org/title", label = "Title", stringsAsFactors = FALSE)
+    } else if (grepl("rdfs:domain", query, fixed = TRUE)) {
+      data.frame(prop = "http://ex.org/title", domain = "http://ex.org/Book",
+                 stringsAsFactors = FALSE)
+    } else if (grepl("rdfs:range", query, fixed = TRUE)) {
+      data.frame(prop = "http://ex.org/title",
+                 range = "http://www.w3.org/2001/XMLSchema#string", stringsAsFactors = FALSE)
+    } else {
+      data.frame()
+    }
+  }
+  testthat::local_mocked_bindings(sparql_query = fake_sparql)
+
+  schema <- extract_schema_generic("https://example.org/sparql")
+
+  expect_equal(schema$classes$label, "Book")
+  expect_equal(schema$properties$label, "Title")
+  expect_equal(schema$property_domains$domain, "http://ex.org/Book")
+  expect_equal(schema$property_ranges$range, "http://www.w3.org/2001/XMLSchema#string")
+})
+
+test_that("extract_schema_generic falls back to no label when none is declared", {
+  fake_sparql <- function(url, query, timeout = 60) {
+    if (grepl("?s a ?class", query, fixed = TRUE)) {
+      data.frame(class = "http://ex.org/Book", stringsAsFactors = FALSE)
+    } else {
+      data.frame()
+    }
+  }
+  testthat::local_mocked_bindings(sparql_query = fake_sparql)
+
+  schema <- extract_schema_generic("https://example.org/sparql")
+
+  expect_equal(schema$classes$uri, "http://ex.org/Book")
+  expect_true(is.na(schema$classes$label))
+})
+
+test_that("extract_schema_generic tolerates a failing endpoint", {
+  testthat::local_mocked_bindings(
+    sparql_query = function(url, query, timeout = 60) stop("boom")
+  )
+
+  schema <- suppressWarnings(extract_schema_generic("https://example.org/sparql"))
+
+  expect_equal(nrow(schema$classes), 0)
+  expect_equal(nrow(schema$properties), 0)
+})