#' Get Available Collections of MODIS Product(s) #' #' @description #' Checks and retrieves available MODIS collection(s) for a given product. #' #' @param product \code{character}. MODIS grid product to check for existing #' collections, see \code{\link{getProduct}}. #' @param collection \code{character} or \code{integer}. If provided, the #' function only checks if the specified collection exists and returns the #' collection number formatted based on the \code{as} parameter or \code{FALSE} #' if it doesn't exists. The check is performed on #' \href{https://lpdaac.usgs.gov/}{LP DAAC} as the exclusive source for several #' (but by far not all) products. #' @param newest \code{logical}. If \code{TRUE} (default), return only the #' newest collection, else return all available collections. #' @param forceCheck \code{logical}, defaults to \code{FALSE}. If \code{TRUE}, #' connect to the 'LP DAAC' FTP server and get available collections, of which #' an updated version is permanently stored in #' \code{MODIS:::combineOptions()$auxPath}. #' @param as \code{character}, defaults to \code{'character'} which returns the #' typical 3-digit collection number (i.e., \code{"005"}). \code{as = 'numeric'} #' returns the result as \code{numeric} (i.e., \code{5}). #' @param quiet \code{logical}, defaults to \code{TRUE}. #' @param ... Additional arguments passed to \code{MODIS:::combineOptions}. #' #' @return #' A 3-digit \code{character} or \code{numeric} object (depending on 'as') or, #' if \code{length(product) > 1}, a \code{list} of such objects with each slot #' corresponding to the collection available for a certain product. #' Additionally, a text file in a hidden folder located in #' \code{getOption("MODIS_localArcPath")} as database for future calls. If #' 'collection' is provided, only the (formatted) collection (or \code{FALSE} if #' it could not be found) is returned. #' #' @author #' Matteo Mattiuzzi, Florian Detsch #' #' @seealso #' \code{\link{getProduct}}. #' #' @examples #' \dontrun{ #' #' # update or get collections for MOD11C3 and MYD11C3 #' getCollection(product="M.D11C3") #' getCollection(product="M.D11C3",newest=FALSE) #' #' getCollection(product="M.D11C3",collection=3) #' getCollection(product="M.D11C3",collection=41) #' getCollection(product="M.D11C3",collection="041") #' getCollection(product="M.D11C3",forceCheck=TRUE) #' } #' #' @export getCollection #' @name getCollection getCollection <- function(product,collection=NULL,newest=TRUE,forceCheck=FALSE,as="character",quiet=TRUE, ...) { opts <- combineOptions(...) #### # checks for product if (missing(product)) { stop("Please provide a valid product") } productN <- getProduct(x = if (is.character(product)) { sapply(product, function(i) skipDuplicateProducts(i, quiet = quiet)) } else product, quiet = TRUE) if (is.null(productN)) { stop("Unknown product") } ## if 'collections' dataset does not exist in opts$auxPath, copy it from ## 'inst/external', then import data dir_aux <- opts$auxPath if (!dir.exists(dir_aux)) dir.create(dir_aux, recursive = TRUE) fls_col <- file.path(dir_aux, "collections.RData") if (!file.exists(fls_col)) invisible( file.copy(system.file("external", "collections.RData", package = "MODIS"), fls_col) ) load(fls_col) if (forceCheck | sum(!productN$PRODUCT %in% colnames(MODIScollection))>0) { sturheit <- stubborn(level=opts$stubbornness) load(system.file("external", "MODIS_FTPinfo.RData", package = "MODIS")) for (i in seq_along(productN$PRODUCT)) { ## retrieve ftp server address based on product source information server <- unlist(productN$SOURCE[[i]]) ftp_id <- sapply(MODIS_FTPinfo, function(i) i$name %in% server) ftp_id <- which(ftp_id)[1] ftp <- file.path(MODIS_FTPinfo[[ftp_id]]$basepath, productN$PF1[i], "/") cat("Updating collection from", server[1], "for product:" , productN$PRODUCT[i], "\n") if(exists("dirs")) { suppressWarnings(rm(dirs)) } for (g in 1:sturheit) { try(dirs <- filesUrl(ftp)) if(exists("dirs")) { if(all(dirs != FALSE)) { break } } } if (!exists("dirs")) { cat("FTP is not available, using stored information from previous calls (this should be mostly fine)\n") } else { ## choose relevant folders and remove empty ones dirs = grep(paste0(productN$PRODUCT[i], "\\.[[:digit:]]{3}"), dirs , value = TRUE) ids = sapply(file.path(ftp, dirs, "/"), function(ftpdir) { cnt = RCurl::getURL(ftpdir, dirlistonly = TRUE) dts = regmatches(cnt, regexpr("[[:digit:]]{4}\\.[[:digit:]]{2}\\.[[:digit:]]{2}", cnt)) return(length(dts) > 0) }) dirs = dirs[ids] ## information about products and collections ls_prod_col <- sapply(dirs, function(x) {strsplit(x, "\\.")}) prod <- sapply(ls_prod_col, "[[", 1) coll <- sapply(ls_prod_col, "[[", 2) mtr <- cbind(prod,coll) mtr <- tapply(INDEX=mtr[,1],X=mtr[,2],function(x){x}) maxrow <- max(nrow(MODIScollection),sapply(mtr,function(x)length(x))) basemtr <- matrix(NA,ncol=nrow(mtr), nrow = maxrow) colnames(basemtr) <- names(mtr) for(u in 1:ncol(basemtr)) { basemtr[1:length(mtr[[u]]),u] <- mtr[[u]] } tmp = as.integer(basemtr) tmp[tmp >= 10 & !is.na(tmp)] = tmp[tmp >= 10 & !is.na(tmp)] / 10 basemtr = matrix(as.integer(basemtr[order(tmp), ]) , ncol = nrow(mtr), nrow = maxrow) colnames(basemtr) = names(mtr) ## if new collections are available, ## add additional rows to 'MODIScollection' if (nrow(MODIScollection) < maxrow & nrow(MODIScollection) > 0) { new_rows <- matrix(data = NA, nrow = maxrow-nrow(MODIScollection), ncol = ncol(MODIScollection)) new_rows <- data.frame(new_rows) names(new_rows) <- names(MODIScollection) MODIScollection <- rbind(MODIScollection, new_rows) } if (ncol(MODIScollection)==0) { # relevant only for time MODIScollection <- data.frame(basemtr) # create new } else { # or update the available one MODIScollection[, colnames(basemtr)] = basemtr } } } } #write.table(MODIScollection,file.path(opts$auxPath,"collections",fsep="/")) ind <- which(colnames(MODIScollection)%in%productN$PRODUCT) if(length(ind)==1) { res <- list(MODIScollection[,ind]) names(res) <- colnames(MODIScollection)[ind] } else if (length(ind)>1) { res <- as.list(MODIScollection[,ind]) } else { stop("No data available, check product input?") # should not happen getProduct() should catch that before } res <- lapply(res, function(x){as.numeric(as.character(x[!is.na(x)]))}) if (!is.null(collection)) { # if collection is provided...return formatted collection or 'FALSE' isOk <- lapply(res,function(x) { if (as.numeric(collection) %in% x) { as.numeric(collection) } else { FALSE } }) if (sum(isOk==FALSE)==length(isOk)) { cat("Product(s) not available in collection '",collection,"'. Try 'getCollection('",productN$request,"',newest=FALSE,forceCheck=TRUE)'\n",sep="") return(invisible(isOk)) } else if (sum(isOk==FALSE)>0 & sum(isOk==FALSE)