diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index a3ac618..562fe0f 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -4,9 +4,10 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] -name: R-CMD-check +name: R-CMD-check.yaml + +permissions: read-all jobs: R-CMD-check: @@ -29,7 +30,7 @@ jobs: R_KEEP_PKG_SOURCE: yes steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-pandoc@v2 @@ -47,3 +48,4 @@ jobs: - uses: r-lib/actions/check-r-package@v2 with: upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/R/blackmarbler.R b/R/blackmarbler.R index 73431a1..b361281 100644 --- a/R/blackmarbler.R +++ b/R/blackmarbler.R @@ -760,131 +760,131 @@ bm_extract <- function(roi_sf, # Download data -------------------------------------------------------------- r_list <- lapply(date, function(date_i){ - #out <- tryCatch( - # { - - #### Make name for raster based on date - date_name_i <- define_date_name(date_i, product_id) - - #### If save to file - if(output_location_type == "file"){ - - out_name_end <- paste0("_", date_name_i, ".Rds") - out_name <- paste0(out_name_begin, out_name_end) - out_path <- file.path(file_dir, out_name) - - make_raster <- TRUE - if(file_skip_if_exists & file.exists(out_path)) make_raster <- FALSE - - if(make_raster){ + out <- tryCatch( + { - #### Make raster - r <- bm_raster_i(roi_sf = roi_sf, - product_id = product_id, - date = date_i, - bearer = bearer, - variable = variable, - quality_flag_rm = quality_flag_rm, - check_all_tiles_exist = check_all_tiles_exist, - h5_dir = h5_dir, - quiet = quiet, - temp_dir = temp_dir) - names(r) <- date_name_i + #### Make name for raster based on date + date_name_i <- define_date_name(date_i, product_id) - #### Extract - r_agg <- exact_extract(x = r, y = roi_sf, fun = aggregation_fun, - progress = !quiet) - roi_df <- roi_sf - roi_df$geometry <- NULL - - if(length(aggregation_fun) > 1){ - names(r_agg) <- paste0("ntl_", names(r_agg)) - r_agg <- bind_cols(r_agg, roi_df) + #### If save to file + if(output_location_type == "file"){ + + out_name_end <- paste0("_", date_name_i, ".Rds") + out_name <- paste0(out_name_begin, out_name_end) + out_path <- file.path(file_dir, out_name) + + make_raster <- TRUE + if(file_skip_if_exists & file.exists(out_path)) make_raster <- FALSE + + if(make_raster){ + + #### Make raster + r <- bm_raster_i(roi_sf = roi_sf, + product_id = product_id, + date = date_i, + bearer = bearer, + variable = variable, + quality_flag_rm = quality_flag_rm, + check_all_tiles_exist = check_all_tiles_exist, + h5_dir = h5_dir, + quiet = quiet, + temp_dir = temp_dir) + names(r) <- date_name_i + + #### Extract + r_agg <- exact_extract(x = r, y = roi_sf, fun = aggregation_fun, + progress = !quiet) + roi_df <- roi_sf + roi_df$geometry <- NULL + + if(length(aggregation_fun) > 1){ + names(r_agg) <- paste0("ntl_", names(r_agg)) + r_agg <- bind_cols(r_agg, roi_df) + } else{ + roi_df[[paste0("ntl_", aggregation_fun)]] <- r_agg + r_agg <- roi_df + } + + if(add_n_pixels){ + + r_n_obs <- exact_extract(r, roi_sf, function(values, coverage_fraction) + sum(!is.na(values)), + progress = !quiet) + + r_n_obs_poss <- exact_extract(r, roi_sf, function(values, coverage_fraction) + length(values), + progress = !quiet) + + r_agg$n_pixels <- r_n_obs_poss + r_agg$n_non_na_pixels <- r_n_obs + r_agg$prop_non_na_pixels <- r_agg$n_non_na_pixels / r_agg$n_pixels + } + + r_agg$date <- date_i + + #### Export + saveRDS(r_agg, out_path) + + } else{ + warning(paste0('"', out_path, '" already exists; skipping.\n')) + } + + r_out <- NULL # Saving as file, so output from function should be NULL + } else{ - roi_df[[paste0("ntl_", aggregation_fun)]] <- r_agg - r_agg <- roi_df - } - - if(add_n_pixels){ + r_out <- bm_raster_i(roi_sf = roi_sf, + product_id = product_id, + date = date_i, + bearer = bearer, + variable = variable, + quality_flag_rm = quality_flag_rm, + check_all_tiles_exist = check_all_tiles_exist, + h5_dir = h5_dir, + quiet = quiet, + temp_dir = temp_dir) + names(r_out) <- date_name_i + + if(add_n_pixels){ + + r_n_obs <- exact_extract(r_out, roi_sf, function(values, coverage_fraction) + sum(!is.na(values)), + progress = !quiet) + + r_n_obs_poss <- exact_extract(r_out, roi_sf, function(values, coverage_fraction) + length(values), + progress = !quiet) + + roi_sf$n_pixels <- r_n_obs_poss + roi_sf$n_non_na_pixels <- r_n_obs + roi_sf$prop_non_na_pixels <- roi_sf$n_non_na_pixels / roi_sf$n_pixels + } + + r_out <- exact_extract(x = r_out, y = roi_sf, fun = aggregation_fun, + progress = !quiet) - r_n_obs <- exact_extract(r, roi_sf, function(values, coverage_fraction) - sum(!is.na(values)), - progress = !quiet) + roi_df <- roi_sf + roi_df$geometry <- NULL - r_n_obs_poss <- exact_extract(r, roi_sf, function(values, coverage_fraction) - length(values), - progress = !quiet) + if(length(aggregation_fun) > 1){ + names(r_out) <- paste0("ntl_", names(r_out)) + r_out <- bind_cols(r_out, roi_df) + } else{ + + roi_df[[paste0("ntl_", aggregation_fun)]] <- r_out + r_out <- roi_df + } - r_agg$n_pixels <- r_n_obs_poss - r_agg$n_non_na_pixels <- r_n_obs - r_agg$prop_non_na_pixels <- r_agg$n_non_na_pixels / r_agg$n_pixels + r_out$date <- date_i } - r_agg$date <- date_i + return(r_out) - #### Export - saveRDS(r_agg, out_path) - - } else{ - warning(paste0('"', out_path, '" already exists; skipping.\n')) + # HERE + }, + error=function(e) { + return(NULL) } - - r_out <- NULL # Saving as file, so output from function should be NULL - - } else{ - r_out <- bm_raster_i(roi_sf = roi_sf, - product_id = product_id, - date = date_i, - bearer = bearer, - variable = variable, - quality_flag_rm = quality_flag_rm, - check_all_tiles_exist = check_all_tiles_exist, - h5_dir = h5_dir, - quiet = quiet, - temp_dir = temp_dir) - names(r_out) <- date_name_i - - if(add_n_pixels){ - - r_n_obs <- exact_extract(r_out, roi_sf, function(values, coverage_fraction) - sum(!is.na(values)), - progress = !quiet) - - r_n_obs_poss <- exact_extract(r_out, roi_sf, function(values, coverage_fraction) - length(values), - progress = !quiet) - - roi_sf$n_pixels <- r_n_obs_poss - roi_sf$n_non_na_pixels <- r_n_obs - roi_sf$prop_non_na_pixels <- roi_sf$n_non_na_pixels / roi_sf$n_pixels - } - - r_out <- exact_extract(x = r_out, y = roi_sf, fun = aggregation_fun, - progress = !quiet) - - roi_df <- roi_sf - roi_df$geometry <- NULL - - if(length(aggregation_fun) > 1){ - names(r_out) <- paste0("ntl_", names(r_out)) - r_out <- bind_cols(r_out, roi_df) - } else{ - - roi_df[[paste0("ntl_", aggregation_fun)]] <- r_out - r_out <- roi_df - } - - r_out$date <- date_i - } - - return(r_out) - - ## HERE - # }, - # error=function(e) { - # return(NULL) - # } - #) + ) }) diff --git a/README.md b/README.md index 6f25da3..d18b5ce 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ [![GitHub Repo stars](https://img.shields.io/github/stars/worldbank/blackmarbler)](https://github.com/worldbank/blackmarbler) [![activity](https://img.shields.io/github/commit-activity/m/worldbank/blackmarbler)](https://github.com/worldbank/blackmarbler/graphs/commit-activity) [![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/license/mit) - +[![R-CMD-check](https://github.com/worldbank/blackmarbler/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/worldbank/blackmarbler/actions/workflows/R-CMD-check.yaml) **BlackMarbleR** is a R package that provides a simple way to use nighttime lights data from NASA's Black Marble. [Black Marble](https://blackmarble.gsfc.nasa.gov) is a [NASA Earth Science Data Systems (ESDS)](https://www.earthdata.nasa.gov) project that provides a product suite of daily, monthly and yearly global [nighttime lights](https://www.earthdata.nasa.gov/topics/human-dimensions/nighttime-lights). This package automates the process of downloading all relevant tiles from the [NASA LAADS DAAC](https://ladsweb.modaps.eosdis.nasa.gov/) to cover a region of interest, converting and mosaicing the raw files (in HDF5 format) to georeferenced rasters. @@ -336,6 +336,6 @@ If `output_location_type = "file"`, the following arguments can be used: For more information on NASA Black Marble, see: -* [Academic paper](https://pdf.sciencedirectassets.com/271745/1-s2.0-S0034425718X00054/1-s2.0-S003442571830110X/am.pdf?X-Amz-Security-Token=IQoJb3JpZ2luX2VjEHEaCXVzLWVhc3QtMSJIMEYCIQDArjfr5uSMpM5mQ3cJsNon%2FoLp8Ja8Y9fMXzOKSRTPzwIhAOiZ1vPs4kAYZsWYZF%2BLDQnpqWROIr65WPpEx4AuIVfxKrMFCBkQBRoMMDU5MDAzNTQ2ODY1IgxhyDy7tYJXVUSG9VEqkAWtazYKcwJfrw5bEYNUT7kQyaPJeqsd3Ez33YZAXD9WQ7q8Grsa8xhgfTxwCoPe4fSkxY3juJejdDsEtaXCGWwI6ZOpPstQE29Nkf1fUKBcLPEC0v0Gp5EqPFqJv89HvSYRXEIioqky%2BhAlR0QoVcTsy95v%2BATl%2BY4xIsOpbiRg%2F7nCNx7BGFETK50lsmMUjFeIOVQ8MqBICtUvHbvBl5Xf0Q5cho4Kczji79oo0aTvF35jIl9W0DSuaPpn4Gl%2B2MjwO39Y%2Bt51c9bFe%2F09Ze2drSqzg5i1iT1%2FAPqCcwT4W4FEqg2juiFLOvzXkM404u7J7yFAOnwHi6zg0z97Et77Ucm%2FE6f4%2Fwz9u2A9m9i84d9g2IvLUn9QL22A4QvoFjr5Nc%2BUQTV7j7pyICduk0Bb9gR%2BQrKv%2FRBgaUbgxD8bxM7GLkH0QqBBNVqRctmAIh2x%2F6dEhfXDw08wpnt2sNgH65NvCFQKvQZslo65aZ%2F42qieqs2UvJWycgpAbz6ZczMHN8%2FwjAkQnBF15BZkC2AsW5Xs%2BtXc3%2Fn2rU6TIkGfituf%2B%2F6mtpN1J4migVO6zbV5v2eUFyl26xilNaHV9m0Fse9lD41oQ8Nd3OdrL1fgtGvEzNDjD9tX15B4vZaPqgttfZa0UfFB6pgN1hh4aca0WCwjOgYQzA2Zcaq9RFfeDFNimIqS%2FO78lGzrfQL02ZxfL1E3uOFhD4G4TLoSXU258ik6JUxgy5t91JTHqLL5WlRmp5Q2XdA6g3yj%2F1qnAzz%2FjSXNH8moYEo6vM5MKodUmfIyQos2QChiD65bv0OJi%2BaGM%2Fquenhrkzq4OCtgR7tKDS%2FIxu%2FgdjdzHqlJghx4h9MirQR%2FXacQsbZ0VZMF4DCHx5K6BjqwAe1jQA%2Bu5VqWcrWNf%2BdW%2FFYNxIIiThd22VDZwtwWmgw62g7FaUA%2Bfm7p9MQiXFgVKumiGWuUS6HjUwdpMHU5xZ2M4FW%2FTV8eaIi8jqUwxNyBDdwrMi%2FvlfODzC8xRppZKPflzolxf5doSsEZxcaBVGfmoaep0rK4fYVssKhc3uLbHXSpnxyZqntTv78MXsp1wglcdKj9AIji4RUWDVCyNQaaeXAG8XXF%2BxaY2q5fNyml&X-Amz-Algorithm=AWS4-HMAC-SHA256&X-Amz-Date=20241125T172622Z&X-Amz-SignedHeaders=host&X-Amz-Expires=300&X-Amz-Credential=ASIAQ3PHCVTYWHTYLA6J%2F20241125%2Fus-east-1%2Fs3%2Faws4_request&X-Amz-Signature=6703c42a66a14f6bd39b67e40a399f11da2e87467a341381b25853a27127de05&hash=859f116b3c45db6bb47bfc9cc540cc3176dce2b2017448034740575ee68d2ca5&host=68042c943591013ac2b2430a89b270f6af2c76d8dfd086a07176afe7c76c2c61&pii=S003442571830110X&tid=pdf-ac1c6031-531b-4e32-b9e2-9038901e496b&sid=e4ed55ea7138924ddf8b61e7e34b10874ac3gxrqa&type=client) +* [Academic paper](https://doi.org/10.1016/j.rse.2018.03.017) * [Substack Post](https://www.spatialedge.co/p/not-all-nightlight-datasets-are-the) * [Webinar](https://appliedsciences.nasa.gov/get-involved/training/english/arset-introduction-nasas-black-marble-night-lights-data) diff --git a/man/bm_extract.Rd b/man/bm_extract.Rd index 011ba2c..08ff91d 100644 --- a/man/bm_extract.Rd +++ b/man/bm_extract.Rd @@ -59,7 +59,7 @@ For information on other variable choices, see \href{https://ladsweb.modaps.eosd \item{quality_flag_rm}{Quality flag values to use to set values to \code{NA}. Each pixel has a quality flag value, where low quality values can be removed. Values are set to \code{NA} for each value in the \code{quality_flag_rm} vector. Note that \code{quality_flag_rm} does not apply for \code{VNP46A1}. (Default: \code{NULL}). -For \code{VNP46A1} and \code{VNP46A2} (daily data): +For \code{VNP46A2} (daily data): \itemize{ \item \code{0}: High-quality, Persistent nighttime lights \item \code{1}: High-quality, Ephemeral nighttime Lights diff --git a/man/bm_raster.Rd b/man/bm_raster.Rd index f1237cf..36406e1 100644 --- a/man/bm_raster.Rd +++ b/man/bm_raster.Rd @@ -53,7 +53,7 @@ For information on other variable choices, see \href{https://ladsweb.modaps.eosd \item{quality_flag_rm}{Quality flag values to use to set values to \code{NA}. Each pixel has a quality flag value, where low quality values can be removed. Values are set to \code{NA} for each value in the \code{quality_flag_rm} vector. Note that \code{quality_flag_rm} does not apply for \code{VNP46A1}. (Default: \code{NULL}). -For \code{VNP46A1} and \code{VNP46A2} (daily data): +For \code{VNP46A2} (daily data): \itemize{ \item \code{0}: High-quality, Persistent nighttime lights \item \code{1}: High-quality, Ephemeral nighttime Lights diff --git a/readme_figures/testing.R b/readme_figures/testing.R index 4545a14..3727dcd 100644 --- a/readme_figures/testing.R +++ b/readme_figures/testing.R @@ -1,5 +1,20 @@ # Testing +#### Basic +library(blackmarbler) +library(sf) +bearer <- read.csv("~/Dropbox/bearer_bm.csv")$token + +roi_sf <- data.frame(lat = -1.943889, lon = 30.059444, id = 1) |> + st_as_sf(coords = c("lon", "lat"), + crs = 4326) |> + st_buffer(dist = 20000) + +r_20210205 <- bm_raster(roi_sf = roi_sf, + product_id = "VNP46A3", + date = "2021-02-05", + bearer = bearer) + library(readr) library(hdf5r) library(dplyr) diff --git a/vignettes/assess-quality.Rmd b/vignettes/assess-quality.Rmd index 39707b5..f61f797 100644 --- a/vignettes/assess-quality.Rmd +++ b/vignettes/assess-quality.Rmd @@ -64,7 +64,8 @@ bearer <- "BEARER-TOKEN-HERE" ```{r bearer, include = FALSE} #bearer <- read.csv("~/Desktop/bearer_bm.csv")$token -bearer <- read.csv("https://www.dropbox.com/scl/fi/pipze9nvak5qo7pedvwb4/bearer_bm.csv?rlkey=bkpv62s657c5w9jbchpg2vvr7&dl=1")$token +bearer <- read.csv("https://www.dropbox.com/scl/fi/u8ixf74zxqfkwn2trv2ty/bearer_bm.csv?rlkey=zbvco8rarlzedil9kw5ybkkou&st=23me404b&dl=1")$token +#bearer <- Sys.getenv("BEARER_NASA_TOKEN") ``` ```{r}