Nothing
# Author: Matteo Mattiuzzi, Anja Klisch, matteo.mattiuzzi@boku.ac.at
# Date : July 2011
# Licence GPL v3
getHdf <- function(product, begin=NULL, end=NULL, tileH=NULL, tileV=NULL, extent=NULL, collection=NULL, HdfName, quiet=FALSE, wait=0.5, checkIntegrity=FALSE,...)
{
# product="MOD13Q1"; begin="2010001"; end="2010005"; tileH=NULL; tileV=NULL; extent=NULL; collection=NULL; quiet=FALSE; wait=0.5; checkIntegrity=FALSE; z=1;u=1
opts <- combineOptions(...)
sturheit <- stubborn(level=opts$stubbornness)
wait <- as.numeric(wait)
# TODO HdfName as regex
if (!missing(HdfName))
{
HdfName <- unlist(HdfName)
dates <- list()
for (i in seq_along(HdfName))
{
HdfName[i] <- basename(HdfName[i]) # separate name from path
path <- genString(HdfName[i],...)
path$localPath <- setPath(path$localPath)
if (!file.exists(paste0(path$localPath,"/",HdfName[i])))
{
ModisFileDownloader(HdfName[i],quiet=quiet,...)
}
if(checkIntegrity)
{
doCheckIntegrity(HdfName[i], quiet=quiet,...)
}
dates[[i]] <- paste0(path$local,"/",HdfName[i])
}
return(invisible(unlist(dates)))
} else
{ # if HdfName isn't provided:
if (missing(product))
{
stop("Please provide the supported-'product'. See in: 'getProduct()'")
}
#######
# check product
product <- getProduct(x=product,quiet=TRUE)
# check if missing collection, else bilieve it
if(is.null(collection))
{
product$CCC <- getCollection(product=product,collection=collection,quiet=TRUE)[[1]]
} else
{
product$CCC <- sprintf("%03d",as.numeric(unlist(collection)[1]))
}
#########
if (product$SENSOR[1]=="MODIS")
{
if (is.null(begin))
{
cat("No begin(-date) set, getting data from the beginning\n")
}
if (is.null(end))
{
cat("No end(-date) set, getting data up to the most actual\n")
}
# tranform dates
tLimits <- transDate(begin=begin,end=end)
} else if (product$SENSOR=="C-Band-RADAR")
{
if (!is.null(tileH) & !is.null(tileV))
{
tileID <- getTile(tileH=tileH,tileV=tileV,system="SRTM")$tile
} else
{
tileID <- getTile(extent=extent,system="SRTM")$tile
}
ntiles <- length(tileID)
ntiles <- length(tileID)
path <- genString("SRTM")
files <- paste0("srtm",tileID,".zip")
dir.create(path$localPath,showWarnings=FALSE,recursive=TRUE)
if (!file.exists(paste(path$localPath,"meta.zip",sep="/")))
{
cat("Getting SRTM metadata from: ftp://xftp.jrc.it\nThis is done once (the metadata is not used at the moment!)\n")
download.file("ftp://xftp.jrc.it/pub/srtmV4/SRTM_META/meta.zip",paste(path$localPath,"meta.zip",sep="/"),
mode='wb', method=opts$dlmethod, quiet=quiet, cacheOK=TRUE)
}
if (!file.exists(paste(path$localPath,".SRTM_sizes",sep="/")))
{
if (! require(RCurl))
{
stop("You need to install the 'RCurl' package: install.packages('RCurl')")
}
sizes <- getURL(paste0(path$remotePath[[1]],"/"))
sizes <- strsplit(sizes, if(.Platform$OS.type=="unix"){"\n"} else{"\r\n"})[[1]]
sizes <- sapply(sizes,function(x){x <- strsplit(x," ")[[1]];paste(x[length(x)],x[length(x)-5],sep=" ")})
names(sizes) <- NULL
write.table(sizes,paste(path$localPath,".SRTM_sizes",sep="/"),quote=FALSE,row.names=FALSE,col.names=FALSE)
}
sizes <- read.table(paste(path$localPath,".SRTM_sizes",sep="/"))
files <- files[files %in% sizes[,1]] # remove Tiles that are not on the server
startIND <- 1:length(path$remotePath) # for better cycling over the servers
startIND <- rep(startIND,length(files))
cat("Be avare, that sources for SRTM data have limited the number of requests!\nNormally it suspends the download, and after a while it continues. So may you have to be patient!\n")
for(d in seq_along(files))
{
isOK <- TRUE
if (file.exists(paste0(path$localPath,"/",files[d])))
{
isOK <- checksizefun(file=paste0(path$localPath,"/",files[d]),sizeInfo=sizes,flexB=50000)$isOK # flexB!
}
if (!file.exists(paste0(path$localPath,"/",files[d]))| !isOK)
{
timeout <- options("timeout") # TEST I'm not sure if it helps (timeout is used in ?download.file)
options(timeout=15)
for(g in 1:sturheit)
{
server <- names(path$remotePath)[rep(startIND[d:(d+length(path$remotePath)-1)],length=sturheit)]
cat("Getting SRTM data from:",server[g],"\n")
Sys.sleep(wait)
hdf=1
try(
hdf <- download.file(
paste0(path$remotePath[[server[g]]],"/", files[d]),
destfile=paste0(path$localPath,"/", files[d]),
mode='wb', method=opts$dlmethod, quiet=quiet, cacheOK=TRUE),
silent=TRUE
)
if (hdf==0)
{
SizeCheck <- checksizefun(file=paste0(path$localPath,"/", files[d]),sizeInfo=sizes,flexB=50000)
if(!SizeCheck$isOK) {hdf=1} # if size check fails, re-try!
}
if(hdf==0 & !quiet)
{
lastused <- server[g]
if (g==1)
{
cat("Downloaded by the first try!\n\n")
} else
{
cat("Downloaded after",g,"retries!\n\n")
}
}
if(hdf==0)
{
break
}
}
options(timeout=as.numeric(timeout)) # set timeout back to default
}
}
SRTM <- paste0(path$localPath,"/",files)
return(invisible(SRTM))
}
dates <- list()
output <- list() # path info for the invisible output
l=0
for(z in seq_along(product$PRODUCT))
{ # Platforms MOD/MYD
if (product$TYPE[z]=="Swath")
{
cat("'Swath'-products not yet supported, jumping to the next.\n")
} else
{
todo <- paste0(product$PRODUCT[z],".",product$CCC)
for (u in seq_along(todo))
{
# tileID
if (product$TYPE[z]=="CMG")
{
tileID="GLOBAL"
ntiles=1
} else
{
if (!is.null(tileH) & !is.null(tileV))
{
extent <- getTile(tileH=tileH,tileV=tileV)
} else
{
extent <- getTile(extent=extent)
}
tileID <- extent$tile
ntiles <- length(tileID)
}
onlineInfo <- getStruc(product=product$PRODUCT[z],collection=product$CCC,server=opts$MODISserverOrder[1],begin=tLimits$begin,end=tLimits$end,wait=0)
if(!is.na(onlineInfo$online))
{
if (!onlineInfo$online & length(opts$MODISserverOrder)==2)
{
cat(opts$MODISserverOrder[1]," seams not online, trying on '",opts$MODISserverOrder[2],"':\n",sep="")
onlineInfo <- getStruc(product=product$PRODUCT[z],collection=product$CCC,begin=tLimits$begin,end=tLimits$end,wait=0,server=opts$MODISserverOrder[2])
}
if(is.null(onlineInfo$dates))
{
stop("Could not connect to server(s), and no data is available offline!\n")
}
if(!is.na(onlineInfo$online))
{
if(!onlineInfo$online)
{
cat("Could not connect to server(s), data download disabled!\n")
}
}
}
datedirs <- as.Date(onlineInfo$dates)
datedirs <- datedirs[!is.na(datedirs)]
sel <- datedirs
us <- sel >= tLimits$begin & sel <= tLimits$end
if (sum(us,na.rm=TRUE)>0)
{
suboutput <- list()
l=l+1
dates[[l]] <- datedirs[us]
dates[[l]] <- cbind(as.character(dates[[l]]),matrix(rep(NA, length(dates[[l]])*ntiles),ncol=ntiles,nrow=length(dates[[l]])))
colnames(dates[[l]]) <- c("date",tileID)
for (i in 1:nrow(dates[[l]]))
{ # i=1
#cat(dates[[l]][i,1],"\n")
#flush.console()
year <- format(as.Date(dates[[l]][i,1]), "%Y")
doy <- as.integer(format(as.Date(dates[[l]][i,1]), "%j"))
doy <- sprintf("%03d",doy)
mtr <- rep(1,ntiles) # for file availability flaging
path <- genString(x=strsplit(todo[u],"\\.")[[1]][1],collection=strsplit(todo[u],"\\.")[[1]][2],date=dates[[l]][i,1])
for(j in 1:ntiles)
{
dates[[l]][i,j+1] <- paste0(strsplit(todo[u],"\\.")[[1]][1],".",paste0("A",year,doy),".",if (tileID[j]!="GLOBAL") {paste0(tileID[j],".")},strsplit(todo[u],"\\.")[[1]][2],".*.hdf$") # create pattern
if (length(dir(path$localPath,pattern=dates[[l]][i,j+1]))>0)
{ # if available locally
HDF <- dir(path$localPath,pattern=dates[[l]][i,j+1]) # extract HDF file
if (length(HDF)>1)
{ # in very recent files sometimes there is more than 1 file/tile/date if so get the most recent processing date
select <- list()
for (d in 1:length(HDF))
{
select[[d]]<- strsplit(HDF[d],"\\.")[[1]][5]
}
HDF <- HDF[which.max(unlist(select))]
}
dates[[l]][i,j+1] <- HDF
mtr[j] <- 0
}
}
if (sum(mtr)!=0 & (onlineInfo$online | is.na(onlineInfo$online)))
{ # if one or more of the tiles in the given date is missing, its necessary to go online
if(exists("ftpfiles"))
{
rm(ftpfiles)
}
if (!require(RCurl))
{
stop("You need to install the 'RCurl' package: install.packages('RCurl')")
}
for (g in 1:sturheit)
{ # get list of FILES in remote dir
# server <- names(path$remotePath)[g%%length(path$remotePath)+1]
ftpfiles <- try(filesUrl(path$remotePath[[which(names(path$remotePath)==onlineInfo$source)]]),silent=TRUE)
if(ftpfiles[1]==FALSE)
{
rm(ftpfiles)
}
if(exists("ftpfiles"))
{
break
}
Sys.sleep(wait)
}
if(!exists("ftpfiles"))
{
stop("Problems with online connections try a little later")
}
if (ftpfiles[1] != "total 0")
{
ftpfiles <- unlist(lapply(strsplit(ftpfiles," "),function(x){x[length(x)]})) # found empty dir!
for(j in 1:ntiles)
{ # j=1
if(mtr[j]==1)
{ # if tile is missing get it
onFtp <- grep(ftpfiles,pattern=dates[[l]][i,j+1],value=TRUE)
HDF <- grep(onFtp,pattern=".hdf$",value=TRUE)
if(length(HDF)>0)
{
if (length(HDF)>1)
{ # in very recent files sometimes there is more than 1 file/tile/date if so get the last
select <- list()
for (d in seq_along(HDF))
{
select[[d]] <- strsplit(HDF[d],"\\.")[[1]][5]
}
HDF <- HDF[which.max(unlist(select))]
}
dates[[l]][i,j+1] <- HDF
hdf <- ModisFileDownloader(HDF, wait=wait, quiet=quiet)
mtr[j] <- hdf
} else
{
dates[[l]][i,j+1] <- NA
}
}
}
} else
{
dates[[l]][i,(j+1):ncol(dates[[l]])] <- NA
} # on ftp is possible to find empty folders!
}
if(checkIntegrity)
{ # after each 'i' do the sizeCheck
isIn <- doCheckIntegrity(paste0(path$localPath,dates[[l]][i,-1]), wait=wait, quiet=quiet,...)
}
suboutput[[i]] <- paste0(path$localPath,dates[[l]][i,-1])
} # end i
output[[l]] <- as.character(unlist(suboutput))
names(output)[l] <- todo[u]
} else
{
cat(paste0("No files on ftp in date range for: ",todo[u],"\n\n"))
}
}
}
}
return(invisible(output))
}
} ## END: FTP vs ARC check and download
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.