From 7dbb0cae7fa29f8292759e2a8f97237abca36eac Mon Sep 17 00:00:00 2001 From: almac2022 Date: Tue, 10 Mar 2026 20:48:41 -0700 Subject: [PATCH] Add fly_thumb_georef() to georeference thumbnails to footprints MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Warps downloaded thumbnail JPGs to their estimated ground footprint using GDAL GCPs. Produces georeferenced GeoTIFFs in BC Albers (3005). No new dependencies — uses sf::gdal_utils(). Fixes #16 Co-Authored-By: Claude Opus 4.6 --- NAMESPACE | 1 + R/fly_thumb_georef.R | 136 +++++++++++++++++++++++++ man/fly_thumb_georef.Rd | 55 ++++++++++ tests/testthat/test-fly_thumb_georef.R | 101 ++++++++++++++++++ vignettes/airphoto-selection.Rmd | 21 ++++ 5 files changed, 314 insertions(+) create mode 100644 R/fly_thumb_georef.R create mode 100644 man/fly_thumb_georef.Rd create mode 100644 tests/testthat/test-fly_thumb_georef.R diff --git a/NAMESPACE b/NAMESPACE index 63cea0f..932a493 100644 --- a/NAMESPACE +++ b/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,":=") diff --git a/R/fly_thumb_georef.R b/R/fly_thumb_georef.R new file mode 100644 index 0000000..03cd2eb --- /dev/null +++ b/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 +} diff --git a/man/fly_thumb_georef.Rd b/man/fly_thumb_georef.Rd new file mode 100644 index 0000000..4603d93 --- /dev/null +++ b/man/fly_thumb_georef.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fly_thumb_georef.R +\name{fly_thumb_georef} +\alias{fly_thumb_georef} +\title{Georeference downloaded thumbnails to footprint polygons} +\usage{ +fly_thumb_georef( + fetch_result, + photos_sf, + dest_dir = "georef", + overwrite = FALSE +) +} +\arguments{ +\item{fetch_result}{A tibble returned by \code{\link[=fly_fetch]{fly_fetch()}}, with columns +\code{airp_id}, \code{dest}, and \code{success}.} + +\item{photos_sf}{The same sf object passed to \code{fly_fetch()}, with a +\code{scale} column for footprint estimation.} + +\item{dest_dir}{Directory for output GeoTIFFs. Created if it does not +exist.} + +\item{overwrite}{If \code{FALSE} (default), skip files that already exist.} +} +\value{ +A tibble with columns \code{airp_id}, \code{source}, \code{dest}, and \code{success}. +} +\description{ +Warps thumbnail images to their estimated ground footprint using GCPs +(ground control points) derived from \code{\link[=fly_footprint]{fly_footprint()}}. Produces +georeferenced GeoTIFFs in BC Albers (EPSG:3005). +} +\details{ +Each thumbnail's four corners are mapped to the corresponding footprint +polygon corners computed by \code{\link[=fly_footprint]{fly_footprint()}} in BC Albers. GDAL +translates the image with GCPs then warps to the target CRS using +bilinear resampling. + +\strong{Accuracy:} footprints assume flat terrain and nadir camera angle. +The georeferenced thumbnails are approximate — useful for visual context, +not survey-grade positioning. See \code{\link[=fly_footprint]{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 + +} diff --git a/tests/testthat/test-fly_thumb_georef.R b/tests/testthat/test-fly_thumb_georef.R new file mode 100644 index 0000000..7f59c60 --- /dev/null +++ b/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) +}) diff --git a/vignettes/airphoto-selection.Rmd b/vignettes/airphoto-selection.Rmd index ab12db9..0e61fae 100644 --- a/vignettes/airphoto-selection.Rmd +++ b/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`.