refactor: add argument

R/build_parts.R → R/build_part_body.R

@@ -1,5 +1,4 @@
 #' Builds the "body" part of a query.
-#' @param query a list with elements of the query
 #' @param subject an anonymous variable (for instance,
 #' and by default, "?subject") or item (for instance "wd:Q456"))
 #' @param verb the property (for instance "wdt:P190")
@@ -14,17 +13,15 @@
 #' @param within_distance if provided, north-west and south-east coordinates of
 #' bounding box for the triple query.
 #' @noRd
-build_part_body = function(query = NA,
-                           triple = NULL,
+build_part_body = function(triple = NULL,
                            subject = NULL,
                            verb = NULL,
                            object = NULL,
                            required = TRUE,
                            within_box = c(NA, NA),
                            within_distance = c(NA, NA),
-                           filter = NA) {
-
-  part_body = query[["body"]]
+                           filter = NA,
+                           other_triples) {
 
   if (!is.null(triple)) {
     elts = decompose_triple_pattern(triple)
@@ -42,11 +39,39 @@ build_part_body = function(query = NA,
       )
   } else {
     new_triple = glue::glue("{subject} {verb} {object}.")
+    if (sub(".$", "", new_triple) %in% other_triples[["sibling_triple"]]) {
+      little_siblings = other_triples[other_triples[["sibling_triple"]] == sub(".$", "", new_triple),]
+      little_siblings = split(little_siblings, seq_len(nrow(little_siblings)))
+
+      sibling_triples = purrr::map_chr(
+        little_siblings,
+        ~build_part_body(
+          triple = .x[["triple"]],
+          required = .x[["required"]],
+          within_box = .x[["within_box"]],
+          within_distance = .x[["within_distance"]],
+          filter = .x[["filter"]],
+          other_triples = other_triples
+        )
+      ) %>%
+        paste(collapse = "")
+    } else {
+      sibling_triples = NA
+    }
+  }
+
+  if (!is.na(sibling_triples)) {
+    new_triple = sprintf("\n\t%s\n\t%s\n", new_triple, sibling_triples)
+  }
+
+
+  if (!is.na(filter)) {
+    new_triple = sprintf("\n\t%s\n\tFILTER(%s)\n", new_triple, filter)
   }
 
   if (!required) {
     new_triple = if (!is.na(filter)) {
-      sprintf("OPTIONAL {\n\t%s\n\tFILTER(%s)\n}\n", new_triple, filter)
+      sprintf("OPTIONAL {%s}\n", new_triple)
     } else {
       sprintf("OPTIONAL {%s}", new_triple)
     }
@@ -86,5 +111,5 @@ build_part_body = function(query = NA,
     )
   }
 
-  glue::glue("{part_body}\n{new_triple}")
+  sprintf("\n%s", new_triple)
 }

R/build_sparql.R

@@ -0,0 +1,254 @@
+#' Assemble query parts into a proper SPARQL query
+#' @param .query a list with elements of the query
+#' @param strict whether to perform some linting on the query,
+#' and error in case a problem is detected.
+#' @return A query object
+#' @export
+#' @examples
+#' spq_init() %>%
+#'   spq_add("?city wdt:P31 wd:Q515") %>%
+#'   spq_label(city, .languages = "fr$") %>%
+#'   spq_add("?city wdt:P1082 ?pop") %>%
+#'   spq_assemble() %>%
+#'   cat()
+spq_assemble = function(.query, strict = TRUE) {
+
+  .query = spq_prefix(.query, auto = TRUE, prefixes = NULL)
+
+  # prefixes -----
+  prefixes_known = .query[["prefixes_provided"]] %>%
+    dplyr::bind_rows(usual_prefixes)
+  check_prefixes(.query[["prefixes_used"]], prefixes_known = prefixes_known)
+
+  part_prefixes <- if (nrow(.query[["prefixes_provided"]]) > 0) {
+    glue::glue(
+      'PREFIX {.query[["prefixes_provided"]][["name"]]}: <{.query[["prefixes_provided"]][["url"]]}>') %>%
+      paste0(collapse = "\n")
+  } else {
+    ""
+  }
+
+  group_by <- if (sum(.query[["structure"]][["grouping"]]) > 0) {
+    grouping_vars <- .query[["structure"]][["name"]][.query[["structure"]][["grouping"]]]
+    paste0("GROUP BY ", paste0(grouping_vars, collapse = " "), "\n")
+  } else {
+    ""
+  }
+
+  ordering <- .query[["structure"]][.query[["structure"]][["ordering"]] != "none", ]
+
+  order_by <- if (!is.null(ordering) && nrow(ordering) > 0) {
+    ordering_vars = paste0(ordering[["ordering"]], collapse = " ")
+    sprintf("ORDER BY %s", ordering_vars)
+  } else {
+    ""
+  }
+
+  # selections and bindings ----
+  binded <- ""
+  select <- if (sum(.query[["structure"]][["selected"]]) == 0) {
+    "*"
+  } else {
+    selected <- .query[["structure"]][["name"]][.query[["structure"]][["selected"]]]
+
+    # no var defined: this happens in testing
+    # and other contexts where we demo functions partially
+    select <- if (is.null(.query[["vars"]])) {
+      selected
+    } else {
+      selected_df <- .query[["vars"]] %>%
+        dplyr::filter(name %in% selected) %>%
+        dplyr::select(name, formula) %>%
+        dplyr::distinct() %>%
+        dplyr::left_join(.query[["structure"]], by = "name")
+
+      nongrouping_selected_df = dplyr::filter(selected_df, !grouping) %>%
+        dplyr::group_by(name) %>%
+        # TODO it'd probably be weird to have >1 formula
+        # so check that
+        dplyr::summarize(selected_pattern = dplyr::if_else(
+          !all(is.na(formula)),
+          formula[!is.na(formula)][1],
+          name[1]
+        ))
+        nongrouping_selected = nongrouping_selected_df[["selected_pattern"]]
+        nongrouping_selected = rlang::set_names(
+          nongrouping_selected,
+          nongrouping_selected_df[["name"]]
+        )
+
+      # hack to have formulas last
+      # more readability if formulas use vars from select
+      formulas_last <- order(grepl(" AS ", nongrouping_selected, fixed = TRUE))
+      nongrouping_selected <- nongrouping_selected[formulas_last]
+
+      grouping_selected <- dplyr::filter(selected_df, grouping) %>%
+        dplyr::group_by(name) %>%
+        dplyr::summarize(selected_pattern = name[1]) %>%
+        dplyr::pull(selected_pattern)
+
+      # we get this to be sure to include any ancestor
+      # of selected var in a BIND
+      selected_vars = .query[["vars"]][.query[["vars"]][["name"]] %in% selected_df[["name"]], ]
+      ancestor_vars = selected_vars[!is.na(selected_vars[["ancestor"]]), ]
+
+      filtered_vars = selected_vars[selected_vars[["name"]] %in% .query[["filters"]][["var"]], ]
+
+      potential_binded <- c(grouping_selected, ancestor_vars[["ancestor"]], filtered_vars[["name"]])
+      if (length(potential_binded) > 0) {
+        to_bind <- dplyr::filter(.query[["vars"]],
+          name %in% potential_binded,
+          !is.na(formula))
+        if (nrow(to_bind) > 0) {
+          binded <- paste(
+            sprintf("BIND%s", to_bind[["formula"]]),
+            collapse = "\n"
+          )
+          binded <- paste0(binded, "\n")
+        }
+      } else {
+        to_bind = NULL
+      }
+
+      # nicer to put grouping variables first
+      select = c(grouping_selected, nongrouping_selected)
+
+      # put labels near variables
+      any_label = any(grepl("_label", select, fixed = TRUE))
+      if (any_label) {
+        new_select = select[!grepl("_label", select, fixed = TRUE)]
+        labels = select[grepl("_label", select, fixed = TRUE)]
+        select = purrr::reduce2(
+          labels,
+          names(labels),
+          \(new_select, x, y) add_label(new_select, x, y, old_select = select),
+          .init = new_select
+        )
+      }
+
+      # do not use formula both in BIND and SELECT
+      # so remove it from SELECT
+      select[names(select) %in% to_bind[["name"]]] =
+        names(select)[names(select) %in% to_bind[["name"]]]
+      select
+    }
+
+  }
+
+  # body ----
+  triples_present = !is.null(.query[["triples"]])
+  body = if (triples_present) {
+
+    firstborn_triples = .query[["triples"]][is.na(.query[["triples"]][["sibling_triple"]]),]
+    firstborn_triples = split(firstborn_triples, seq_len(nrow(firstborn_triples)))
+
+    # they'll be built as we build their big siblings
+    other_triples = .query[["triples"]][!is.na(.query[["triples"]][["sibling_triple"]]),]
+
+    purrr::map_chr(
+      firstborn_triples,
+      ~build_part_body(
+        triple = .x[["triple"]],
+        required = .x[["required"]],
+        within_box = .x[["within_box"]],
+        within_distance = .x[["within_distance"]],
+        filter = .x[["filter"]],
+        other_triples = other_triples
+      )
+    ) |>
+      paste0(collapse = "")
+  } else {
+    NULL
+  }
+
+ valued_vars <- .query[["vars"]][!is.na(.query[["vars"]][["values"]]), ]
+
+ if (!is.null(valued_vars) && nrow(valued_vars) > 0) {
+    body <- paste(
+      c(
+        body,
+        sprintf("VALUES ?%s %s", valued_vars[["name"]], valued_vars[["values"]])
+        ),
+      collapse = "\n"
+    )
+  }
+
+  # duplicate ----
+  spq_duplicate <- if (is.null(.query[["spq_duplicate"]])) {
+    ""
+  } else {
+    sprintf("%s ", .query[["spq_duplicate"]])
+  }
+
+  limit <- if (is.null(.query[["limit"]])) {
+    ""
+  } else {
+    glue::glue('LIMIT {.query[["limit"]]}\n')
+  }
+
+  offset <- if (is.null(.query[["offset"]])) {
+    ""
+  } else {
+    glue::glue('OFFSET {.query[["offset"]]}')
+  }
+
+  filters <- if (is.null(.query[["filters"]])) {
+    ""
+  } else {
+    if (strict) {
+
+      unknown_filtered_variables <- .query[["filters"]][["var"]][
+        !(.query[["filters"]][["var"]] %in% .query[["vars"]][["name"]])
+      ]
+      if (length(unknown_filtered_variables) > 0) {
+        cli::cli_abort(c(
+          "Can't filter on undefined variables: {toString(unknown_filtered_variables)}",
+          i = "You haven't mentioned them in any triple, VALUES, mutate."
+        ))
+      }
+    }
+
+    paste0(
+      sprintf("FILTER(%s)", .query[["filters"]][["filter"]]),
+      collapse = "\n"
+    )
+  }
+
+  paste0(
+    part_prefixes, "\n",
+    "SELECT ", spq_duplicate, paste0(select, collapse = " "), "\n",
+    "WHERE {\n",
+    body, "\n", binded,
+    filters, "\n",
+    "}\n",
+    group_by,
+    order_by, "\n",
+    limit,
+    offset
+  )
+}
+
+utils::globalVariables(c("usual_prefixes", "formula", "selected_pattern"))
+
+add_label = function(vector, label, label_name, old_select) {
+  unlabelled = which(sprintf("%s_label", vector) == label_name)
+  unlabelled_present = (length(unlabelled) == 1)
+
+  if (unlabelled_present) {
+   return(append(vector, label, after = unlabelled))
+  }
+
+   old_position = which(old_select == label)
+   if (old_position == 1) {
+     return(append(vector, label, after = 0))
+   }
+
+   old_neighbour = old_select[old_position - 1]
+   old_neighbour_current_position = which(vector == old_neighbour)
+   append(vector, label, after = old_neighbour_current_position)
+
+}
+
+check_prefixes <- function(prefixes, prefixes_known) {
+  purrr::walk(prefixes, check_prefix, prefixes_known = prefixes_known)
+}

R/spq_add.R

@@ -21,6 +21,8 @@
 #'   for the center coordinates to be retrieved directly from the query.
 #' @param .prefixes Custom prefixes
 #' @param .filter Filter for the triple. Only use this with `.required=FALSE`
+#' @param .sibling_triple_pattern Triple this triple is to be grouped with,
+#' especially (only?) useful if the sibling triple is optional.
 #' @export
 #' @section Examples:
 #' ```r
@@ -60,7 +62,8 @@ spq_add = function(.query = NULL,
                     .label = NA,
                     .within_box = c(NA, NA),
                     .within_distance = c(NA, NA),
-                    .filter = NULL) {
+                    .filter = NULL,
+                    .sibling_triple_pattern = NA) {
   .query = .query %||% spq_init()
 
   elts = decompose_triple_pattern(
@@ -84,7 +87,8 @@ spq_add = function(.query = NULL,
     required = .required,
     within_box = list(.within_box),
     within_distance = list(.within_distance),
-    filter = .filter
+    filter = .filter,
+    sibling_triple = .sibling_triple_pattern
   )
 
   # variable tracking ----