From c0c8fbea20f42fcbb9397b296d976ee28d7b792f Mon Sep 17 00:00:00 2001 From: lysoifer Date: Thu, 8 Aug 2024 19:13:47 -0400 Subject: [PATCH 1/2] add netrc file authentication --- R/RcppExports.R | 14 +- R/cmr.R | 302 +++++++++++++++++++++++--------------------- src/RcppExports.cpp | 74 +++++------ 3 files changed, 204 insertions(+), 186 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index d473c13..0c15b22 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,7 +1,7 @@ -# Generated by using Rcpp::compileAttributes() -> do not edit by hand -# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 - -.nnls_solver <- function(x, A, iterate = 400L, tolerance = 0.000001) { - .Call('_luna_nnls_solver', PACKAGE = 'luna', x, A, iterate, tolerance) -} - +# Generated by using Rcpp::compileAttributes() -> do not edit by hand +# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +.nnls_solver <- function(x, A, iterate = 400L, tolerance = 0.000001) { + .Call(`_luna_nnls_solver`, x, A, iterate, tolerance) +} + diff --git a/R/cmr.R b/R/cmr.R index 99ce9ad..18d5ea0 100644 --- a/R/cmr.R +++ b/R/cmr.R @@ -1,142 +1,160 @@ -# Authors: Alex Mandel, Aniruddha Ghosh, Robert J. Hijmans -# July 2019 -# Version 0.1 -# Licence GPL v3 - -# Converted from the NASA official pyCMR -# https://github.com/nasa/pyCMR - -#AUTH_HOST = 'urs.earthdata.nasa.gov' - - -.get_search_results <- function(url, limit, kwargs){ - # Search the CMR granules - #:param limit: limit of the number of results - #:param kwargs: search parameters - #:return: list of results () - - page_num <- 1 - results <- NULL - - while (length(results) < limit){ - #print(page_num) - response <- httr::GET( - url=url, - # TODO: fix next line to take all possible args passed via ... - httr::add_headers(Accept="text/csv"), - query=c(kwargs, page_num=page_num) - #, page_size=self._PAGE_SIZE), - # headers=self._SEARCH_HEADER # what is the header passed from parent function? - ) - - # Check for a valid response - httr::stop_for_status(response) - - #unparsed_page = content(response,parsed="application/json") - # parsing without messages - # http://r.789695.n4.nabble.com/httr-content-without-message-td4747453.html - if (httr::http_type(response) == "text/csv"){ - - # Per httr docs testing for expected type and parsing manually - #unparsed_page = readr::read_csv(httr::content(response, as="text")) - p <- utils::read.csv(text=httr::content(response, as="text"), check.names=FALSE, stringsAsFactors=FALSE) - - #Check the URL column is not empty - catcher <- tryCatch(urls <- p[["Online Access URLs"]], error=function(e){e}) - - if(!inherits(catcher, "error")){ - if(length(urls)==0){ - break - } - # Append the full table of results - results <- rbind(results, p) - page_num <- page_num + 1 - } else { - break - } - } else { - #The response was not a csv, we should throw and error? - break - } - } - return(results) -} - - -.searchCollection <- function(cmr_host="https://cmr.earthdata.nasa.gov", limit=100, ...){ - # Search the CMR collections - # :param limit: limit of the number of results - # :param kwargs ...: search parameters - # :return: dataframe of results - SEARCH_COLLECTION_URL = paste0(cmr_host,"/search/collections") - results <- .get_search_results(url=SEARCH_COLLECTION_URL, limit=limit, ...) - return(results) -} - -.cmr_download_one <- function(url, path, USERNAME, PASSWORD, overwrite, ...){ - # Download a single result - # TODO check if file exists - outfile <- file.path(path, basename(url)) - if ((!file.exists(outfile)) | overwrite){ - if(!is.null(USERNAME)){ - f <- httr::GET(url, httr::authenticate(USERNAME, PASSWORD), httr::progress(), httr::write_disk(outfile, overwrite = overwrite)) - } else { - f <- utils::download.file(url, outfile, mode = "wb") - return(f) - } - } - return(outfile) -} - - -.cmr_download <- function(urls, path, username, password, overwrite, ...){ - # Given a list of results, download all of them - - files <- rep("", length(urls)) - for (i in 1:length(urls)) { - f <- tryCatch( - .cmr_download_one(urls[i], path, username, password, overwrite), - error = function(e){e} - ) - if (inherits(f, "error")) { - warning("failure: ", urls[i]) - f <- file.path(path, urls[i]) - if ( isTRUE(file.info(f)$size < 1) ) file.remove(f) - } else { - files[i] = urls[i] - } - } - cat("\n") - return(files) -} - -.searchGranules <- function(product="MOD09A1", start_date, end_date, extent, limit=100, datesuffix = "T00:00:00Z", ...){ - #Search the CMR granules - #:param limit: limit of the number of results - #:param kwargs: search parameters - #:return: dataframe of results - - e <- .getExtent(extent) - - # for testing validity - start_date <- as.Date(start_date) - end_date <- as.Date(end_date) - - temporal <- paste0(start_date, datesuffix, ",", end_date, datesuffix) - - params <- list( - short_name=product, temporal=temporal, downloadable="true", bounding_box=e - ) - - pars <- list(...) - if (length(pars) > 0) { - params <- c(params, pars) - } - - cmr_host="https://cmr.earthdata.nasa.gov" - url <- file.path(cmr_host, "search/granules") - results <- .get_search_results(url=url, limit=limit, kwargs=params) - return(results) -} - -# CMR download attempt +# Authors: Alex Mandel, Aniruddha Ghosh, Robert J. Hijmans +# July 2019 +# Version 0.1 +# Licence GPL v3 + +# Converted from the NASA official pyCMR +# https://github.com/nasa/pyCMR + +#AUTH_HOST = 'urs.earthdata.nasa.gov' + + +.get_search_results <- function(url, limit, kwargs){ + # Search the CMR granules + #:param limit: limit of the number of results + #:param kwargs: search parameters + #:return: list of results () + + page_num <- 1 + results <- NULL + + while (length(results) < limit){ + #print(page_num) + response <- httr::GET( + url=url, + # TODO: fix next line to take all possible args passed via ... + httr::add_headers(Accept="text/csv"), + query=c(kwargs, page_num=page_num) + #, page_size=self._PAGE_SIZE), + # headers=self._SEARCH_HEADER # what is the header passed from parent function? + ) + + # Check for a valid response + httr::stop_for_status(response) + + #unparsed_page = content(response,parsed="application/json") + # parsing without messages + # http://r.789695.n4.nabble.com/httr-content-without-message-td4747453.html + if (httr::http_type(response) == "text/csv"){ + + # Per httr docs testing for expected type and parsing manually + #unparsed_page = readr::read_csv(httr::content(response, as="text")) + p <- utils::read.csv(text=httr::content(response, as="text"), check.names=FALSE, stringsAsFactors=FALSE) + + #Check the URL column is not empty + catcher <- tryCatch(urls <- p[["Online Access URLs"]], error=function(e){e}) + + if(!inherits(catcher, "error")){ + if(length(urls)==0){ + break + } + # Append the full table of results + results <- rbind(results, p) + page_num <- page_num + 1 + } else { + break + } + } else { + #The response was not a csv, we should throw and error? + break + } + } + return(results) +} + + +.searchCollection <- function(cmr_host="https://cmr.earthdata.nasa.gov", limit=100, ...){ + # Search the CMR collections + # :param limit: limit of the number of results + # :param kwargs ...: search parameters + # :return: dataframe of results + SEARCH_COLLECTION_URL = paste0(cmr_host,"/search/collections") + results <- .get_search_results(url=SEARCH_COLLECTION_URL, limit=limit, ...) + return(results) +} + +.cmr_download_one <- function(url, path, netrc, overwrite, ...){ + # Download a single result + # TODO check if file exists + outfile <- file.path(path, basename(url)) + if ((!file.exists(outfile)) | overwrite){ + if(!is.null(netrc)){ + f = GET(url, write_disk(outfile, overwrite = overwrite), progress(), + config(netrc = TRUE, netrc_file = netrc), set_cookies("LC" = "cookies")) + } else { + f <- utils::download.file(url, outfile, mode = "wb") + return(f) + } + } + return(outfile) +} + +.get_netrc = function(username, password) { + usr <- file.path(Sys.getenv("USERPROFILE")) # Retrieve home dir (for netrc file) + if (usr == "") {usr = Sys.getenv("HOME")} # If no user profile exists, use home + netrc <- file.path(usr,'.netrc', fsep = .Platform$file.sep) # Path to netrc file + + if (file.exists(netrc) == FALSE || grepl("urs.earthdata.nasa.gov", readLines(netrc)[1]) == FALSE) { + netrc_conn <- file(netrc) + + # User will be prompted for NASA Earthdata Login Username and Password below + writeLines(c("machine urs.earthdata.nasa.gov", + sprintf("login %s", username), + sprintf("password %s", password)), netrc_conn) + close(netrc_conn) + } + netrc <- file.path(usr,'.netrc', fsep = .Platform$file.sep) # Path to netrc file + return(netrc) +} + +.cmr_download <- function(urls, path, username, password, overwrite, ...){ + # Given a list of results, download all of them + netrc = .get_netrc(username, password) # get netrc file + files <- rep("", length(urls)) + for (i in 1:length(urls)) { + f <- tryCatch( + .cmr_download_one(urls[i], path, netrc, overwrite), + error = function(e){e} + ) + if (inherits(f, "error")) { + warning("failure: ", urls[i]) + f <- file.path(path, urls[i]) + if ( isTRUE(file.info(f)$size < 1) ) file.remove(f) + } else { + files[i] = urls[i] + } + } + cat("\n") + return(files) +} + +.searchGranules <- function(product="MOD09A1", start_date, end_date, extent, limit=100, datesuffix = "T00:00:00Z", ...){ + #Search the CMR granules + #:param limit: limit of the number of results + #:param kwargs: search parameters + #:return: dataframe of results + + e <- .getExtent(extent) + + # for testing validity + start_date <- as.Date(start_date) + end_date <- as.Date(end_date) + + temporal <- paste0(start_date, datesuffix, ",", end_date, datesuffix) + + params <- list( + short_name=product, temporal=temporal, downloadable="true", bounding_box=e + ) + + pars <- list(...) + if (length(pars) > 0) { + params <- c(params, pars) + } + + cmr_host="https://cmr.earthdata.nasa.gov" + url <- file.path(cmr_host, "search/granules") + results <- .get_search_results(url=url, limit=limit, kwargs=params) + return(results) +} + +# CMR download attempt diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 3ba4b5b..0410166 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -1,37 +1,37 @@ -// Generated by using Rcpp::compileAttributes() -> do not edit by hand -// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 - -#include -#include - -using namespace Rcpp; - -#ifdef RCPP_USE_GLOBAL_ROSTREAM -Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); -Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); -#endif - -// nnls_solver -arma::mat nnls_solver(arma::mat x, arma::mat A, int iterate, float tolerance); -RcppExport SEXP _luna_nnls_solver(SEXP xSEXP, SEXP ASEXP, SEXP iterateSEXP, SEXP toleranceSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type x(xSEXP); - Rcpp::traits::input_parameter< arma::mat >::type A(ASEXP); - Rcpp::traits::input_parameter< int >::type iterate(iterateSEXP); - Rcpp::traits::input_parameter< float >::type tolerance(toleranceSEXP); - rcpp_result_gen = Rcpp::wrap(nnls_solver(x, A, iterate, tolerance)); - return rcpp_result_gen; -END_RCPP -} - -static const R_CallMethodDef CallEntries[] = { - {"_luna_nnls_solver", (DL_FUNC) &_luna_nnls_solver, 4}, - {NULL, NULL, 0} -}; - -RcppExport void R_init_luna(DllInfo *dll) { - R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); - R_useDynamicSymbols(dll, FALSE); -} +// Generated by using Rcpp::compileAttributes() -> do not edit by hand +// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +#include +#include + +using namespace Rcpp; + +#ifdef RCPP_USE_GLOBAL_ROSTREAM +Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); +Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); +#endif + +// nnls_solver +arma::mat nnls_solver(arma::mat x, arma::mat A, int iterate, float tolerance); +RcppExport SEXP _luna_nnls_solver(SEXP xSEXP, SEXP ASEXP, SEXP iterateSEXP, SEXP toleranceSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< arma::mat >::type x(xSEXP); + Rcpp::traits::input_parameter< arma::mat >::type A(ASEXP); + Rcpp::traits::input_parameter< int >::type iterate(iterateSEXP); + Rcpp::traits::input_parameter< float >::type tolerance(toleranceSEXP); + rcpp_result_gen = Rcpp::wrap(nnls_solver(x, A, iterate, tolerance)); + return rcpp_result_gen; +END_RCPP +} + +static const R_CallMethodDef CallEntries[] = { + {"_luna_nnls_solver", (DL_FUNC) &_luna_nnls_solver, 4}, + {NULL, NULL, 0} +}; + +RcppExport void R_init_luna(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} From 69e057af26cece299785e64e8f11d1b5d99e05bc Mon Sep 17 00:00:00 2001 From: lysoifer Date: Sat, 10 Aug 2024 11:53:02 -0400 Subject: [PATCH 2/2] import httr --- DESCRIPTION | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3feefec..289ebf3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,8 +7,8 @@ Encoding: UTF-8 Language: en-US Depends: R (>= 4.0.0), terra (>= 1.6.41) LinkingTo: Rcpp, RcppArmadillo -Imports: methods, Rcpp (>= 1.0-10) -Suggests: httr, rvest, xml2, jsonlite, meteor, signal +Imports: methods, Rcpp (>= 1.0-10), httr +Suggests: rvest, xml2, jsonlite, meteor, signal Maintainer: Robert J. Hijmans Description: Tools for acquiring and (pre-) processing satellite remote sensing data. Including for downloading data from NASA such as LANDSAT and MODIS. License: GPL (>=3) @@ -20,3 +20,4 @@ Authors@R: c( person("Alex", "Mandel", role="ctb"), person("Benson", "Kenduiywo", role = "ctb"), person("Jakob", "Schwalb-Willmann", role = "ctb")) +RoxygenNote: 7.3.2