R/obpginfo.R

# obpgtools::obpginfo


#' Returns a suggested display range for an obpginfo object
#'
#'
#' @export
#' @param x an \code{obpginfo} class list or character parameter name
#' @return a two element suggested display range
suggested_range <- function(x){

   r <- NULL
   if (inherits(x, 'character')){
      r <- switch(tolower(x),
        "sst"       = c(-2, 45),
        "ocx"       = c(0.00999999978,20.0000000),
        'chl'       = c(0.00999999978,20.0000000),
        "chlor_a"   = c(0.00999999978,20.0000000),
        "par"       = c(0.0, 76.1999969),
        "pic"       = c(9.99999975e-06, 0.0500000007),
        "poc"       = c(10.0, 1000.0),
         NULL)

   }  else if(inherits(x, "OBPGInfo"))
      r <- switch(tolower(x$param),
        "sst"   = c(-2, 45),
        "chl"   = switch(x$flavor,
                        "ocx" = c(0.00999999978,20.0000000),
                        "chlor_a" = c(0.00999999978,20.0000000)),
        "par"   = c(0.0, 76.1999969),
        "pic"   = c(9.99999975e-06, 0.0500000007),
        "poc"   = c(10.0, 1000.0),
         NULL)
    r
}


#' Returns a suggested display scaling for an obpginfo object
#'
#'
#' @export
#' @param x an \code{obpginfo} class list
#' @return character scaling suggestion (e.g. LINEAR, LOG)
suggested_scaling <- function(x){

    r <- 'LINEAR'
    if (inherits(x, 'character')){
        r <- switch(tolower(x),
            "chl" = 'LOG',
            'chlor_a' = 'LOG',
            'LINEAR')
    } else if (inherits(x, "OBPGInfo")) {
        r <- switch(tolower(x$param),
            "chl" = 'LOG',
            'chlor_a' = 'LOG',
            "LINEAR")
    }
    r
}


#' Return one or more parameter units
#'
#' @export
#' @param x character vector of known parameter names. If Missing then a list
#'    with all are returned.  Alternatively, the input may be a \code{obpginfo}
#'    class object.
#' @return named character vector of unitss
parameter_units <- function(x){
   lut <- c(
      CHL = "mg/m^3",
      RRS = "1/sr",
      Angstrom = "",
      aot = "",
      K490 = "m^-1",
      CDOM = "",
      PIC = "mol/m^3",
      POC = "mg/m^3",
      PAR = "Einstein/(m^2 %*% day)",
      NFLH = "mW/(cm^2 %*% um %*% sr)",
      SST = "C*degree",
      SSS = "PSU")

   if (!missing(x)){
      if (inherits(x, "OBPGInfoRefCLass")){
         lut <- lut[x$param]
      } else {
         lut <- lut[x]
      }
   }
   lut
}


#' Returns a named list of known platform codes
#'
#' @export
#' @return a named character vector of platform codes
platform_codes <- function(){
   c(
      "SeaWiFS"      = "S",
      "Aqua MODIS"   = "A",
      "Terra MODIS"  = "T",
      "OCTS"         = "O",
      "CZCS"         = "C",
      "OCM2"         = "O2_",
      "VIIRS"        = "V",
      "Aquarius"     = "Q"
   )
}


#' Return a list of known period codes
#'
#' @export
#' @return a named cahracter vector of period codes
period_codes <- function(){
   c(
      "Daily"                 = "DAY",
      "8-Day"                 = "8D",
      "Monthly"               = "MO",
      "Seasonal autumn"       = "SNAU",
      "Seasonal winter"       = "SNWI",
      "Seasonal spring"       = "SNSP",
      "Seasonal summer"       = "SNSU",
      "Yearly"                = "YR",
      "32-Day rolling mean"   = "R32",
      "3-Day rolling mean"    = "R3QL",
      "Monthly climatology"   = "MC",
      "Seasonal climatology summer"    = "SCSU",
      "Seasonal climatology autumn"    = "SCAU",
      "Seasonal climatology winter"    = "SCWI",
      "Seasonal climatology spring"    = "SCSP",
      "Mission composite"     = "CU"
      )
}

#' Convert a string to a obpginfo class structure
#'
#' @export
#' @seealso \href{http://oceancolor.gsfc.nasa.gov/cms/}{Ocean Color Web}
#' @param x character - one or more OBPG filename or obpginfo class object
#' @return returns a list of \code{obpginfo} class object(s),
#' possibly the same as the input if obpginfo objects are provided,
#' Each element is a \code{obpginfo} object which is a list as shown below or is
#' NULL if there is an issue.
#' \describe{
#'    \item{filename}{orginal file name, may include path if provided}
#'    \item{name}{basename sans extension(s) if any}
#'    \item{id}{just the platform and dates}
#'    \item{platform}{platform code such as "A"}
#'    \item{product}{product code such as "L3m"}
#'    \item{period}{period code such as "DAY" or "MO"}
#'    \item{param}{geophysical parameter code such as "SST"}
#'    \item{flavor}{specific info regarding \code{param}"}
#'    \item{res}{resolution code such as "4km" or "9km"}
#'    \item{dates}{Date start and end dates for the period, for period "DAY" these are the same}
#'    }
parse_obpginfo <- function(x = "A20021612002192.L3m_R32_SST_sst_9km.foo"){

   # the engine - runs one filename or obpginfo object
   obpginfo_one <- function(x){
      if (inherits(x, "OBPGInfo")) return(x)
      if (!inherits(x, "character")) return(NULL)
      name <- basename(x)
      platform <- substring(name, 1,1)
      pcodes <- platform_codes()
      ix <- platform %in% pcodes
      if (!any(ix)) {
         cat(sprintf("platform %s not known, should be one of %s",
            platform, paste(unname(pcodes), collapse = "")) )
         return(NULL)
      }
      ss <- strsplit(name, ".", fixed = TRUE)[[1]]
      stamp <- ss[1]
      name <- paste(ss[1:2], collapse = ".")
      id <- ss[1]
      nid <- nchar(id)

      dates <- if (nid == 15){   # A1234ddd1234ddd
         c(substring(id, 2, 2+7-1), substring(id, 9, 9+7-1))
      } else if (nid == 8){      # A1234dd
         rep(substring(id, 2, 2+7-1),2)
      } else if (nid == 11){ #A123412341ww
         y1 <- substring(id, 2, 5)
         y2 <- substring(id, 6,9)
         ww <- as.numeric(substring(id, 10, 11)) * 8 - 7
         dates <- c(sprintf("%s%0.3i", y1, ww), sprintf("%s%0.3i", y2, ww))
      } else {
         cat(sprintf("date format not known: %s\n", id))
         return(NULL)
      }


      s2 <- strsplit(ss[2], "_", fixed = TRUE)[[1]]
      ns2 <- length(s2)

      period <- s2[2]
      pcodes <- period_codes()
      if (!any(period %in% pcodes)){
         stop(sprintf("period %s not known, should be one of %s",
            period, paste(unname(pcodes), collapse = "")) )
      }
      flavor <- if (ns2 > 4) {
            paste(s2[4:(ns2-1)], collapse = "_")
         } else {
            ""
         }

      structure(list(
         filename = x, # the input
         name = name, # filename, etc
         id = id,
         platform = platform, # "A", "T", etc
         product = s2[1], # "L3SMI", etc
         period = s2[2], # "R32", "DAY", etc
         param = s2[3], # SST, "CHL", etc
         flavor = paste(s2[4:(length(s2)-1)], collapse = "_"), # "sst", "chlor_a", etc
         res = s2[ns2], # 9km, 4km, etc
         #dates = as.POSIXct(dates, format = "%Y%j", tz = "UTC")),  # start,end (may be the same)
         dates = as.Date(dates, format = "%Y%j")),
         class = "OBPGInfo")
   } #obpginfo_one

   r <- lapply(x, obpginfo_one)
   # try to name them sensibly
   names(r) <- sapply(r, function(x) if (!is.null(x)) x$name else "")
   class(r) <- "OBPGInfoList"
   r
}


#' Print an OBPGInfo object
#'
#' @export
#' @param x OBPGInfo object
#' @param ... further argument
print.OBPGInfo <- function(x, ...){
   cat(sprintf("filename: %s\n", x$filename))
   cat(sprintf("name: %s\n", x$name))
   cat(sprintf("id: %s\n", x$id))
   cat(sprintf("platform: %s   product: %s   period: %s\n", x$platform, x$product, x$period))
   cat(sprintf("param: %s   flavor: %s   res: %s\n", x$param, x$flavor, x$res))
   fdate <- format(x$dates, "%Y-%m-%d")
   if (!identical(x$dates[1], x$dates[2])){
      cat(sprintf("dates: %s to %s\n", fdate[1], fdate[2]))
   } else {
      cat(sprintf("date: %s\n", fdate[1]))
   }
}


#' Get one or more 8D week numbers (1-46)
#' @export
#' @param x OBPGInfo object
#' @param what character 'first', 'last' or 'both' (the default)
#' @return numeric week number
get_weeks <- function(x, what = c("first", "last", "both")[3]) UseMethod("get_weeks")


#' Get one or more weeks
#'
#' @export
#' @param x OBPGInfo object
#' @param what character 'first', 'last' or 'both' (the default)
#' @return numeric week number
get_weeks.default <- function(x, what = c("first", "last", "both")[3]){
   if ("dates" %in% names(x)) {
      r <- as.numeric(format(x$dates, "%j"))
      r <- findInterval(r, eight_days())
      r <- switch(tolower(what[1]),
         "first" = r[1],
         "last" = r[2],
         r)
   } else {
      r <- NULL
   }
   return(r)
}

#' Get one or more weeks
#'
#' @export
#' @param x OBPGInfo object
#' @param what character 'first', 'last' or 'both' (the default)
#' @return numeric week number
get_weeks.OBPFInfo <- function(x, what = c("first", "last", "both")[3]){
   if ("dates" %in% names(x)) {
      r <- as.numeric(format(x$dates, "%j"))
      r <- findInterval(r, eight_days())
      r <- switch(tolower(what[1]),
         "first" = r[1],
         "last" = r[2],
         r)
   } else {
      r <- NULL
   }
   return(r)
}

#' Get one or more weeks
#'
#' @export
#' @param x OBPGInfoList object
#' @param what character 'first', 'last' or 'both' (the default)
#' @return either POSIXct or character
get_weeks.OBPGInfoList <- function(x,what = c("first", "last", "both")[3]){
   sapply(x, get_weeks.default, what = what)
}


#' Get one or more dates
#'
#' @export
#' @param x OBPGInfo or OBPGInfoList object
#' @param format character, by default 'POSIXct', but any format code is permitted
#' @param what character 'first', 'last' or 'both' (the default)
#' @return either POSIXct or character
get_dates <- function(x, format = 'POSIXct', what = c("first", "last", "both")[3]) UseMethod('get_dates')

#' Get one or more dates
#'
#' @export
#' @param x OBPGInfo object
#' @param format character, by default 'POSIXct', but any format code is permitted
#' @param what character 'first', 'last' or 'both' (the default)
#' @return either POSIXct or character
get_dates.default <- function(x, format = 'POSIXct', what = c("first", "last", "both")[3]){
   if ("dates" %in% names(x)) {
      r <- x$dates
   } else {
      r <- NULL
   }
   return(r)
}


#' Get one or more dates
#'
#' @export
#' @param x OBPGInfo object
#' @param format character, 'Date' (default) 'POSIXct', but any format code is permitted
#' @param what character 'first', 'last' or 'both' (the default)
#' @return either Date, POSIXct or character
get_dates.OBPGInfo <- function(x,
   format = c('Date','POSIXct')[1],
   what = c("first", "last", "both")[3]){
      y <- switch(format,
         'Date'  = x$dates,
         'POSIXct' = x$dates,
         format(x$dates, format))
      switch(tolower(what),
         'both' = y,
         'first' = y[1],
         y[2])
}


#' Get one or more dates of OPBGInfo elements of a OBPGInfoList object
#'
#' @export
#' @param x OBPGInfoList objects
#' @param format character, by default 'POSIXct', but any format code is permitted
#' @param what character 'first', 'last' or 'both' (the default)
#' @return list of dates as per format and what
get_dates.OBPGInfoList = function(x,
   format = c("Date",'POSIXct')[1],
   what = c("first", "last", "both")[3]){
      r <- lapply(x, get_dates.OBPGInfo, format = format, what = what)
      if (format == 'POSIXct' && !inherits(r[[1]], 'POSIXct') ) {
         r <- lapply(r, as.POSIXct, origin = as.POSIXct("1970-01-01 00:00:00", tz = "UTC"))
      }
      r
}


#' Convert a character to a OBPGInfoList object
#'
#' @export
#' @seealso \href{http://oceancolor.gsfc.nasa.gov/cms/}{Ocean Color Web}
#' @param x character - one or more OBPG filenames
#' @return \code{OBPInfoList} class object with one or more \code{OBPGInfo} class
#' objects each of which has the following fields.
#'
#' \describe{
#'    \item{filename}{orginal file name, may include path if provided}
#'    \item{name}{basename sans extension(s) if any}
#'    \item{platform}{platform code such as "A"}
#'    \item{product}{product code such as "L3m"}
#'    \item{period}{period code such as "DAY" or "MO"}
#'    \item{param}{geophysical parameter code such as "SST"}
#'    \item{flavor}{specific info regarding \code{param}"}
#'    \item{res}{resolution code such as "4km" or "9km"}
#'    \item{dates}{Date start and end dates for the period, for period "DAY" these are the same}
#'    }
OBPGInfo <- function(x) {
   parse_obpginfo(x)
}
btupper/obpgtools documentation built on May 13, 2019, 8:42 a.m.