Add code for get_document(s)

Author: vanatteveldt

DESCRIPTION

@@ -40,4 +40,4 @@ Remotes:
     JBGruber/dockr
 License: MIT + file LICENSE
 Encoding: UTF-8
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2

NAMESPACE

@@ -9,14 +9,15 @@ export(delete_documents)
 export(delete_index)
 export(delete_index_user)
 export(delete_user)
+export(get_document)
+export(get_documents)
 export(get_fields)
 export(list_index_users)
 export(list_indexes)
 export(list_users)
 export(modify_index)
 export(modify_index_user)
 export(modify_user)
-export(ping)
 export(query_aggregate)
 export(query_documents)
 export(refresh_index)

R/index.R

@@ -268,3 +268,32 @@ get_fields <- function(index, credentials = NULL) {
     purrr::list_rbind()
 }
 
+
+#' Retrieve a single document
+#'
+#' @param index The index to get fields for
+#' @param doc_id A single document_id
+#' @param fields Optional character vector listing the fields to retrieve
+#' @param credentials  The credentials to use. If not given, uses last login information
+#'
+#' @returns A tibble with one row containing the requested fields
+#' @export
+get_document <- function(index, doc_id, fields, credentials = NULL) {
+  res <- request(credentials, c("index", index, "documents", doc_id), query=list(fields=fields), query.multi="comma")
+  tibble::as_tibble(res) |> tibble::add_column(.id=doc_id, .before=1)
+}
+
+#' Retrieve multiple documents using a purrr map over get_document
+#'
+#' @param index The index to get fields for
+#' @param doc_ids A vector of document_ids
+#' @param fields Optional character vector listing the fields to retrieve
+#' @param credentials  The credentials to use. If not given, uses last login information
+#' @param ...Other options to pass to map, e.g. .progress
+#' @returns A tibble with one row containing the requested fields
+#' @export
+get_documents <- function(index, doc_ids, fields, credentials = NULL, ...) {
+  purrr::map(doc_ids, function(doc_id) get_document(index, doc_id, fields, credentials), ...) |>
+    purrr::list_rbind()
+}
+

R/lib.R

@@ -2,12 +2,13 @@ pkg.env <- new.env()
 
 #' Helper function to get credentials from argument or pkg.env
 #' @noRd
-get_credentials = function(credentials = NULL) {
+get_credentials = function(credentials=NULL) {
 
   if (is.null(credentials)) {
     if (!is.null(pkg.env$current_server)) {
       credentials = amcat_get_token(pkg.env$current_server)
       credentials$host <- pkg.env$current_server
+      credentials$authorization <- pkg.env$authorization
     } else {
       stop("Please use amcat_login() first")
     }
@@ -18,13 +19,13 @@ get_credentials = function(credentials = NULL) {
 #' Helper function to execute a request to this API
 #' @noRd
 request_response <- function(credentials,
-                             url,
-                             method = "GET",
-                             body = NULL,
-                             error_on_404 = TRUE,
-                             max_tries = NULL,
-                             auto_unbox = TRUE,
-                             ...) {
+                    url,
+                    method = "GET",
+                    body = NULL,
+                    query = NULL,
+                    query.multi = "error",
+                    error_on_404 = TRUE,
+                    ...) {
 
   # current httr2 version has a bug in req_url_path that can't handle objects of
   # length != 1, already fixed on gh
@@ -40,23 +41,20 @@ request_response <- function(credentials,
                                        error_on_404 ,
                                        httr2::resp_status(resp) >= 400),
       body = amcat_error_body
-    ) |>
-    # for uploads, we sometimes get 500/502 when elastic is processing new documents
-    # in these cases amcat4 reports a server error because the connection times out.
-    # It makes sense to wait a little and retry
-    httr2::req_retry(max_tries = max_tries,
-                     is_transient = function(x) httr2::resp_status(x) %in% c(429, 500, 502, 503))
+    )
 
+  if (!is.null(query)) {
+    req <- do.call(httr2::req_url_query, c(list(req), .multi=query.multi, query))
+  }
   if (!is.null(body)) {
     req <- req |>
-      httr2::req_body_json(body, auto_unbox = auto_unbox)
+      httr2::req_body_json(body)
   }
 
   if (credentials$authorization != "no_auth") {
     req <- req |>
       httr2::req_auth_bearer_token(credentials$access_token)
   }
-
   httr2::req_perform(req)
 }
 
@@ -87,60 +85,40 @@ make_path <- function(...) {
 #' Custom error message for requests
 #' @noRd
 amcat_error_body <- function(resp) {
-
+  # resp <<- resp
   if (grepl("json", httr2::resp_content_type(resp), fixed = TRUE)) {
     ebody <- httr2::resp_body_json(resp)
-
-    if (purrr::pluck_exists(ebody, "message")) {
-      return(purrr::pluck(ebody, "message"))
-    } else if (purrr::pluck_exists(ebody, "detail")) {
-      return(purrr::pluck(ebody, "detail"))
-    } else if (is.list(ebody$detail$body$error)) {
-      error <- purrr::map_chr(names(ebody$detail$body$error), function(n) {
-        paste0(tools::toTitleCase(n), ": ", ebody$detail$body$error[[n]])
-      })
-    } else {
-      # TODO: find a cleaner way to parse this
-      msg <- try(ebody[["detail"]][[1]][["msg"]], silent = TRUE)
-      if (methods::is(msg, "try-error")) msg <- NULL
-      detail <- try(toString(ebody[["detail"]][[1]][["loc"]]), silent = TRUE)
-      if (methods::is(detail, "try-error")) detail <- toString(ebody[["detail"]])
-      error <- paste0(msg, detail, .sep = ": ")
-    }
-
+    # TODO: find a cleaner way to parse this
+    msg <- try(ebody[["detail"]][[1]][["msg"]])
+    if (methods::is(msg, "try-error")) msg <- NULL
+    detail <- try(toString(ebody[["detail"]][[1]][["loc"]]))
+    if (methods::is(detail, "try-error")) detail <- toString(ebody[["detail"]])
+    error <- c(
+      ebody$error,
+      paste0(msg, detail, .sep = ": ")
+    )
   } else {
-    # if no further information is returned, revert to httr2 default by
-    # returning NULL
     error <- NULL
   }
 
   if (httr2::resp_status(resp) == 401)
     error <- glue::glue(error, " (hint: see ?amcat_login on how to get a fresh token)")
-
   return(error)
 }
 
 
 #' Helper function to convert date columns in date format
 #' @noRd
 convert_datecols <- function(df, index) {
-  type <- NULL
   datecols <- dplyr::filter(get_fields(index), type == "date")$name
 
-  for (date_col in intersect(colnames(df), datecols)) {
-    # AmCAT / elastic does not standardize date input/output, so try different formats
-    # (and maybe complain to whoever is in charge of AmCAT?)
-    df[[date_col]] <- lubridate::parse_date_time(df[[date_col]], orders=c("ymdHMSz", "ymdHMS", "ymdHM", "ymd"))
-  }
+  for (date_col in intersect(colnames(df), datecols))
+    df[[date_col]] <- strptime(df[[date_col]], format =  "%Y-%m-%dT%H:%M:%S")
   df
 }
 
 
 #' Truncate id columns when printing
-#'
-#' @param x id column in a data.frame with amcat4 data.
-#' @inheritParams rlang::args_dots_used
-#'
 #' @export
 #' @importFrom pillar pillar_shaft
 #' @method pillar_shaft id_col
@@ -154,47 +132,3 @@ pillar_shaft.id_col <- function(x, ...) {
 }
 
 
-#' @title Check if an amcat instance is reachable
-#'
-#' @description Check if a server is reachable by sending a request to its
-#'   config endpoint.
-#'
-#' @param server A character string of the server URL. If missing the server for
-#'   the logged in session is tried.
-#'
-#' @return A logical value indicating if the server is reachable.
-#'
-#' @export
-#'
-#' @examples
-#' \dontrun{
-#' ping("http://localhost/amcat")
-#' }
-ping <- function(server) {
-  if (missing(server)) server <- pkg.env$current_server
-  tryCatch({
-    httr2::request(server) |>
-      httr2::req_url_path_append("config") |>
-      httr2::req_error(is_error = function(resp) FALSE) |>
-      httr2::req_perform() |>
-      (\(resp) !is.null(httr2::resp_body_json(resp)$resource))()
-  }, error = function(resp) FALSE)
-}
-
-
-#' Helper function to safely turn results into a tibble without unnesting list fields
-#' @noRd
-safe_bind_rows <- function(l) {
-  purrr::map(l, function(tbl) {
-    purrr::map(tbl, function(c) {
-      if (is.list(c) & length(c) > 1) {
-        return(list(c))
-      } else {
-        return(c)
-      }
-    }) |>
-      tibble::as_tibble()
-  }) |>
-    dplyr::bind_rows()
-}
-

amcat4r.Rproj

@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 0ca4ea7c-2377-4438-8752-161a6ff85428
 
 RestoreWorkspace: Default
 SaveWorkspace: Default