# 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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.