Improve error handling in fhir_batch_to_tibble and enhance safe_get_concept function

- Updated fhir_batch_to_tibble to handle zero-length and non-character error values gracefully, preventing crashes from empty vectors.
- Refined safe_get_concept to return structured results, allowing callers to distinguish between "not found" and other error types for better logging and reporting.
- Adjusted example scripts to reflect the new structured error handling approach.

Author: alex-omophub

R/fhir.R

@@ -216,7 +216,10 @@ fhir_batch_to_tibble <- function(result, codings) {
       return(paste(names(err) %||% "", unlist(lapply(err, as.character)),
                    sep = "=", collapse = "; "))
     }
-    as.character(err)[[1L]]
+    # Zero-length / non-character fallbacks: single-bracket indexing
+    # returns NA on a length-0 vector instead of throwing. Guards
+    # against `character(0)`, `integer(0)`, etc.
+    as.character(err)[1L]
   }
 
   make_row <- function(i) {

inst/examples/error_handling.R

@@ -158,32 +158,40 @@ cat("\n")
 cat("5. Graceful degradation\n")
 cat("-----------------------\n")
 
-# Function that returns NULL on error instead of failing
+# Function that returns a structured result instead of failing. The
+# caller can distinguish "not found" from other error categories so
+# downstream logging / reporting is honest about what went wrong.
 safe_get_concept <- function(client, concept_id) {
   tryCatch(
-    client$concepts$get(concept_id),
-    httr2_http_404 = function(e) NULL,
+    list(ok = TRUE, value = client$concepts$get(concept_id), reason = NA_character_),
+    httr2_http_404 = function(e) {
+      list(ok = FALSE, value = NULL, reason = "not found")
+    },
     httr2_http = function(e) {
-      message("HTTP error for concept ", concept_id, ": ",
-              conditionMessage(e)[[1]])
-      NULL
+      list(
+        ok = FALSE,
+        value = NULL,
+        reason = sprintf("HTTP error: %s", conditionMessage(e)[[1]])
+      )
     },
     error = function(e) {
-      message("Error fetching concept ", concept_id, ": ",
-              conditionMessage(e)[[1]])
-      NULL
+      list(
+        ok = FALSE,
+        value = NULL,
+        reason = sprintf("error: %s", conditionMessage(e)[[1]])
+      )
     }
   )
 }
 
 concept_ids <- c(201826, 999999999, 320128)
-cat("  Fetching concepts with fallback to NULL:\n")
+cat("  Fetching concepts with structured results:\n")
 for (id in concept_ids) {
-  concept <- safe_get_concept(client, id)
-  if (!is.null(concept)) {
-    cat(sprintf("    [%d] %s\n", id, concept$concept_name))
+  result <- safe_get_concept(client, id)
+  if (isTRUE(result$ok)) {
+    cat(sprintf("    [%d] %s\n", id, result$value$concept_name))
   } else {
-    cat(sprintf("    [%d] (not found)\n", id))
+    cat(sprintf("    [%d] (%s)\n", id, result$reason))
   }
 }
 cat("\n")

inst/examples/navigate_hierarchy.R

@@ -134,8 +134,12 @@ for (type_name in names(by_type)) {
   items <- by_type[[type_name]]
   cat(sprintf("\n  %s (%d):\n", type_name, length(items)))
   for (r in head(items, 3)) {
+    # Prefer the nested ``concept_2`` object (full concept details) but
+    # fall back to the flat ``concept_id_2`` field so deprecated or
+    # invalid target concepts without a populated nested object still
+    # surface an ID instead of rendering as unknown.
     target <- r$concept_2 %||% list()
-    target_id <- target$concept_id %||% "?"
+    target_id <- target$concept_id %||% r$concept_id_2 %||% "?"
     target_name <- target$concept_name %||% "Unknown"
     cat(sprintf("    -> [%s] %s\n", target_id, target_name))
   }

tests/testthat/test-fhir.R

@@ -442,3 +442,68 @@ test_that("fhir_resolve_codeable_concept standalone matches R6 method", {
 
   expect_identical(r6_result, wrapper_result)
 })
+
+# ==============================================================================
+# resolve_batch(as_tibble = TRUE) with unusual `error` shapes
+# ==============================================================================
+
+test_that("resolve_batch(as_tibble = TRUE) handles zero-length error values", {
+  # Regression for a bug where `as.character(err)[[1L]]` crashed with
+  # "subscript out of bounds" when the API returned an empty character
+  # vector (or any other length-0 value) in the `error` field.
+  base_req <- httr2::request("https://api.omophub.com/v1")
+  resource <- FhirResource$new(base_req)
+
+  local_mocked_bindings(
+    perform_post = function(req, path, body = NULL, query = NULL) {
+      list(
+        results = list(
+          list(error = character(0)),       # empty character vector
+          list(error = integer(0)),         # empty integer vector
+          list(error = list())              # empty list
+        ),
+        summary = list(total = 3L, resolved = 0L, failed = 3L)
+      )
+    }
+  )
+
+  codings <- list(
+    list(system = "http://snomed.info/sct", code = "a"),
+    list(system = "http://snomed.info/sct", code = "b"),
+    list(system = "http://snomed.info/sct", code = "c")
+  )
+
+  # Must not throw, must return one row per input
+  tbl <- resource$resolve_batch(codings, as_tibble = TRUE)
+  expect_s3_class(tbl, "tbl_df")
+  expect_equal(nrow(tbl), 3L)
+  expect_true(all(tbl$status == "failed"))
+})
+
+test_that("resolve_batch(as_tibble = TRUE) handles unusual scalar error shapes", {
+  # Coverage for the non-character fallback: numeric and logical errors
+  # must be coerced via as.character() without throwing.
+  base_req <- httr2::request("https://api.omophub.com/v1")
+  resource <- FhirResource$new(base_req)
+
+  local_mocked_bindings(
+    perform_post = function(req, path, body = NULL, query = NULL) {
+      list(
+        results = list(
+          list(error = 42L),
+          list(error = TRUE)
+        ),
+        summary = list(total = 2L, resolved = 0L, failed = 2L)
+      )
+    }
+  )
+
+  codings <- list(
+    list(system = "http://snomed.info/sct", code = "a"),
+    list(system = "http://snomed.info/sct", code = "b")
+  )
+
+  tbl <- resource$resolve_batch(codings, as_tibble = TRUE)
+  expect_equal(nrow(tbl), 2L)
+  expect_equal(tbl$status_detail, c("42", "TRUE"))
+})