Skip to content

Commit

Permalink
Test fix
Browse files Browse the repository at this point in the history
- check_bbox no longer accepts numeric reference
- multiraster test
  • Loading branch information
Insang Song committed Dec 15, 2023
1 parent 7c0870f commit 57a3e5e
Show file tree
Hide file tree
Showing 10 changed files with 357 additions and 172 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -32,4 +32,4 @@ Suggests:
withr
Config/testthat/edition: 3
LitrVersionUsed: 0.9.0
LitrId: 1e61aeed84e5dbe3049b68162b45eb9f
LitrId: 7257094bb3467e9ae0dc2cb267c95b4a
3 changes: 0 additions & 3 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -40,9 +40,6 @@ importFrom(dplyr,ungroup)
importFrom(dplyr,where)
importFrom(exactextractr,exact_extract)
importFrom(future.apply,future_lapply)
importFrom(igraph,components)
importFrom(igraph,graph_from_edgelist)
importFrom(igraph,mst)
importFrom(methods,is)
importFrom(rlang,`!!!`)
importFrom(rlang,inject)
Expand Down
46 changes: 10 additions & 36 deletions R/check.R
Original file line number Diff line number Diff line change
Expand Up @@ -46,10 +46,7 @@ check_crs_align <-
Please refer to epsg.io and ?sf::st_crs or ?terra::crs.\n")
}
check_crs_sf <- function(input, crs_standard) {
if (is.na(sf::st_crs(input)) || is.null(sf::st_crs(input))) {
stop('Please check the coordinate system or
its EPSG code of your input object.')
}
invisible(check_crs(input))
input_crs <- sf::st_crs(input)$epsg
standard_crs <- sf::st_crs(crs_standard)$epsg
if (input_crs == standard_crs) {
Expand All @@ -61,10 +58,7 @@ check_crs_align <-
}

check_crs_terra <- function(input, crs_standard) {
if (is.na(terra::crs(input)) || is.null(terra::crs(input))) {
stop('Please check the coordinate system or
its EPSG code of your input object.')
}
invisible(check_crs(input))
input_crs <- terra::crs(input, describe = TRUE)$code
standard_crs <- terra::crs(crs_standard, describe = TRUE)$code
if (input_crs == standard_crs) {
Expand Down Expand Up @@ -138,46 +132,26 @@ extent_to_polygon <- function(
#' This function will return TRUE if the reference region
#' completely contains your data's extent and FALSE otherwise.
#' @param data_query sf*/stars/SpatVector/SpatRaster object.
#' @param reference sf*/stars/SpatVector/SpatRaster object or
#' a named numeric vector with four names (xmin, ymin, xmax, and ymax).
#' @param reference_crs Well-known-text-formatted or
#' EPSG code of the reference's coordinate system.
#' Only required when a named numeric vector is passed to reference.
#' @param reference sf*/stars/SpatVector/SpatRaster object
#' @return TRUE (the queried data extent is completely within
#' the reference bounding box) or FALSE
#' @author Insang Song \email{geoissong@@gmail.com}
#'
#' @export
check_bbox <- function(
data_query,
reference,
reference_crs = NULL
reference
) {
if (is.numeric(reference) && is.null(reference_crs)) {
stop("CRS should be entered when the reference extent is a vector.\n")
}
if (is.numeric(reference) && !is.null(reference_crs)) {
reference <- sf::st_as_sfc(sf::st_bbox(reference), crs = reference_crs)
}
query_crs <- check_crs(data_query)
reference <- sf::st_as_sfc(sf::st_bbox(reference))
print(sf::st_crs(reference))
# invisible check data_query CRS check
invisible(check_crs(data_query))

ref_crs <- check_crs(reference)
if (is.null(reference_crs)) {
reference <-
sf::st_as_sfc(
sf::st_bbox(reference),
crs = ref_crs
)
}
if (is.na(query_crs) || is.null(query_crs)) {
stop("The dataset you queried has no CRS.
Please make sure your dataset has the correct CRS.\n")
}
data_query_bb <-
sf::st_as_sfc(sf::st_bbox(data_query),
crs = sf::st_crs(data_query))

query_matched <- sf::st_transform(data_query_bb, sf::st_crs(ref_crs))
print(sf::st_crs(data_query_bb))
query_matched <- sf::st_transform(data_query_bb, sf::st_crs(reference))
check_result <- as.logical(unlist(sf::st_within(query_matched, reference)))
return(check_result)
}
Expand Down
3 changes: 0 additions & 3 deletions R/interpret_computational_domain.R
Original file line number Diff line number Diff line change
Expand Up @@ -158,9 +158,6 @@ sp_index_grid <-
#' # dg_merged <- grid_merge(sf::st_as_sf(sss), dgs, 100)
#'
#' #### NOT RUN ####
#' @importFrom igraph graph_from_edgelist
#' @importFrom igraph mst
#' @importFrom igraph components
#' @importFrom dplyr group_by
#' @importFrom dplyr summarize
#' @importFrom dplyr ungroup
Expand Down
23 changes: 11 additions & 12 deletions R/scale_process.R
Original file line number Diff line number Diff line change
Expand Up @@ -57,8 +57,11 @@ distribute_process_grid <-
if (is.character(grid_target_id) && !grepl(":", grid_target_id)) {
stop("Character grid_target_id should be in a form of 'startid:endid'.\n")
}
if (is.numeric(grid_target_id) && length(grid_target_id) != 2) {
stop("Numeric grid_target_id should be in a form of c(startid, endid).\n")
if (is.numeric(grid_target_id)) {
if (length(grid_target_id) != 2) {
stop("Numeric grid_target_id should be in a form of c(startid, endid).\n")
}
grid_target_ids <- unique(grids$original[["CGRIDID"]])[grid_target_id]

Check warning on line 64 in R/scale_process.R

View check run for this annotation

Codecov / codecov/patch

R/scale_process.R#L64

Added line #L64 was not covered by tests
}
# subset using grids and grid_id
if (is.null(grid_target_id)) {
Expand All @@ -70,16 +73,13 @@ distribute_process_grid <-
c(which(unique(grids$original[["CGRIDID"]]) == grid_id_parsed[1]),
which(unique(grids$original[["CGRIDID"]]) == grid_id_parsed[2]))
}
if (is.numeric(grid_target_id)) {
grid_target_ids <- unique(grids$original[["CGRIDID"]])[grid_target_id]
}

par_fun <- list(...)
detected_id <- grep("^id", names(par_fun), value = TRUE)
detected_id <- par_fun[[detected_id]]
if (is.null(detected_id)) {
detected_id <- "ID"
}
# detected_point <- grep("^(points|poly)", names(par_fun), value = TRUE)

grids_target <-
grids$original[grid_target_ids %in% unlist(grids$original[["CGRIDID"]]), ]
Expand All @@ -91,8 +91,6 @@ distribute_process_grid <-
sf::sf_use_s2(FALSE)

run_result <- tryCatch({
## TODO:
## parse function arguments
args_input <- list(...)
# args_fun <- formals(fun_dist)
## Strongly assuming that
Expand Down Expand Up @@ -195,7 +193,7 @@ distribute_process_hierarchy <-
split_level,
unlist(regions[[split_level]]))

regions_list <- base::split(regions, split_level)
regions_list <- base::split(split_level, split_level)

results_distributed <-
future_lapply(
Expand All @@ -205,6 +203,7 @@ distribute_process_hierarchy <-
run_result <-
tryCatch(
{
subregion <- regions[startsWith(split_level, subregion), ]
args_input <- list(...)
## Strongly assuming that
# the first is "at", the second is "from"
Expand Down Expand Up @@ -293,12 +292,12 @@ distribute_process_multirasters <- function(
run_result <-
tryCatch({
args_input <- list(...)
vect_target_tr <- rast_short(args_input, "SpatVector")
vect_target_sf <- rast_short(args_input, "sf")
vect_target_tr <- detect_class(args_input, "SpatVector")
vect_target_sf <- detect_class(args_input, "sf")
vect_target <- (vect_target_tr | vect_target_sf)
vect_ext <- terra::ext(args_input[vect_target][[1]])

rast_target <- rast_short(args_input, "SpatRaster")
rast_target <- detect_class(args_input, "SpatRaster")

args_input[rast_target] <- rast_short(path, win = vect_ext)

Expand Down
9 changes: 2 additions & 7 deletions man/check_bbox.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading

0 comments on commit 57a3e5e

Please sign in to comment.