Nothing
R/Class-IrisClient.R
In IRISSeismic: Classes and Methods for Seismic Data Analysis
Defines functions
getDistaz.IrisClient
getTraveltime.IrisClient
getEvent.IrisClient
getEvalresp.IrisClient
getDataAvailability.IrisClient
getUnavailability.IrisClient
getAvailability.IrisClient
getChannel.IrisClient
getStation.IrisClient
getNetwork.IrisClient
getRotation.IrisClient
getTimeseries.IrisClient
getSNCL.IrisClient
getDataselect.IrisClient
##
## S4 classes for communicating with EarthScope web services.
##
## Copyright (C) 2012 Mazama Science, Inc.
## by Jonathan Callahan, jonathan@mazamascience.com
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to the Free Software
## Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
################################################################################
# R classes for an EarthScope web services request client.
#
# Inspiration for the functionality in this code comes from obspy.iris.client.Client
#
# https://docs.obspy.org/packages/autogen/obspy.iris.client.Client.html
#
#
# Documentation for FDSN Web Services is available here:
#
# https://www.fdsn.org/webservices/
#
################################################################################
################################################################################
# Class IrisClient
#
# EarthScope web service request client.
#
# :type site: str, optional
# :param site: top level domain URL of the web services (default
# is ``'https://service.earthscope.org/'``).
# :type service_type: str, optional
# :param service_type: second element of URL, usually fdsnws
# :type debug: bool, optional
# :param debug: Enables verbose output (default is ``False``).
# :type user_agent: str, optional
# :param user_agent: Sets an client identification string which may be
# used on server side for statistical analysis (default contains the
# current module version and basic information about the used
# operation system, e.g.
# ``'IRISSeismic/1.7.1 RCurl/1.98-1.16 R/4.2.2 x86_64-pc-linux-gnu (MUSTANG)'``,
# where user_agent="MUSTANG"
# (default is "unidentified R script")
# :type event_site: str, optional
# :param event_site: top level domain URL of the event web service (default
# is ``'https://earthquake.usgs.gov/'``).
# :type dataselect_site: str, optional
# :param dataselect_site: top level domain URL of the dataselect web service
# (default is the site parameter)
# :type station_site: str, optional
# :param station_site: top level domain URL of the station web service
# (default is the site parameter)
# :type dataselect_site: str, optional
# :param availability_site: top level domain URL of the availability web service
# (default is the site parameter)
# :type retries: numeric, optional
# :param retries: number of times to retry a web service call in the case of
# failure (default = 1, must be less than 6)
#
################################################################################
utils::globalVariables(c("irisNetrc", "irisPass"))
# check for a user R profile for the IRIS Client site URL
# otherwise, use the default URL
irisSite <- "https://service.earthscope.org"
if (Sys.getenv("IrisClient_site") != "") {
irisSite <- Sys.getenv("IrisClient_site")
}
eventSite <- "https://earthquake.usgs.gov"
if (Sys.getenv("IrisClient_event_site") != "") {
eventSite <- Sys.getenv("IrisClient_event_site")
} else if (Sys.getenv("IrisClient_site") != "") {
if (!stringr::str_detect(
Sys.getenv("IrisClient_site"),
regex("service.*.iris.edu|service.*.earthscope.org")
)) {
eventSite <- Sys.getenv("IrisClient_site")
}
}
dataselectSite <- irisSite
if (Sys.getenv("IrisClient_dataselect_site") != "") {
dataselectSite <- Sys.getenv("IrisClient_dataselect_site")
}
stationSite <- irisSite
if (Sys.getenv("IrisClient_station_site") != "") {
stationSite <- Sys.getenv("IrisClient_station_site")
}
availabilitySite <- irisSite
if (Sys.getenv("IrisClient_availability_site") != "") {
availabilitySite <- Sys.getenv("IrisClient_availability_site")
}
# we will want the client using us as a library to be able to identify itself.
# it's easy enough to make this an environment setting as well.
# we will generate a default user agent to represent the metrics calculators.
irisUserAgent <- "unidentified R script"
if (Sys.getenv("IrisClient_agent") != "") {
irisUserAgent <- Sys.getenv("IrisClient_agent")
}
useragent1 <- paste0(
"IRISSeismic/",
ifelse("IRISSeismic" %in%
rownames(utils::installed.packages()),
utils::installed.packages()["IRISSeismic", "Version"],
"local code"
),
" RCurl/",
ifelse("RCurl" %in% rownames(utils::installed.packages()),
utils::installed.packages()["RCurl", "Version"],
"local code"
),
" R/", R.version$major, ".", R.version$minor,
" ", version$platform,
" (", irisUserAgent, ")"
)
setClass(
"IrisClient",
# typed slots (aka attributes) for class IrisClient
representation(
site = "character",
service_type = "character",
debug = "logical",
useragent = "character",
event_site = "character",
dataselect_site = "character",
station_site = "character",
availability_site = "character",
retries = "numeric"
)
)
setMethod(
"initialize", "IrisClient",
function(.Object,
site = irisSite,
debug = FALSE,
useragent = useragent1,
service_type = "fdsnws",
event_site = eventSite,
dataselect_site = dataselectSite,
station_site = stationSite,
availability_site = availabilitySite,
retries = 1) {
.Object@site <- site
.Object@service_type <- service_type
.Object@debug <- debug
.Object@useragent <- useragent
.Object@event_site <- event_site
.Object@dataselect_site <- dataselect_site
.Object@station_site <- station_site
.Object@availability_site <- availability_site
.Object@retries <- retries
.Object
}
)
setValidity("IrisClient", function(object) {
if (object@retries > 5) {
"@retries must be 5 or fewer"
} else {
TRUE
}
})
################################################################################
# getDataselect method returns a Stream object
#
# This implementation matches some of the functionality in the obspy dataselect
# function.
#
# https://docs.obspy.org/_modules/obspy/iris/client.html#Client.dataselect
#
################################################################################
if (!isGeneric("getDataselect")) {
setGeneric("getDataselect", function(obj, network, station, location, channel,
starttime, endtime, ...) {
standardGeneric("getDataselect")
})
}
getDataselect.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
quality = NULL,
repository = NULL,
inclusiveEnd = TRUE,
ignoreEpoch = FALSE) {
if (!is.logical(inclusiveEnd)) {
stop(paste("getDataselect.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
if (!is.logical(ignoreEpoch)) {
stop(paste("getDataselect.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
url <- obj@dataselect_site
if (!is.null(irisNetrc) || !is.null(irisPass)) {
url <- paste(url, obj@service_type, "dataselect/1/queryauth?", sep = "/")
} else {
url <- paste(url, obj@service_type, "dataselect/1/query?", sep = "/")
}
if (obj@service_type == "ph5ws") {
url <- paste(url, "reqtype=fdsn&net=", network, sep = "")
} else {
url <- paste(url, "net=", network, sep = "")
}
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the URL
# NOTE: For getDataselect only, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"),
sep = ""
)
url <- paste(url, "&cha=", channel, sep = "")
url <- paste(url, "&start=", format(starttime, "%Y-%m-%dT%H:%M:%OS6",
tz = "GMT"
),
sep = ""
)
if (!inclusiveEnd) {
endtime <- endtime - 0.000001
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
} else {
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
}
url <- paste(url, "&nodata=204", sep = "")
if (!is.null(quality) && obj@service_type != "ph5ws") {
url <- paste(url, "&quality=", quality, sep = "")
}
if (!is.null(repository) && obj@service_type != "ph5ws") {
if (repository %in% c(
"realtime", "primary", "bud", "primary,realtime",
"realtime,primary"
)) {
url <- paste(url, "&repository=", repository, sep = "")
} else {
err_msg <- c("Invalid repository, acceptable values are 'realtime' and
'primary'. To search both, do not specify a repository.")
stop(paste("getDataselect.IrisClient:", err_msg))
}
}
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
h <- RCurl::basicTextGatherer()
# Make authenticated request using password
if (!is.null(irisPass)) {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) { # Make authenticated request with netrc file
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
# authentication error or internal server error, try again
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
h <- RCurl::basicTextGatherer()
if (!is.null(irisPass)) {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (header["status"] == "204") { # fdsnws dataselect returned nothing
stop(paste("getDataselect.IrisClient: No Data:", header["status"], url))
}
if (header["status"] != "200") { # fdsnws dataselect returned something unexpected
if (header["status"] == "400") {
stop(paste("getDataselect.IrisClient: Bad Request:", url))
} else if (header["status"] == "404") {
stop(paste("getDataselect.IrisClient: URL Not Found:", url))
} else {
stop(paste(
"getDataselect.IrisClient: Unexpected http status code",
header["status"], header["statusMessage"], url
))
}
}
# No errors so proceed
# Channel metadata is required to properly apply InstrumentSensitivity corrections
result <- try(
channels <- getChannel(
obj, network, station, location, channel,
starttime, endtime
),
silent = TRUE
)
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
# NOTE: Sometimes, the station webservice will return multiple records for the same SNCL
# NOTE: each with a different scale or starttime. This still represents a single SNCL.
# NOTE: What to do about multiple scales in the following getChannel request?
# Solution 1: if ignoreEpoch==TRUE, then just take the first epoch presented
# https://service.earthscope.org/fdsnws/station/1/query?net=H2&sta=H2O&loc=00&cha=LHZ&starttime=2001-02-28T18:29:44&endtime=2001-02-28T19:29:44&includerestricted=false&format=text&level=channel
sncls <- paste(
channels$network, channels$station, channels$location,
channels$channel
)
if (nrow(channels) > 1 && !ignoreEpoch) {
stop(paste(
"getDataselect.IrisClient: Multiple epochs: getChannel returned",
length(sncls), "records"
))
} else {
channelInfo <- channels[1, ]
}
# No errors so proceed
stream <- miniseed2Stream(dataselectResponse,
url,
starttime,
endtime,
channelInfo$instrument,
channelInfo$scale,
channelInfo$scalefreq,
channelInfo$scaleunits,
channelInfo$latitude,
channelInfo$longitude,
channelInfo$elevation,
channelInfo$depth,
channelInfo$azimuth,
channelInfo$dip,
removeZeroSampleTraces = TRUE
)
return(stream)
}
# All arguments specified
setMethod(
"getDataselect", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct"
),
function(obj, network, station, location, channel, starttime,
endtime, ...) {
getDataselect.IrisClient(
obj, network, station, location, channel,
starttime, endtime, ...
)
}
)
################################################################################
# getSNCL method is a convenience wrapper for getDataselect
################################################################################
if (!isGeneric("getSNCL")) {
setGeneric("getSNCL", function(obj, sncl, starttime, endtime, ...) {
standardGeneric("getSNCL")
})
}
getSNCL.IrisClient <- function(obj,
sncl,
starttime,
endtime,
quality = NULL,
repository = NULL,
inclusiveEnd = TRUE,
ignoreEpoch = FALSE) {
parts <- unlist(stringr::str_split(sncl, "\\."))
return(getDataselect.IrisClient(obj,
parts[1],
parts[2],
parts[3],
parts[4],
starttime,
endtime,
quality = quality,
repository = repository,
inclusiveEnd = inclusiveEnd,
ignoreEpoch = ignoreEpoch
))
}
# All arguments specified
setMethod(
"getSNCL", signature(
obj = "IrisClient", sncl = "character",
starttime = "POSIXct", endtime = "POSIXct"
),
function(obj, sncl, starttime, endtime, ...) {
getSNCL.IrisClient(obj, sncl, starttime, endtime, ...)
}
)
################################################################################
# getTimeseries method returns a Stream object
#
# Data are obtained from the timeseries web service:
#
# https://service.earthscope.org/irisws/timeseries/1/
#
# This method functions much like getDataselect() but allows for various types
# of signal processing.
#
################################################################################
if (!isGeneric("getTimeseries")) {
setGeneric("getTimeseries", function(obj,
network,
station,
location,
channel,
starttime,
endtime, ...) {
standardGeneric("getTimeseries")
})
}
getTimeseries.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
processing = NULL,
repository = NULL,
inclusiveEnd = TRUE,
ignoreEpoch = FALSE) {
if (!is.logical(inclusiveEnd)) {
stop(paste("getTimeseries.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
if (!is.logical(ignoreEpoch)) {
stop(paste("getTimeseries.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
url <- obj@site
if (!is.null(irisNetrc) || !is.null(irisPass)) {
url <- paste(url, "irisws/timeseries/1/queryauth?", sep = "/")
} else {
url <- paste(url, "irisws/timeseries/1/query?", sep = "/")
}
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the URL
# NOTE: For getTimeseries only, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", channel, sep = "")
url <- paste(url, "&start=", format(starttime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
if (!inclusiveEnd) {
endtime <- endtime - 0.000001
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
} else {
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
}
if (!is.null(repository) && obj@service_type != "ph5ws") {
if (repository %in% c(
"realtime",
"primary",
"bud",
"primary,realtime",
"realtime,primary"
)) {
url <- paste(url, "&repository=", repository, sep = "")
} else {
err_msg <- c("Invalid repository, acceptable values are 'realtime' and
'primary'. To search both, do not specify a repository.")
stop(paste("getTimeseries.IrisClient:", err_msg))
}
}
if (!is.null(processing)) {
url <- paste(url, processing, sep = "")
}
url <- paste(url, "&format=miniseed", sep = "")
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Make webservice request
h <- RCurl::basicTextGatherer()
# Make authenticated request using environmental variable password
if (!is.null(irisPass)) {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) {
# Make authenticated request using a netrc file
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else { # Make unauthenticated request
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
# authentication error or internal server error, try again
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
h <- RCurl::basicTextGatherer()
if (!is.null(irisPass)) {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (header["status"] == "204") { # irisws timeseries returned nothing
stop(paste("getTimeseries.IrisClient: No Data:", header["status"], url))
}
if (header["status"] != "200") { # irisws timeseries returned something unexpected
if (header["status"] == "400") {
stop(paste("getTimeseries.IrisClient: Bad Request:", url))
} else if (header["status"] == "404") {
stop(paste("getTimeseries.IrisClient: URL Not Found:", url))
} else {
stop(paste(
"getTimeseriesIrisClient: Unexpected http status code",
header["status"], header["statusMessage"], url
))
}
}
# No errors so proceed
# Channel metadata is required to properly apply InstrumentSensitivity
# corrections
result <- try(
channels <- getChannel(
obj, network, station, location,
channel, starttime, endtime
),
silent = TRUE
)
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
# NOTE: Sometimes, the station webservice will return multiple records for
# NOTE: the same SNCL each with a different scale or starttime. This still
# NOTE: represents a single SNCL. What to do about multiple scales in the
# NOTE: following getChannel request?
# Solution 1: if ignoreEpoch==TRUE, then just take the first epoch presented
# https://service.earthscope.org/fdsnws/station/1/query?net=H2&sta=H2O&loc=00&cha=LHZ&starttime=2001-02-28T18:29:44&endtime=2001-02-28T19:29:44&includerestricted=false&format=text&level=channel
sncls <- paste(
channels$network, channels$station, channels$location,
channels$channel
)
if (nrow(channels) > 1 && !ignoreEpoch) {
stop(paste(
"getTimeseries.IrisClient: Multiple epochs: getChannel returned",
length(sncls), "records"
))
} else {
channelInfo <- channels[1, ]
}
# No errors so proceed
stream <- miniseed2Stream(timeseriesResponse,
url,
starttime,
endtime,
channelInfo$instrument,
channelInfo$scale,
channelInfo$scalefreq,
channelInfo$scaleunits,
channelInfo$latitude,
channelInfo$longitude,
channelInfo$elevation,
channelInfo$depth,
channelInfo$azimuth,
channelInfo$dip,
removeZeroSampleTraces = TRUE
)
return(stream)
}
# All arguments specified
setMethod(
"getTimeseries", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct"
),
function(obj, network, station, location, channel, starttime,
endtime, ...) {
getTimeseries.IrisClient(
obj, network, station, location, channel,
starttime, endtime, ...
)
}
)
################################################################################
# getRotation method returns a list of three Stream objects
#
# Data are obtained from the rotation web service:
#
# https://service.earthscope.org/irisws/rotation/1/
#
################################################################################
if (!isGeneric("getRotation")) {
setGeneric("getRotation", function(obj,
network,
station,
location,
channelSet,
starttime,
endtime,
processing) {
standardGeneric("getRotation")
})
}
getRotation.IrisClient <- function(obj,
network,
station,
location,
channelSet,
starttime,
endtime,
processing) {
url <- paste(obj@site, "/irisws/rotation/1/query?", sep = "")
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the
# NOTE: URL. For getRotation only, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url,
"&loc=",
stringr::str_replace(location, " ", "--"),
sep = ""
)
url <- paste(url, "&chaset=", channelSet, sep = "")
url <- paste(url,
"&start=", format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url,
"&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, processing, sep = "")
url <- paste(url, "&output=miniseed", sep = "")
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Download the rotation service response (zip file) to a temporary file
temp <- tempfile()
result <- try(utils::download.file(url, temp, quiet = TRUE))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getRotation.IrisClient:", err_msg, url))
}
# Create a dataframe of zip file contents and discard the metadata file
zipContents <- utils::unzip(temp, list = TRUE, junkpaths = TRUE)
metadata_mask <- stringr::str_detect(zipContents$Name, "metadata")
zipContents <- zipContents[!metadata_mask, ]
# Sanity check
if (nrow(zipContents) != 3) {
stop(paste(
"getRotation.IrisClient: rotation service return has",
nrow(zipContents), "traces -- 3 expected"
))
}
# Extract the three miniseed records, convert them to Stream objects and store
# them in streamList
streamList <- list()
for (i in seq(3)) {
con <- unz(temp, zipContents$Name[i], open = "rb")
rawMiniseed <- readBin(con, "raw", zipContents$Length[i])
streamList[[i]] <- miniseed2Stream(rawMiniseed,
url = paste(
"rotation:",
zipContents$Name[i]
),
requestedStarttime = starttime,
requestedEndtime = endtime,
sensor = "rotation web service",
removeZeroSampleTraces = TRUE
)
close(con)
}
# Remove the temporary file
unlink(temp)
return(streamList)
}
# All arguments specified
setMethod(
"getRotation", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channelSet = "character",
starttime = "POSIXct",
endtime = "POSIXct",
processing = "character"
),
function(obj, network, station, location, channelSet, starttime,
endtime, processing) {
getRotation.IrisClient(
obj, network, station, location, channelSet,
starttime, endtime, processing
)
}
)
################################################################################
# getNetwork method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=network".
#
# https://service.earthscope.org/fdsnws/station/1/
#
# Example output:
#
# #Network | Description | StartTime | EndTime | TotalStations
# IU|Global Seismograph Network (GSN - IRIS/USGS)|1988-01-01T00:00:00|2500-12-12T23:59:59|254
#
################################################################################
if (!isGeneric("getNetwork")) {
setGeneric("getNetwork", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getNetwork")
})
}
getNetwork.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (obj@service_type != "ph5ws") {
url <- paste(url, "&includerestricted=",
ifelse(includerestricted, "true", "false"),
sep = ""
)
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getNetwork() method
url <- paste(url, "&level=network", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# #Network | Description | StartTime | EndTime | TotalStations
colNames <- c(
"network", "description", "starttime", "endtime",
"totalstations"
)
colClasses <- c(rep("character", 4), "numeric")
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getNetwork.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getNetwork.IrisClient: Couldn't connect to host", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getNetwork.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getNetwork.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getNetwork.IrisClient: Cannot open connection", url))
} else {
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Return a dataframe with rows ordered by network
return(DF[order(DF$network), ])
}
# All arguments specified
setMethod(
"getNetwork", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getNetwork.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use FALSE
setMethod(
"getNetwork", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getNetwork.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = FALSE,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getStation method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=station".
#
# https://service.earthscope.org/fdsnws/station/1/
#
# Example output:
#
# #Network | Station | Latitude | Longitude | Elevation | SiteName | StartTime | EndTime
# IU|COR|44.5855|-123.3046|110.0|Corvallis, Oregon, USA|2009-09-26T00:00:00|2599-12-31T23:59:59
#
################################################################################
if (!isGeneric("getStation")) {
setGeneric("getStation", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getStation")
})
}
getStation.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (!is.null(includerestricted) && obj@service_type != "ph5ws") {
url <- paste(url, "&includerestricted=", includerestricted, sep = "")
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getStation() method
url <- paste(url, "&level=station", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Latitude | Longitude | Elevation | SiteName | StartTime | EndTime
colNames <- c(
"network",
"station",
"latitude",
"longitude",
"elevation",
"sitename",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 2), rep("numeric", 3), rep("character", 3))
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getStation.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getStation.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getStation.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getStation.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getStation.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getStation.IrisClient: couldn't connect to host", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getStation.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getStation.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) {
gurlc <- ""
}
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getStation.IrisClient: Cannot open the connection:", url))
} else {
stop(paste("getStation.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Return dataframe with rows ordered by network.station
netsta <- paste(DF$network, DF$station, sep = ".")
return(DF[order(netsta), ])
}
# All arguments specified
setMethod(
"getStation", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getStation.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use NULL
setMethod(
"getStation", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getStation.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = NULL,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getChannel method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=channel".
#
# https://service.earthscope.org/fdsnws/station/1/
#
# Example output:
#
# #Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip | Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
# IU|COR|10|LHZ|44.5855|-123.3046|110.0|0.0|0.0|-90.0|Trillium 240 broad band|1.98775E9|0.02|M/S|1.0|2011-01-15T07:00:00|2012-03-08T08:43:00
#
################################################################################
if (!isGeneric("getChannel")) {
setGeneric("getChannel", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getChannel")
})
}
getChannel.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (obj@service_type == "fdsnws") {
if (!is.null(includerestricted)) {
url <- paste(url, "&includerestricted=", tolower(includerestricted),
sep = ""
)
}
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getChannel() method
url <- paste(url, "&level=channel", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip |
# Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
colNames <- c(
"network",
"station",
"location",
"channel",
"latitude",
"longitude",
"elevation",
"depth",
"azimuth",
"dip",
"instrument",
"scale",
"scalefreq",
"scaleunits",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(
rep("character", 4),
rep("numeric", 6),
"character",
rep("numeric", 2),
"character",
"numeric",
rep("character", 2)
)
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getChannel.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getChannel.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getChannel.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getChannel.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getChannel.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getChannel.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getChannel.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getChannel.IrisClient: Cannot open connection", url))
} else {
stop(paste("getChannel.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Convert " " location codes back into the "" that is used in the miniSEED
# record
DF$location <- stringr::str_replace(DF$location, " ", "")
# new station web service now returns blank loc codes, which convert to NA
# switch NA's to "" as well
DF$location[is.na(DF$location)] <- ""
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Add a snclId column
DF$snclId <- paste(DF$network, DF$station, DF$location, DF$channel, sep = ".")
# Return dataframe with rows ordered by snclId
return(DF[order(DF$snclId), ])
}
# All arguments specified
setMethod(
"getChannel", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getChannel.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use NULL
setMethod(
"getChannel", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getChannel.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = NULL,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getAvailability method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=channel".
# With additional parameters, this webservice returns information on all
# matching SNCLs that have available data.
#
# The fdsnws/station web service will return space characters for location
# codes that are SPACE SPACE.
#
# https://service.earthscope.org/fdsnws/station/1/
#
# #Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip | Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
# CU|ANWB|00|LHZ|17.66853|-61.78557|39.0|0.0|0.0|-90.0|Streckeisen STS-2 Standard-gain|2.43609E9|0.05|M/S|1.0|2010-02-10T18:35:00|2599-12-31T23:59:59
#
################################################################################
if (!isGeneric("getAvailability")) {
setGeneric("getAvailability", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getAvailability")
})
}
getAvailability.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (obj@service_type != "ph5ws") {
url <- paste(url, "&includerestricted=", ifelse(includerestricted, "true",
"false"
),
sep = ""
)
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getAvailability() method
if (obj@service_type != "ph5ws") {
url <- paste(url, "&includeavailability=true", sep = "")
url <- paste(url, "&matchtimeseries=true", sep = "")
}
url <- paste(url, "&level=channel", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip |
# Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
colNames <- c(
"network",
"station",
"location",
"channel",
"latitude",
"longitude",
"elevation",
"depth",
"azimuth",
"dip",
"instrument",
"scale",
"scalefreq",
"scaleunits",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(
rep("character", 4),
rep("numeric", 6),
"character",
rep("numeric", 2),
"character",
"numeric",
rep("character", 2)
)
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getAvailability.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getAvailability.IrisClient: couldn't connect to host", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getAvailability.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getAvailability.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getAvailability.IrisClient: Cannot open connection", url))
} else {
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Filter out unwanted channels -- first to come to mind is LOG, but others get added by recommendation.
DF <- DF[!(DF$channel %in% c("LOG", "ACE", "OCF")), ]
# Convert " " location codes back into the "" that is used in the miniSEED record
DF$location <- stringr::str_replace(DF$location, " ", "")
# new station web service now returns blank loc codes, which convert to NA
# switch NA's to "" as well
DF$location[is.na(DF$location)] <- ""
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Add a snclId column
DF$snclId <- paste(DF$network, DF$station, DF$location, DF$channel, sep = ".")
# Return dataframe with rows ordered by snclId
return(DF[order(DF$snclId), ])
}
# All arguments specified
setMethod(
"getAvailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getAvailability.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use FALSE
setMethod(
"getAvailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getAvailability.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = FALSE,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getUnavailability method returns a dataframe with those channels that are found
# in the getChannel() dataframe but not in the getAvailability() dataframe.
################################################################################
if (!isGeneric("getUnavailability")) {
setGeneric("getUnavailability", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getUnavailability")
})
}
getUnavailability.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Get all channels
c <- getChannel(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
# Get available channels
a <- getAvailability(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
# Create unique record identifiers (SNCL is enough)
c_sncls <- paste(c$network, c$station, c$location, c$channel, sep = ".")
a_sncls <- paste(a$network, a$station, a$location, a$channel, sep = ".")
unavailable_mask <- !(c_sncls %in% a_sncls)
return(c[unavailable_mask, ])
}
# All arguments specified
setMethod(
"getUnavailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getUnavailability.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use FALSE
setMethod(
"getUnavailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getUnavailability.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = FALSE,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getDataAvailability method returns a dataframe with information from the output
# of the iris availability web service with "format=text&level=channel".
#
# https://service.earthscope.org/fdsnws/availability/1/
#
################################################################################
if (!isGeneric("getDataAvailability")) {
setGeneric("getDataAvailability", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge) {
standardGeneric("getDataAvailability")
})
}
getDataAvailability.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge) {
url <- paste(obj@availability_site, obj@service_type, "availability/1/query?",
sep = "/"
)
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"),
sep = ""
)
url <- paste(url, "&cha=", channel, sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
url <- paste(url, "&format=geocsv", sep = "")
url <- paste(url, "&nodata=204", sep = "")
# Add optional arguments if they are found
mergeflag <- 0
if (missing(mergequality) || mergequality == TRUE) {
url <- paste(url, "&merge=quality", sep = "")
mergequality <- TRUE
mergeflag <- 1
}
if (!missing(mergesamplerate) && mergesamplerate == TRUE) {
if (mergeflag == 0) {
url <- paste(url, "&merge=samplerate", sep = "")
mergeflag <- 1
} else {
url <- paste(url, ",samplerate", sep = "")
}
} else {
mergesamplerate <- FALSE
} # default is FALSE
if (missing(mergeoverlap) || mergeoverlap == TRUE) {
if (mergeflag == 0) {
url <- paste(url, "&merge=overlap", sep = "")
mergeflag <- 1
} else {
url <- paste(url, ",overlap", sep = "")
}
} # default is TRUE
if (!missing(mergetolerance)) {
url <- paste(url, "&mergegaps=", mergetolerance, sep = "")
} # default is 1.5 sample rate
if (!missing(includerestricted)) {
url <- paste(url, "&includerestricted=", includerestricted, sep = "")
} else {
url <- paste(url, "&includerestricted=TRUE", sep = "")
} # default is TRUE
if (!missing(excludetoolarge) && excludetoolarge == TRUE) {
url <- paste(url, "&limit=500000", sep = "")
} # default is FALSE
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Location | Channel | Quality | SampleRate | StartTime | EndTime
# Network | Station | Location | Channel | SampleRate | StartTime | EndTime
if (mergequality == FALSE) {
if (mergesamplerate == TRUE) {
colNames <- c(
"network",
"station",
"location",
"channel",
"quality",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 7))
} else {
colNames <- c(
"network",
"station",
"location",
"channel",
"quality",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 8))
}
} else {
if (mergesamplerate == TRUE) {
colNames <- c(
"network",
"station",
"location",
"channel",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 6))
} else {
colNames <- c(
"network",
"station",
"location",
"channel",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 7))
}
}
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataAvailability.IrisClient:", strtrim(err_msg, 500), url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getDataAvailability.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getDataAvailability.IrisClient: Cannot open connection", url))
} else if (stringr::str_detect(
err_msg,
regex("Error 500: Internal Server Error")
)) {
err_msg <- stringr::str_replace_all(err_msg, "[\r\n\t]", "")
stop(paste(
"getDataAvailability.IrisClient: Internal Server Error:",
stringr::str_match(
err_msg,
"Error 500: Internal Server Error(.+)Usage"
)[, 2],
url
))
} else {
stop(paste(
"getDataAvailability.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = "",
skip = 4
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getDataAvailability.IrisClient: Cannot open connection", url))
} else {
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Filter out unwanted channels -- first to come to mind is LOG, but others get added by recommendation.
DF <- DF[!(DF$channel %in% c("LOG", "ACE", "OCF")), ]
# Convert " " location codes back into the "" that is used in the miniSEED record
DF$location <- stringr::str_replace(DF$location, " ", "")
DF$location[is.na(DF$location)] <- ""
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Add a snclId column
DF$snclId <- paste(DF$network, DF$station, DF$location, DF$channel, sep = ".")
# Return dataframe with rows ordered by snclId
return(DF[order(DF$snclId), ])
}
# All required arguments specified
setMethod(
"getDataAvailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
mergequality = "ANY",
mergesamplerate = "ANY",
mergeoverlap = "ANY",
mergetolerance = "ANY",
includerestricted = "ANY",
excludetoolarge = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge) {
getDataAvailability.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge
)
}
)
################################################################################
# getEvalresp method returns instrument response data from the evalresp webservice:
#
# https://service/irisws/evalresp/1/
#
################################################################################
if (!isGeneric("getEvalresp")) {
setGeneric("getEvalresp", function(obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing) {
standardGeneric("getEvalresp")
})
}
getEvalresp.IrisClient <- function(obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing) {
# TODO: getEvalresp should test for wildcards in network, station, location, channel
# TODO: and return an error if any are found.
url <- obj@site
if (obj@service_type == "ph5ws") {
url <- paste(url, "ph5ws/evalresp/1/query?", sep = "/")
} else {
url <- paste(url, "irisws/evalresp/1/query?", sep = "/")
}
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the URL
# NOTE: For getEvalresp, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", channel, sep = "")
# NOTE: a single 'time' parameter is used rather than 'starttime' and 'endtime'
url <- paste(url, "&time=", format(time, "%Y-%m-%dT%H:%M:%OS0", tz = "GMT"), sep = "") # ws_evalresp requires "T" format
if (missing(output)) {
output <- "fap"
}
url <- paste(url, "&output=", output, sep = "")
# Add optional arguments if they are found
if (!missing(minfreq)) {
url <- paste(url, "&minfreq=", minfreq, sep = "")
}
if (!missing(maxfreq)) {
url <- paste(url, "&maxfreq=", maxfreq, sep = "")
}
if (!missing(nfreq)) {
url <- paste(url, "&nfreq=", nfreq, sep = "")
}
if (!missing(units)) {
url <- paste(url, "&units=", units, sep = "")
}
if (!missing(spacing)) {
url <- paste(url, "&spacing=", spacing, sep = "")
}
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Handle requests for either freq-amp-phase or freq-real-imag
if (output == "fap") {
colNames <- c("freq", "amp", "phase")
} else if (output == "cs") {
colNames <- c("freq", "real", "imag")
} else {
stop(paste(
"getEvalresp.IrisClient: bad output arg = '", output,
"' -- must be 'fap' or 'cs'"
))
}
# Conversion of URL into a data frame is a single line with utils::read.table().
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvalresp.IrisClient:", strtrim(err_msg, 500), url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getEvalresp.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvalresp.IrisClient: Cannot open connection", url))
} else if (stringr::str_detect(
err_msg,
regex("Error 500: Internal Server Error")
)) {
err_msg <- stringr::str_replace_all(err_msg, "[\r\n\t]", "")
stop(paste(
"getEvalresp.IrisClient: Internal Server Error:",
stringr::str_match(
err_msg,
"Error 500: Internal Server Error(.+)Usage"
)[, 2],
url
))
} else {
stop(paste(
"getEvalresp.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(DF <- utils::read.table(txtcon, col.names = colNames),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvalresp.IrisClient: Cannot open connection", url))
} else {
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Return the dataframe, guaranteeing that it is ordered by frequency
return(DF[order(DF$freq), ])
}
# All required arguments specified
setMethod(
"getEvalresp", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
time = "POSIXct",
minfreq = "ANY",
maxfreq = "ANY",
nfreq = "ANY",
units = "ANY",
output = "ANY",
spacing = "ANY"
),
function(obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing) {
getEvalresp.IrisClient(
obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing
)
}
)
################################################################################
# getEvent method returns seismic event data from the event webservice:
#
# https://earthquake.usgs.gov/fdsnws/event/1/
#
# TODO: The getEvent method could be fleshed out with a more complete list
# TODO: of arguments to be used as ws-event parameters.
################################################################################
if (!isGeneric("getEvent")) {
setGeneric("getEvent", function(obj,
starttime,
endtime,
minmag,
maxmag,
magtype,
mindepth,
maxdepth) {
standardGeneric("getEvent")
})
}
getEvent.IrisClient <- function(obj,
starttime,
endtime,
minmag,
maxmag,
magtype,
mindepth,
maxdepth) {
url <- paste(obj@event_site, "/fdsnws/event/1/query?", sep = "")
url <- paste(url, "starttime=", format(starttime, "%Y-%m-%dT%H:%M:%OS0",
tz = "GMT"
),
sep = ""
)
url <- paste(url, "&endtime=", format(endtime, "%Y-%m-%dT%H:%M:%OS0",
tz = "GMT"
),
sep = ""
)
url <- paste(url, "&format=text", sep = "")
# Add optional arguments if they are non-null
if (!missing(minmag)) {
url <- paste(url, "&minmag=", minmag, sep = "")
}
if (!missing(maxmag)) {
url <- paste(url, "&maxmag=", maxmag, sep = "")
}
if (!missing(magtype)) {
url <- paste(url, "&magtype=", magtype, sep = "")
}
if (!missing(mindepth)) {
url <- paste(url, "&mindepth=", mindepth, sep = "")
}
if (!missing(maxdepth)) {
url <- paste(url, "&maxdepth=", maxdepth, sep = "")
}
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# https://earthquake.usgs.gov/fdsnws/event/1/query?starttime=2013-02-01T00:00:00&endtime=2013-02-02T00:00:00&minmag=5&format=text
#
# #EventID | Time | Latitude | Longitude | Depth | Author | Catalog | Contributor | ContributorID | MagType | Magnitude | MagAuthor | EventLocationName
# 4075900|2013-02-01T22:18:33|-11.12|165.378|10.0|NEIC|NEIC PDE|NEIC PDE-Q||MW|6.4|GCMT|SANTA CRUZ ISLANDS
# Assign column names and classes for the returned data
colNames <- c(
"eventId",
"time",
"latitude",
"longitude",
"depth",
"author",
"cCatalog",
"contributor",
"contributorId",
"magType",
"magnitude",
"magAuthor",
"eventLocationName"
)
colClasses <- c(
"character",
"character",
"numeric",
"numeric",
"numeric",
"factor",
"factor",
"factor",
"factor",
"factor",
"numeric",
"factor",
"character"
)
# Conversion of URL into a data frame is a single line with read.table().
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvent.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvent.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getEvent.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getEvent.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("service unavailable",
ignore_case = TRUE
)) ||
header["status"] == "503") {
stop(paste("getEvent.IrisClient: Service Unavailable", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvent.IrisClient: Cannot open connection", url))
} else if (stringr::str_detect(err_msg, regex("Not Found",
ignore_case = TRUE
)) ||
header["status"] == "404") {
stop(paste("getEvent.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getEvent.IrisClient: Couldn't connect to host", url))
} else if (header["status"] != "200" && header["status"] != "204") {
stop(paste(
"getEvent.IrisClient: Unexpected http status code",
header["status"], err_msg, url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.table(txtcon,
sep = "|",
quote = "",
col.names = colNames,
colClasses = colClasses
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvent.IrisClient: Cannot open connection", url))
} else {
stop(paste("getEvent.IrisClient:", err_msg, url))
}
}
# Last check to make sure DF is defined
if (!exists("DF")) {
stop(paste("getEvent.IrisClient: No Data Found"))
}
# No errors so proceed
# Final data conversion
DF$time <- as.POSIXct(DF$time, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Return dataframe with rows ordered by time
return(DF[order(DF$time), ])
}
# All arguments specified
setMethod(
"getEvent", signature(
obj = "IrisClient",
starttime = "POSIXct",
endtime = "POSIXct",
minmag = "ANY",
maxmag = "ANY",
magtype = "ANY",
mindepth = "ANY",
maxdepth = "ANY"
),
function(obj, starttime, endtime, minmag, maxmag,
magtype, mindepth, maxdepth) {
getEvent.IrisClient(
obj, starttime, endtime, minmag, maxmag,
magtype, mindepth, maxdepth
)
}
)
################################################################################
# getTraveltime method returns a dataframe with information from the traveltime
# webservice:
#
# https://service.earthscope.org/irisws/traveltime/1/
#
################################################################################
if (!isGeneric("getTraveltime")) {
setGeneric("getTraveltime", function(obj,
latitude,
longitude,
depth,
staLatitude,
staLongitude) {
standardGeneric("getTraveltime")
})
}
getTraveltime.IrisClient <- function(obj, latitude, longitude, depth,
staLatitude, staLongitude) {
# Create URL arguments from incoming parameters
evloc <- paste("[", latitude, ",", longitude, "]", sep = "")
staloc <- paste("[", staLatitude, ",", staLongitude, "]", sep = "")
# Assemble URL
url <- paste(obj@site, "/irisws/traveltime/1/query?", sep = "")
url <- paste(url, "&evloc=", evloc, sep = "")
url <- paste(url, "&evdepth=", depth, sep = "")
url <- paste(url, "&staloc=", staloc, sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# https://service.earthscope.org/irisws/traveltime/1/query?evloc=[-11.12,165.378]&evdepth=10.0&staloc=[-30.4183,151.6293]
#
# Model: iasp91
# Distance Depth Phase Travel Ray Param Takeoff Incident Purist Purist
# (deg) (km) Name Time (s) p (s/deg) (deg) (deg) Distance Name
# -----------------------------------------------------------------------------------
# 23.14 10.0 P 306.34 10.542 33.42 33.36 23.14 = P
# 23.14 10.0 P 306.88 9.162 28.60 28.55 23.14 = P
# 23.14 10.0 P 308.47 9.679 30.38 30.32 23.14 = P
# 23.14 10.0 PcP 534.45 2.082 6.25 6.24 23.14 = PcP
# 23.14 10.0 S 558.79 16.323 29.61 29.55 23.14 = S
# 23.14 10.0 S 560.09 19.178 35.48 35.42 23.14 = S
# 23.14 10.0 S 563.00 17.678 32.35 32.29 23.14 = S
# 23.14 10.0 S 575.53 23.885 46.29 46.20 23.14 = S
# 23.14 10.0 S 575.59 23.797 46.07 45.98 23.14 = S
# 23.14 10.0 ScS 978.54 3.844 6.68 6.67 23.14 = ScS
# 23.14 10.0 PKiKP 998.81 0.511 1.53 1.53 23.14 = PKiKP
# 23.14 10.0 SKiKS 1422.54 0.570 0.99 0.99 23.14 = SKiKS
# Assign column names and classes for the returned data
colNames <- c(
"distance",
"depth",
"phaseName",
"travelTime",
"rayParam",
"takeoff",
"incident",
"puristDistance",
"dummy",
"puristName"
)
colClasses <- c(
"numeric", "numeric", "factor", "numeric", "numeric",
"numeric", "numeric", "numeric", "character", "character"
)
# Conversion of URL into a data frame is a single line with read.table().
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getTraveltime.IrisClient: Couldn't connect to host", url))
} else if (stringr::str_detect(
err_msg,
regex("Not Found", ignore_case = TRUE)
) ||
header["status"] == "404") {
stop(paste("getTraveltime.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getTraveltime.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getTraveltime.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
returnValue <- utils::read.table(txtcon,
skip = 4,
col.names = colNames,
colClasses = colClasses
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getTraveltime.IrisClient: Cannot open connection", url))
} else {
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Only use the first seven columns
DF <- returnValue[, c(1:8, 10)]
# Return dataframe with rows ordered by travelTime
return(DF[order(DF$travelTime), ])
}
# All arguments specified
setMethod(
"getTraveltime", signature(
obj = "IrisClient",
latitude = "numeric",
longitude = "numeric",
depth = "numeric",
staLatitude = "numeric",
staLongitude = "numeric"
),
function(obj, latitude, longitude, depth, staLatitude, staLongitude) {
getTraveltime.IrisClient(
obj, latitude, longitude, depth,
staLatitude, staLongitude
)
}
)
################################################################################
# getDistaz method returns a dataframe with information from the distaz
# webservice:
#
# https://service.earthscope.org/irisws/distaz/1/
#
################################################################################
if (!isGeneric("getDistaz")) {
setGeneric("getDistaz", function(obj,
latitude,
longitude,
staLatitude,
staLongitude) {
standardGeneric("getDistaz")
})
}
getDistaz.IrisClient <- function(obj,
latitude,
longitude,
staLatitude,
staLongitude) {
# Assemble URL
url <- paste(obj@site, "/irisws/distaz/1/query?", sep = "")
url <- paste(url, "&evtlat=", latitude, sep = "")
url <- paste(url, "&evtlon=", longitude, sep = "")
url <- paste(url, "&stalat=", staLatitude, sep = "")
url <- paste(url, "&stalon=", staLongitude, sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Get data from distaz web service
h <- RCurl::basicTextGatherer()
result <- try(
distazXml <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDistaz.IrisClient:", err_msg))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDistaz.IrisClient:", err_msg))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
distazXml <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getDistaz.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getDistaz.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- distazXml
if (stringr::str_detect(err_msg, regex("Not Found",
ignore_case = TRUE
)) ||
header["status"] == "404") {
stop(paste("getDistaz.IrisClient: URL Not Found:", url))
} else if (stringr::str_detect(err_msg, regex("connect to host",
ignore_case = TRUE
))) {
stop(paste("getDistaz.IrisClient: Could not connect to host", url))
} else if (stringr::str_detect(
err_msg,
regex("Error", ignore_case = TRUE)
)) {
err_msg <- stringr::str_extract(err_msg, "Error (.+)")
stop(paste("getDistaz.IrisClient: Error", err_msg, url))
} else if (nchar(distazXml) == 0) {
stop(paste("getDistaz.IrisClient: returned empty string", url))
} else {
stop(paste(
"getDistaz.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
# No errors so proceed
# https://service.earthscope.org/irisws/distaz/1/query?stalat=0.0&stalon=0.0&evtlat=15.0&evtlon=0.0
#
# <DistanceAzimuth>
# <azimuth>180.0</azimuth>
# <backAzimuth>0.0</backAzimuth>
# <distance>14.90407</distance>
# </DistanceAzimuth>
# See this example for magic with the XML package:
#
# https://www.omegahat.net/RSXML/gettingStarted.html
result <- try(xmlList <- XML::xmlToList(distazXml), silent = TRUE)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDistaz.IrisClient:", err_msg))
}
xmlNames <- names(xmlList)
xmlList <- c(
xmlList["ellipsoid"],
sapply(
xmlList[xmlNames[!xmlNames %in% c("ellipsoid")]],
as.numeric
)
)
DF <- as.data.frame(xmlList)
colnames(DF)[colnames(DF) == "ellipsoid..attrs"] <- "ellipsoid.name"
return(DF)
}
# All arguments specified
setMethod(
"getDistaz", signature(
obj = "IrisClient",
latitude = "numeric",
longitude = "numeric",
staLatitude = "numeric",
staLongitude = "numeric"
),
function(obj,
latitude,
longitude,
staLatitude,
staLongitude) {
getDistaz.IrisClient(
obj,
latitude,
longitude,
staLatitude,
staLongitude
)
}
)
Try the IRISSeismic package in your browser
Any scripts or data that you put into this service are public.
IRISSeismic documentation built on March 19, 2026, 9:07 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions getDistaz.IrisClient getTraveltime.IrisClient getEvent.IrisClient getEvalresp.IrisClient getDataAvailability.IrisClient getUnavailability.IrisClient getAvailability.IrisClient getChannel.IrisClient getStation.IrisClient getNetwork.IrisClient getRotation.IrisClient getTimeseries.IrisClient getSNCL.IrisClient getDataselect.IrisClient
##
## S4 classes for communicating with EarthScope web services.
##
## Copyright (C) 2012 Mazama Science, Inc.
## by Jonathan Callahan, jonathan@mazamascience.com
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to the Free Software
## Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
################################################################################
# R classes for an EarthScope web services request client.
#
# Inspiration for the functionality in this code comes from obspy.iris.client.Client
#
# https://docs.obspy.org/packages/autogen/obspy.iris.client.Client.html
#
#
# Documentation for FDSN Web Services is available here:
#
# https://www.fdsn.org/webservices/
#
################################################################################
################################################################################
# Class IrisClient
#
# EarthScope web service request client.
#
# :type site: str, optional
# :param site: top level domain URL of the web services (default
# is ``'https://service.earthscope.org/'``).
# :type service_type: str, optional
# :param service_type: second element of URL, usually fdsnws
# :type debug: bool, optional
# :param debug: Enables verbose output (default is ``False``).
# :type user_agent: str, optional
# :param user_agent: Sets an client identification string which may be
# used on server side for statistical analysis (default contains the
# current module version and basic information about the used
# operation system, e.g.
# ``'IRISSeismic/1.7.1 RCurl/1.98-1.16 R/4.2.2 x86_64-pc-linux-gnu (MUSTANG)'``,
# where user_agent="MUSTANG"
# (default is "unidentified R script")
# :type event_site: str, optional
# :param event_site: top level domain URL of the event web service (default
# is ``'https://earthquake.usgs.gov/'``).
# :type dataselect_site: str, optional
# :param dataselect_site: top level domain URL of the dataselect web service
# (default is the site parameter)
# :type station_site: str, optional
# :param station_site: top level domain URL of the station web service
# (default is the site parameter)
# :type dataselect_site: str, optional
# :param availability_site: top level domain URL of the availability web service
# (default is the site parameter)
# :type retries: numeric, optional
# :param retries: number of times to retry a web service call in the case of
# failure (default = 1, must be less than 6)
#
################################################################################
utils::globalVariables(c("irisNetrc", "irisPass"))
# check for a user R profile for the IRIS Client site URL
# otherwise, use the default URL
irisSite <- "https://service.earthscope.org"
if (Sys.getenv("IrisClient_site") != "") {
irisSite <- Sys.getenv("IrisClient_site")
}
eventSite <- "https://earthquake.usgs.gov"
if (Sys.getenv("IrisClient_event_site") != "") {
eventSite <- Sys.getenv("IrisClient_event_site")
} else if (Sys.getenv("IrisClient_site") != "") {
if (!stringr::str_detect(
Sys.getenv("IrisClient_site"),
regex("service.*.iris.edu|service.*.earthscope.org")
)) {
eventSite <- Sys.getenv("IrisClient_site")
}
}
dataselectSite <- irisSite
if (Sys.getenv("IrisClient_dataselect_site") != "") {
dataselectSite <- Sys.getenv("IrisClient_dataselect_site")
}
stationSite <- irisSite
if (Sys.getenv("IrisClient_station_site") != "") {
stationSite <- Sys.getenv("IrisClient_station_site")
}
availabilitySite <- irisSite
if (Sys.getenv("IrisClient_availability_site") != "") {
availabilitySite <- Sys.getenv("IrisClient_availability_site")
}
# we will want the client using us as a library to be able to identify itself.
# it's easy enough to make this an environment setting as well.
# we will generate a default user agent to represent the metrics calculators.
irisUserAgent <- "unidentified R script"
if (Sys.getenv("IrisClient_agent") != "") {
irisUserAgent <- Sys.getenv("IrisClient_agent")
}
useragent1 <- paste0(
"IRISSeismic/",
ifelse("IRISSeismic" %in%
rownames(utils::installed.packages()),
utils::installed.packages()["IRISSeismic", "Version"],
"local code"
),
" RCurl/",
ifelse("RCurl" %in% rownames(utils::installed.packages()),
utils::installed.packages()["RCurl", "Version"],
"local code"
),
" R/", R.version$major, ".", R.version$minor,
" ", version$platform,
" (", irisUserAgent, ")"
)
setClass(
"IrisClient",
# typed slots (aka attributes) for class IrisClient
representation(
site = "character",
service_type = "character",
debug = "logical",
useragent = "character",
event_site = "character",
dataselect_site = "character",
station_site = "character",
availability_site = "character",
retries = "numeric"
)
)
setMethod(
"initialize", "IrisClient",
function(.Object,
site = irisSite,
debug = FALSE,
useragent = useragent1,
service_type = "fdsnws",
event_site = eventSite,
dataselect_site = dataselectSite,
station_site = stationSite,
availability_site = availabilitySite,
retries = 1) {
.Object@site <- site
.Object@service_type <- service_type
.Object@debug <- debug
.Object@useragent <- useragent
.Object@event_site <- event_site
.Object@dataselect_site <- dataselect_site
.Object@station_site <- station_site
.Object@availability_site <- availability_site
.Object@retries <- retries
.Object
}
)
setValidity("IrisClient", function(object) {
if (object@retries > 5) {
"@retries must be 5 or fewer"
} else {
TRUE
}
})
################################################################################
# getDataselect method returns a Stream object
#
# This implementation matches some of the functionality in the obspy dataselect
# function.
#
# https://docs.obspy.org/_modules/obspy/iris/client.html#Client.dataselect
#
################################################################################
if (!isGeneric("getDataselect")) {
setGeneric("getDataselect", function(obj, network, station, location, channel,
starttime, endtime, ...) {
standardGeneric("getDataselect")
})
}
getDataselect.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
quality = NULL,
repository = NULL,
inclusiveEnd = TRUE,
ignoreEpoch = FALSE) {
if (!is.logical(inclusiveEnd)) {
stop(paste("getDataselect.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
if (!is.logical(ignoreEpoch)) {
stop(paste("getDataselect.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
url <- obj@dataselect_site
if (!is.null(irisNetrc) || !is.null(irisPass)) {
url <- paste(url, obj@service_type, "dataselect/1/queryauth?", sep = "/")
} else {
url <- paste(url, obj@service_type, "dataselect/1/query?", sep = "/")
}
if (obj@service_type == "ph5ws") {
url <- paste(url, "reqtype=fdsn&net=", network, sep = "")
} else {
url <- paste(url, "net=", network, sep = "")
}
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the URL
# NOTE: For getDataselect only, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"),
sep = ""
)
url <- paste(url, "&cha=", channel, sep = "")
url <- paste(url, "&start=", format(starttime, "%Y-%m-%dT%H:%M:%OS6",
tz = "GMT"
),
sep = ""
)
if (!inclusiveEnd) {
endtime <- endtime - 0.000001
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
} else {
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
}
url <- paste(url, "&nodata=204", sep = "")
if (!is.null(quality) && obj@service_type != "ph5ws") {
url <- paste(url, "&quality=", quality, sep = "")
}
if (!is.null(repository) && obj@service_type != "ph5ws") {
if (repository %in% c(
"realtime", "primary", "bud", "primary,realtime",
"realtime,primary"
)) {
url <- paste(url, "&repository=", repository, sep = "")
} else {
err_msg <- c("Invalid repository, acceptable values are 'realtime' and
'primary'. To search both, do not specify a repository.")
stop(paste("getDataselect.IrisClient:", err_msg))
}
}
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
h <- RCurl::basicTextGatherer()
# Make authenticated request using password
if (!is.null(irisPass)) {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) { # Make authenticated request with netrc file
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
# authentication error or internal server error, try again
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
h <- RCurl::basicTextGatherer()
if (!is.null(irisPass)) {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else {
result <- try(
dataselectResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (header["status"] == "204") { # fdsnws dataselect returned nothing
stop(paste("getDataselect.IrisClient: No Data:", header["status"], url))
}
if (header["status"] != "200") { # fdsnws dataselect returned something unexpected
if (header["status"] == "400") {
stop(paste("getDataselect.IrisClient: Bad Request:", url))
} else if (header["status"] == "404") {
stop(paste("getDataselect.IrisClient: URL Not Found:", url))
} else {
stop(paste(
"getDataselect.IrisClient: Unexpected http status code",
header["status"], header["statusMessage"], url
))
}
}
# No errors so proceed
# Channel metadata is required to properly apply InstrumentSensitivity corrections
result <- try(
channels <- getChannel(
obj, network, station, location, channel,
starttime, endtime
),
silent = TRUE
)
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataselect.IrisClient:", err_msg, url))
}
# NOTE: Sometimes, the station webservice will return multiple records for the same SNCL
# NOTE: each with a different scale or starttime. This still represents a single SNCL.
# NOTE: What to do about multiple scales in the following getChannel request?
# Solution 1: if ignoreEpoch==TRUE, then just take the first epoch presented
# https://service.earthscope.org/fdsnws/station/1/query?net=H2&sta=H2O&loc=00&cha=LHZ&starttime=2001-02-28T18:29:44&endtime=2001-02-28T19:29:44&includerestricted=false&format=text&level=channel
sncls <- paste(
channels$network, channels$station, channels$location,
channels$channel
)
if (nrow(channels) > 1 && !ignoreEpoch) {
stop(paste(
"getDataselect.IrisClient: Multiple epochs: getChannel returned",
length(sncls), "records"
))
} else {
channelInfo <- channels[1, ]
}
# No errors so proceed
stream <- miniseed2Stream(dataselectResponse,
url,
starttime,
endtime,
channelInfo$instrument,
channelInfo$scale,
channelInfo$scalefreq,
channelInfo$scaleunits,
channelInfo$latitude,
channelInfo$longitude,
channelInfo$elevation,
channelInfo$depth,
channelInfo$azimuth,
channelInfo$dip,
removeZeroSampleTraces = TRUE
)
return(stream)
}
# All arguments specified
setMethod(
"getDataselect", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct"
),
function(obj, network, station, location, channel, starttime,
endtime, ...) {
getDataselect.IrisClient(
obj, network, station, location, channel,
starttime, endtime, ...
)
}
)
################################################################################
# getSNCL method is a convenience wrapper for getDataselect
################################################################################
if (!isGeneric("getSNCL")) {
setGeneric("getSNCL", function(obj, sncl, starttime, endtime, ...) {
standardGeneric("getSNCL")
})
}
getSNCL.IrisClient <- function(obj,
sncl,
starttime,
endtime,
quality = NULL,
repository = NULL,
inclusiveEnd = TRUE,
ignoreEpoch = FALSE) {
parts <- unlist(stringr::str_split(sncl, "\\."))
return(getDataselect.IrisClient(obj,
parts[1],
parts[2],
parts[3],
parts[4],
starttime,
endtime,
quality = quality,
repository = repository,
inclusiveEnd = inclusiveEnd,
ignoreEpoch = ignoreEpoch
))
}
# All arguments specified
setMethod(
"getSNCL", signature(
obj = "IrisClient", sncl = "character",
starttime = "POSIXct", endtime = "POSIXct"
),
function(obj, sncl, starttime, endtime, ...) {
getSNCL.IrisClient(obj, sncl, starttime, endtime, ...)
}
)
################################################################################
# getTimeseries method returns a Stream object
#
# Data are obtained from the timeseries web service:
#
# https://service.earthscope.org/irisws/timeseries/1/
#
# This method functions much like getDataselect() but allows for various types
# of signal processing.
#
################################################################################
if (!isGeneric("getTimeseries")) {
setGeneric("getTimeseries", function(obj,
network,
station,
location,
channel,
starttime,
endtime, ...) {
standardGeneric("getTimeseries")
})
}
getTimeseries.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
processing = NULL,
repository = NULL,
inclusiveEnd = TRUE,
ignoreEpoch = FALSE) {
if (!is.logical(inclusiveEnd)) {
stop(paste("getTimeseries.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
if (!is.logical(ignoreEpoch)) {
stop(paste("getTimeseries.IrisClient: option inclusiveEnd must be TRUE or
FALSE"))
}
url <- obj@site
if (!is.null(irisNetrc) || !is.null(irisPass)) {
url <- paste(url, "irisws/timeseries/1/queryauth?", sep = "/")
} else {
url <- paste(url, "irisws/timeseries/1/query?", sep = "/")
}
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the URL
# NOTE: For getTimeseries only, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", channel, sep = "")
url <- paste(url, "&start=", format(starttime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
if (!inclusiveEnd) {
endtime <- endtime - 0.000001
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
} else {
url <- paste(url, "&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
}
if (!is.null(repository) && obj@service_type != "ph5ws") {
if (repository %in% c(
"realtime",
"primary",
"bud",
"primary,realtime",
"realtime,primary"
)) {
url <- paste(url, "&repository=", repository, sep = "")
} else {
err_msg <- c("Invalid repository, acceptable values are 'realtime' and
'primary'. To search both, do not specify a repository.")
stop(paste("getTimeseries.IrisClient:", err_msg))
}
}
if (!is.null(processing)) {
url <- paste(url, processing, sep = "")
}
url <- paste(url, "&format=miniseed", sep = "")
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Make webservice request
h <- RCurl::basicTextGatherer()
# Make authenticated request using environmental variable password
if (!is.null(irisPass)) {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) {
# Make authenticated request using a netrc file
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else { # Make unauthenticated request
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
# authentication error or internal server error, try again
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
h <- RCurl::basicTextGatherer()
if (!is.null(irisPass)) {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
userpwd = irisPass,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else if (!is.null(irisNetrc)) {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
netrc = 1,
netrc.file = irisNetrc,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
} else {
result <- try(
timeseriesResponse <-
RCurl::getBinaryURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
}
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (header["status"] == "204") { # irisws timeseries returned nothing
stop(paste("getTimeseries.IrisClient: No Data:", header["status"], url))
}
if (header["status"] != "200") { # irisws timeseries returned something unexpected
if (header["status"] == "400") {
stop(paste("getTimeseries.IrisClient: Bad Request:", url))
} else if (header["status"] == "404") {
stop(paste("getTimeseries.IrisClient: URL Not Found:", url))
} else {
stop(paste(
"getTimeseriesIrisClient: Unexpected http status code",
header["status"], header["statusMessage"], url
))
}
}
# No errors so proceed
# Channel metadata is required to properly apply InstrumentSensitivity
# corrections
result <- try(
channels <- getChannel(
obj, network, station, location,
channel, starttime, endtime
),
silent = TRUE
)
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTimeseries.IrisClient:", err_msg, url))
}
# NOTE: Sometimes, the station webservice will return multiple records for
# NOTE: the same SNCL each with a different scale or starttime. This still
# NOTE: represents a single SNCL. What to do about multiple scales in the
# NOTE: following getChannel request?
# Solution 1: if ignoreEpoch==TRUE, then just take the first epoch presented
# https://service.earthscope.org/fdsnws/station/1/query?net=H2&sta=H2O&loc=00&cha=LHZ&starttime=2001-02-28T18:29:44&endtime=2001-02-28T19:29:44&includerestricted=false&format=text&level=channel
sncls <- paste(
channels$network, channels$station, channels$location,
channels$channel
)
if (nrow(channels) > 1 && !ignoreEpoch) {
stop(paste(
"getTimeseries.IrisClient: Multiple epochs: getChannel returned",
length(sncls), "records"
))
} else {
channelInfo <- channels[1, ]
}
# No errors so proceed
stream <- miniseed2Stream(timeseriesResponse,
url,
starttime,
endtime,
channelInfo$instrument,
channelInfo$scale,
channelInfo$scalefreq,
channelInfo$scaleunits,
channelInfo$latitude,
channelInfo$longitude,
channelInfo$elevation,
channelInfo$depth,
channelInfo$azimuth,
channelInfo$dip,
removeZeroSampleTraces = TRUE
)
return(stream)
}
# All arguments specified
setMethod(
"getTimeseries", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct"
),
function(obj, network, station, location, channel, starttime,
endtime, ...) {
getTimeseries.IrisClient(
obj, network, station, location, channel,
starttime, endtime, ...
)
}
)
################################################################################
# getRotation method returns a list of three Stream objects
#
# Data are obtained from the rotation web service:
#
# https://service.earthscope.org/irisws/rotation/1/
#
################################################################################
if (!isGeneric("getRotation")) {
setGeneric("getRotation", function(obj,
network,
station,
location,
channelSet,
starttime,
endtime,
processing) {
standardGeneric("getRotation")
})
}
getRotation.IrisClient <- function(obj,
network,
station,
location,
channelSet,
starttime,
endtime,
processing) {
url <- paste(obj@site, "/irisws/rotation/1/query?", sep = "")
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the
# NOTE: URL. For getRotation only, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url,
"&loc=",
stringr::str_replace(location, " ", "--"),
sep = ""
)
url <- paste(url, "&chaset=", channelSet, sep = "")
url <- paste(url,
"&start=", format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url,
"&end=", format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, processing, sep = "")
url <- paste(url, "&output=miniseed", sep = "")
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Download the rotation service response (zip file) to a temporary file
temp <- tempfile()
result <- try(utils::download.file(url, temp, quiet = TRUE))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getRotation.IrisClient:", err_msg, url))
}
# Create a dataframe of zip file contents and discard the metadata file
zipContents <- utils::unzip(temp, list = TRUE, junkpaths = TRUE)
metadata_mask <- stringr::str_detect(zipContents$Name, "metadata")
zipContents <- zipContents[!metadata_mask, ]
# Sanity check
if (nrow(zipContents) != 3) {
stop(paste(
"getRotation.IrisClient: rotation service return has",
nrow(zipContents), "traces -- 3 expected"
))
}
# Extract the three miniseed records, convert them to Stream objects and store
# them in streamList
streamList <- list()
for (i in seq(3)) {
con <- unz(temp, zipContents$Name[i], open = "rb")
rawMiniseed <- readBin(con, "raw", zipContents$Length[i])
streamList[[i]] <- miniseed2Stream(rawMiniseed,
url = paste(
"rotation:",
zipContents$Name[i]
),
requestedStarttime = starttime,
requestedEndtime = endtime,
sensor = "rotation web service",
removeZeroSampleTraces = TRUE
)
close(con)
}
# Remove the temporary file
unlink(temp)
return(streamList)
}
# All arguments specified
setMethod(
"getRotation", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channelSet = "character",
starttime = "POSIXct",
endtime = "POSIXct",
processing = "character"
),
function(obj, network, station, location, channelSet, starttime,
endtime, processing) {
getRotation.IrisClient(
obj, network, station, location, channelSet,
starttime, endtime, processing
)
}
)
################################################################################
# getNetwork method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=network".
#
# https://service.earthscope.org/fdsnws/station/1/
#
# Example output:
#
# #Network | Description | StartTime | EndTime | TotalStations
# IU|Global Seismograph Network (GSN - IRIS/USGS)|1988-01-01T00:00:00|2500-12-12T23:59:59|254
#
################################################################################
if (!isGeneric("getNetwork")) {
setGeneric("getNetwork", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getNetwork")
})
}
getNetwork.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (obj@service_type != "ph5ws") {
url <- paste(url, "&includerestricted=",
ifelse(includerestricted, "true", "false"),
sep = ""
)
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getNetwork() method
url <- paste(url, "&level=network", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# #Network | Description | StartTime | EndTime | TotalStations
colNames <- c(
"network", "description", "starttime", "endtime",
"totalstations"
)
colClasses <- c(rep("character", 4), "numeric")
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getNetwork.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getNetwork.IrisClient: Couldn't connect to host", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getNetwork.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getNetwork.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getNetwork.IrisClient: Cannot open connection", url))
} else {
stop(paste("getNetwork.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Return a dataframe with rows ordered by network
return(DF[order(DF$network), ])
}
# All arguments specified
setMethod(
"getNetwork", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getNetwork.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use FALSE
setMethod(
"getNetwork", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getNetwork.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = FALSE,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getStation method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=station".
#
# https://service.earthscope.org/fdsnws/station/1/
#
# Example output:
#
# #Network | Station | Latitude | Longitude | Elevation | SiteName | StartTime | EndTime
# IU|COR|44.5855|-123.3046|110.0|Corvallis, Oregon, USA|2009-09-26T00:00:00|2599-12-31T23:59:59
#
################################################################################
if (!isGeneric("getStation")) {
setGeneric("getStation", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getStation")
})
}
getStation.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (!is.null(includerestricted) && obj@service_type != "ph5ws") {
url <- paste(url, "&includerestricted=", includerestricted, sep = "")
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getStation() method
url <- paste(url, "&level=station", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Latitude | Longitude | Elevation | SiteName | StartTime | EndTime
colNames <- c(
"network",
"station",
"latitude",
"longitude",
"elevation",
"sitename",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 2), rep("numeric", 3), rep("character", 3))
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getStation.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getStation.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getStation.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getStation.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getStation.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getStation.IrisClient: couldn't connect to host", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getStation.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getStation.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) {
gurlc <- ""
}
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getStation.IrisClient: Cannot open the connection:", url))
} else {
stop(paste("getStation.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Return dataframe with rows ordered by network.station
netsta <- paste(DF$network, DF$station, sep = ".")
return(DF[order(netsta), ])
}
# All arguments specified
setMethod(
"getStation", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getStation.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use NULL
setMethod(
"getStation", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getStation.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = NULL,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getChannel method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=channel".
#
# https://service.earthscope.org/fdsnws/station/1/
#
# Example output:
#
# #Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip | Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
# IU|COR|10|LHZ|44.5855|-123.3046|110.0|0.0|0.0|-90.0|Trillium 240 broad band|1.98775E9|0.02|M/S|1.0|2011-01-15T07:00:00|2012-03-08T08:43:00
#
################################################################################
if (!isGeneric("getChannel")) {
setGeneric("getChannel", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getChannel")
})
}
getChannel.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (obj@service_type == "fdsnws") {
if (!is.null(includerestricted)) {
url <- paste(url, "&includerestricted=", tolower(includerestricted),
sep = ""
)
}
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getChannel() method
url <- paste(url, "&level=channel", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip |
# Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
colNames <- c(
"network",
"station",
"location",
"channel",
"latitude",
"longitude",
"elevation",
"depth",
"azimuth",
"dip",
"instrument",
"scale",
"scalefreq",
"scaleunits",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(
rep("character", 4),
rep("numeric", 6),
"character",
rep("numeric", 2),
"character",
"numeric",
rep("character", 2)
)
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getChannel.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getChannel.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getChannel.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getChannel.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getChannel.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getChannel.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getChannel.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getChannel.IrisClient: Cannot open connection", url))
} else {
stop(paste("getChannel.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Convert " " location codes back into the "" that is used in the miniSEED
# record
DF$location <- stringr::str_replace(DF$location, " ", "")
# new station web service now returns blank loc codes, which convert to NA
# switch NA's to "" as well
DF$location[is.na(DF$location)] <- ""
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Add a snclId column
DF$snclId <- paste(DF$network, DF$station, DF$location, DF$channel, sep = ".")
# Return dataframe with rows ordered by snclId
return(DF[order(DF$snclId), ])
}
# All arguments specified
setMethod(
"getChannel", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getChannel.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use NULL
setMethod(
"getChannel", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getChannel.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = NULL,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getAvailability method returns a dataframe with information from the output
# of the fdsn station web service with "format=text&level=channel".
# With additional parameters, this webservice returns information on all
# matching SNCLs that have available data.
#
# The fdsnws/station web service will return space characters for location
# codes that are SPACE SPACE.
#
# https://service.earthscope.org/fdsnws/station/1/
#
# #Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip | Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
# CU|ANWB|00|LHZ|17.66853|-61.78557|39.0|0.0|0.0|-90.0|Streckeisen STS-2 Standard-gain|2.43609E9|0.05|M/S|1.0|2010-02-10T18:35:00|2599-12-31T23:59:59
#
################################################################################
if (!isGeneric("getAvailability")) {
setGeneric("getAvailability", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getAvailability")
})
}
getAvailability.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Parameters common to all 'station' webservice requests
url <- paste(obj@station_site, obj@service_type, "station/1/query?", sep = "/")
url <- paste(url, "net=", ifelse(network == "", "*", network), sep = "")
url <- paste(url, "&sta=", ifelse(station == "", "*", station), sep = "")
# NOTE: Blank locations containing two spaces must be converted to "--"
location <- ifelse(location == "", "*", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", ifelse(channel == "", "*", channel), sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT"),
sep = ""
)
url <- paste(url, "&nodata=204", sep = "")
if (obj@service_type != "ph5ws") {
url <- paste(url, "&includerestricted=", ifelse(includerestricted, "true",
"false"
),
sep = ""
)
}
url <- paste(url, "&format=text", sep = "")
# Add optional geographic constraints if they are passed in
if (!missing(latitude)) {
url <- paste(url, "&latitude=", latitude, sep = "")
}
if (!missing(longitude)) {
url <- paste(url, "&longitude=", longitude, sep = "")
}
if (!missing(minradius)) {
url <- paste(url, "&minradius=", minradius, sep = "")
}
if (!missing(maxradius)) {
url <- paste(url, "&maxradius=", maxradius, sep = "")
}
# Parameters specific to the getAvailability() method
if (obj@service_type != "ph5ws") {
url <- paste(url, "&includeavailability=true", sep = "")
url <- paste(url, "&matchtimeseries=true", sep = "")
}
url <- paste(url, "&level=channel", sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Location | Channel | Latitude | Longitude | Elevation | Depth | Azimuth | Dip |
# Instrument | Scale | ScaleFreq | ScaleUnits | SampleRate | StartTime | EndTime
colNames <- c(
"network",
"station",
"location",
"channel",
"latitude",
"longitude",
"elevation",
"depth",
"azimuth",
"dip",
"instrument",
"scale",
"scalefreq",
"scaleunits",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(
rep("character", 4),
rep("numeric", 6),
"character",
rep("numeric", 2),
"character",
"numeric",
rep("character", 2)
)
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getAvailability.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getAvailability.IrisClient: couldn't connect to host", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getAvailability.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getAvailability.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = ""
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getAvailability.IrisClient: Cannot open connection", url))
} else {
stop(paste("getAvailability.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Filter out unwanted channels -- first to come to mind is LOG, but others get added by recommendation.
DF <- DF[!(DF$channel %in% c("LOG", "ACE", "OCF")), ]
# Convert " " location codes back into the "" that is used in the miniSEED record
DF$location <- stringr::str_replace(DF$location, " ", "")
# new station web service now returns blank loc codes, which convert to NA
# switch NA's to "" as well
DF$location[is.na(DF$location)] <- ""
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Add a snclId column
DF$snclId <- paste(DF$network, DF$station, DF$location, DF$channel, sep = ".")
# Return dataframe with rows ordered by snclId
return(DF[order(DF$snclId), ])
}
# All arguments specified
setMethod(
"getAvailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getAvailability.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use FALSE
setMethod(
"getAvailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getAvailability.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = FALSE,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getUnavailability method returns a dataframe with those channels that are found
# in the getChannel() dataframe but not in the getAvailability() dataframe.
################################################################################
if (!isGeneric("getUnavailability")) {
setGeneric("getUnavailability", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
standardGeneric("getUnavailability")
})
}
getUnavailability.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
# Get all channels
c <- getChannel(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
# Get available channels
a <- getAvailability(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
# Create unique record identifiers (SNCL is enough)
c_sncls <- paste(c$network, c$station, c$location, c$channel, sep = ".")
a_sncls <- paste(a$network, a$station, a$location, a$channel, sep = ".")
unavailable_mask <- !(c_sncls %in% a_sncls)
return(c[unavailable_mask, ])
}
# All arguments specified
setMethod(
"getUnavailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "logical",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getUnavailability.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius
)
}
)
# includerestricted="missing", use FALSE
setMethod(
"getUnavailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
includerestricted = "missing",
latitude = "ANY",
longitude = "ANY",
minradius = "ANY",
maxradius = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted,
latitude,
longitude,
minradius,
maxradius) {
getUnavailability.IrisClient(obj,
network,
station,
location,
channel,
starttime,
endtime,
includerestricted = FALSE,
latitude,
longitude,
minradius,
maxradius
)
}
)
################################################################################
# getDataAvailability method returns a dataframe with information from the output
# of the iris availability web service with "format=text&level=channel".
#
# https://service.earthscope.org/fdsnws/availability/1/
#
################################################################################
if (!isGeneric("getDataAvailability")) {
setGeneric("getDataAvailability", function(obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge) {
standardGeneric("getDataAvailability")
})
}
getDataAvailability.IrisClient <- function(obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge) {
url <- paste(obj@availability_site, obj@service_type, "availability/1/query?",
sep = "/"
)
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"),
sep = ""
)
url <- paste(url, "&cha=", channel, sep = "")
url <- paste(url, "&starttime=",
format(starttime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
url <- paste(url, "&endtime=",
format(endtime, "%Y-%m-%dT%H:%M:%OS6", tz = "GMT"),
sep = ""
)
url <- paste(url, "&format=geocsv", sep = "")
url <- paste(url, "&nodata=204", sep = "")
# Add optional arguments if they are found
mergeflag <- 0
if (missing(mergequality) || mergequality == TRUE) {
url <- paste(url, "&merge=quality", sep = "")
mergequality <- TRUE
mergeflag <- 1
}
if (!missing(mergesamplerate) && mergesamplerate == TRUE) {
if (mergeflag == 0) {
url <- paste(url, "&merge=samplerate", sep = "")
mergeflag <- 1
} else {
url <- paste(url, ",samplerate", sep = "")
}
} else {
mergesamplerate <- FALSE
} # default is FALSE
if (missing(mergeoverlap) || mergeoverlap == TRUE) {
if (mergeflag == 0) {
url <- paste(url, "&merge=overlap", sep = "")
mergeflag <- 1
} else {
url <- paste(url, ",overlap", sep = "")
}
} # default is TRUE
if (!missing(mergetolerance)) {
url <- paste(url, "&mergegaps=", mergetolerance, sep = "")
} # default is 1.5 sample rate
if (!missing(includerestricted)) {
url <- paste(url, "&includerestricted=", includerestricted, sep = "")
} else {
url <- paste(url, "&includerestricted=TRUE", sep = "")
} # default is TRUE
if (!missing(excludetoolarge) && excludetoolarge == TRUE) {
url <- paste(url, "&limit=500000", sep = "")
} # default is FALSE
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Set up the colnames we wish to have in our dataframe
# Network | Station | Location | Channel | Quality | SampleRate | StartTime | EndTime
# Network | Station | Location | Channel | SampleRate | StartTime | EndTime
if (mergequality == FALSE) {
if (mergesamplerate == TRUE) {
colNames <- c(
"network",
"station",
"location",
"channel",
"quality",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 7))
} else {
colNames <- c(
"network",
"station",
"location",
"channel",
"quality",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 8))
}
} else {
if (mergesamplerate == TRUE) {
colNames <- c(
"network",
"station",
"location",
"channel",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 6))
} else {
colNames <- c(
"network",
"station",
"location",
"channel",
"samplerate",
"starttime",
"endtime"
)
colClasses <- c(rep("character", 7))
}
}
# Make webservice request
# NOTE: Be sure to set na.strings="" as "NA" is a valid network name
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataAvailability.IrisClient:", strtrim(err_msg, 500), url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getDataAvailability.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getDataAvailability.IrisClient: Cannot open connection", url))
} else if (stringr::str_detect(
err_msg,
regex("Error 500: Internal Server Error")
)) {
err_msg <- stringr::str_replace_all(err_msg, "[\r\n\t]", "")
stop(paste(
"getDataAvailability.IrisClient: Internal Server Error:",
stringr::str_match(
err_msg,
"Error 500: Internal Server Error(.+)Usage"
)[, 2],
url
))
} else {
stop(paste(
"getDataAvailability.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.delim(txtcon,
sep = "|",
col.names = colNames,
colClasses = colClasses,
na.strings = "",
skip = 4
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getDataAvailability.IrisClient: Cannot open connection", url))
} else {
stop(paste("getDataAvailability.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Filter out unwanted channels -- first to come to mind is LOG, but others get added by recommendation.
DF <- DF[!(DF$channel %in% c("LOG", "ACE", "OCF")), ]
# Convert " " location codes back into the "" that is used in the miniSEED record
DF$location <- stringr::str_replace(DF$location, " ", "")
DF$location[is.na(DF$location)] <- ""
# Convert time strings
DF$starttime <- as.POSIXct(DF$starttime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
DF$endtime <- as.POSIXct(DF$endtime, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Add a snclId column
DF$snclId <- paste(DF$network, DF$station, DF$location, DF$channel, sep = ".")
# Return dataframe with rows ordered by snclId
return(DF[order(DF$snclId), ])
}
# All required arguments specified
setMethod(
"getDataAvailability", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
starttime = "POSIXct",
endtime = "POSIXct",
mergequality = "ANY",
mergesamplerate = "ANY",
mergeoverlap = "ANY",
mergetolerance = "ANY",
includerestricted = "ANY",
excludetoolarge = "ANY"
),
function(obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge) {
getDataAvailability.IrisClient(
obj,
network,
station,
location,
channel,
starttime,
endtime,
mergequality,
mergesamplerate,
mergeoverlap,
mergetolerance,
includerestricted,
excludetoolarge
)
}
)
################################################################################
# getEvalresp method returns instrument response data from the evalresp webservice:
#
# https://service/irisws/evalresp/1/
#
################################################################################
if (!isGeneric("getEvalresp")) {
setGeneric("getEvalresp", function(obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing) {
standardGeneric("getEvalresp")
})
}
getEvalresp.IrisClient <- function(obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing) {
# TODO: getEvalresp should test for wildcards in network, station, location, channel
# TODO: and return an error if any are found.
url <- obj@site
if (obj@service_type == "ph5ws") {
url <- paste(url, "ph5ws/evalresp/1/query?", sep = "/")
} else {
url <- paste(url, "irisws/evalresp/1/query?", sep = "/")
}
url <- paste(url, "net=", network, sep = "")
url <- paste(url, "&sta=", station, sep = "")
# NOTE: Locations with blanks must be converted into "--" when creating the URL
# NOTE: For getEvalresp, convert "" to "--"
location <- ifelse(location == "", "--", location)
url <- paste(url, "&loc=", stringr::str_replace(location, " ", "--"), sep = "")
url <- paste(url, "&cha=", channel, sep = "")
# NOTE: a single 'time' parameter is used rather than 'starttime' and 'endtime'
url <- paste(url, "&time=", format(time, "%Y-%m-%dT%H:%M:%OS0", tz = "GMT"), sep = "") # ws_evalresp requires "T" format
if (missing(output)) {
output <- "fap"
}
url <- paste(url, "&output=", output, sep = "")
# Add optional arguments if they are found
if (!missing(minfreq)) {
url <- paste(url, "&minfreq=", minfreq, sep = "")
}
if (!missing(maxfreq)) {
url <- paste(url, "&maxfreq=", maxfreq, sep = "")
}
if (!missing(nfreq)) {
url <- paste(url, "&nfreq=", nfreq, sep = "")
}
if (!missing(units)) {
url <- paste(url, "&units=", units, sep = "")
}
if (!missing(spacing)) {
url <- paste(url, "&spacing=", spacing, sep = "")
}
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Handle requests for either freq-amp-phase or freq-real-imag
if (output == "fap") {
colNames <- c("freq", "amp", "phase")
} else if (output == "cs") {
colNames <- c("freq", "real", "imag")
} else {
stop(paste(
"getEvalresp.IrisClient: bad output arg = '", output,
"' -- must be 'fap' or 'cs'"
))
}
# Conversion of URL into a data frame is a single line with utils::read.table().
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvalresp.IrisClient:", strtrim(err_msg, 500), url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("Not Found", ignore_case = TRUE)) ||
header["status"] == "404") {
stop(paste("getEvalresp.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvalresp.IrisClient: Cannot open connection", url))
} else if (stringr::str_detect(
err_msg,
regex("Error 500: Internal Server Error")
)) {
err_msg <- stringr::str_replace_all(err_msg, "[\r\n\t]", "")
stop(paste(
"getEvalresp.IrisClient: Internal Server Error:",
stringr::str_match(
err_msg,
"Error 500: Internal Server Error(.+)Usage"
)[, 2],
url
))
} else {
stop(paste(
"getEvalresp.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(DF <- utils::read.table(txtcon, col.names = colNames),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvalresp.IrisClient: Cannot open connection", url))
} else {
stop(paste("getEvalresp.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Return the dataframe, guaranteeing that it is ordered by frequency
return(DF[order(DF$freq), ])
}
# All required arguments specified
setMethod(
"getEvalresp", signature(
obj = "IrisClient",
network = "character",
station = "character",
location = "character",
channel = "character",
time = "POSIXct",
minfreq = "ANY",
maxfreq = "ANY",
nfreq = "ANY",
units = "ANY",
output = "ANY",
spacing = "ANY"
),
function(obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing) {
getEvalresp.IrisClient(
obj,
network,
station,
location,
channel,
time,
minfreq,
maxfreq,
nfreq,
units,
output,
spacing
)
}
)
################################################################################
# getEvent method returns seismic event data from the event webservice:
#
# https://earthquake.usgs.gov/fdsnws/event/1/
#
# TODO: The getEvent method could be fleshed out with a more complete list
# TODO: of arguments to be used as ws-event parameters.
################################################################################
if (!isGeneric("getEvent")) {
setGeneric("getEvent", function(obj,
starttime,
endtime,
minmag,
maxmag,
magtype,
mindepth,
maxdepth) {
standardGeneric("getEvent")
})
}
getEvent.IrisClient <- function(obj,
starttime,
endtime,
minmag,
maxmag,
magtype,
mindepth,
maxdepth) {
url <- paste(obj@event_site, "/fdsnws/event/1/query?", sep = "")
url <- paste(url, "starttime=", format(starttime, "%Y-%m-%dT%H:%M:%OS0",
tz = "GMT"
),
sep = ""
)
url <- paste(url, "&endtime=", format(endtime, "%Y-%m-%dT%H:%M:%OS0",
tz = "GMT"
),
sep = ""
)
url <- paste(url, "&format=text", sep = "")
# Add optional arguments if they are non-null
if (!missing(minmag)) {
url <- paste(url, "&minmag=", minmag, sep = "")
}
if (!missing(maxmag)) {
url <- paste(url, "&maxmag=", maxmag, sep = "")
}
if (!missing(magtype)) {
url <- paste(url, "&magtype=", magtype, sep = "")
}
if (!missing(mindepth)) {
url <- paste(url, "&mindepth=", mindepth, sep = "")
}
if (!missing(maxdepth)) {
url <- paste(url, "&maxdepth=", maxdepth, sep = "")
}
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# https://earthquake.usgs.gov/fdsnws/event/1/query?starttime=2013-02-01T00:00:00&endtime=2013-02-02T00:00:00&minmag=5&format=text
#
# #EventID | Time | Latitude | Longitude | Depth | Author | Catalog | Contributor | ContributorID | MagType | Magnitude | MagAuthor | EventLocationName
# 4075900|2013-02-01T22:18:33|-11.12|165.378|10.0|NEIC|NEIC PDE|NEIC PDE-Q||MW|6.4|GCMT|SANTA CRUZ ISLANDS
# Assign column names and classes for the returned data
colNames <- c(
"eventId",
"time",
"latitude",
"longitude",
"depth",
"author",
"cCatalog",
"contributor",
"contributorId",
"magType",
"magnitude",
"magAuthor",
"eventLocationName"
)
colClasses <- c(
"character",
"character",
"numeric",
"numeric",
"numeric",
"factor",
"factor",
"factor",
"factor",
"factor",
"numeric",
"factor",
"character"
)
# Conversion of URL into a data frame is a single line with read.table().
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvent.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getEvent.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getEvent.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getEvent.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("service unavailable",
ignore_case = TRUE
)) ||
header["status"] == "503") {
stop(paste("getEvent.IrisClient: Service Unavailable", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvent.IrisClient: Cannot open connection", url))
} else if (stringr::str_detect(err_msg, regex("Not Found",
ignore_case = TRUE
)) ||
header["status"] == "404") {
stop(paste("getEvent.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getEvent.IrisClient: Couldn't connect to host", url))
} else if (header["status"] != "200" && header["status"] != "204") {
stop(paste(
"getEvent.IrisClient: Unexpected http status code",
header["status"], err_msg, url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
DF <- utils::read.table(txtcon,
sep = "|",
quote = "",
col.names = colNames,
colClasses = colClasses
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getEvent.IrisClient: Cannot open connection", url))
} else {
stop(paste("getEvent.IrisClient:", err_msg, url))
}
}
# Last check to make sure DF is defined
if (!exists("DF")) {
stop(paste("getEvent.IrisClient: No Data Found"))
}
# No errors so proceed
# Final data conversion
DF$time <- as.POSIXct(DF$time, "%Y-%m-%dT%H:%M:%OS", tz = "GMT")
# Return dataframe with rows ordered by time
return(DF[order(DF$time), ])
}
# All arguments specified
setMethod(
"getEvent", signature(
obj = "IrisClient",
starttime = "POSIXct",
endtime = "POSIXct",
minmag = "ANY",
maxmag = "ANY",
magtype = "ANY",
mindepth = "ANY",
maxdepth = "ANY"
),
function(obj, starttime, endtime, minmag, maxmag,
magtype, mindepth, maxdepth) {
getEvent.IrisClient(
obj, starttime, endtime, minmag, maxmag,
magtype, mindepth, maxdepth
)
}
)
################################################################################
# getTraveltime method returns a dataframe with information from the traveltime
# webservice:
#
# https://service.earthscope.org/irisws/traveltime/1/
#
################################################################################
if (!isGeneric("getTraveltime")) {
setGeneric("getTraveltime", function(obj,
latitude,
longitude,
depth,
staLatitude,
staLongitude) {
standardGeneric("getTraveltime")
})
}
getTraveltime.IrisClient <- function(obj, latitude, longitude, depth,
staLatitude, staLongitude) {
# Create URL arguments from incoming parameters
evloc <- paste("[", latitude, ",", longitude, "]", sep = "")
staloc <- paste("[", staLatitude, ",", staLongitude, "]", sep = "")
# Assemble URL
url <- paste(obj@site, "/irisws/traveltime/1/query?", sep = "")
url <- paste(url, "&evloc=", evloc, sep = "")
url <- paste(url, "&evdepth=", depth, sep = "")
url <- paste(url, "&staloc=", staloc, sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# https://service.earthscope.org/irisws/traveltime/1/query?evloc=[-11.12,165.378]&evdepth=10.0&staloc=[-30.4183,151.6293]
#
# Model: iasp91
# Distance Depth Phase Travel Ray Param Takeoff Incident Purist Purist
# (deg) (km) Name Time (s) p (s/deg) (deg) (deg) Distance Name
# -----------------------------------------------------------------------------------
# 23.14 10.0 P 306.34 10.542 33.42 33.36 23.14 = P
# 23.14 10.0 P 306.88 9.162 28.60 28.55 23.14 = P
# 23.14 10.0 P 308.47 9.679 30.38 30.32 23.14 = P
# 23.14 10.0 PcP 534.45 2.082 6.25 6.24 23.14 = PcP
# 23.14 10.0 S 558.79 16.323 29.61 29.55 23.14 = S
# 23.14 10.0 S 560.09 19.178 35.48 35.42 23.14 = S
# 23.14 10.0 S 563.00 17.678 32.35 32.29 23.14 = S
# 23.14 10.0 S 575.53 23.885 46.29 46.20 23.14 = S
# 23.14 10.0 S 575.59 23.797 46.07 45.98 23.14 = S
# 23.14 10.0 ScS 978.54 3.844 6.68 6.67 23.14 = ScS
# 23.14 10.0 PKiKP 998.81 0.511 1.53 1.53 23.14 = PKiKP
# 23.14 10.0 SKiKS 1422.54 0.570 0.99 0.99 23.14 = SKiKS
# Assign column names and classes for the returned data
colNames <- c(
"distance",
"depth",
"phaseName",
"travelTime",
"rayParam",
"takeoff",
"incident",
"puristDistance",
"dummy",
"puristName"
)
colClasses <- c(
"numeric", "numeric", "factor", "numeric", "numeric",
"numeric", "numeric", "numeric", "character", "character"
)
# Conversion of URL into a data frame is a single line with read.table().
h <- RCurl::basicTextGatherer()
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
gurlc <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- gurlc
if (stringr::str_detect(err_msg, regex("couldn't connect to host",
ignore_case = TRUE
))) {
stop(paste("getTraveltime.IrisClient: Couldn't connect to host", url))
} else if (stringr::str_detect(
err_msg,
regex("Not Found", ignore_case = TRUE)
) ||
header["status"] == "404") {
stop(paste("getTraveltime.IrisClient: URL Not Found", url))
} else if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getTraveltime.IrisClient: Cannot open connection", url))
} else {
stop(paste(
"getTraveltime.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
if (length(gurlc) == 0) gurlc <- ""
txtcon <- textConnection(gurlc)
on.exit(close(txtcon), add = TRUE)
result <- try(
returnValue <- utils::read.table(txtcon,
skip = 4,
col.names = colNames,
colClasses = colClasses
),
silent = TRUE
)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
if (stringr::str_detect(err_msg, regex("cannot open the connection",
ignore_case = TRUE
))) {
stop(paste("getTraveltime.IrisClient: Cannot open connection", url))
} else {
stop(paste("getTraveltime.IrisClient:", err_msg, url))
}
}
# No errors so proceed
# Only use the first seven columns
DF <- returnValue[, c(1:8, 10)]
# Return dataframe with rows ordered by travelTime
return(DF[order(DF$travelTime), ])
}
# All arguments specified
setMethod(
"getTraveltime", signature(
obj = "IrisClient",
latitude = "numeric",
longitude = "numeric",
depth = "numeric",
staLatitude = "numeric",
staLongitude = "numeric"
),
function(obj, latitude, longitude, depth, staLatitude, staLongitude) {
getTraveltime.IrisClient(
obj, latitude, longitude, depth,
staLatitude, staLongitude
)
}
)
################################################################################
# getDistaz method returns a dataframe with information from the distaz
# webservice:
#
# https://service.earthscope.org/irisws/distaz/1/
#
################################################################################
if (!isGeneric("getDistaz")) {
setGeneric("getDistaz", function(obj,
latitude,
longitude,
staLatitude,
staLongitude) {
standardGeneric("getDistaz")
})
}
getDistaz.IrisClient <- function(obj,
latitude,
longitude,
staLatitude,
staLongitude) {
# Assemble URL
url <- paste(obj@site, "/irisws/distaz/1/query?", sep = "")
url <- paste(url, "&evtlat=", latitude, sep = "")
url <- paste(url, "&evtlon=", longitude, sep = "")
url <- paste(url, "&stalat=", staLatitude, sep = "")
url <- paste(url, "&stalon=", staLongitude, sep = "")
# Write debug output
if (obj@debug) {
write(paste("<debug>URL =", url), stdout())
}
# Get data from distaz web service
h <- RCurl::basicTextGatherer()
result <- try(
distazXml <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
# Handle error response
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDistaz.IrisClient:", err_msg))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDistaz.IrisClient:", err_msg))
}
sleep_seconds <- jitter(3, 10)
retries <- obj@retries
while (header["status"] %in% c(401, 429, 500:511) && retries > 0) {
if (header["status"] == 429) sleep_seconds <- sleep_seconds + 60
Sys.sleep(sleep_seconds)
result <- try(
distazXml <- RCurl::getURL(url,
useragent = obj@useragent,
.opts = list(
headerfunction = h$update,
followlocation = TRUE,
low.speed.time = 300,
low.speed.limit = 1,
connecttimeout = 300
)
),
silent = TRUE
)
if (inherits(result, "try-error")) {
stop(paste("getDistaz.IrisClient:", err_msg, url))
}
result <- try(header <- RCurl::parseHTTPHeader(h$value()))
if (inherits(result, "try-error")) {
stop(paste("getDistaz.IrisClient:", err_msg, url))
}
sleep_seconds <- sleep_seconds * 2
retries <- retries - 1
}
if (!header["status"] %in% c("200", "204")) {
err_msg <- distazXml
if (stringr::str_detect(err_msg, regex("Not Found",
ignore_case = TRUE
)) ||
header["status"] == "404") {
stop(paste("getDistaz.IrisClient: URL Not Found:", url))
} else if (stringr::str_detect(err_msg, regex("connect to host",
ignore_case = TRUE
))) {
stop(paste("getDistaz.IrisClient: Could not connect to host", url))
} else if (stringr::str_detect(
err_msg,
regex("Error", ignore_case = TRUE)
)) {
err_msg <- stringr::str_extract(err_msg, "Error (.+)")
stop(paste("getDistaz.IrisClient: Error", err_msg, url))
} else if (nchar(distazXml) == 0) {
stop(paste("getDistaz.IrisClient: returned empty string", url))
} else {
stop(paste(
"getDistaz.IrisClient: Unexpected http status code",
header["status"], strtrim(err_msg, 500), url
))
}
}
# No errors so proceed
# https://service.earthscope.org/irisws/distaz/1/query?stalat=0.0&stalon=0.0&evtlat=15.0&evtlon=0.0
#
# <DistanceAzimuth>
# <azimuth>180.0</azimuth>
# <backAzimuth>0.0</backAzimuth>
# <distance>14.90407</distance>
# </DistanceAzimuth>
# See this example for magic with the XML package:
#
# https://www.omegahat.net/RSXML/gettingStarted.html
result <- try(xmlList <- XML::xmlToList(distazXml), silent = TRUE)
if (inherits(result, "try-error")) {
err_msg <- geterrmessage()
stop(paste("getDistaz.IrisClient:", err_msg))
}
xmlNames <- names(xmlList)
xmlList <- c(
xmlList["ellipsoid"],
sapply(
xmlList[xmlNames[!xmlNames %in% c("ellipsoid")]],
as.numeric
)
)
DF <- as.data.frame(xmlList)
colnames(DF)[colnames(DF) == "ellipsoid..attrs"] <- "ellipsoid.name"
return(DF)
}
# All arguments specified
setMethod(
"getDistaz", signature(
obj = "IrisClient",
latitude = "numeric",
longitude = "numeric",
staLatitude = "numeric",
staLongitude = "numeric"
),
function(obj,
latitude,
longitude,
staLatitude,
staLongitude) {
getDistaz.IrisClient(
obj,
latitude,
longitude,
staLatitude,
staLongitude
)
}
)
Try the IRISSeismic package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.