Add fly_thumb_georef for thumbnail georeferencing

NAMESPACE

@@ -9,6 +9,7 @@ export(fly_query_habitat)
 export(fly_query_lakes)
 export(fly_select)
 export(fly_summary)
+export(fly_thumb_georef)
 export(fly_trim_habitat)
 importFrom(rlang,"!!")
 importFrom(rlang,":=")

R/fly_thumb_georef.R

@@ -0,0 +1,136 @@
+#' Georeference downloaded thumbnails to footprint polygons
+#'
+#' Warps thumbnail images to their estimated ground footprint using GCPs
+#' (ground control points) derived from [fly_footprint()]. Produces
+#' georeferenced GeoTIFFs in BC Albers (EPSG:3005).
+#'
+#' @param fetch_result A tibble returned by [fly_fetch()], with columns
+#'   `airp_id`, `dest`, and `success`.
+#' @param photos_sf The same sf object passed to `fly_fetch()`, with a
+#'   `scale` column for footprint estimation.
+#' @param dest_dir Directory for output GeoTIFFs. Created if it does not
+#'   exist.
+#' @param overwrite If `FALSE` (default), skip files that already exist.
+#' @return A tibble with columns `airp_id`, `source`, `dest`, and `success`.
+#'
+#' @details
+#' Each thumbnail's four corners are mapped to the corresponding footprint
+#' polygon corners computed by [fly_footprint()] in BC Albers. GDAL
+#' translates the image with GCPs then warps to the target CRS using
+#' bilinear resampling.
+#'
+#' **Accuracy:** footprints assume flat terrain and nadir camera angle.
+#' The georeferenced thumbnails are approximate — useful for visual context,
+#' not survey-grade positioning. See [fly_footprint()] for details on
+#' limitations.
+#'
+#' @examples
+#' centroids <- sf::st_read(system.file("testdata/photo_centroids.gpkg", package = "fly"))
+#'
+#' # Fetch and georeference first 2 thumbnails
+#' fetched <- fly_fetch(centroids[1:2, ], type = "thumbnail",
+#'                      dest_dir = tempdir())
+#' georef <- fly_thumb_georef(fetched, centroids[1:2, ],
+#'                            dest_dir = tempdir())
+#' georef
+#'
+#' @export
+fly_thumb_georef <- function(fetch_result, photos_sf,
+                             dest_dir = "georef", overwrite = FALSE) {
+  if (!all(c("airp_id", "dest", "success") %in% names(fetch_result))) {
+    stop("`fetch_result` must be output from `fly_fetch()`.", call. = FALSE)
+  }
+
+  dir.create(dest_dir, recursive = TRUE, showWarnings = FALSE)
+
+  # Build footprints in BC Albers
+  footprints <- fly_footprint(photos_sf) |> sf::st_transform(3005)
+
+  # Match fetch results to photos by airp_id
+  ids <- fetch_result$airp_id
+
+  results <- dplyr::tibble(
+    airp_id = ids,
+    source  = fetch_result$dest,
+    dest    = NA_character_,
+    success = FALSE
+  )
+
+  for (i in seq_len(nrow(results))) {
+    if (!fetch_result$success[i]) next
+    src <- results$source[i]
+    if (is.na(src) || !file.exists(src)) next
+
+    out_file <- file.path(dest_dir,
+                          sub("\\.[^.]+$", ".tif", basename(src)))
+    results$dest[i] <- out_file
+
+    if (!overwrite && file.exists(out_file)) {
+      results$success[i] <- TRUE
+      next
+    }
+
+    # Find matching footprint
+    fp_idx <- which(photos_sf[["airp_id"]] == results$airp_id[i])
+    if (length(fp_idx) == 0) next
+    fp <- footprints[fp_idx[1], ]
+
+    results$success[i] <- tryCatch(
+      georef_one(src, fp, out_file),
+      error = function(e) {
+        message("Failed to georef ", basename(src), ": ", e$message)
+        FALSE
+      }
+    )
+  }
+
+  n_ok <- sum(results$success)
+  message("Georeferenced ", n_ok, " of ", nrow(results), " thumbnails")
+  results
+}
+
+#' Georeference a single thumbnail to a footprint polygon
+#' @noRd
+georef_one <- function(src, fp, out_file) {
+  # Get footprint corner coordinates
+  # fly_footprint builds: BL, BR, TR, TL, BL (closing)
+  coords <- sf::st_coordinates(fp)[1:4, , drop = FALSE]
+
+  # Read image dimensions via GDAL
+  info <- sf::gdal_utils("info", source = src, quiet = TRUE)
+  dims <- regmatches(info, regexpr("Size is \\d+, \\d+", info))
+  if (length(dims) == 0) return(FALSE)
+  px <- as.integer(strsplit(sub("Size is ", "", dims), ", ")[[1]])
+  ncol_px <- px[1]
+  nrow_px <- px[2]
+
+  # Map pixel corners to footprint corners
+  # Pixel: TL=(0,0), TR=(ncol,0), BR=(ncol,nrow), BL=(0,nrow)
+  # Footprint coords: [1]=BL, [2]=BR, [3]=TR, [4]=TL
+  gcp_args <- c(
+    "-gcp", 0,       0,       coords[4, 1], coords[4, 2],
+    "-gcp", ncol_px, 0,       coords[3, 1], coords[3, 2],
+    "-gcp", ncol_px, nrow_px, coords[2, 1], coords[2, 2],
+    "-gcp", 0,       nrow_px, coords[1, 1], coords[1, 2]
+  )
+
+  # Step 1: translate with GCPs
+
+  tmp_file <- tempfile(fileext = ".tif")
+  on.exit(unlink(tmp_file), add = TRUE)
+
+  sf::gdal_utils("translate",
+    source = src,
+    destination = tmp_file,
+    options = c("-a_srs", "EPSG:3005", gcp_args)
+  )
+
+  # Step 2: warp to target CRS
+  sf::gdal_utils("warp",
+    source = tmp_file,
+    destination = out_file,
+    options = c("-t_srs", "EPSG:3005", "-r", "bilinear")
+  )
+
+  file.exists(out_file) && file.size(out_file) > 0
+}

tests/testthat/test-fly_thumb_georef.R

@@ -0,0 +1,101 @@
+test_that("fly_thumb_georef returns expected columns", {
+  centroids <- sf::st_read(testdata_path("photo_centroids.gpkg"), quiet = TRUE)
+  dest_fetch <- file.path(tempdir(), "fly_georef_test_fetch")
+  unlink(dest_fetch, recursive = TRUE)
+
+  fetched <- fly_fetch(centroids[1, ], type = "thumbnail",
+                       dest_dir = dest_fetch)
+  dest_georef <- file.path(tempdir(), "fly_georef_test_out")
+  unlink(dest_georef, recursive = TRUE)
+
+  result <- fly_thumb_georef(fetched, centroids[1, ],
+                             dest_dir = dest_georef)
+  expect_s3_class(result, "tbl_df")
+  expect_true(all(c("airp_id", "source", "dest", "success") %in% names(result)))
+})
+
+test_that("fly_thumb_georef produces georeferenced TIFFs", {
+  centroids <- sf::st_read(testdata_path("photo_centroids.gpkg"), quiet = TRUE)
+  dest_fetch <- file.path(tempdir(), "fly_georef_test_tiff_fetch")
+  unlink(dest_fetch, recursive = TRUE)
+
+  fetched <- fly_fetch(centroids[1, ], type = "thumbnail",
+                       dest_dir = dest_fetch)
+  dest_georef <- file.path(tempdir(), "fly_georef_test_tiff_out")
+  unlink(dest_georef, recursive = TRUE)
+
+  result <- fly_thumb_georef(fetched, centroids[1, ],
+                             dest_dir = dest_georef)
+  expect_true(result$success[1])
+  expect_true(file.exists(result$dest[1]))
+
+  # Verify it has a CRS
+  info <- sf::gdal_utils("info", source = result$dest[1], quiet = TRUE)
+  expect_true(grepl("3005", info))
+})
+
+test_that("fly_thumb_georef skips failed fetches", {
+  centroids <- sf::st_read(testdata_path("photo_centroids.gpkg"), quiet = TRUE)
+  fake_fetch <- dplyr::tibble(
+    airp_id = centroids$airp_id[1],
+    url = "https://example.com/fake.jpg",
+    dest = "/nonexistent/fake.jpg",
+    success = FALSE
+  )
+  result <- fly_thumb_georef(fake_fetch, centroids[1, ],
+                             dest_dir = tempdir())
+  expect_false(result$success[1])
+})
+
+test_that("fly_thumb_georef skips existing when overwrite is FALSE", {
+  centroids <- sf::st_read(testdata_path("photo_centroids.gpkg"), quiet = TRUE)
+  dest_fetch <- file.path(tempdir(), "fly_georef_overwrite_fetch")
+  unlink(dest_fetch, recursive = TRUE)
+
+  fetched <- fly_fetch(centroids[1, ], type = "thumbnail",
+                       dest_dir = dest_fetch)
+  dest_georef <- file.path(tempdir(), "fly_georef_overwrite_out")
+  unlink(dest_georef, recursive = TRUE)
+
+  # First run
+  fly_thumb_georef(fetched, centroids[1, ], dest_dir = dest_georef)
+  f <- list.files(dest_georef, full.names = TRUE)[1]
+  mtime1 <- file.mtime(f)
+  Sys.sleep(1)
+
+  # Second run without overwrite
+  fly_thumb_georef(fetched, centroids[1, ],
+                   dest_dir = dest_georef, overwrite = FALSE)
+  mtime2 <- file.mtime(f)
+  expect_equal(mtime1, mtime2)
+})
+
+test_that("fly_thumb_georef rejects bad input", {
+  expect_error(fly_thumb_georef(data.frame(x = 1), data.frame(y = 1)),
+               "fly_fetch")
+})
+
+test_that("fly_thumb_georef extent matches footprint", {
+  centroids <- sf::st_read(testdata_path("photo_centroids.gpkg"), quiet = TRUE)
+  dest_fetch <- file.path(tempdir(), "fly_georef_extent_fetch")
+  unlink(dest_fetch, recursive = TRUE)
+
+  fetched <- fly_fetch(centroids[1, ], type = "thumbnail",
+                       dest_dir = dest_fetch)
+  dest_georef <- file.path(tempdir(), "fly_georef_extent_out")
+  unlink(dest_georef, recursive = TRUE)
+
+  result <- fly_thumb_georef(fetched, centroids[1, ],
+                             dest_dir = dest_georef)
+
+  # Compare georef extent to footprint extent
+  fp <- fly_footprint(centroids[1, ]) |> sf::st_transform(3005)
+  fp_bbox <- sf::st_bbox(fp)
+
+  info <- sf::gdal_utils("info", source = result$dest[1], quiet = TRUE)
+  # Extract corner coordinates from gdalinfo
+  ul <- regmatches(info, regexpr("Upper Left\\s+\\([^)]+\\)", info))
+  lr <- regmatches(info, regexpr("Lower Right\\s+\\([^)]+\\)", info))
+  expect_length(ul, 1)
+  expect_length(lr, 1)
+})

vignettes/airphoto-selection.Rmd

@@ -242,3 +242,24 @@ legend("topright", legend = scale_labels,
        fill = adjustcolor(palette[seq_along(scale_labels)], 0.3),
        border = palette[seq_along(scale_labels)], bty = "n")
 ```
+
+# Thumbnail retrieval and georeferencing
+
+`fly_fetch()` downloads thumbnail images (or flight logs, calibration
+reports) from the BC Data Catalogue URLs included in the centroid data.
+`fly_thumb_georef()` warps each thumbnail to its estimated footprint
+polygon, producing georeferenced GeoTIFFs in BC Albers.
+
+```{r fetch-georef}
+fetched <- fly_fetch(centroids[1:3, ], type = "thumbnail",
+                     dest_dir = tempdir())
+georef <- fly_thumb_georef(fetched, centroids[1:3, ],
+                           dest_dir = tempdir())
+georef[, c("airp_id", "dest", "success")]
+```
+
+The georeferenced TIFFs inherit the flat-terrain and nadir-camera
+assumptions from `fly_footprint()` — they are approximate, useful for
+visual context rather than survey-grade positioning. Metadata from the
+original centroid data (date, scale, focal length) links back via
+`airp_id`.