obpgtools: obpgtools for Ocean Biology Processing Group

#' Retrieve the base use for different services
#'
#' @export
#' @param service character - either 'opendap' or 'direct'
#' @return character base uri
obpg_base_uri <- function(service = c("opendap", 'direct')[1]){
    switch(tolower(service[1]),
        'opendap'   = "https://oceandata.sci.gsfc.nasa.gov:443/opendap",
        'direct'    = 'https://oceandata.sci.gsfc.nasa.gov/cgi/getfile',
        NULL)
}

#' Precompute direct download URLs
#'
#' Keep in mind that just because we can mock-up an OPeNDAP URI doesn't mean
#' that OBPG actually has that resource.
#'
#' @export
#' @param patterns character vector of one or more filename patterns
#' @param dates  vector of one or more Date or POSIXct objects
#' @param base_uri character base uri
#' @param platform character, defaults to 'MODISA'
#' @param product  character, defaults to 'L3SMI' - ignored but left to match \code{opendap_uri()}
#' @return character vector of URI
direct_uri <- function(
    patterns =  c(
        chlor_a = "L3m_DAY_CHL_chlor_a_4km.nc",
        par = "L3m_DAY_PAR_par_4km.nc",
        pic = "L3m_DAY_PIC_pic_4km.nc",
        poc = "L3m_DAY_POC_poc_4km.nc",
        sst = "L3m_DAY_SST_sst_4km.nc"),
    dates    = Sys.Date(),
    base_uri = obpg_base_uri("direct"),
    platform = 'MODISA',
    product  = 'L3SMI'){
    # https://oceandata.sci.gsfc.nasa.gov/cgi/getfile/A2015004.L3m_DAY_CHL_chlor_a_9km.nc
    if (FALSE){
         patterns =  c(
            chlor_a = "L3m_DAY_CHL_chlor_a_4km.nc",
            par = "L3m_DAY_PAR_par_4km.nc",
            pic = "L3m_DAY_PIC_pic_4km.nc",
            poc = "L3m_DAY_POC_poc_4km.nc",
            sst = "L3m_DAY_SST_sst_4km.nc")
        dates    = Sys.Date()
        base_uri = 'https://oceandata.sci.gsfc.nasa.gov/cgi/getfile'
        platform = 'MODISA'
        product  = 'L3SMI'
    }

    prod_code <- switch(platform[1],
        'MODISA' = 'A',
        'MODIST' = 'T',
        'SeaWiFS'= 'S',
        'VIRRS'  = 'V')

    roll = "0"
    if (grepl("R32", patterns[[1]], fixed = TRUE)) roll = "32"
    if (grepl("8D", patterns[[1]], fixed = TRUE)) roll = "8"

    daterange <- function(date, n = 32){
        date2 = date + as.numeric(n) - 1
        d1 = format(date, '%Y%j')
        d2 = format(date2, '%Y%j')
        paste0(d1, d2, ".")
    }


    yeardoy = switch(roll,
        "0" = format(dates, paste0(prod_code, "%Y%j.")),
        "32" = format(dates, paste0(prod_code, daterange(dates,n = 32))),
        "8" = format(dates, paste0(prod_code, daterange(dates,n = 8)))
        )




    baseuri     = file.path(base_uri[1], yeardoy)

    uri    = unlist(lapply(baseuri,  paste0,  patterns), recursive = TRUE)

    uri

}

#' Precompute OPeNDAP URLs.
#'
#' Keep in mind that just because we can mock-up an OPeNDAP URI doesn't mean
#' that OBPG actually has that resource.
#'
#' @export
#' @param patterns character vector of one or more filename patterns
#' @param dates  vector of one or more Date or POSIXct objects
#' @param base_uri character base uri
#' @param platform character, defaults to 'MODISA'
#' @param product  character, defaults to 'L3SMI'
#' @return character vector of URI
opendap_uri <- function(
    patterns =  c(
        chlor_a = "L3m_DAY_CHL_chlor_a_4km.nc",
        par = "L3m_DAY_PAR_par_4km.nc",
        pic = "L3m_DAY_PIC_pic_4km.nc",
        poc = "L3m_DAY_POC_poc_4km.nc",
        sst = "L3m_DAY_SST_sst_4km.nc"),
    dates    = Sys.Date(),
    base_uri = obpg_base_uri("opendap"),
    platform = 'MODISA',
    product  = 'L3SMI'){

    if (FALSE){
         patterns =  c(
            chlor_a = "L3m_DAY_CHL_chlor_a_4km.nc",
            par = "L3m_DAY_PAR_par_4km.nc",
            pic = "L3m_DAY_PIC_pic_4km.nc",
            poc = "L3m_DAY_POC_poc_4km.nc",
            sst = "L3m_DAY_SST_sst_4km.nc")
        dates    = Sys.Date()
        base_uri = obpg_base_uri("opendap")
        platform = 'MODISA'
        product  = 'L3SMI'
    }

    prod_code <- switch(platform[1],
        'MODISA' = 'A',
        'MODIST' = 'T',
        'SeaWiFS'= 'S',
        'VIRRS'  = 'V')

    roll = "0"
    if (grepl("R32", patterns[[1]], fixed = TRUE)) roll = "32"
    if (grepl("8D", patterns[[1]], fixed = TRUE)) roll = "8"

    daterange <- function(date, n = 32){
        date2 = date + as.numeric(n) - 1
        d1 = format(date, '%Y%j')
        d2 = format(date2, '%Y%j')
        paste0(d1, d2, ".")
    }


    yeardoy = switch(roll,
        "0" = format(dates, paste0("%Y/%j/", prod_code, "%Y%j.")),
        "32" = format(dates, paste0("%Y/%j/", prod_code, daterange(dates,n = 32))),
        "8" = format(dates, paste0("%Y/%j/", prod_code, daterange(dates,n = 8)))
        )

    baseuri     = file.path(base_uri[1], platform[1], product[1], yeardoy)

    uri    = unlist(lapply(baseuri,  paste0,  patterns), recursive = TRUE)

    uri

}



#' Retrieve MODISA files.  Saves rasters to obpg data directory.
#'
#' For big requests the OBPG can be problematic so repeated attempts may be required
#'
#' @export
#' @param uri character of OPENDAP URI - precomputed query result URIs or NULL
#' @param where character, the geographic name of the region
#' @param date_filter POSIXct dates (window, start, end, etc)
#' @param what character how to treat the date_filter (within, before, after)
#' @param bbox the bounding box for subsetting
#' @param overwrite logical, if TRUE then overwrite exisiting files
#' @param email character, if not 'none' then try to send and email at the end
#' @param greplargs named character vector - patterns to search for
#' @param voice rscritping::Logger object
#' @return NULL
obpg_fetch_DAY_thredds <- function(
    uri = NULL,
    where = c('native','gom', 'nwa')[2],
    date_filter = as.POSIXct(c("2015-01-01", "2017-07-21"), tz = 'UTC'),
    what = 'within',
    bbox = obpgtools::obpg_bb("gom"),
    overwrite = TRUE,
    email = "none",
    greplargs = c(
        chlor_a = "L3m_DAY_CHL_chlor_a_4km.nc",
        par = "L3m_DAY_PAR_par_4km.nc",
        pic = "L3m_DAY_PIC_pic_4km.nc",
        poc = "L3m_DAY_POC_poc_4km.nc",
        sst = "L3m_DAY_SST_sst_4km.nc"),
    voice = rscripting::Logger('obpg_fetch_DAY_thredds', filename = obpg_path("log"))){


    if (FALSE){
        where = c('native','gom')[2]
        date_filter = as.POSIXct(c("2015-01-01", "2017-07-21"), tz = 'UTC')
        what = 'within'
        bbox = obpgtools::obpg_bb("gom")
        overwrite = TRUE
        email = "none"
        greplargs = c(
            chlor_a = "L3m_DAY_CHL_chlor_a_4km.nc",
            par = "L3m_DAY_PAR_par_4km.nc",
            pic = "L3m_DAY_PIC_pic_4km.nc",
            poc = "L3m_DAY_POC_poc_4km.nc",
            sst = "L3m_DAY_SST_sst_4km.nc")
    }

    path <- obpg_path(where[1], "DAY")
    if (!dir.exists(path)){
        voice$error("path not found: %s", path)
        return(NULL)
    }

    # convert greplargs to a list
    greplargs_to_list <- function(x){
        lapply(x, function(x)list(pattern = x, fixed = TRUE))
    }

    # put the params in sort order - that's how they get returned from OBPG
    greplargs <- greplargs[order(names(greplargs))]


    if (is.null(uri)){
        # query
        voice$info("querying...")
        qry <- obpgcrawler::obpg_query(
            platform = 'MODISA',
            date_filter = date_filter, what = what,
            greplargs = greplargs_to_list(greplargs))

        voice$info("query yields %i items", length(qry))
        if (length(qry) <= 0) return(NULL)
        uri <- sapply(qry, function(x) x$url)
    }
    names(uri) <- basename(uri)

    # make sure the destination paths exist
    opaths <- file.path(obpg_path(), where[1], 'DAY', names(greplargs))
    names(opaths) <- names(greplargs)
    ok <- sapply(opaths, function(x){
            if (dir.exists(x)) TRUE else dir.create(x)
        })

    # gather the info about each query
    fi <- obpgtools::OBPGInfo(names(uri))

    ofiles <- sapply(fi,function(f) paste0(f$name, '.grd'))

    for (i in seq_along(uri)){
        param <- fi[[i]]$flavor
        name <- fi[[i]]$name
        #ofile <- file.path(opaths[param],paste0(name, '.grd'))
        ofile <- file.path(opaths[param], ofiles[i])
        if (overwrite || !file.exists(ofile) ){
            voice$info("THREDDS: Downloading: %s", name)
            X <- spnc::SPNC(uri[i])
            R <- obpg_extract(X, what = param, bb = bbox, ofile = ofile, overwrite = overwrite)
            X$close()
        } else {
            voice$info("Previously downloaded: %s", name)
        }
    }
    if (any(grepl("@", email, fixed = TRUE)))
        rscripting::sendmail(to = email,
            sbj = 'obpg_fetch_DAY_thredds', msg = 'done')
    decompose_obpg(ofiles)
}

#' Extract a region from an OBPG SPNC (specifically L3SMIRefCLass) or Raster object.
#'
#' @export
#' @param X raster or L3SMIRefClass object
#' @param what parameter name
#' @param bb NULL or optional 4 element bounding box
#' @param ofile character, optional filename to write to
#' @param modify logical if TRUE then returned will be modified with
#'      log10 scaling and or data range clipping as appropriate
#' @param overwrite logical if TRUE then overwrite existing files
#' @return NULL or RasterLayer
obpg_extract <- function(X, what = 'sst', bb = NULL, ofile = NULL, overwrite = TRUE, modify = TRUE){

    #stopifnot(inherits(X, 'L3SMIRefClass'))

    if (inherits(X, 'L3SMIRefClass')){
        r <- try(X$get_raster(what = what[1], bb = bb))

        if (inherits(r, 'try-error')) return(NULL)
        #filename <- X$NC$file
    } else {
        r <- raster::crop(X, bb)
        #filename <- raster::filename(r)
    }
    if (modify){
        #info <- OBPGInfo(filename)[[1]]
        rng <- suggested_range(what)
        scl <- suggested_scaling(what)
        if (scl == 'LOG') r <- log10(r)
        if (!is.null(rng)) r[ (r < rng[1]) | (r > rng[2]) ] <- NA
    }


    if (!is.null(ofile)) r <- raster::writeRaster(r, ofile, overwrite = overwrite[1])

    r
}


#' Retrieve MODISA files.  Saves rasters to obpg data directory.
#'
#' @export
#' @param where character, the geographic name of the region
#' @param date_filter POSIXct dates (window, start, end, etc)
#' @param what character how to treat the date_filter (within, before, after)
#' @param bbox the bounding box for subsetting
#' @param overwrite logical, if TRUE then overwrite exisiting files
#' @param params named character vector - patterns to search for
#' @param email character for optional notification or 'none' for no email
#' @param voice rscritping::Logger object
#' @return tibble database of new files or NULL
obpg_fetch_DAY_direct <- function(
    where = 'gom',
    date_filter = as.POSIXct(c("2015-01-01", "2016-12-31"), tz = 'UTC'),
    what = 'within',
    bbox = obpgtools::obpg_bb("gom"),
    overwrite = TRUE,
    email = 'none',
    params = c("chlor_a", "par", "pic", "poc", "sst"),
    voice = rscripting::Logger('obpg_fetch_DAY_direct', filename = obpg_path("log"))){

    if (FALSE){
        date_filter = as.POSIXct(c("2015-01-01", "2016-12-31"), tz = 'UTC')
        what = 'within'
        bbox = obpgtools::obpg_bb("gom")
        overwrite = TRUE
        params = c("chlor_a", "par", "pic", "poc", "sst")
        voice = rscripting::Logger('obpg_fetch_DAY_direct', filename = obpg_path("log"))
    }

    path <- obpg_path(where, "DAY")
    if (!dir.exists(path)){
        voice$error("path not found: %s", path)
        return(NULL)
    }

    # for each year
    #     for each param
    #         list the available
    #         for each needed day
    #             download to '/dev/shm/temp.nc'
    #             read as raster and crop to bb
    #             save to OBPG_PATH/gom/DAY
    #             delete '/dev/shm/temp.nc'
    # poc is POC in the html tables - hmmm

    res <- '4km'
    level <- 'Mapped'
    params_lut <- c(
        chlor_a = 'chlor_a',
        par = 'par',
        pic = 'pic',
        poc = 'POC',
        sst = 'sst')
    params_flag <- c(
        chlor_a = 'CHL',
        par = 'PAR',
        pic = 'PIC',
        poc = 'POC',
        sst = 'SST')

    dates <- seq(from = date_filter[1], to = date_filter[2], by = 'day')
    years <- format(dates, "%Y")
    days <- split(format(dates, "A%Y%j.L3m_DAY"), years)

    # make sure the output directories exist
    opaths <- file.path(path, params)

    ok <- sapply(opaths, function(x){
            if (dir.exists(x)) TRUE else dir.create(x)
        })
    names(opaths) <- params
    temp_path <- "/dev/shm/obpg"
    if (!file.exists(temp_path)) dir.create(temp_path, recursive = TRUE)
    ofiles <- character()
    for (y in names(days)){
        voice$info("year = %s", y)
        for (p in params){
            voice$info("query param: %s", p)
            x <- obpgcrawler::query_direct(mission = 'MODIS-Aqua', freq = "Daily",
                param = params_lut[p], level = 'Mapped', year = y)
            if (!is.null(x)){
                these <- sprintf("%s_%s_%s_%s.nc", days[[y]], params_flag[p], p, res[1])
                ix <- x[,'Filename'] %in% these
                if (any(ix)){
                    nm <- x[ix,'Filename']
                    for (n in nm){
                        voice$info("Direct: downloading %s", n)
                        temp_file <- file.path(temp_path, n)
                        ok <- obpgcrawler::download_direct(n, output_path = temp_path)
                        if (ok == 0){
                            ofile <- file.path(opaths[p], gsub(".nc", ".grd", n, fixed = TRUE))
                            #X <- try(spnc::SPNC(temp_file))
                            X <- try(raster::raster(temp_file, varname = p))
                            if (!inherits(X, 'try-error')){
                                r <- obpg_extract(X, what = p, bb = bbox, ofile = ofile, overwrite = overwrite)
                                if (!inherits(r, 'try-error')) {
                                    ofiles <- append(ofiles, basename(ofile))
                                } else {
                                    voice$error("Error saving raster: %s", ofile)
                                }
                            } else {
                                voice$error("Error invoking or raster SPNC class")
                            }

                        } else {
                            voice$error("Error downloading %s",n)
                        } # ok?
                        if (inherits(X, 'L3SMOIRefClass')) X$close()
                        ok <- system(paste("rm -rf", temp_file))
                    } # nm loop
                } # any ix?
            } # x not NULL?
        } # params loop
    }  # years loop
    ok <- system(paste("rm -rf", temp_path))

    if (any(grepl("@", email, fixed = TRUE)))
        rscripting::sendmail(to = email, sbj = 'obpg_fetch_DAY_direct', msg = 'done')
    decompose_obpg(ofiles)
}