added storm fxns, ropensci#57

NAMESPACE

@@ -2,6 +2,17 @@
 
 S3method(ncdc_plot,ncdc_data)
 S3method(print,erddap_search)
+S3method(print,storm_data)
+S3method(type_sum,Date)
+S3method(type_sum,POSIXt)
+S3method(type_sum,array)
+S3method(type_sum,character)
+S3method(type_sum,default)
+S3method(type_sum,factor)
+S3method(type_sum,integer)
+S3method(type_sum,logical)
+S3method(type_sum,matrix)
+S3method(type_sum,numeric)
 export(erddap_data)
 export(erddap_info)
 export(erddap_search)
@@ -38,9 +49,12 @@ export(noaa_stations)
 export(readshpfile)
 export(seaice)
 export(seaiceeurls)
+export(storm_data)
+export(storm_meta)
 export(swdi)
 export(theme_ice)
 export(tornadoes)
+export(type_sum)
 import(XML)
 import(assertthat)
 import(ggplot2)

R/storms.R

@@ -0,0 +1,94 @@
+#' Get NOAA wind storm data from International Best Track Archive for Climate Stewardship (IBTrACS)
+#' 
+#' @export
+#' 
+#' @param basin (character) A basin name, one of EP, NA, NI, SA, SI, SP, or WP.
+#' @param storm (character) A storm serial number of the form YYYYJJJHTTNNN. See Details.
+#' @param year (numeric) One of the years from 1842 to 2014
+#' @param path (character) A path to store the files, Default: \code{~/.rnoaa/storms}
+#' @param overwrite (logical) To overwrite the path to store files in or not, Default: TRUE.
+#' 
+#' @details Details for storm serial numbers:
+#' \itemize{
+#'  \item YYYY is the corresponding year of the first recorded observation of the storm
+#'  \item JJJ is the day of year of the first recorded observation of the storm
+#'  \item H is the hemisphere of the storm: N=Northern, S=Southern
+#'  \item TT is the absolute value of the rounded latitude of the first recorded observation of the 
+#'  storm (range 0-90, if basin=SA or SH, then TT in reality is negative)
+#'  \item NNN is the rounded longitude of the first recorded observation of the storm (range 0-359)
+#' } 
+#' 
+#' For example: \code{1970143N19091} is a storm in the North Atlantic which started on 
+#' May 23, 1970 near 19°N 91°E
+#' 
+#' See \url{http://www.ncdc.noaa.gov/ibtracs/index.php?name=numbering} for more.
+#'
+#' @examples \donttest{
+#' storm_data(basin='WP')
+#' storm_data(storm='1970143N19091')
+#' storm_data(year=1940)
+#' storm_data(year=1941)
+#' storm_data(year=2010)
+#' 
+#' # Or get all data, simply don't specify a value for basin, storm, or year
+#' res <- storm_data(read=FALSE) # just get path
+#' head()
+#' }
+
+storm_data <- function(basin=NULL, storm=NULL, year=NULL, path="~/.rnoaa/storms", 
+                       overwrite = TRUE, read = TRUE){
+
+  csvpath <- csv_local(basin, storm, year, path)
+  if(!is_storm(x = csvpath)){
+    csvpath <- storm_GET(path, basin, storm, year, overwrite)
+  }
+  message(sprintf("<path>%s", csvpath), "\n")
+  structure(list(data=read_csv(csvpath)), class="storm_data")
+}
+
+#' @export 
+print.storm_data <- function(x, ..., n = 10){
+  cat("<NOAA Storm Data>", sep = "\n")
+  cat(sprintf("Size: %s X %s\n", NROW(x$data), NCOL(x$data)), sep = "\n")
+  trunc_mat(x$data, n = n)
+}
+
+storm_GET <- function(bp, basin, storm, year, overwrite){
+  dir.create(csv_local_base(basin, storm, year, bp), showWarnings = FALSE, recursive = TRUE)
+  fp <- csv_local(basin, storm, year, bp)
+  res <- suppressWarnings(GET(csv_remote(basin, storm, year), write_disk(fp, overwrite)))
+  res$request$writer[[1]]
+}
+
+filecheck <- function(basin, storm, year){
+  tmp <- noaa_compact(list(basin=basin, storm=storm, year=year))
+  if(length(tmp) > 1) stop("You can only supply one or more of basin, storm, or year")
+  if(length(tmp) == 0) list(all="Allstorms") else tmp
+}
+
+filepath <- function(basin, storm, year){
+  tmp <- filecheck(basin, storm, year)
+  switch(names(tmp),
+         all = 'Allstorms',
+         basin = sprintf('basin/Basin.%s', tmp[[1]]),
+         storm = sprintf('storm/Storm.%s', tmp[[1]]),
+         year = sprintf('year/Year.%s', tmp[[1]])
+  )
+}
+
+fileext <- function(basin, storm, year){
+  tt <- filepath(basin, storm, year)
+  if(grepl("Allstorms", tt)) paste0(tt, '.ibtracs_all.v03r06.csv.gz') else paste0(tt, '.ibtracs_all.v03r06.csv')  
+}
+
+csv_remote <- function(basin, storm, year) file.path(stormurl(), fileext(basin, storm, year))
+csv_local <- function(basin, storm, year, path) file.path(path, fileext(basin, storm, year))
+
+csv_local_base <- function(basin, storm, year, path){
+  tt <- filecheck(basin, storm, year)
+  if(names(tt)=="all") path else file.path(path, names(tt))
+}
+
+is_storm <- function(x) if(file.exists(x)) TRUE else FALSE
+
+stormurl <- function(x = "csv") sprintf('ftp://eclipse.ncdc.noaa.gov/pub/ibtracs/v03r06/all/%s', x)

R/storms_meta.R

@@ -0,0 +1,14 @@
+#' Get NOAA wind storm metadata.
+#' 
+#' @export
+#'
+#' @examples \donttest{
+#' head( storm_meta() )
+#' head( storm_meta("storm_columns") )
+#' head( storm_meta("storm_names") )
+#' }
+
+storm_meta <- function(what="storm_columns")
+{
+  switch(what, storm_columns = storm_columns, storm_names = storm_names)
+}

R/tornadoes.R

@@ -10,7 +10,7 @@
 #' plot(shp) # may take 10 sec or so to render
 #' }
 
-tornadoes <- function(path="~/.tornadoes", overwrite = TRUE)
+tornadoes <- function(path="~/.rnoaa/tornadoes", overwrite = TRUE)
 {
   if(!is_tornadoes(path.expand(file.path(path, "tornadoes")))){
     url <- 'http://spc.noaa.gov/gis/svrgis/zipped/tornado.zip'

R/utils.r

@@ -0,0 +1,120 @@
+trunc_mat <- function(x, n = NULL){
+  rows <- nrow(x)
+  if (!is.na(rows) && rows == 0)
+    return()
+  if (is.null(n)) {
+    if (is.na(rows) || rows > 100) { n <- 10 }
+    else { n <- rows }
+  }
+  df <- as.data.frame(head(x, n))
+  if (nrow(df) == 0)
+    return()
+  #   is_list <- vapply(df, is.list, logical(1))
+  #   df[is_list] <- lapply(df[is_list], function(x) vapply(x, obj_type, character(1)))
+  mat <- format(df, justify = "left")
+  width <- getOption("width")
+  values <- c(format(rownames(mat))[[1]], unlist(mat[1, ]))
+  names <- c("", colnames(mat))
+  w <- pmax(nchar(values), nchar(names))
+  cumw <- cumsum(w + 1)
+  too_wide <- cumw[-1] > width
+  if (all(too_wide)) {
+    too_wide[1] <- FALSE
+    df[[1]] <- substr(df[[1]], 1, width)
+  }
+  shrunk <- format(df[, !too_wide, drop = FALSE])
+  needs_dots <- is.na(rows) || rows > n
+  if (needs_dots) {
+    dot_width <- pmin(w[-1][!too_wide], 3)
+    dots <- vapply(dot_width, function(i) paste(rep(".", i), collapse = ""), FUN.VALUE = character(1))
+    shrunk <- rbind(shrunk, .. = dots)
+  }
+  print(shrunk)
+  if (any(too_wide)) {
+    vars <- colnames(mat)[too_wide]
+    types <- vapply(df[too_wide], type_sum, character(1))
+    var_types <- paste0(vars, " (", types, ")", collapse = ", ")
+    cat(noaa_wrap("Variables not shown: ", var_types), "\n", sep = "")
+  }
+}
+
+noaa_wrap <- function (..., indent = 0, width = getOption("width")){
+  x <- paste0(..., collapse = "")
+  wrapped <- strwrap(x, indent = indent, exdent = indent + 5, width = width)
+  paste0(wrapped, collapse = "\n")
+}
+
+#' Type summary
+#' @export
+#' @keywords internal
+type_sum <- function (x) UseMethod("type_sum")
+
+#' @method type_sum default
+#' @export
+#' @rdname type_sum
+type_sum.default <- function (x) unname(abbreviate(class(x)[1], 4))
+
+#' @method type_sum character
+#' @export
+#' @rdname type_sum
+type_sum.character <- function (x) "chr"
+
+#' @method type_sum Date
+#' @export
+#' @rdname type_sum
+type_sum.Date <- function (x) "date"
+
+#' @method type_sum factor
+#' @export
+#' @rdname type_sum
+type_sum.factor <- function (x) "fctr"  
+
+#' @method type_sum integer
+#' @export
+#' @rdname type_sum
+type_sum.integer <- function (x) "int"
+
+#' @method type_sum logical
+#' @export
+#' @rdname type_sum
+type_sum.logical <- function (x) "lgl"
+
+#' @method type_sum array
+#' @export
+#' @rdname type_sum
+type_sum.array <- function (x){
+  paste0(NextMethod(), "[", paste0(dim(x), collapse = ","), 
+         "]")
+}
+
+#' @method type_sum matrix
+#' @export
+#' @rdname type_sum
+type_sum.matrix <- function (x){
+  paste0(NextMethod(), "[", paste0(dim(x), collapse = ","),
+         "]")
+}
+
+#' @method type_sum numeric
+#' @export
+#' @rdname type_sum
+type_sum.numeric <- function (x) "dbl"
+
+#' @method type_sum POSIXt
+#' @export
+#' @rdname type_sum
+type_sum.POSIXt <- function (x) "time"
+
+obj_type <- function (x)
+{
+  if (!is.object(x)) {
+    paste0("<", type_sum(x), if (!is.array(x))
+      paste0("[", length(x), "]"), ">")
+  }
+  else if (!isS4(x)) {
+    paste0("<S3:", paste0(class(x), collapse = ", "), ">")
+  }
+  else {
+    paste0("<S4:", paste0(is(x), collapse = ", "), ">")
+  }
+}

R/zzz.r

@@ -176,3 +176,16 @@ check_response_swdi <- function(x, format){
 }
 
 noaa_compact <- function (l) Filter(Negate(is.null), l)
+
+fread_csv <- function(x){ 
+  tmp <- data.frame(suppressWarnings(fread(x)))
+  names(tmp) <- tolower(names(tmp))
+  tmp
+}
+
+read_csv <- function(x){
+  tmp <- read.csv(x, header = FALSE, sep = ",", stringsAsFactors=FALSE, skip = 3)
+  nmz <- names(read.csv(x, header = TRUE, sep = ",", stringsAsFactors=FALSE, skip = 1, nrows=1))
+  names(tmp) <- tolower(nmz)
+  tmp
+}

man/storm_data.Rd

@@ -0,0 +1,52 @@
+% Generated by roxygen2 (4.0.2): do not edit by hand
+\name{storm_data}
+\alias{storm_data}
+\title{Get NOAA wind storm data from International Best Track Archive for Climate Stewardship (IBTrACS)}
+\usage{
+storm_data(basin = NULL, storm = NULL, year = NULL,
+  path = "~/.rnoaa/storms", overwrite = TRUE, read = TRUE)
+}
+\arguments{
+\item{basin}{(character) A basin name, one of EP, NA, NI, SA, SI, SP, or WP.}
+
+\item{storm}{(character) A storm serial number of the form YYYYJJJHTTNNN. See Details.}
+
+\item{year}{(numeric) One of the years from 1842 to 2014}
+
+\item{path}{(character) A path to store the files, Default: \code{~/.rnoaa/storms}}
+
+\item{overwrite}{(logical) To overwrite the path to store files in or not, Default: TRUE.}
+}
+\description{
+Get NOAA wind storm data from International Best Track Archive for Climate Stewardship (IBTrACS)
+}
+\details{
+Details for storm serial numbers:
+\itemize{
+ \item YYYY is the corresponding year of the first recorded observation of the storm
+ \item JJJ is the day of year of the first recorded observation of the storm
+ \item H is the hemisphere of the storm: N=Northern, S=Southern
+ \item TT is the absolute value of the rounded latitude of the first recorded observation of the
+ storm (range 0-90, if basin=SA or SH, then TT in reality is negative)
+ \item NNN is the rounded longitude of the first recorded observation of the storm (range 0-359)
+}
+
+For example: \code{1970143N19091} is a storm in the North Atlantic which started on
+May 23, 1970 near 19°N 91°E
+
+See \url{http://www.ncdc.noaa.gov/ibtracs/index.php?name=numbering} for more.
+}
+\examples{
+\donttest{
+storm_data(basin='WP')
+storm_data(storm='1970143N19091')
+storm_data(year=1940)
+storm_data(year=1941)
+storm_data(year=2010)
+
+# Or get all data, simply don't specify a value for basin, storm, or year
+res <- storm_data(read=FALSE) # just get path
+head()
+}
+}
+

man/storm_meta.Rd

@@ -0,0 +1,18 @@
+% Generated by roxygen2 (4.0.2): do not edit by hand
+\name{storm_meta}
+\alias{storm_meta}
+\title{Get NOAA wind storm metadata.}
+\usage{
+storm_meta(what = "storm_columns")
+}
+\description{
+Get NOAA wind storm metadata.
+}
+\examples{
+\donttest{
+head( storm_meta() )
+head( storm_meta("storm_columns") )
+head( storm_meta("storm_names") )
+}
+}
+

man/tornadoes.Rd

@@ -3,7 +3,7 @@
 \alias{tornadoes}
 \title{Get NOAA tornado data.}
 \usage{
-tornadoes(path = "~/.tornadoes", overwrite = TRUE)
+tornadoes(path = "~/.rnoaa/tornadoes", overwrite = TRUE)
 }
 \arguments{
 \item{path}{A path to store the files, Default: \code{~/.ots/kelp}}