From 701a58adb09aca2742a4b15f9dcd3b421c89cfe4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mateusz=20=C5=BB=C3=B3=C5=82tak?= Date: Thu, 3 Jan 2019 14:20:29 +0100 Subject: [PATCH] Major cleaning: * Credentials moved from R's options to package internal environment. Doesn't really protect them but at least makes them less visible. * Obsolete spatial objects related functions removed. * spat2jgeom rewritten using rgdal::writeOGR * More tests * Code formatting sanitizing in progress --- .travis.yml | 2 +- DESCRIPTION | 3 +- R/S2_buy_granule.R | 77 ++++++-------- R/S2_check_access.R | 64 +++++------- R/S2_do_query.R | 5 +- R/S2_generate_RGB.R | 143 +++++++++++++------------- R/S2_initialize_user.R | 21 ++-- R/S2_put_ROI.R | 63 ++++++------ R/S2_user_info.R | 17 +-- R/buy_check.R | 12 +-- R/jgeom_to_SpatialPolygons.R | 81 --------------- R/roi2jgeom.R | 35 +++++++ R/roi_to_jgeom.R | 42 -------- R/spat2jgeom.R | 30 ++++++ R/spat_to_jgeom.R | 48 --------- R/xy_to_jgeom.R | 46 --------- R/zzz.R | 10 -- man/S2_buy_granule.Rd | 10 +- tests/testthat/test-S2_generate_RGB.R | 12 +++ tests/testthat/test-S2_query.R | 40 ------- tests/testthat/test-credentials.R | 23 +++++ tests/testthat/test-downloads.R | 40 +++++++ 22 files changed, 340 insertions(+), 484 deletions(-) delete mode 100644 R/jgeom_to_SpatialPolygons.R create mode 100644 R/roi2jgeom.R delete mode 100644 R/roi_to_jgeom.R create mode 100644 R/spat2jgeom.R delete mode 100644 R/spat_to_jgeom.R delete mode 100644 R/xy_to_jgeom.R delete mode 100644 R/zzz.R create mode 100644 tests/testthat/test-S2_generate_RGB.R create mode 100644 tests/testthat/test-credentials.R create mode 100644 tests/testthat/test-downloads.R diff --git a/.travis.yml b/.travis.yml index 0960497..ce04a95 100644 --- a/.travis.yml +++ b/.travis.yml @@ -23,4 +23,4 @@ after_success: notifications: email: - zozlak@zozlak.org - - sebastian.boeck@boku.ac.at +# - sebastian.boeck@boku.ac.at diff --git a/DESCRIPTION b/DESCRIPTION index 1982a72..cc2bb5f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: sentinel2 Title: Tools to access Sentinel-2 data pre-processed by IVFL, BOKU Vienna -Version: 0.3.1 +Version: 0.4.0 Authors@R: c( person("Sebastian", "Boeck", email = "sebastian.boeck@boku.ac.at", role = c("aut", "cre")), person("Mateusz", "Zoltak", email = "mateusz.zoltak@boku.ac.at", role = c("ctb")) @@ -16,7 +16,6 @@ Imports: httr, jsonlite, methods, - raster, rgdal, sp Suggests: diff --git a/R/S2_buy_granule.R b/R/S2_buy_granule.R index b6c7d37..a7d5a16 100644 --- a/R/S2_buy_granule.R +++ b/R/S2_buy_granule.R @@ -3,74 +3,59 @@ #' Buy granule using granuleId #' #' @param granuleId character vector of one or more granuleId's to buy -#' @param mode one of "ask" and "always". If "ask", the user is prompted for -#' confirmation before spending coins ( - in interactive sessions only!). -#' If "always", granules are bought anyway. +#' @param mode one of 'ask', 'always' or 'force'. If 'ask', the user is prompted +#' for confirmation before spending coins ( - in interactive sessions only!). +#' If 'always', granules are bought without prompting but granule bought +#' already are skipped. If 'force', granules are bought without prompting and +#' also withoug checking if they are already bought. #' @export -S2_buy_granule <- function(granuleId, mode=c("ask", "always")){ - - buy_mode <- match.arg(mode) +S2_buy_granule = function(granuleId, mode = c('ask', 'always', 'force')) { + buy_mode = match.arg(mode) # Check how many coins are required and available ---------------------------- - to_buy <- buy_check(granuleId = granuleId) - user_coins <- S2_user_info()$'coinsRemain' + to_buy = buy_check(granuleId = granuleId) + user_coins = S2_user_info()$'coinsRemain' # Check if number of granules to buy exceeds coin budget --------------------- - if (user_coins < sum(to_buy)){ - - cat(sprintf("You try to buy %s granules, but you seem to have only %s coins left.\n", - sum(to_buy), user_coins)) + if (user_coins < sum(to_buy)) { + cat(sprintf( + "You try to buy %s granules, but you seem to have only %s coins left.\n", + sum(to_buy), user_coins) + ) cat("Please check coin budget or reduce number of granules to buy.") stop("Not enough coins to buy granules!") - - } else if (sum(to_buy) == 0){ - + } else if (sum(to_buy) == 0 | buy_mode == 'force') { cat("Nothing to buy.") return(invisible(NULL)) - } # Promt user for confirmation ------------------------------------------------ # Check if session is running in interactive mode ---------------------------- - - if (buy_mode == "ask"){ - - if (!interactive()){ - + if (buy_mode == "ask") { + if (!interactive()) { stop("'mode = 'ask'' can only be run in interactive mode!") - } else { - cat(sprintf("You are about to buy %s granules.", sum(to_buy))) - quest <- "This action will cost you coins! Type 'YES' to proceed:\t" - buy_all <- readline(prompt = quest) %in% c("YES", "'YES'") - + quest = "This action will cost you coins! Type 'YES' to proceed:\t" + if (!readline(prompt = quest) %in% c("YES", "'YES'")) { + cat("Action canceled.") + return(invisible(NULL)) + } } - - } else if (buy_mode == "always"){ - buy_all <- TRUE } # Finally buy granule's if buy_all is TRUE ----------------------------------- - - if (isTRUE(buy_all)){ - - user <- getOption("S2user") - password <- getOption("S2password") - - for (i in seq_along(granuleId)){ - httr::PUT('https://s2.boku.eodc.eu', - config = httr::authenticate(user, password), - path = list('granule', granuleId[i])) - } - - } else { - - cat("Action canceled.") - return(invisible(NULL)) - + credentials = get_credentials() + auth = httr::authenticate(credentials['user'], credentials['password']) + + for (i in seq_along(granuleId)) { + httr::PUT( + 'https://s2.boku.eodc.eu', + config = auth, + path = list('granule', granuleId[i]) + ) } } diff --git a/R/S2_check_access.R b/R/S2_check_access.R index 6335e2e..2e0134a 100644 --- a/R/S2_check_access.R +++ b/R/S2_check_access.R @@ -8,51 +8,37 @@ #' credentials seem to be valid, FALSE if 'anything' went wrong #' @export -S2_check_access <- function(verbose = TRUE){ - user <- getOption("S2user") - password <- getOption("S2password") - srvrsp <- httr::GET('https://s2.boku.eodc.eu/user/current', - config = httr::authenticate(user, password)) - - if (httr::status_code(srvrsp) == 200){ - if (httr::content(srvrsp)$userId == user){ - - if (isTRUE(verbose)){ - cat(sprintf("Logged in to 'https://s2.boku.eodc.eu' as %s\n", user)) +S2_check_access = function(verbose = TRUE){ + credentials = get_credentials() + srvrsp = httr::GET( + 'https://s2.boku.eodc.eu/user/current', + config = httr::authenticate(credentials['user'], credentials['password']) + ) + + if (httr::status_code(srvrsp) == 200) { + if (httr::content(srvrsp)$userId == credentials['user']) { + if (isTRUE(verbose)) { + cat(sprintf("Logged in to 'https://s2.boku.eodc.eu' as %s\n", credentials['user'])) } return(TRUE) - - } else if (httr::content(srvrsp)$userId == "public"){ - - if (user == "default" && password == "default"){ - if (isTRUE(verbose)){ - warning("Not logged in at 'https://s2.boku.eodc.eu' -> limited access to database:\n", - "please supply 'user' and 'password' via 'S2_initialize_user()'\n", - "see '?S2_intialize_user' for details!") - } - return(FALSE) - - } else { - - if (isTRUE(verbose)){ - warning("Not logged in to s2.boku.eodc.eu -> access to database limited:\n", - "please check credentials and use 'S2_initialize_user()' to\n", - "supply a valid 'user' and 'password'\n", - "see '?S2_intialize_user' or visit 'https://s2.boku.eodc.eu' for details!") - } - return(FALSE) - + } else { + if (isTRUE(verbose)) { + warning( + "Not logged in to s2.boku.eodc.eu -> access to database limited:\n", + "please check credentials and use 'S2_initialize_user()' to\n", + "supply a valid 'user' and 'password'\n", + "see '?S2_intialize_user' or visit 'https://s2.boku.eodc.eu' for details!" + ) } + return(FALSE) } } else { - - if (isTRUE(verbose)){ - warning(sprintf("Unable to access server! Status code %s returned", - httr::status_code(srvrsp))) + if (isTRUE(verbose)) { + warning( + sprintf("Unable to access server! Status code %s returned", + httr::status_code(srvrsp)) + ) } return(FALSE) - } - } - diff --git a/R/S2_do_query.R b/R/S2_do_query.R index de605a1..9a4645e 100644 --- a/R/S2_do_query.R +++ b/R/S2_do_query.R @@ -10,15 +10,14 @@ S2_do_query = function(query, path){ - user = getOption("S2user") - password = getOption("S2password") + credentials = get_credentials() filter = sapply(query, is.logical) query[filter] = as.numeric(query[filter]) rtrn = httr::GET( 'https://s2.boku.eodc.eu', - config = httr::authenticate(user, password), + config = httr::authenticate(credentials['user'], credentials['password']), path = path, query = query ) diff --git a/R/S2_generate_RGB.R b/R/S2_generate_RGB.R index ae5119e..43c6856 100644 --- a/R/S2_generate_RGB.R +++ b/R/S2_generate_RGB.R @@ -29,98 +29,103 @@ #' @return NULL #' @export -S2_generate_RGB <- function(granuleId, - destfile = NULL, - resolution = c("highest", "lowest"), - atmCorr = TRUE, - r = "B08", - g = "B04", - b = "B03", - ra = 20, - ga = 20, - ba = 20, - rb = 20, - gb = 20, - bb = 20, - overwrite = FALSE){ - - resolution <- match.arg(resolution) - resolution <- switch(resolution, "highest" = FALSE, "lowest" = TRUE) - - query <- S2_query_image(granuleId = granuleId, atmCorr = atmCorr) - - if (length(query) == 0 && !isTRUE(atmCorr)){ +S2_generate_RGB = function( + granuleId, + destfile = NULL, + resolution = c("highest", "lowest"), + atmCorr = TRUE, + r = "B08", + g = "B04", + b = "B03", + ra = 20, + ga = 20, + ba = 20, + rb = 20, + gb = 20, + bb = 20, + overwrite = FALSE +){ + if (length(granuleId) != 1) { + stop('granuleId has to be a vector of length one') + } - warning("Unable to process 'granuleId ", granuleId, "'. Not found in database!") - return(invisible(NULL)) + resolution = match.arg(resolution) + resolution = switch(resolution, "highest" = FALSE, "lowest" = TRUE) - } else if (length(query) == 0 && isTRUE(atmCorr)){ + query = S2_query_image(granuleId = granuleId, atmCorr = atmCorr) - warning("Unable to process 'granuleId ", granuleId, "'. Maybe its not (yet) ", - "atmospherically corrected!\n") + if (length(query) == 0 && !isTRUE(atmCorr)) { + warning("Unable to process 'granuleId ", granuleId, "'. Not found in database!") + return(invisible(NULL)) + } else if (length(query) == 0 && isTRUE(atmCorr)) { + warning( + "Unable to process 'granuleId ", granuleId, "'. Maybe its not (yet) ", + "atmospherically corrected!\n" + ) return(invisible(NULL)) - } - imageIds <- integer(3) - min_resolution <- Inf + imageIds = integer(3) + min_resolution = Inf - for (i in seq_len(3)){ - sel <- query[query$band == c(r, g, b)[i], , drop=FALSE] - sel <- sel[order(sel$resolution, decreasing = resolution)[1], , drop=FALSE] - min_resolution <- min(c(min_resolution, sel$resolution)) + for (i in seq_len(3)) { + sel = query[query$band == c(r, g, b)[i], , drop = FALSE] + sel = sel[order(sel$resolution, decreasing = resolution)[1], , drop = FALSE] + min_resolution = min(c(min_resolution, sel$resolution)) - if (is.na(sel$url)){ + if (is.na(sel$url)) { warning("Access to image denied. You seem to lack permission to download file!") return(invisible(NULL)) } - imageIds[i] <- sel[, "imageId"] + imageIds[i] = sel[, "imageId"] } # Generate filename ---------------------------------------------------------- - autoname <- sprintf("RGB_%s_%s_%s_%sm_%s_%s_%s_Id%s_%s.tif", - r, g, b, min_resolution, - unique(format_date(query$date)), - unique(query$utm), - unique(query$orbit), - granuleId, ifelse(atmCorr, "L2A", "L1C")) - - - query <- list(r = imageIds[1], - g = imageIds[2], - b = imageIds[3], - ra = ra, - ga = ga, - ba = ba, - rb = rb, - gb = gb, - bb = bb) - - user <- getOption("S2user") - password <- getOption("S2password") - rtrn <- httr::modify_url('https://s2.boku.eodc.eu', - username = utils::URLencode(user, reserved = TRUE), - password = utils::URLencode(password, reserved = TRUE), - path = "rgb", - query = query) - - - if (is.null(destfile)){ - destfile <- autoname + autoname = sprintf( + "RGB_%s_%s_%s_%sm_%s_%s_%s_Id%s_%s.tif", + r, g, b, min_resolution, + unique(format_date(query$date)), + unique(query$utm), + unique(query$orbit), + granuleId, ifelse(atmCorr, "L2A", "L1C") + ) + + query = list( + r = imageIds[1], + g = imageIds[2], + b = imageIds[3], + ra = ra, + ga = ga, + ba = ba, + rb = rb, + gb = gb, + bb = bb + ) + + credentials = get_credentials() + rtrn = httr::modify_url( + 'https://s2.boku.eodc.eu', + username = utils::URLencode(credentials['user'], reserved = TRUE), + password = utils::URLencode(credentials['password'], reserved = TRUE), + path = "rgb", + query = query + ) + + if (is.null(destfile)) { + destfile = autoname } - if (dir.exists(destfile)){ - destfile <- sprintf("%s/%s", destfile, autoname) + if (dir.exists(destfile)) { + destfile = sprintf("%s/%s", destfile, autoname) } - - if (file.exists(destfile) && !isTRUE(overwrite)){ + if (file.exists(destfile) && !isTRUE(overwrite)) { warning(destfile, " already exists! Use 'overwrite = TRUE' to overwrite") return(invisible(NULL)) } curl::curl_download(url = rtrn, destfile = destfile) - return(invisible(NULL)) + return(destfile) } diff --git a/R/S2_initialize_user.R b/R/S2_initialize_user.R index 586fdcb..42cae3c 100644 --- a/R/S2_initialize_user.R +++ b/R/S2_initialize_user.R @@ -1,13 +1,13 @@ +cfgUser = 'test@s2.boku.eodc.eu' +cfgPswd = 'test' + #' Set login credentials for 's2.boku.eodc.eu' #' #' Set 'user' and 'password' login credentials for the current #' R session #' -#' \code{S2_initialize_user} store 'user' and 'password' in \code{options}. -#' If needed, functions in package 'sentinel2' will retrieve the credentials -#' using 'getOption()'. This will avoid passing login credentials multiple -#' times in a single session and allows users to permanentely configure their -#' login in a '.Rprofile' file. +#' \code{S2_initialize_user} remembers user credentials allowing other package +#' functions to retrieve them when needed. #' #' @note Requires a valid registration to 'https://s2.boku.eodc.eu' to gain #' access to database functionality where authentication is mandatory. @@ -15,8 +15,13 @@ #' 'https://s2.boku.eodc.eu' #' @param password character password for 'https://s2.boku.eodc.eu' #' @export +S2_initialize_user = function(user, password, permanent = TRUE) { + cfgUser <<- user + cfgPswd <<- password +} -S2_initialize_user <- function(user = "test@s2.boku.eodc.eu", password = "test"){ - options("S2user" = user) - options("S2password" = password) +#' Internal function getting user credentials +#' +get_credentials = function() { + return(c(user = cfgUser, password = cfgPswd)) } diff --git a/R/S2_put_ROI.R b/R/S2_put_ROI.R index f9c01de..712f0fb 100644 --- a/R/S2_put_ROI.R +++ b/R/S2_put_ROI.R @@ -15,14 +15,15 @@ #' @export -S2_put_ROI <- function(geometry, - regionId = NULL, - cloudCovMax = 50, - indicators = NULL, - dateMin = NULL, - dateMax = NULL, - srid = 4326){ - +S2_put_ROI = function( + geometry, + regionId = NULL, + cloudCovMax = 50, + indicators = NULL, + dateMin = NULL, + dateMax = NULL, + srid = 4326 +){ if (is.null(dateMin) || is.null(dateMax)) { stop("Please supply 'dateMin' and 'dateMax' in format 'YYYY-MM-DD") } @@ -32,31 +33,33 @@ S2_put_ROI <- function(geometry, } if (is.null(regionId)) { - stop("'regionId' not specified!", - "\n-> If you want to update an existing 'roi', please supply valid 'regionId'", - "\n-> If you like to create a new 'regionId' enter desired name") + stop( + "'regionId' not specified!", + "\n-> If you want to update an existing 'roi', please supply valid 'regionId'", + "\n-> If you like to create a new 'regionId' enter desired name" + ) } - geometry <- roi_to_jgeom(geometry) - - body_l <- list(cloudCovMax = cloudCovMax, - dateMin = dateMin, - dateMax = dateMax, - geometry = geometry, - indicators = indicators, - srid = srid) + geometry = roi_to_jgeom(geometry) + body_l = list( + cloudCovMax = cloudCovMax, + dateMin = dateMin, + dateMax = dateMax, + geometry = geometry, + indicators = indicators, + srid = srid + ) + body_l = body_l[!sapply(body_l , is.null)] - body_l <- body_l[!sapply(body_l , is.null)] - - user <- getOption("S2user") - password <- getOption("S2password") - url <- httr::modify_url('https://s2.boku.eodc.eu', - username = utils::URLencode(user, reserved = TRUE), - password = utils::URLencode(password, reserved = TRUE), - path = list("user", user, "roi", regionId)) - rtrn <- httr::PUT(url = url, body = body_l, encode = "form", - httr::content_type('application/x-www-form-urlencoded')) + credentials = get_credentials() + url = httr::modify_url( + 'https://s2.boku.eodc.eu', + path = list("user", credentials['user'], "roi", regionId) + ) + rtrn = httr::PUT( + url = url, body = body_l, + config = httr::authenticate(credentials['user'], credentials['password']) + ) return(rtrn) - } diff --git a/R/S2_user_info.R b/R/S2_user_info.R index 87525bc..0436a07 100644 --- a/R/S2_user_info.R +++ b/R/S2_user_info.R @@ -8,15 +8,16 @@ #' database products #' @export -S2_user_info <- function(){ - user <- getOption("S2user") - password <- getOption("S2password") - srvrsp <- httr::GET('https://s2.boku.eodc.eu/user/current', - config = httr::authenticate(user, password)) +S2_user_info = function(){ + credentials = get_credentials() + srvrsp = httr::GET( + 'https://s2.boku.eodc.eu/user/current', + config = httr::authenticate(credentials['user'], credentials['password']) + ) - srvrsp <- httr::content(srvrsp) - srvrsp$coinsRemain <- srvrsp$coins - srvrsp$coinsUsed - srvrsp$admin <- NULL + srvrsp = httr::content(srvrsp) + srvrsp$coinsRemain = srvrsp$coins - srvrsp$coinsUsed + srvrsp$admin = NULL return(srvrsp) } diff --git a/R/buy_check.R b/R/buy_check.R index 4f1ff96..50206a7 100644 --- a/R/buy_check.R +++ b/R/buy_check.R @@ -5,16 +5,14 @@ #' @param granuleId a character vector of one or more granuleId's #' @return logical of the same length as granuleId, where \code{TRUE} means a #' granule needs to be bougth to gain access - - -buy_check <- function(granuleId){ - +buy_check = function(granuleId){ to_buy <- rep(FALSE, length(granuleId)) - for (i in seq_along(granuleId)){ - to_buy[i] <- is.na(S2_query_granule(granuleId = granuleId[i])['url']) + for (i in seq_along(granuleId)) { + g = S2_query_granule(granuleId = granuleId[i]) + to_buy[i] = is.na(g$url) | g$atmCorr == 0 } - names(to_buy) <- granuleId + names(to_buy) = granuleId return(to_buy) } diff --git a/R/jgeom_to_SpatialPolygons.R b/R/jgeom_to_SpatialPolygons.R deleted file mode 100644 index 6b7cadd..0000000 --- a/R/jgeom_to_SpatialPolygons.R +++ /dev/null @@ -1,81 +0,0 @@ -#' Converts json geometry to SpatialPolygons -#' -#' Turn a json geometry as returned by a database query using 'retGeometry = 1' -#' into a SpatialPolygons object -#' -#' @note The geometry is first replaced by its convex hull for simplification! -#' @param x character json geometry as returned by a database query with -#' 'retGeometry = 1' -#' @param utm two-digit utm zone used for an optional reprojection -#' @return SpatialPolygons object of the geometry supplied via x - -jgeom_to_SpatialPolygons <- function(x, utm=NULL){ - # require(raster) - # require(sp) - y <- unlist(strsplit(x, split = '"coordinates":')) - - stopifnot(grepl(pattern = "MultiPolygon|Polygon", y[[1]])) - y0 <- y[[2]] - - y0 <- gsub("}", "", y0) - y0 <- gsub("\\[{4,}", "[[[", y0) - y0 <- gsub("\\]{4,}", "]]]", y0) - y0 <- gsub("[[:space:]]", "", y0) - y0 <- gsub("\\]{3},\\[{3}", "]]] [[[", y0) - y0 <- unlist(strsplit(y0, split = " ")) - - - rtrn <- vector(mode = 'list', length = length(y0)) - for (ii in seq_along(y0)){ - y1 <- unlist(strsplit(y0[ii], split = "]]")) - y1 <- strsplit(x = y1, split = "\\]|\\[|,") - empty1 <- logical(length(y1)) - for(i in seq_along(y1)){ - - y_ <- matrix(stats::na.omit(as.numeric(y1[[i]])), ncol = 2, byrow = TRUE) - if(nrow(y_) == 0){ - empty1[i] <- TRUE - } else if (i == 1){ - y1[[i]] <- sp::Polygon(y_, hole = FALSE) - } else { - y1[[i]] <- sp::Polygon(y_, hole = TRUE) - } - } - y1 <- y1[!empty1] - rtrn[[ii]] <- sp::Polygons(y1, ID = ii) - - } - rtrn <- sp::SpatialPolygons(rtrn, proj4string = raster::crs(raster::raster())) - - if (!is.null(utm)){ - - epsg0 <- sprintf("+init=epsg:32%s%s", - ifelse(sp::coordinates(rtrn)[2] < 0, 7, 6), - substring(utm, first = 1, last = 2)) - rtrn <- sp::spTransform(rtrn, CRSobj = sp::CRS(epsg0)) - - } - return(rtrn) -} - -# jgeom_to_SpatialPolygons <- function(x){ -# rtrn <- vector(mode = "list", length = length(x)) -# for (i in seq_along(x)){ -# ptrn <- "\\[-?[0-9]+[.]?[0-9]*,-?[0-9]+[.]?[0-9]*\\]" -# y <- unlist(strsplit(x[i], split = '"coordinates":'))[2] -# y <- unlist(regmatches(y, m = gregexpr(pattern = ptrn, text = y))) -# y <- substr(y, start = 2, stop = nchar(y) - 1) -# y <- strsplit(y, split = ",") -# y <- do.call(rbind, y) -# y <- apply(y, 2, as.numeric) -# hull <- grDevices::chull(y) -# y <- y[c(hull, hull[1]), ] -# y <- sp::Polygon(y) -# y <- sp::Polygons(list(y), ID=i) -# -# rtrn[[i]] <- y -# } -# rtrn <- sp::SpatialPolygons(rtrn, proj4string = raster::crs(raster::raster())) -# -# return(rtrn) -# } diff --git a/R/roi2jgeom.R b/R/roi2jgeom.R new file mode 100644 index 0000000..c912cf6 --- /dev/null +++ b/R/roi2jgeom.R @@ -0,0 +1,35 @@ +#' Convert a region of interest to a json geometry +#' +#' @param roi a region of interest supplied as a vector/matrix of named ('x', +#' 'y') coordinates or any sp package spatial +#' object or a path to a file \code{\link[rgdal]{readOGR}} can open or a json +#' geometry character string +#' @param projection sp's package CRS object providing points projection. +#' Applicable only when the \code{roi} parameter is a vector/matrix of +#' coordinates +#' @note Coordinates are assumed to be projected (WGS-84, 4326). Spatial objects +#' will be reprojected as necessary +#' @return character, a json geometry string +#' @export +roi_to_jgeom = function(roi, projection = sp::CRS('+init=epsg:4326')){ + if (is.character(roi) && file.exists(roi)) { + roi = gsub(pattern = '[\\]', replacement = '/', roi) + + if (grepl('.[.][sS][hH][pP]$', roi)) { + dsn = sub('/[^/]+$', '', roi) + layer = sub('^.*/(.+)[.][sS][hH][pP]$', '\\1', roi) + roi = rgdal::readOGR(dsn, layer, verbose = FALSE) + } else { + roi = rgdal::readOGR(roi) + } + } else if (is.character(roi)) { + roi = rgdal::readOGR(roi, 'OGRGeoJSON', verbose = FALSE) + } else if (all(c("x", "y") %in% colnames(rbind(roi)))){ + roi_geom = sp::SpatialPoints(xy, projection) + } + + roi = sp::spTransform(roi, CRSobj = sp::CRS('+init=epsg:4326')) + roi_geom = spat2jgeom(spat = roi, round = round) + + return(roi_geom) +} diff --git a/R/roi_to_jgeom.R b/R/roi_to_jgeom.R deleted file mode 100644 index 8179241..0000000 --- a/R/roi_to_jgeom.R +++ /dev/null @@ -1,42 +0,0 @@ -#' Convert a region of interest to a json geometry -#' -#' @param roi a region of interest supplied as a vector/matrix of named ('x', 'y') -#' coordinates or a SpatialPoints object or a SpatialPolygons object or a path -#' to a file \code{\link[rgdal]{readOGR}} can open or a json geometry character string -#' @param round number of digits to round coordinates to -#' @note Coordinates are assumed to be projected (WGS-84, 4326). Spatial objects -#' will be reprojected as necessary -#' @return character, a json geometry string -#' @export - -roi_to_jgeom <- function(roi, round = Inf){ - - if (is.character(roi) && file.exists(roi)) { - - roi <- gsub(pattern = '[\\]', replacement = '/', roi) - - if (grepl('.[.][sS][hH][pP]$', roi)) { - dsn <- sub('/[^/]+$', '', roi) - layer <- sub('^.*/(.+)[.][sS][hH][pP]$', '\\1', roi) - roi <- rgdal::readOGR(dsn, layer, verbose = FALSE) - } else { - roi <- rgdal::readOGR(roi) - } - } - - if ("Spatial" %in% methods::is(roi)) { - if (!raster::compareCRS(roi, raster::raster())) { - roi <- sp::spTransform(roi, CRSobj = raster::crs(raster::raster())) - } - roi_geom <- spat_to_jgeom(spat = roi, round = round) - } else if (all(c("x", "y") %in% colnames(rbind(roi)))) { - roi_geom <- xy_to_jgeom(xy = roi, round = round) - } else if (length(grep("^\\{[[:print:]]*\\}$", roi)) != 0) { - roi_geom <- roi - } else { - stop("'roi' not recognized!") - } - - return(roi_geom) - -} diff --git a/R/spat2jgeom.R b/R/spat2jgeom.R new file mode 100644 index 0000000..2d0b8f9 --- /dev/null +++ b/R/spat2jgeom.R @@ -0,0 +1,30 @@ +#' Convert any sp package geometry to a json geometry +#' +#' @note Objects consisting of many one feature are covnerted to GeoJSON +#' Polygons while objects consisting of many features to MultiPolygons. +#' +#' @param spat an sp package spatial object or list of sp package spatial +#' objects +#' @return vector of corresponding JSON geometries +#' +spat2jgeom = function(spat){ + if (!is.list(spat)) { + spat = list(spat) + } + + tmpFile = tempfile() + on.exit({ + unlink(tmpFile) + }) + + rtrn = vector(mode = 'list', length = length(spat)) + for (i in seq_along(spat)) { + rgdal::writeOGR(spat[[i]], tmpFile, '', driver = 'GeoJSON', verbose = FALSE) + features = jsonlite::fromJSON(readLines(tmpFile), simplifyDataFrame = FALSE)$features + if (length('features') == 1) { + rtrn[i] = jsonlite::toJSON(features[[1]]$geometry) + } else { + + } + } +} diff --git a/R/spat_to_jgeom.R b/R/spat_to_jgeom.R deleted file mode 100644 index 8117cd6..0000000 --- a/R/spat_to_jgeom.R +++ /dev/null @@ -1,48 +0,0 @@ -#' Convert SpatialPoints/PatialPolygons to json geometry -#' -#' Turn a SpatialPoints/PatialPolygons object into a json geometry string -#' -#' @param spat a spatial object of class SpatialPolygons or SpatialPoints -#' @param round number of digits to round coordinates to -#' @return character string, a single json geometry -#' - -spat_to_jgeom <- function(spat, round = Inf){ - - rtrn <- vector(mode = 'list', length = length(spat)) - - if (any(grepl("SpatialPolygon", class(spat)))){ - g_type <- "MultiPolygon" - } else if (any(grepl("SpatialPoints", class(spat)))){ - g_type <- "MultiPoint" - } else { - stop("Spatial object supplied as 'geometry' is not of class 'SpatialPoints' or 'SpatialPolygons'") - } - - for (i in seq_along(spat)){ - - poi_xy <- raster::geom(spat[i, ])[, c("x", "y"), drop = FALSE] - - if (g_type == "MultiPoint"){ - - poi_xy <- data.frame(round(poi_xy, round)) - poi_xy <- with(poi_xy, paste(x, y, sep = ",")) - poi_xy <- sprintf("[%s]", poi_xy) - - } else if (g_type == "MultiPolygon"){ - - poi_xy <- data.frame(apply(round(poi_xy, round), 2, as.character)) - poi_xy <- with(poi_xy, paste(sprintf("[%s,%s]", x, y), collapse=",")) - poi_xy <- sprintf("[[%s]]", poi_xy) - } - - rtrn[[i]] <- poi_xy - - } - - rtrn <- paste(unlist(rtrn), collapse=",") - rtrn <- sprintf('{"type":"%s","coordinates":[%s]}', g_type, rtrn) - return(rtrn) -} - - diff --git a/R/xy_to_jgeom.R b/R/xy_to_jgeom.R deleted file mode 100644 index 8b9f2b9..0000000 --- a/R/xy_to_jgeom.R +++ /dev/null @@ -1,46 +0,0 @@ -#' Convert xy coordinates to json geometry -#' -#' Turn a xy coordinates vector (1 point) or matrix (multiple points) into a -#' json geometry string -#' @note Elements of vector/columns of matrix must be named 'x' and 'y' -#' @param xy named vector matrix of 'x' and 'y' coordinates assumed to be projected -#' (4326, WGS-84) -#' @param round number of digits to round coordinates to -#' @return a json geometry string of type 'MultiPoint' -#' - -xy_to_jgeom <- function(xy, round = Inf){ - - poi_xy <- data.frame(rbind(xy)) - - stopifnot(all(c("x", "y") %in% colnames(poi_xy))) - - poi_xy <- round(poi_xy[, c("x", "y"), drop = FALSE], digits = round) - - # if (nrow(poi_xy) == 1){ - # - # poi_xy <- data.frame(round(poi_xy, round)) - # g_type <- "Point" - # poi_xy <- with(poi_xy, paste(x, y, sep = ",")) - # - # } else if (nrow(poi_xy) > 1){ - # - # g_type <- "Polygon" - # - # poi_xy <- data.frame(apply(round(poi_xy, round), 2, as.character)) - # poi_xy <- with(poi_xy, paste(sprintf("[%s,%s]", x, y), collapse=",")) - # poi_xy <- sprintf("[%s]", poi_xy) - # - # } - - g_type <- "MultiPoint" - - # poi_xy <- data.frame(apply(round(poi_xy, round), 2, as.character)) - poi_xy <- with(poi_xy, paste(sprintf("[%s,%s]", x, y), collapse=",")) - # poi_xy <- sprintf("[%s]", poi_xy) - - - rtrn <- sprintf('{"type":"%s","coordinates":[%s]}', g_type, poi_xy) - return(rtrn) - -} diff --git a/R/zzz.R b/R/zzz.R deleted file mode 100644 index 9a8548e..0000000 --- a/R/zzz.R +++ /dev/null @@ -1,10 +0,0 @@ -#' .onLoad setup credentials -#' @description -#' Setup login credentials on package start, if not retrieved already (e.g. from -#' .Rprofile). -#' @param libname library name -#' @param pkgname package name -.onLoad <- function(libname, pkgname){ - if (is.null(getOption("S2user"))) options("S2user" = "default") - if (is.null(getOption("S2password"))) options("S2password" = "default") -} diff --git a/man/S2_buy_granule.Rd b/man/S2_buy_granule.Rd index d7e4e9e..d6ef6e8 100644 --- a/man/S2_buy_granule.Rd +++ b/man/S2_buy_granule.Rd @@ -4,14 +4,16 @@ \alias{S2_buy_granule} \title{Buy a granule at 'https://s2.boku.eodc.eu'} \usage{ -S2_buy_granule(granuleId, mode = c("ask", "always")) +S2_buy_granule(granuleId, mode = c("ask", "always", "force")) } \arguments{ \item{granuleId}{character vector of one or more granuleId's to buy} -\item{mode}{one of "ask" and "always". If "ask", the user is prompted for -confirmation before spending coins ( - in interactive sessions only!). -If "always", granules are bought anyway.} +\item{mode}{one of 'ask', 'always' or 'force'. If 'ask', the user is prompted +for confirmation before spending coins ( - in interactive sessions only!). +If 'always', granules are bought without prompting but granule bought +already are skipped. If 'force', granules are bought without prompting and +also withoug checking if they are already bought.} } \description{ Buy granule using granuleId diff --git a/tests/testthat/test-S2_generate_RGB.R b/tests/testthat/test-S2_generate_RGB.R new file mode 100644 index 0000000..1a4633e --- /dev/null +++ b/tests/testthat/test-S2_generate_RGB.R @@ -0,0 +1,12 @@ +context('S2_query') + +test_that('S2_generate_RGB() works', { + imgs = S2_query_image(owned = TRUE, atmCorr = TRUE, resolution = 60, cloudCovMax = 10) %>% + dplyr::filter(band %in% c('B02', 'B03', 'B04')) %>% + dplyr::arrange(date, band) + file = tempfile() + S2_generate_RGB(imgs$granuleId[1], destfile = file, overwrite = TRUE) + expect_true(file.exists(file)) + expect_gt(file.size(file), 1000000) + unlink(file) +}) diff --git a/tests/testthat/test-S2_query.R b/tests/testthat/test-S2_query.R index 8e48fbe..16724d2 100644 --- a/tests/testthat/test-S2_query.R +++ b/tests/testthat/test-S2_query.R @@ -1,5 +1,4 @@ context('S2_query') -S2_initialize_user() test_that('S2_query_angle() works', { data = S2_query_angle( @@ -153,45 +152,6 @@ test_that('S2_query_roi() works', { # expect_true(all(unlist(lapply(data$geometry, function(x){'sf' %in% class(x)})))) # }) -test_that('S2 downloads images', { - if (file.exists('test.jp2')) { - unlink('test.jp2') - } - on.exit({ - if (file.exists('test.jp2')) { - unlink('test.jp2') - } - }) - - data = S2_query_image(imageId = 29392766) - S2_download(data$url, 'test.jp2') - expect_true(file.exists('test.jp2')) - expect_equal(file.info('test.jp2')$size, 3190469) -}) - -test_that('S2 downloads granules', { - if (file.exists('testDir.zip')) { - unlink('testDir.zip') - } - if (dir.exists('testDir')) { - system('rm -fR testDir') - } - tryCatch( - { - S2_download('https://test%40s2.boku.eodc.eu:test@s2.boku.eodc.eu/granule/2920000', destfile = 'testDir', zip = TRUE, skipExisting = FALSE) - expect_true(file.exists('testDir/MTD_TL.xml')) - }, - finally = { - if (file.exists('testDir.zip')) { - unlink('testDir.zip') - } - if (dir.exists('testDir')) { - system('rm -fR testDir') - } - } - ) -}) - test_that('data frame is always returned', { data = S2_query_product(productId = -1) expect_is(data, 'data.frame') diff --git a/tests/testthat/test-credentials.R b/tests/testthat/test-credentials.R new file mode 100644 index 0000000..5fe0cfe --- /dev/null +++ b/tests/testthat/test-credentials.R @@ -0,0 +1,23 @@ +context('credentials') + +test_that('S2_user_info() works', { + ui = S2_user_info() + expect_equal(ui$userId, 'test@s2.boku.eodc.eu') + expect_lt(ui$coinsRemain, 0) +}) + +test_that('S2_initialize_user() works', { + S2_initialize_user('aaa', 'bbb') + ui = S2_user_info() + expect_equal(ui, list(userId = 'public', coins = 0, coinsUsed = 0, coinsRemain = 0)) + + S2_initialize_user('test@s2.boku.eodc.eu', 'test') +}) + +test_that('S2_check_access() works', { + S2_initialize_user('aaa', 'bbb') + expect_false(suppressWarnings(S2_check_access())) + + S2_initialize_user('test@s2.boku.eodc.eu', 'test') + expect_true(S2_check_access()) +}) diff --git a/tests/testthat/test-downloads.R b/tests/testthat/test-downloads.R new file mode 100644 index 0000000..327a1a2 --- /dev/null +++ b/tests/testthat/test-downloads.R @@ -0,0 +1,40 @@ +context('downloads') + +test_that('S2 downloads images', { + if (file.exists('test.jp2')) { + unlink('test.jp2') + } + on.exit({ + if (file.exists('test.jp2')) { + unlink('test.jp2') + } + }) + + data = S2_query_image(imageId = 29392766) + S2_download(data$url, 'test.jp2') + expect_true(file.exists('test.jp2')) + expect_equal(file.info('test.jp2')$size, 3190469) +}) + +test_that('S2 downloads granules', { + if (file.exists('testDir.zip')) { + unlink('testDir.zip') + } + if (dir.exists('testDir')) { + system('rm -fR testDir') + } + tryCatch( + { + S2_download('https://test%40s2.boku.eodc.eu:test@s2.boku.eodc.eu/granule/2920000', destfile = 'testDir', zip = TRUE, skipExisting = FALSE) + expect_true(file.exists('testDir/MTD_TL.xml')) + }, + finally = { + if (file.exists('testDir.zip')) { + unlink('testDir.zip') + } + if (dir.exists('testDir')) { + system('rm -fR testDir') + } + } + ) +})