R/zzz.r

Defines functions GET_retry assert assert_range rnoaa_cache_dir is_windows check4pkg check_key safe_read_csv storms_read_csv noaa_compact check_response_swdi check_response long2utm ncdc_theme is.ncdc_stations is.ncdc_locs_cats is.ncdc_locs is.ncdc_datacats is.ncdc_datatypes is.ncdc_datasets is.ncdc_data

Documented in check_response check_response_swdi is.ncdc_data is.ncdc_datacats is.ncdc_datasets is.ncdc_datatypes is.ncdc_locs is.ncdc_locs_cats is.ncdc_stations ncdc_theme

#' Check object class
#'
#' Check if an object is of class ncdc_data, ncdc_datasets,
#' ncdc_datatypes, ncdc_datacats, ncdc_locs, ncdc_locs_cats,
#' or ncdc_stations
#'
#' @param x input
#' @export
#' @keywords internal
is.ncdc_data <- function(x) inherits(x, "ncdc_data")

#' @rdname is.ncdc_data
#' @export
#' @keywords internal
is.ncdc_datasets <- function(x) inherits(x, "ncdc_datasets")

#' @rdname is.ncdc_data
#' @export
#' @keywords internal
is.ncdc_datatypes <- function(x) inherits(x, "ncdc_datatypes")

#' @rdname is.ncdc_data
#' @export
#' @keywords internal
is.ncdc_datacats <- function(x) inherits(x, "ncdc_datacats")

#' @rdname is.ncdc_data
#' @export
#' @keywords internal
is.ncdc_locs <- function(x) inherits(x, "ncdc_locs")

#' @rdname is.ncdc_data
#' @export
#' @keywords internal
is.ncdc_locs_cats <- function(x) inherits(x, "ncdc_locs_cats")

#' @rdname is.ncdc_data
#' @export
#' @keywords internal
is.ncdc_stations <- function(x) inherits(x, "ncdc_stations")

#' Theme for plotting NOAA data
#' @export
#' @keywords internal
ncdc_theme <- function(){
  list(theme(panel.grid.major = element_blank(),
             panel.grid.minor = element_blank(),
             legend.position = c(0.7,0.6),
             legend.key = element_blank()),
       guides(col = guide_legend(nrow=1)))
}

# Function to get UTM zone from a single longitude and latitude pair
# originally from David LeBauer I think
# @param lon Longitude, in decimal degree style
# @param lat Latitude, in decimal degree style
long2utm <- function(lon, lat) {
  if(56 <= lat & lat < 64){
    if(0 <= lon & lon < 3){ 31 } else
      if(3 <= lon & lon < 12) { 32 } else { NULL }
  } else
  if(72 <= lat) {
    if(0 <= lon & lon < 9){ 31 } else
      if(9 <= lon & lon < 21) { 33 } else
        if(21 <= lon & lon < 33) { 35 } else
          if(33 <= lon & lon < 42) { 37 } else { NULL }
  }
  (floor((lon + 180)/6) %% 60) + 1
}

#' Check response from NOAA, including status codes, server error messages, mime-type, etc.
#' @keywords internal
check_response <- function(x){
  if (!x$status_code == 200) {
    res <- tryCatch(jsonlite::fromJSON(x$parse("UTF-8"), FALSE),
      error = function(e) e)
    if (inherits(res, "error")) x$raise_for_status()
    stnames <- names(res)
    if (!is.null(stnames)) {
      if ('developerMessage' %in% stnames || 'message' %in% stnames) {
        warning(sprintf("Error: (%s) - %s", x$status_code,
            noaa_compact(list(jsonlite::fromJSON(x$parse("UTF-8"), FALSE)$developerMessage,
              jsonlite::fromJSON(x$parse("UTF-8"), FALSE)$message))),
            call. = FALSE)
      } else {
        warning(sprintf("Error: (%s)", x$status_code), call. = FALSE)
      }
    } else {
      z <- x$status_http()
      warning(z$status, ": ", z$message)
    }
  } else {
    # government shutdown check
    if (
      grepl("html", x$response_headers$`content-type`) &&
      grepl("shutdown", x$parse("UTF-8"))
    ) {
      stop("there's a government shutdown; check back later")
    }
    stopifnot("wrong response type, open an issue" =
      grepl("application/json", x$response_headers$`content-type`))
    res <- x$parse("UTF-8")
    out <- jsonlite::fromJSON(res, simplifyVector = FALSE)
    if (!'results' %in% names(out)) {
      if (length(out) == 0) {
        warning("Sorry, no data found", call. = FALSE)
      }
    } else {
      if (
        class(try(out$results, silent = TRUE)) == "try-error" ||
        is.null(try(out$results, silent = TRUE)) 
      ) {
        warning("Sorry, no data found", call. = FALSE)
      }
    }
    return( out )
  }
}

#' Check response from NOAA SWDI service, including status codes, server error messages,
#' mime-type, etc.
#' @keywords internal
check_response_swdi <- function(x, format){
  if (!x$status_code == 200) {
    res <- x$parse("UTF-8")
    if (length(res) == 0) {
      stop(x$status_http()$message)
    }
    err <- gsub("\n", "", xpathApply(res, "//error", xmlValue)[[1]])
    if (!is.null(err)) {
      if (grepl('ERROR', err, ignore.case = TRUE)) {
        warning(sprintf("(%s) - %s", x$status_code, err))
      } else {
        warning(x$status_http()$message)
      }
    } else {
      warning(x$status_http()$message)
    }
  } else {
    # government shutdown check
    if (
      grepl("html", x$response_headers$`content-type`) &&
      grepl("shutdown", x$parse("UTF-8"))
    ) {
      stop("there's a government shutdown; check back later")
    }
    if (format == 'csv') {
      stopifnot(grepl('text/plain', x$response_headers$`content-type`))
      read.delim(text = x$parse("UTF-8"), sep = ",")
    } else {
      stopifnot(grepl('text/xml', x$response_headers$`content-type`))
      txt <- x$parse("UTF-8")
      # check for no results first
      if (grepl("<count>0</count>", txt)) stop("no results found")
      # read xml
      xml2::read_xml(txt)
    }
  }
}

noaa_compact <- function(l) Filter(Negate(is.null), l)

storms_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
}

safe_read_csv <- function(x, header = TRUE, stringsAsFactors = FALSE, sep = ",") {
  assert(x, "character")
  tmp <- tryCatch(
    read.csv(x, header = header, sep = sep,
      stringsAsFactors = stringsAsFactors),
    error = function(e) e,
    warning = function(w) w
  )
  if (inherits(tmp, "warning"))
    stop(tmp$message)
  if (inherits(tmp, "error"))
    stop("file ", x, " malformed; delete file and try again")
  return(tmp)
}

check_key <- function(x){
  tmp <- if(is.null(x)) Sys.getenv("NOAA_KEY", "") else x
  if(tmp == "") getOption("noaakey", stop("need an API key for NOAA data")) else tmp
}

# check for a package
check4pkg <- function(x) {
  if (!requireNamespace(x, quietly = TRUE)) {
    stop(sprintf("Please install '%s'", x), call. = FALSE)
  } else {
    invisible(TRUE)
  }
}

# Check operating system is windows
is_windows <- function() {
  .Platform$OS.type == "windows"
}

rnoaa_cache_dir <- function() rappdirs::user_cache_dir("rnoaa")

assert_range <- function(x, y) {
  if (!x %in% y) {
    stop(sprintf("%s must be between %s and %s",
                 deparse(substitute(x)), min(y), max(y)), call. = FALSE)
  }
}

assert <- function(x, y) {
  if (!is.null(x)) {
    if (!inherits(x, y)) {
      stop(deparse(substitute(x)), " must be of class ",
           paste0(y, collapse = ", "), call. = FALSE)
    }
  }
}

GET_retry <- function(url, ..., times = 3) {
  cliret <- crul::HttpClient$new(url)
  res <- suppressWarnings(cliret$get(...))
  if (res$status_code > 226) {
    message("Request failed - Retrying")
    stat <- 500
    i <- 0
    while (stat > 226 && i <= times) {
      i <- i + 1
      res <- suppressWarnings(cliret$get(...))
      stat <- res$status_code
    }
    if (res$status_code > 226) stop("Request failed, try again", call. = FALSE)
  }
  return(res)
}

Try the rnoaa package in your browser

Any scripts or data that you put into this service are public.

rnoaa documentation built on May 19, 2021, 9:13 a.m.