From 411357a5c1d70c203ac848fc6d102c15abd77eab Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Sun, 26 Mar 2023 11:18:02 -0400 Subject: [PATCH] refactor: rename list.ok to allow_list - refactor: rename list.ok to allow_list - refactor: update staticimports - refactor: add input check to st_bbox_ext - refactor: stop importing map, map_lgl, and discard from purrr - feat: drop write_exif + start exporting write_exif_from separately - refactor: improve checking of logical inputs for is_sf and related functions --- NAMESPACE | 4 - NEWS.md | 8 +- R/as_point.R | 7 +- R/as_sf.R | 2 +- R/get_coords.R | 1 - R/is_sf.R | 16 +- R/read_sf_exif.R | 259 +++++-------------------------- R/read_sf_ext.R | 3 +- R/sfext-package.R | 22 +-- R/st_bbox_ext.R | 18 ++- R/st_buffer_ext.R | 11 +- R/st_filter_ext.R | 10 +- R/st_misc.R | 1 - R/st_transform_ext.R | 6 +- R/staticimports.R | 332 +++++++++++++++++++++++++++++----------- R/utils-check.R | 13 +- R/utils-is.R | 2 +- man/as_point.Rd | 2 +- man/check_sf.Rd | 4 +- man/is_sf.Rd | 4 +- man/read_sf_exif.Rd | 76 +-------- man/read_sf_ext.Rd | 4 +- man/st_bbox_ext.Rd | 6 +- man/st_buffer_ext.Rd | 4 +- man/st_filter_ext.Rd | 4 +- man/st_make_grid_ext.Rd | 2 +- man/st_transform_ext.Rd | 4 +- man/write_exif_from.Rd | 45 ++++++ 28 files changed, 412 insertions(+), 458 deletions(-) create mode 100644 man/write_exif_from.Rd diff --git a/NAMESPACE b/NAMESPACE index ab5e241..9395565 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -146,7 +146,6 @@ export(st_trim) export(st_union_by) export(st_union_ext) export(transform_sf) -export(write_exif) export(write_exif_from) export(write_sf_cache) export(write_sf_ext) @@ -168,7 +167,6 @@ importFrom(cli,cli_warn) importFrom(cli,pluralize) importFrom(cliExtras,cli_abort_ifnot) importFrom(cliExtras,cli_ask) -importFrom(cliExtras,cli_paths) importFrom(cliExtras,cli_warn_ifnot) importFrom(cliExtras,cli_yesno) importFrom(cliExtras,cls_vec) @@ -208,10 +206,8 @@ importFrom(janitor,make_clean_names) importFrom(lifecycle,badge) importFrom(lifecycle,deprecated) importFrom(lifecycle,signal_stage) -importFrom(purrr,discard) importFrom(purrr,map) importFrom(purrr,map_dfr) -importFrom(purrr,map_lgl) importFrom(purrr,walk) importFrom(purrr,walk2) importFrom(rlang,.data) diff --git a/NEWS.md b/NEWS.md index a57f42d..3325640 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,10 @@ - +# sfext development + +* Deprecate `get_data_dir()` function (superseded by) `filenamr::get_data_dir()`. +* Removed `write_exif()` function (moved to `filenamr::write_exif()`). +* Replace null.ok parameter with allow_null and list.ok parameter with allow_list. +* Stop importing `purrr::map()` and `purrr::map_lgl()` (replaced with `standalone-purrr.R`). +* Add new pkg parameter to `read_sf_pkg()` as alternative to package parameter. # sfext 0.1.0.9000 (2023-03-15) diff --git a/R/as_point.R b/R/as_point.R index 92bf381..3043119 100644 --- a/R/as_point.R +++ b/R/as_point.R @@ -15,7 +15,7 @@ #' @details Using as_points: #' #' [as_points()] always returns an sfc object. The parameters are passed to -#' as_point using [purrr::map] and then converted to sfc using +#' as_point using [purrr::map()] and then converted to sfc using #' [sf::st_as_sfc()]. The ... parameters must include a crs, otherwise the crs #' will be NA for the resulting sfc object. #' @@ -63,7 +63,6 @@ as_point <- function(..., to = "POINT") { #' @rdname as_point #' @name as_points #' @export -#' @importFrom purrr map #' @importFrom sf st_as_sfc st_cast as_points <- function(..., to = "POINT", call = caller_env()) { params <- list2(...) @@ -223,7 +222,7 @@ as_lines <- function(..., to = "LINESTRING") { #' @name as_polygons #' @rdname as_point #' @export -#' @importFrom purrr map_dfr map_lgl +#' @importFrom purrr map_dfr as_polygons <- function(..., to = "POLYGON") { params <- list2(...) crs <- NULL @@ -234,7 +233,7 @@ as_polygons <- function(..., to = "POLYGON") { crs <- sf::st_crs(params[[1]]) } - if (all(purrr::map_lgl(params, ~ is_polygon(.x)))) { + if (all(map_lgl(params, ~ is_polygon(.x)))) { return(purrr::map_dfr(params, ~ as_sf(.x))) } diff --git a/R/as_sf.R b/R/as_sf.R index 0e5b334..97552c2 100644 --- a/R/as_sf.R +++ b/R/as_sf.R @@ -268,7 +268,7 @@ make_sf_grid_list <- function(x, style = "rect", ncol = 2, nrow = 2, .id = "grid #' @rdname as_sf #' @export as_sf_class <- function(x, class = NULL, allow_null = TRUE, call = caller_env(), ...) { - if (is.null(class) && allow_null) { + if (is.null(class) && is_true(allow_null)) { return(x) } diff --git a/R/get_coords.R b/R/get_coords.R index 55e1c04..9715d26 100644 --- a/R/get_coords.R +++ b/R/get_coords.R @@ -95,7 +95,6 @@ get_coords <- function(x, #' @aliases st_coords_minmax #' @rdname get_coords #' @importFrom dplyr mutate row_number select bind_cols -#' @importFrom purrr map #' @importFrom tibble enframe #' @importFrom sf st_drop_geometry get_minmax <- function(x, crs = NULL, keep_all = TRUE, drop = TRUE) { diff --git a/R/is_sf.R b/R/is_sf.R index a1c2a20..b541867 100644 --- a/R/is_sf.R +++ b/R/is_sf.R @@ -6,7 +6,7 @@ #' @param ext If `TRUE`, check if x is a `sf`, `sfc`, or `bbox` class object or #' not; defaults to `FALSE`. (used by [is_sf]) #' @param allow_null If `TRUE` and x is `NULL`, return `TRUE`; defaults to `FALSE`. -#' @param list.ok If `TRUE`, [is_sf] will return TRUE if x is a list of sf objects. +#' @param allow_list If `TRUE`, [is_sf] will return TRUE if x is a list of sf objects. #' @details #' - [is_sf]: is x a `sf` class object? #' - [is_sfc]: is x is a `sfc` class object? @@ -19,7 +19,7 @@ #' #' @export #' @md -is_sf <- function(x, ext = FALSE, allow_null = FALSE, list.ok = FALSE) { +is_sf <- function(x, ext = FALSE, allow_null = FALSE, allow_list = FALSE) { classes <- "sf" if (isTRUE(ext)) { @@ -28,7 +28,7 @@ is_sf <- function(x, ext = FALSE, allow_null = FALSE, list.ok = FALSE) { classes <- c(classes, ext) } - if (!list.ok) { + if (isFALSE(allow_list)) { return(is_class(x, classes = classes, allow_null = allow_null)) } @@ -61,7 +61,7 @@ is_bbox <- function(x, allow_null = FALSE) { #' @param named If `TRUE`, check if sf list is named; defaults `FALSE`. #' @export is_sf_list <- function(x, named = FALSE, ext = FALSE, allow_null = FALSE) { - if (is.null(x) && allow_null) { + if (is.null(x) && isTRUE(allow_null)) { return(TRUE) } @@ -80,11 +80,11 @@ is_sf_list <- function(x, named = FALSE, ext = FALSE, allow_null = FALSE) { ) ) - if (!named) { + if (isFALSE(named)) { return(is_sf_list) } - is_sf_list && is_named(x) + isTRUE(is_sf_list) && is_named(x) } #' @name is_raster @@ -98,7 +98,7 @@ is_raster <- function(x, allow_null = FALSE) { #' @rdname is_sf #' @export is_sp <- function(x, allow_null = FALSE) { - if (is.null(x) && allow_null) { + if (is.null(x) && isTRUE(allow_null)) { return(TRUE) } @@ -109,7 +109,7 @@ is_sp <- function(x, allow_null = FALSE) { #' @rdname is_sf #' @export is_geo_coords <- function(x, allow_null = FALSE) { - if (is.null(x) && allow_null) { + if (is.null(x) && isTRUE(allow_null)) { return(TRUE) } diff --git a/R/read_sf_exif.R b/R/read_sf_exif.R index df49b7d..27254b2 100644 --- a/R/read_sf_exif.R +++ b/R/read_sf_exif.R @@ -49,18 +49,16 @@ exif_xwalk <- #' IPTC:Caption-Abstract #' - keywords: Keywords, IPTC:Keywords, XMP-dc:Subject #' -#' @param path A path to folder or file. -#' @param bbox Optional bounding box to crop returned file (excluding images -#' with location data outside the bounding box). If bbox is provided the -#' returned data will match the crs of the bbox. -#' @param filetype The file extension or file type; defaults to `NULL`. +#' @inheritParams filenamr::read_exif #' @param sort Column name for variable to sort by passed to [sort_features()]. #' Currently supports "lon", "lat", or "filename". Defaults to `NULL`. #' @param tags Optional list of EXIF tags to read from files. Must include GPS #' tags to create an `sf` object. -#' @param geometry If `TRUE` (defualt), return a simple feature object. If +#' @param fileext,filetype File extension or file type. filetype is used if +#' fileext is `NULL`. +#' @param bbox Bounding box to filter by. +#' @param geometry If `TRUE` (default), return a simple feature object. If #' `FALSE`, return a data.frame. -#' @param ... Additional EXIF tags to pass to [exiftoolr::exif_read] #' @family read_write #' @example examples/read_sf_exif.R #' @export @@ -71,69 +69,38 @@ exif_xwalk <- #' @importFrom rlang has_name #' @importFrom sf st_crs read_sf_exif <- function(path = NULL, + fileext = NULL, filetype = NULL, bbox = NULL, sort = NULL, tags = NULL, geometry = TRUE, ...) { - rlang::check_installed("exiftoolr") + geo_tags <- c("GPSLatitude", "GPSLongitude") - # FIXME: This is a partial list of filetypes that support GPS EXIF metadata - # filetype <- match.arg(filetype, c("jpg", "jpeg", "png", "tiff", "pdf")) - - if (is.null(tags)) { - # FIXME: The default fields likely vary by file type and could be set based - # on that NOTE: Are there other tags that should be included by default? - tags <- default_exif_tags - } else if (!all(c("GPSLatitude", "GPSLongitude") %in% tags)) { - cli_warn( - c("{.arg tags} must be include {.val {c('GPSLatitude', 'GPSLongitude')}} + if (geometry && !all(geo_tags %in% tags)) { + cli_bullets( + c( + "!" = "{.arg tags} must be include {.val {c('GPSLatitude', 'GPSLongitude')}} to create a {.cls sf} object from EXIF metadata.", - "i" = "The provided {.arg tags} are {.val {tags}}." - ) - ) - } - - path <- get_path_files(path, filetype) - - # FIXME: Figure out how to append path to the end of the table not the - # beginning - data <- - suppressMessages( - exiftoolr::exif_read( - path, - tags = tags + "*" = "Adding required tags to {.arg tags}." ) ) - data <- - # Rename variables - dplyr::rename_with( - janitor::clean_names(data), - ~ sub("^gps_", "", .x) - ) - - xwalk <- exif_xwalk[rlang::has_name(data, exif_xwalk)] + tags <- c(tags, geo_tags) + } data <- - # Rename variables - dplyr::rename_with( - data, - ~ names(xwalk)[which(xwalk == .x)], - .cols = as.character(xwalk) + filenamr::read_exif( + path, + fileext = fileext %||% filetype, + tags = tags ) - data <- fmt_exif_orientation(data) - - data <- fmt_exif_direction(data) - - if (!geometry) { - return(data) + if (geometry) { + data <- df_to_sf(data, from_crs = 4326, crs = bbox) } - data <- df_to_sf(data, from_crs = 4326, crs = bbox) - if (!is.null(sort)) { data <- sort_features(data, sort = sort) } @@ -141,166 +108,16 @@ read_sf_exif <- function(path = NULL, st_filter_ext(data, bbox) } -#' @noRd -fmt_exif_orientation <- function(data) { - has_orientation_names <- - rlang::has_name(data, c("exif_orientation", "img_width", "img_width")) - - if (!all(has_orientation_names)) { - return(data) - } - - dplyr::mutate( - data, - exif_orientation = - dplyr::case_when( - exif_orientation == 1 ~ "Horizontal (normal)", - exif_orientation == 2 ~ "Mirror horizontal", - exif_orientation == 3 ~ "Rotate 180", - exif_orientation == 4 ~ "Mirror vertical", - exif_orientation == 5 ~ "Mirror horizontal and rotate 270 CW", - exif_orientation == 6 ~ "Rotate 90 CW", - exif_orientation == 7 ~ "Mirror horizontal and rotate 90 CW", - exif_orientation == 8 ~ "Rotate 270 CW" - ), - orientation = - dplyr::case_when( - (img_width / img_height) > 1 ~ "landscape", - (img_width / img_height) < 1 ~ "portrait", - (img_width / img_height) == 1 ~ "square" - ), - .after = "exif_orientation" - ) -} - -#' Format img_direction as cardinal directions (degrees and wind directions) +#' Write EXIF data for photos on spatial join with a sf object or list of sf objects +#' +#' Extends [sfext::read_sf_exif()] and [filenamr::write_exif()] #' -#' @noRd -fmt_exif_direction <- function(data, .after = "img_direction") { - if (!all(rlang::has_name(data, c("img_direction")))) { - return(data) - } - - # See https://en.wikipedia.org/wiki/Points_of_the_compass#8-wind_compass_rose - cardinal_degrees <- - c( - "N" = 0, "NE" = 45, - "E" = 90, "SE" = 135, - "S" = 180, "SW" = 225, - "W" = 270, "NW" = 315, "N" = 360 - ) - - dplyr::mutate( - data, - img_cardinal_dir = cardinal_degrees[ - findInterval(img_direction, cardinal_degrees - 22.5) - ], - img_cardinal_wind = names(img_cardinal_dir), - .after = .after - ) -} - -#' @name write_exif -#' @rdname read_sf_exif -#' @param title Title to add to file metadata with exiftoolr, Default: `NULL`. -#' @param author Author to add to file metadata with exiftoolr, Default: `NULL`. -#' @param date Date to add to file metadata with exiftoolr (not currently -#' working), Default: `NULL`. -#' @param keywords Keyword(s) added to file metadata with with exiftoolr, -#' Default: `NULL`. -#' @param description description to add to ImageDescription EXIF tag, XMP-dc -#' Description tag, and IPTC Caption-Abstract tag. -#' @param args Alternate arguments passed to [exiftoolr::exif_call()]. If args -#' is not `NULL`, title, author, date, and keywords are ignored; defaults to -#' `NULL`. -#' @param overwrite If `TRUE`, overwrite any existing EXIF metadata present in the -#' provided fields; defaults to `TRUE` -#' @param append_keywords If `TRUE`, append keywords to existing keywords. If -#' `FALSE` (default), replace existing keywords with the provided values. -#' @export -#' @importFrom cliExtras cli_paths -write_exif <- function(path, - filetype = NULL, - title = NULL, - author = NULL, - date = NULL, - keywords = NULL, - description = NULL, - args = NULL, - overwrite = TRUE, - append_keywords = FALSE) { - rlang::check_installed("exiftoolr") - - # FIXME: I want to implement a method that allows adding, replacing, or modifying exif - if (is.null(args)) { - if (!is.null(title)) { - args <- c(args, glue("-Title={title}")) - args <- c(args, glue("-IPTC:Headline={title}")) - args <- c(args, glue("-IPTC:ObjectName={title}")) - args <- c(args, glue("-XMP-dc:Title={title}")) - } - - if (!is.null(author)) { - args <- c(args, glue("-Author={author}")) - } - - if (!is.null(description)) { - args <- c(args, glue("-ImageDescription={description}")) - args <- c(args, glue("-XMP-dc:Description={description}")) - args <- c(args, glue("-IPTC:Caption-Abstract={description}")) - } - - if (!is.null(date)) { - # FIXME: exiftoolr::exif_call() does not support the "now" value supported - # by exif If CreateDate is set to now automatically, why bother revising - # with exiftoolr anyway? TODO: Add support for subjects (partially - # complete with keywords) - # https://stackoverflow.com/questions/28588696/python-exiftool-combining-subject-and-keyword-tags#28609886 - date <- "now" - if ("png" %in% filetype) { - args <- c(args, glue("-CreationTime={date}")) - } else { - args <- c(args, c("-CreateDate={date}", "-ModifyDate={date}")) - } - } - - if (!is.null(keywords)) { - op <- "+=" - - if (overwrite && !append_keywords) { - op <- "=" - } - - args <- c(args, paste0("-Keywords", op, keywords)) - args <- c(args, paste0("-IPTC:Keywords", op, keywords)) - args <- c(args, paste0("-XMP-dc:Subject", op, keywords)) - } - - if (overwrite) { - args <- c(args, "-overwrite_original") - } - } - - if (!is.null(args)) { - path <- get_path_files(path) - - suppressMessages( - suppressWarnings( - exiftoolr::exif_call( - args = args, - path = path, - quiet = TRUE - ) - ) - ) - - cliExtras::cli_paths(path, "Updated EXIF metadata for") - } -} - #' @name write_exif_from #' @aliases write_exif_keywords -#' @rdname read_sf_exif +#' @inheritParams filenamr::write_exif +#' @inheritParams read_sf_exif +#' @param fileext,filetype File extension or file type. filetype is used if +#' fileext is `NULL`. #' @param from A sf object or list of sf objects where each object has a column #' with a name matching the .id parameter. The attribute value in this column #' are used to assign the tag parameter to the file at the provided path based @@ -319,6 +136,7 @@ write_exif <- function(path, #' @importFrom sf st_drop_geometry st_join #' @importFrom cli cli_bullets write_exif_from <- function(path, + fileext = NULL, filetype = NULL, from, .id = "name", @@ -328,7 +146,11 @@ write_exif_from <- function(path, tag <- match.arg(tolower(tag), c("keywords", "title", "description")) if (!is_sf(path)) { - data <- read_sf_exif(path = path, filetype = filetype) + data <- read_sf_exif( + path = path, + fileext = fileext, + filetype = filetype + ) path <- get_path_files(path, filetype) } else if (is.data.frame(path)) { data <- path @@ -366,6 +188,8 @@ write_exif_from <- function(path, vals = unique(list(.data[[.id]])) )[["vals"]] + replacement_vals <- append_vals + if (!is.null(existing_vals)) { replacement_vals <- map2( @@ -373,19 +197,12 @@ write_exif_from <- function(path, append_vals, ~ unique(append(.x, .y)) ) - } else { - replacement_vals <- append_vals } - len_path <- length(path) - - cli_inform( - c("v" = "Updated EXIF tag {.val {tag}} for {len_path} file{?s}:") + cliExtras::cli_list_files( + path = path, + text = c("v" = "Updated EXIF tag {.val {tag}} for {length(path)} file{?s}:") ) - - path_msg <- paste0("{.file ", path, "}") - cli::cli_bullets(rlang::set_names(path_msg, rep("*", len_path))) - suppressMessages( walk2_write_exif(path, replacement_vals, tag) ) diff --git a/R/read_sf_ext.R b/R/read_sf_ext.R index 2f1821f..e9b7416 100644 --- a/R/read_sf_ext.R +++ b/R/read_sf_ext.R @@ -50,7 +50,8 @@ #' @param url A url for a spatial data file, tabular data with coordinates, or a #' ArcGIS FeatureServer or MapServer to access with [esri2sf::esri2sf()] #' @param data Name of a package dataset; used by [read_sf_pkg()] only. -#' @param package Package name; used by [read_sf_pkg()] only. +#' @param package,pkg Package name; used by [read_sf_pkg()] only. pkg is used if +#' package is `NULL`. #' @param filetype File type supported by [sf::read_sf()]; Default: 'gpkg'; used #' by [read_sf_pkg()] only and required only if the data is in the package #' cache directory or extdata system files. diff --git a/R/sfext-package.R b/R/sfext-package.R index d4b6540..b4f894b 100644 --- a/R/sfext-package.R +++ b/R/sfext-package.R @@ -4,6 +4,18 @@ ## usethis namespace: start #' #' @import rlang +#' @importFrom rlang .data +#' @importFrom rlang .env +#' @importFrom rlang `%||%` +#' @importFrom rlang caller_env +#' @importFrom rlang has_length +#' @importFrom rlang is_interactive +#' @importFrom rlang check_installed +#' @importFrom rlang exec +#' @importFrom rlang env_get_list +#' @importFrom rlang is_true +#' @importFrom rlang is_false +#' @importFrom rlang is_null #' @importFrom cli cli_abort #' @importFrom cli cli_inform #' @importFrom cli cli_warn @@ -17,18 +29,8 @@ #' @importFrom lifecycle deprecated #' @importFrom lifecycle badge #' @importFrom lifecycle signal_stage -#' @importFrom rlang .data -#' @importFrom rlang .env -#' @importFrom rlang `%||%` -#' @importFrom rlang caller_env -#' @importFrom rlang has_length -#' @importFrom rlang is_interactive -#' @importFrom rlang check_installed -#' @importFrom rlang exec -#' @importFrom rlang env_get_list #' @importFrom sf NA_crs_ #' @importFrom sf st_bbox #' @importFrom sf st_crs ## usethis namespace: end NULL - diff --git a/R/st_bbox_ext.R b/R/st_bbox_ext.R index 8ad3beb..a2fb85d 100644 --- a/R/st_bbox_ext.R +++ b/R/st_bbox_ext.R @@ -25,7 +25,6 @@ #' @name st_bbox_ext #' @export #' @importFrom sf st_bbox -#' @importFrom purrr map st_bbox_ext <- function(x = NULL, dist = NULL, diag_ratio = NULL, @@ -35,12 +34,18 @@ st_bbox_ext <- function(x = NULL, class = "bbox", nudge = NULL, allow_null = TRUE, - list.ok = TRUE) { - if (is.null(x) && allow_null) { + allow_list = TRUE) { + check_sf(x, + allow_null = allow_null, + allow_list = allow_list, + ext = c("sf", "sfc", "bbox", "sfg", "Raster", "Extent", "numeric") + ) + + if (is.null(x) && is_true(allow_null)) { return(x) } - if (is_sf_list(x, ext = TRUE) && list.ok) { + if (is_sf_list(x, ext = TRUE) && is_true(allow_list)) { bbox_list <- map( x, @@ -87,12 +92,11 @@ st_bbox_ext <- function(x = NULL, #' @rdname st_bbox_ext #' @name st_bbox_asp #' @export -#' @importFrom purrr map st_bbox_asp <- function(x = NULL, asp = NULL, class = "bbox", - list.ok = TRUE) { - if (is_sf_list(x, ext = TRUE) && list.ok) { + allow_list = TRUE) { + if (is_sf_list(x, ext = TRUE) && is_true(allow_list)) { return( map( x, diff --git a/R/st_buffer_ext.R b/R/st_buffer_ext.R index 522e08e..53d8742 100644 --- a/R/st_buffer_ext.R +++ b/R/st_buffer_ext.R @@ -30,12 +30,11 @@ #' @param single_side If `TRUE`, single-sided buffers are returned for linear #' geometries, in which case negative dist values give buffers on the #' right-hand side, positive on the left. -#' @param list.ok If `TRUE`, allow sf list objects as an input and use +#' @param allow_list If `TRUE`, allow sf list objects as an input and use #' [purrr::map()] to apply the provided parameters to each object within the #' list to return as a new sf list object. #' @param ... additional parameters passed to [sf::st_buffer()] #' @export -#' @importFrom purrr map #' @importFrom sf st_is_longlat st_crs st_transform st_bbox st_buffer #' @importFrom units set_units drop_units st_buffer_ext <- function(x, @@ -46,9 +45,9 @@ st_buffer_ext <- function(x, end_style = NULL, join_style = NULL, single_side = FALSE, - list.ok = TRUE, + allow_list = TRUE, ...) { - if (is_sf_list(x, ext = TRUE) && list.ok) { + if (is_sf_list(x, ext = TRUE) && is_true(allow_list)) { x <- map( x, @@ -62,8 +61,6 @@ st_buffer_ext <- function(x, return(x) } - # check_sf(x, ext = TRUE) - # If bbox, convert to sfc if (is_bbox(x)) { x <- sf_bbox_to_sfc(x) @@ -75,6 +72,8 @@ st_buffer_ext <- function(x, return(x) } + check_sf(x, ext = "sfc") + # If longlat, save crs and transform to suggested crs is_lonlat <- sf::st_is_longlat(x) diff --git a/R/st_filter_ext.R b/R/st_filter_ext.R index 571f6ac..d699d9c 100644 --- a/R/st_filter_ext.R +++ b/R/st_filter_ext.R @@ -15,7 +15,7 @@ #' [sf::st_intersects()]; see details for [sf::st_filter()] for more options. #' @param type Character string passed to type argument of [sf::st_is()] #' to filter features to only those matching the specified geometry type. -#' @param list.ok If `TRUE`, x can be a list of `sf`, `sfc`, or `bbox` objects. +#' @param allow_list If `TRUE`, x can be a list of `sf`, `sfc`, or `bbox` objects. #' If `FALSE`, only `sf`, `sfc`, or `bbox` objects are supported. Defaults to #' `TRUE`. #' @inheritDotParams sf::st_filter -x -y @@ -32,16 +32,16 @@ st_filter_ext <- function(x, crs = NULL, .predicate = sf::st_intersects, type = NULL, - list.ok = TRUE, + allow_list = TRUE, ...) { - if (is.null(y)) { + if (is_null(y)) { if (!is.null(type)) { return(st_filter_geom_type(transform_sf(x, crs = crs), type = type)) } return(transform_sf(x, crs = crs)) } - if (is_sf_list(x, ext = TRUE) && list.ok) { + if (is_sf_list(x, ext = TRUE) && is_true(allow_list)) { x <- map( x, @@ -54,7 +54,7 @@ st_filter_ext <- function(x, crs = crs, .predicate = sf::st_intersects, type = type, - list.ok = list.ok + allow_list = allow_list ) ) diff --git a/R/st_misc.R b/R/st_misc.R index d4060ff..80cdd76 100644 --- a/R/st_misc.R +++ b/R/st_misc.R @@ -112,7 +112,6 @@ st_center <- function(x, #' @export #' @importFrom sf st_is_longlat st_inscribed_circle st_geometry st_dimension #' st_set_geometry -#' @importFrom purrr discard st_square <- function(x, scale = 1, rotate = 0, diff --git a/R/st_transform_ext.R b/R/st_transform_ext.R index 6866a12..206fd46 100644 --- a/R/st_transform_ext.R +++ b/R/st_transform_ext.R @@ -21,7 +21,7 @@ #' rotate must be between -45 and 45 degrees. #' @param allow_null If `TRUE` and x is `NULL` return x without an error. #' Defaults to `FALSE`. -#' @param list.ok If `TRUE`, x can be a list of `sf`, `sfc`, or `bbox` objects. +#' @param allow_list If `TRUE`, x can be a list of `sf`, `sfc`, or `bbox` objects. #' If `FALSE`, only `sf`, `sfc`, or `bbox` objects are supported. Defaults to #' `TRUE`. #' @return An `sf`, `sfc`, or `bbox` object transformed to a new coordinate @@ -35,12 +35,12 @@ st_transform_ext <- function(x, class = NULL, rotate = 0, allow_null = FALSE, - list.ok = TRUE) { + allow_list = TRUE) { if (any(c(is.data.frame(x) && !is_sf(x), is.null(x) && allow_null))) { return(x) } - check_sf(x, ext = TRUE, allow_null = allow_null, list.ok = list.ok) + check_sf(x, ext = TRUE, allow_null = allow_null, allow_list = allow_list) type <- dplyr::case_when( diff --git a/R/staticimports.R b/R/staticimports.R index fc2be95..195c706 100644 --- a/R/staticimports.R +++ b/R/staticimports.R @@ -25,7 +25,7 @@ alpha_to_int <- function(x, n = 1, quiet = TRUE, call = parent.frame()) { - check_nchar(x, n, call = call) + static_check_nchar(x, n, call = call) x[x %in% dict] <- seq_along(dict)[dict %in% x] as_integer(x, quiet) } @@ -98,7 +98,7 @@ as_numbered_labels <- function(x, if (length(cols) == 2) { num_col <- cols[2] - check_name(x, cols[1]) + static_check_name(x, cols[1]) x_col <- x[, cols[1]] } @@ -112,7 +112,7 @@ as_numbered_labels <- function(x, if (str_detect(labels, " ")) { start <- str_extract(labels, "(?<= ).+$") - check_nchar(start, n = 1) + static_check_nchar(start, n = 1) labels <- str_extract(labels, "^.+(?= )") labels <- tolower(labels) if (str_detect(start, "[A-Z]")) { @@ -173,52 +173,6 @@ as_roman <- function(x, quiet = TRUE) { utils::as.roman(x) } -#' @noRd -check_if <- function(condition, message = NULL, call = parent.frame()) { - if (isTRUE(condition)) { - return(invisible(NULL)) - } - - stop( - message, - call. = call - ) -} - -#' @noRd -check_name <- function(x, name = NULL, call = parent.frame()) { - check_if( - condition = has_all_names(x, name), - message = paste0( - "`x` must have ", plural_words("name", length(name), after = " "), name, - ", but ", combine_words(name[!(name %in% names(x))]), " are all missing." - ), - call = call - ) -} - -#' @noRd -check_nchar <- function(x, n = 1, ..., call = parent.frame()) { - num_char <- unique(nchar(x[!is.na(x)], ...)) - - message <- num_char - - if (length(num_char) > 1) { - message <- paste("a range from", min(num_char), "to", max(num_char)) - } - - message <- paste0( - "All objects in `x` must have ", n, plural_words(" character", n), - ", not ", message, "." - ) - - check_if( - condition = is.null(n) | all(n == num_char), - message = message, - call = call - ) -} - #' Combine multiple words into a single string #' #' @author Yihui Xie \email{xie@yihui.name} @@ -621,13 +575,64 @@ set_start_number <- function(x, start = NULL, labels = "arabic") { x + (start - 1) } +#' @name static_check_if +#' @rdname static_check +#' @noRd +static_check_if <- function(condition, message = NULL, call = parent.frame()) { + if (isTRUE(condition)) { + return(invisible(NULL)) + } + + stop( + message, + call. = call + ) +} + +#' @name static_check_name +#' @rdname static_check +#' @noRd +static_check_name <- function(x, name = NULL, call = parent.frame()) { + static_check_if( + condition = has_all_names(x, name), + message = paste0( + "`x` must have ", plural_words("name", length(name), after = " "), name, + ", but ", combine_words(name[!(name %in% names(x))]), " are all missing." + ), + call = call + ) +} + +#' @name static_check_nchar +#' @rdname static_check +#' @noRd +static_check_nchar <- function(x, n = 1, ..., call = parent.frame()) { + num_char <- unique(nchar(x[!is.na(x)], ...)) + + message <- num_char + + if (length(num_char) > 1) { + message <- paste("a range from", min(num_char), "to", max(num_char)) + } + + message <- paste0( + "All objects in `x` must have ", n, plural_words(" character", n), + ", not ", message, "." + ) + + static_check_if( + condition = is.null(n) | all(n == num_char), + message = message, + call = call + ) +} + #' #' @name str_add_fileext #' @rdname str_fileext -#' @param fileext File extension string #' @noRd str_add_fileext <- function(string, fileext = NULL) { - if (!is.null(fileext) & all(has_fileext(string, fileext))) { + if (is.null(fileext) || !is.null(fileext) && all(has_fileext(string, fileext))) { return(string) } @@ -635,7 +640,55 @@ str_add_fileext <- function(string, fileext = NULL) { string <- str_remove_fileext(string) } - paste0(string, ".", fileext) + str_c(string, ".", fileext) +} + +#' Join multiple strings into a single string +#' +#' Dependency-free drop-in alternative for `stringr::str_c()`. +#' +#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package. +#' +#' @param ... One or more character vectors. +#' Zero length arguments are removed. +#' Short arguments are recycled to the length of the longest. +#' +#' Like most other R functions, missing values are "infectious": +#' whenever a missing value is combined with another string +#' the result will always be missing. +#' Use `str_replace_na()` to convert `NA` to "NA" +#' +#' @param sep String to insert between input vectors. +#' +#' @param collapse +#' Optional string used to combine input vectors into single string. +#' +#' @return If `collapse = NULL` (the default) a character vector +#' with length equal to the longest input string. +#' If collapse is non-`NULL`, a character vector of length 1. +#' @noRd +str_c <- function(..., sep = "", collapse = NULL) { + stopifnot( + "`sep` must be a single string, not a character vector." = length(sep) == 1, + "`collapse` must be a single string or `NULL`, not a character vector." = + length(collapse) == 1 || is.null(collapse) + ) + + strings <- Filter(function(x) !is.null(x), list(...)) + + if (length(strings) == 0 || any(lengths(strings) == 0)) { + if (length(collapse) == 0) return(character(0)) + return("") + } + + max_length <- max(lengths(strings)) + + result <- lapply(strings, rep_len, length.out = max_length) + result <- do.call(cbind, result) + result <- apply(result, 1, paste, collapse = sep) + result <- paste(result, collapse = collapse) + + result } #' Detect the presence or absence of a pattern in a string @@ -661,17 +714,13 @@ str_add_fileext <- function(string, fileext = NULL) { #' @return A logical vector. #' @noRd str_detect <- function(string, pattern, negate = FALSE) { - is_fixed <- inherits(pattern, "fixed") - ignore.case <- isTRUE(attr(pattern, "options")$case_insensitive) + if (length(string) == 0 || length(pattern) == 0) return(logical(0)) - if (length(string) == 0 || length(pattern) == 0) { - return(logical(0)) - } + is_fixed <- inherits(pattern, "stringr_fixed") indices <- Vectorize(grep, c("pattern", "x"), USE.NAMES = FALSE)( pattern, x = string, - ignore.case = ignore.case, perl = !is_fixed, fixed = is_fixed, invert = negate @@ -705,32 +754,22 @@ str_detect <- function(string, pattern, negate = FALSE) { #' followed by one column for each capture group. #' @noRd str_extract <- function(string, pattern) { - ignore.case <- isTRUE(attr(pattern, "options")$case_insensitive) - is_fixed <- !ignore.case && inherits(pattern, "fixed") + if (length(string) == 0 || length(pattern) == 0) return(character(0)) - if (length(string) == 0 || length(pattern) == 0) { - return(character(0)) - } + is_fixed <- inherits(pattern, "stringr_fixed") result <- Map( function(string, pattern) { - if (is.na(string) || is.na(pattern)) { - return(NA_character_) - } + if (is.na(string) || is.na(pattern)) return(NA_character_) regmatches( x = string, m = regexpr( - pattern = pattern, - text = string, - ignore.case = ignore.case, - perl = !is_fixed, - fixed = is_fixed + pattern = pattern, text = string, perl = !is_fixed, fixed = is_fixed ) ) }, - string, pattern, - USE.NAMES = FALSE + string, pattern, USE.NAMES = FALSE ) result[lengths(result) == 0] <- NA_character_ @@ -744,10 +783,8 @@ str_extract_fileext <- function(string, fileext = NULL) { if (is.null(fileext)) { fileext <- "[a-zA-Z0-9]+" } - regmatches( - string, - regexpr(paste0("(?<=\\.)", fileext, "$(?!\\.)"), string, perl = TRUE) - ) + + str_extract(string, paste0("(?<=\\.)", fileext, "$(?!\\.)")) } #' Duplicate and concatenate strings within a character vector @@ -773,7 +810,9 @@ str_extract_fileext <- function(string, fileext = NULL) { #' #' @return A character vector. #' @noRd -str_pad <- function(string, width, side = c("left", "right", "both"), pad = " ", use_width = TRUE) { +str_pad <- function( + string, width, side = c("left", "right", "both"), pad = " ", use_width = TRUE +) { if (!is.numeric(width)) { return(string[NA]) } @@ -789,7 +828,8 @@ str_pad <- function(string, width, side = c("left", "right", "both"), pad = " ", pad_width <- width - string_width pad_width[pad_width < 0] <- 0 - switch(side, + switch( + side, "left" = paste0(strrep(pad, pad_width), string), "right" = paste0(string, strrep(pad, pad_width)), "both" = paste0( @@ -821,18 +861,10 @@ str_pad <- function(string, width, side = c("left", "right", "both"), pad = " ", #' @return A character vector. #' @noRd str_remove <- function(string, pattern) { - ignore.case <- isTRUE(attr(pattern, "options")$case_insensitive) - is_fixed <- !ignore.case && inherits(pattern, "fixed") - - sub <- Vectorize(sub, c("pattern", "x"), USE.NAMES = FALSE) - - sub( - pattern, - replacement = "", - x = string, - ignore.case = ignore.case, - perl = !is_fixed, - fixed = is_fixed + if (length(string) == 0 || length(pattern) == 0) return(character(0)) + is_fixed <- inherits(pattern, "stringr_fixed") + Vectorize(sub, c("pattern", "x"), USE.NAMES = FALSE)( + pattern, replacement = "", x = string, perl = !is_fixed, fixed = is_fixed ) } @@ -864,6 +896,24 @@ tosentence <- function(x) { # Imported from pkg:stringstatic # ====================================================================== +#' Control regex matching behavior +#' +#' Dependency-free drop-in alternative for `stringr::regex()`. +#' +#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package. +#' +#' @param pattern Pattern to modify behavior. +#' @param ignore_case Should case differences be ignored in the match? +#' @param multiline +#' If `TRUE`, `$` and `^` match the beginning and end of each line. +#' If `FALSE`, the default, only match the start and end of the input. +#' @param comments +#' If `TRUE`, white space and comments beginning with `#` are ignored. +#' Escape literal spaces with `\\`. +#' @param dotall If `TRUE`, `.` will also match line terminators. +#' +#' @return An integer vector. +#' @noRd regex <- function( pattern, ignore_case = FALSE, @@ -890,6 +940,28 @@ regex <- function( structure(pattern, class = c("stringr_regex", "stringr_pattern", "character")) } +#' Detect the presence or absence of a pattern in a string +#' +#' Dependency-free drop-in alternative for `stringr::str_detect()`. +#' +#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package. +#' +#' @param string Input vector. +#' Either a character vector, or something coercible to one. +#' +#' @param pattern Pattern to look for. +#' +#' The default interpretation is a regular expression, +#' as described in [base::regex]. +#' Control options with [regex()]. +#' +#' Match a fixed string (i.e. by comparing only bytes), using [fixed()]. +#' This is fast, but approximate. +#' +#' @param negate If `TRUE`, return non-matching elements. +#' +#' @return A logical vector. +#' @noRd str_detect <- function(string, pattern, negate = FALSE) { if (length(string) == 0 || length(pattern) == 0) return(logical(0)) @@ -908,6 +980,28 @@ str_detect <- function(string, pattern, negate = FALSE) { result } +#' Extract matching patterns from a string +#' +#' Dependency-free drop-in alternative for `stringr::str_extract()`. +#' +#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package. +#' +#' @param string Input vector. +#' Either a character vector, or something coercible to one. +#' +#' @param pattern Pattern to look for. +#' +#' The default interpretation is a regular expression, +#' as described in [base::regex]. +#' Control options with [regex()]. +#' +#' Match a fixed string (i.e. by comparing only bytes), using [fixed()]. +#' This is fast, but approximate. +#' +#' @return A character matrix. +#' The first column is the complete match, +#' followed by one column for each capture group. +#' @noRd str_extract <- function(string, pattern) { if (length(string) == 0 || length(pattern) == 0) return(character(0)) @@ -931,15 +1025,71 @@ str_extract <- function(string, pattern) { unlist(result) } +#' Remove matched patterns in a string +#' +#' Dependency-free drop-in alternative for `stringr::str_remove()`. +#' +#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package. +#' +#' @param string Input vector. +#' Either a character vector, or something coercible to one. +#' +#' @param pattern Pattern to look for. +#' +#' The default interpretation is a regular expression, +#' as described in [base::regex]. +#' Control options with [regex()]. +#' +#' Match a fixed string (i.e. by comparing only bytes), using [fixed()]. +#' This is fast, but approximate. +#' +#' @return A character vector. +#' @noRd str_remove <- function(string, pattern) { + if (length(string) == 0 || length(pattern) == 0) return(character(0)) is_fixed <- inherits(pattern, "stringr_fixed") Vectorize(sub, c("pattern", "x"), USE.NAMES = FALSE)( pattern, replacement = "", x = string, perl = !is_fixed, fixed = is_fixed ) } +#' Replace matched patterns in a string +#' +#' Dependency-free drop-in alternative for `stringr::str_replace()`. +#' +#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package. +#' +#' @param string Input vector. +#' Either a character vector, or something coercible to one. +#' +#' @param pattern Pattern to look for. +#' +#' The default interpretation is a regular expression, +#' as described in [base::regex]. +#' Control options with [regex()]. +#' +#' Match a fixed string (i.e. by comparing only bytes), using [fixed()]. +#' This is fast, but approximate. +#' +#' @param replacement A character vector of replacements. +#' Should be either length one, or the same length as `string` or `pattern`. +#' References of the form `\1`, `\2`, etc. will be replaced with the contents +#' of the respective matched group (created by `()`). +#' +#' To replace the complete string with `NA`, +#' use `replacement = NA_character_`. +#' +#' Using a function for `replacement` is not yet supported. +#' +#' @return A character vector. +#' @noRd str_replace <- function(string, pattern, replacement) { + if (length(string) == 0 || length(pattern) == 0 || length(replacement) == 0) { + return(character(0)) + } + is_fixed <- inherits(pattern, "stringr_fixed") + Vectorize(sub, c("pattern", "replacement", "x"), USE.NAMES = FALSE)( pattern, replacement, x = string, perl = !is_fixed, fixed = is_fixed ) diff --git a/R/utils-check.R b/R/utils-check.R index eff34f5..fb73a11 100644 --- a/R/utils-check.R +++ b/R/utils-check.R @@ -109,7 +109,7 @@ check_starts_with <- function(x = NULL, #' If x is an `sf` object invisibly return TRUE. If not, return an error with [cli::cli_abort] #' #' @inheritParams is_sf -#' @param list.ok If `TRUE`, return `TRUE` if x is an sf list or, if ext is also +#' @param allow_list If `TRUE`, return `TRUE` if x is an sf list or, if ext is also #' `TRUE`, a list of sf, sfc, or bbox objects. Defaults to `FALSE`. #' @param arg Used internally to create better error messages; defaults to #' [rlang::caller_arg]. @@ -121,24 +121,23 @@ check_starts_with <- function(x = NULL, check_sf <- function(x, arg = caller_arg(x), allow_null = FALSE, - list.ok = FALSE, + allow_list = FALSE, ext = FALSE, call = caller_env(), ...) { rlang::check_required(x, arg = arg, call = call) check_null(x, arg, allow_null) - list.ok <- list.ok && is_sf_list(x, named = FALSE, ext, allow_null) + allow_list <- is_true(allow_list) && is_sf_list(x, named = FALSE, ext, allow_null) - if (is_sf(x, ext, allow_null) || list.ok) { + if (is_sf(x, ext, allow_null) || is_true(allow_list)) { return(invisible(TRUE)) } sf <- "sf" - - if (isTRUE(ext)) { + if (is_true(ext)) { sf <- c(sf, "sfc", "bbox") - } else if (is.character(ext)) { + } else if (is_character(ext)) { sf <- c(sf, ext) } diff --git a/R/utils-is.R b/R/utils-is.R index d32f151..e2bf7ca 100644 --- a/R/utils-is.R +++ b/R/utils-is.R @@ -2,7 +2,7 @@ #' #' @noRd is_class <- function(x, classes = NULL, allow_null = FALSE) { - if (is.null(x) && allow_null) { + if (is.null(x) && isTRUE(allow_null)) { return(TRUE) } diff --git a/man/as_point.Rd b/man/as_point.Rd index aee9723..da835f8 100644 --- a/man/as_point.Rd +++ b/man/as_point.Rd @@ -58,7 +58,7 @@ vector. Using as_points: \code{\link[=as_points]{as_points()}} always returns an sfc object. The parameters are passed to -as_point using \link[purrr:map]{purrr::map} and then converted to sfc using +as_point using \code{\link[purrr:map]{purrr::map()}} and then converted to sfc using \code{\link[sf:st_as_sfc]{sf::st_as_sfc()}}. The ... parameters must include a crs, otherwise the crs will be NA for the resulting sfc object. diff --git a/man/check_sf.Rd b/man/check_sf.Rd index 0c347ec..b3c4436 100644 --- a/man/check_sf.Rd +++ b/man/check_sf.Rd @@ -8,7 +8,7 @@ check_sf( x, arg = caller_arg(x), allow_null = FALSE, - list.ok = FALSE, + allow_list = FALSE, ext = FALSE, call = caller_env(), ... @@ -22,7 +22,7 @@ check_sf( \item{allow_null}{If \code{TRUE} and x is \code{NULL}, return \code{TRUE}; defaults to \code{FALSE}.} -\item{list.ok}{If \code{TRUE}, return \code{TRUE} if x is an sf list or, if ext is also +\item{allow_list}{If \code{TRUE}, return \code{TRUE} if x is an sf list or, if ext is also \code{TRUE}, a list of sf, sfc, or bbox objects. Defaults to \code{FALSE}.} \item{ext}{If \code{TRUE}, check if x is a \code{sf}, \code{sfc}, or \code{bbox} class object or diff --git a/man/is_sf.Rd b/man/is_sf.Rd index 0fbf13c..a68b82f 100644 --- a/man/is_sf.Rd +++ b/man/is_sf.Rd @@ -13,7 +13,7 @@ \alias{is_same_crs} \title{What is the class or spatial attributes of this feature?} \usage{ -is_sf(x, ext = FALSE, allow_null = FALSE, list.ok = FALSE) +is_sf(x, ext = FALSE, allow_null = FALSE, allow_list = FALSE) is_sfg(x, allow_null = FALSE) @@ -39,7 +39,7 @@ not; defaults to \code{FALSE}. (used by \link{is_sf})} \item{allow_null}{If \code{TRUE} and x is \code{NULL}, return \code{TRUE}; defaults to \code{FALSE}.} -\item{list.ok}{If \code{TRUE}, \link{is_sf} will return TRUE if x is a list of sf objects.} +\item{allow_list}{If \code{TRUE}, \link{is_sf} will return TRUE if x is a list of sf objects.} \item{named}{If \code{TRUE}, check if sf list is named; defaults \code{FALSE}.} diff --git a/man/read_sf_exif.Rd b/man/read_sf_exif.Rd index 9a26cb2..1be2c51 100644 --- a/man/read_sf_exif.Rd +++ b/man/read_sf_exif.Rd @@ -2,14 +2,12 @@ % Please edit documentation in R/read_sf_exif.R \name{read_sf_exif} \alias{read_sf_exif} -\alias{write_exif} -\alias{write_exif_from} -\alias{write_exif_keywords} \title{Read EXIF metadata to create a simple feature object or write EXIF metadata to image files} \usage{ read_sf_exif( path = NULL, + fileext = NULL, filetype = NULL, bbox = NULL, sort = NULL, @@ -17,38 +15,14 @@ read_sf_exif( geometry = TRUE, ... ) - -write_exif( - path, - filetype = NULL, - title = NULL, - author = NULL, - date = NULL, - keywords = NULL, - description = NULL, - args = NULL, - overwrite = TRUE, - append_keywords = FALSE -) - -write_exif_from( - path, - filetype = NULL, - from, - .id = "name", - tag = "keywords", - join = NULL, - overwrite = TRUE -) } \arguments{ \item{path}{A path to folder or file.} -\item{filetype}{The file extension or file type; defaults to \code{NULL}.} +\item{fileext, filetype}{File extension or file type. filetype is used if +fileext is \code{NULL}.} -\item{bbox}{Optional bounding box to crop returned file (excluding images -with location data outside the bounding box). If bbox is provided the -returned data will match the crs of the bbox.} +\item{bbox}{Bounding box to filter by.} \item{sort}{Column name for variable to sort by passed to \code{\link[=sort_features]{sort_features()}}. Currently supports "lon", "lat", or "filename". Defaults to \code{NULL}.} @@ -56,48 +30,10 @@ Currently supports "lon", "lat", or "filename". Defaults to \code{NULL}.} \item{tags}{Optional list of EXIF tags to read from files. Must include GPS tags to create an \code{sf} object.} -\item{geometry}{If \code{TRUE} (defualt), return a simple feature object. If +\item{geometry}{If \code{TRUE} (default), return a simple feature object. If \code{FALSE}, return a data.frame.} -\item{...}{Additional EXIF tags to pass to \link[exiftoolr:exif_read]{exiftoolr::exif_read}} - -\item{title}{Title to add to file metadata with exiftoolr, Default: \code{NULL}.} - -\item{author}{Author to add to file metadata with exiftoolr, Default: \code{NULL}.} - -\item{date}{Date to add to file metadata with exiftoolr (not currently -working), Default: \code{NULL}.} - -\item{keywords}{Keyword(s) added to file metadata with with exiftoolr, -Default: \code{NULL}.} - -\item{description}{description to add to ImageDescription EXIF tag, XMP-dc -Description tag, and IPTC Caption-Abstract tag.} - -\item{args}{Alternate arguments passed to \code{\link[exiftoolr:exif_call]{exiftoolr::exif_call()}}. If args -is not \code{NULL}, title, author, date, and keywords are ignored; defaults to -\code{NULL}.} - -\item{overwrite}{If \code{TRUE}, overwrite any existing EXIF metadata present in the -provided fields; defaults to \code{TRUE}} - -\item{append_keywords}{If \code{TRUE}, append keywords to existing keywords. If -\code{FALSE} (default), replace existing keywords with the provided values.} - -\item{from}{A sf object or list of sf objects where each object has a column -with a name matching the .id parameter. The attribute value in this column -are used to assign the tag parameter to the file at the provided path based -on the spatial relationship set by join. For example, from may be boundary -data used to assign keywords based on photo locations.} - -\item{.id}{Column name in from with the values to use for tag values.} - -\item{tag}{EXIF tag to update, supported options include "keywords", "title", -or "description".} - -\item{join}{geometry predicate function; defaults to \code{NULL}, set to -\link[sf:geos_binary_pred]{sf::st_intersects} if from contains only POLYGON or MULTIPOLYGON objects -or \link[sf:st_nearest_feature]{sf::st_nearest_feature} if from contains other types.} +\item{...}{Additional EXIF tags to pass to \code{\link[exiftoolr:exif_read]{exiftoolr::exif_read()}}} } \description{ \code{read_sf_exif()} read EXIF data from folder of files and, geometry is \code{TRUE} diff --git a/man/read_sf_ext.Rd b/man/read_sf_ext.Rd index 345ffb2..fcf553c 100644 --- a/man/read_sf_ext.Rd +++ b/man/read_sf_ext.Rd @@ -23,6 +23,7 @@ read_sf_pkg( data, bbox = NULL, package = NULL, + pkg = NULL, fileext = "gpkg", filetype = NULL, ... @@ -140,7 +141,8 @@ read_sf_gsheet( \item{bbox}{A bounding box object; defaults to \code{NULL}. If \code{"bbox"} is provided, only returns features intersecting the bounding box.} -\item{package}{Package name; used by \code{\link[=read_sf_pkg]{read_sf_pkg()}} only.} +\item{package, pkg}{Package name; used by \code{\link[=read_sf_pkg]{read_sf_pkg()}} only. pkg is used if +package is \code{NULL}.} \item{fileext}{File type or extension. Optional if filename or path include a file extension.} diff --git a/man/st_bbox_ext.Rd b/man/st_bbox_ext.Rd index bbe698d..f77d160 100644 --- a/man/st_bbox_ext.Rd +++ b/man/st_bbox_ext.Rd @@ -16,10 +16,10 @@ st_bbox_ext( class = "bbox", nudge = NULL, allow_null = TRUE, - list.ok = TRUE + allow_list = TRUE ) -st_bbox_asp(x = NULL, asp = NULL, class = "bbox", list.ok = TRUE) +st_bbox_asp(x = NULL, asp = NULL, class = "bbox", allow_list = TRUE) } \arguments{ \item{x}{An object \code{sf}, \code{bbox}, \code{sfc}, \code{raster}, or \code{sp} object or a @@ -53,7 +53,7 @@ vector or sf object.} \item{allow_null}{If \code{TRUE} and x is \code{NULL}, return \code{NULL}.} -\item{list.ok}{If \code{TRUE}, allow sf list objects as an input and use +\item{allow_list}{If \code{TRUE}, allow sf list objects as an input and use \code{\link[purrr:map]{purrr::map()}} to apply the provided parameters to each object within the list to return as a new sf list object.} } diff --git a/man/st_buffer_ext.Rd b/man/st_buffer_ext.Rd index c62d029..21ea373 100644 --- a/man/st_buffer_ext.Rd +++ b/man/st_buffer_ext.Rd @@ -14,7 +14,7 @@ st_buffer_ext( end_style = NULL, join_style = NULL, single_side = FALSE, - list.ok = TRUE, + allow_list = TRUE, ... ) @@ -49,7 +49,7 @@ joinStyle parameter of \code{\link[sf:geos_unary]{sf::st_buffer()}}.} geometries, in which case negative dist values give buffers on the right-hand side, positive on the left.} -\item{list.ok}{If \code{TRUE}, allow sf list objects as an input and use +\item{allow_list}{If \code{TRUE}, allow sf list objects as an input and use \code{\link[purrr:map]{purrr::map()}} to apply the provided parameters to each object within the list to return as a new sf list object.} diff --git a/man/st_filter_ext.Rd b/man/st_filter_ext.Rd index 5be54db..2086b16 100644 --- a/man/st_filter_ext.Rd +++ b/man/st_filter_ext.Rd @@ -14,7 +14,7 @@ st_filter_ext( crs = NULL, .predicate = sf::st_intersects, type = NULL, - list.ok = TRUE, + allow_list = TRUE, ... ) @@ -38,7 +38,7 @@ ignored.} \item{type}{Geometry type.} -\item{list.ok}{If \code{TRUE}, x can be a list of \code{sf}, \code{sfc}, or \code{bbox} objects. +\item{allow_list}{If \code{TRUE}, x can be a list of \code{sf}, \code{sfc}, or \code{bbox} objects. If \code{FALSE}, only \code{sf}, \code{sfc}, or \code{bbox} objects are supported. Defaults to \code{TRUE}.} diff --git a/man/st_make_grid_ext.Rd b/man/st_make_grid_ext.Rd index 2f2dda0..6c10c71 100644 --- a/man/st_make_grid_ext.Rd +++ b/man/st_make_grid_ext.Rd @@ -35,7 +35,7 @@ vector or sf object.} buffer distance. e.g. if the diagonal distance is 3000 meters and the "diag_ratio = 0.1" a 300 meter will be used. Ignored when \code{dist} is provided.} - \item{\code{list.ok}}{If \code{TRUE}, allow sf list objects as an input and use + \item{\code{allow_list}}{If \code{TRUE}, allow sf list objects as an input and use \code{\link[purrr:map]{purrr::map()}} to apply the provided parameters to each object within the list to return as a new sf list object.} \item{\code{asp}}{Aspect ratio of width to height as a numeric value (e.g. 0.33) or diff --git a/man/st_transform_ext.Rd b/man/st_transform_ext.Rd index e4de4e5..95cd79f 100644 --- a/man/st_transform_ext.Rd +++ b/man/st_transform_ext.Rd @@ -12,7 +12,7 @@ st_transform_ext( class = NULL, rotate = 0, allow_null = FALSE, - list.ok = TRUE + allow_list = TRUE ) st_omerc(x, rotate = 0) @@ -36,7 +36,7 @@ rotate must be between -45 and 45 degrees.} \item{allow_null}{If \code{TRUE} and x is \code{NULL} return x without an error. Defaults to \code{FALSE}.} -\item{list.ok}{If \code{TRUE}, x can be a list of \code{sf}, \code{sfc}, or \code{bbox} objects. +\item{allow_list}{If \code{TRUE}, x can be a list of \code{sf}, \code{sfc}, or \code{bbox} objects. If \code{FALSE}, only \code{sf}, \code{sfc}, or \code{bbox} objects are supported. Defaults to \code{TRUE}.} } diff --git a/man/write_exif_from.Rd b/man/write_exif_from.Rd new file mode 100644 index 0000000..e8f0bf6 --- /dev/null +++ b/man/write_exif_from.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_sf_exif.R +\name{write_exif_from} +\alias{write_exif_from} +\alias{write_exif_keywords} +\title{Write EXIF data for photos on spatial join with a sf object or list of sf objects} +\usage{ +write_exif_from( + path, + fileext = NULL, + filetype = NULL, + from, + .id = "name", + tag = "keywords", + join = NULL, + overwrite = TRUE +) +} +\arguments{ +\item{path}{A path to folder or file.} + +\item{fileext, filetype}{File extension or file type. filetype is used if +fileext is \code{NULL}.} + +\item{from}{A sf object or list of sf objects where each object has a column +with a name matching the .id parameter. The attribute value in this column +are used to assign the tag parameter to the file at the provided path based +on the spatial relationship set by join. For example, from may be boundary +data used to assign keywords based on photo locations.} + +\item{.id}{Column name in from with the values to use for tag values.} + +\item{tag}{EXIF tag to update, supported options include "keywords", "title", +or "description".} + +\item{join}{geometry predicate function; defaults to \code{NULL}, set to +\link[sf:geos_binary_pred]{sf::st_intersects} if from contains only POLYGON or MULTIPOLYGON objects +or \link[sf:st_nearest_feature]{sf::st_nearest_feature} if from contains other types.} + +\item{overwrite}{If \code{TRUE}, overwrite any existing EXIF metadata present in +the provided fields; defaults to \code{TRUE}} +} +\description{ +Extends \code{\link[=read_sf_exif]{read_sf_exif()}} and \code{\link[filenamr:read_exif]{filenamr::write_exif()}} +}