Nothing
R/Class-Metric.R
In IRISMustangMetrics: Statistics and Metrics for Seismic Data
Defines functions
spectrumMetric2Xml
timesMetric2Xml
metricList2Xml
metricList2DFList
metricList2DF
show.MultipleTimeValueMetric
show.SpectrumMetric
show.GeneralValueMetric
show.SingleValueMetric
Documented in
metricList2DF
metricList2DFList
metricList2Xml
spectrumMetric2Xml
timesMetric2Xml
## 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 a Metric obj.
#
# This class is part of the MUSTANG project at IRIS DMC.
#
# The Metric class stores generated metrics and allows their output
# as XML.
#
#<measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='A.B.C1.D.E'>
# <example value='1.0'/>
# </target>
# <target snclq='A.B.C2.D.E'>
# <example value='2.0'/>
# </target>
# <target snclq='A.B.C3.D.E'>
# <example value='3.0'/>
# </target>
# </date>
# <date start='2012-02-10T09:20:00.000' end='2012-02-10T18:40:00.000'>
# <target snclq='A.B.C1.D.E'>
# <example value='1.1'/>
# </target>
# <target snclq='A.B.C2.D.E'>
# <example value='2.1'/>
# </target>
# <target snclq='A.B.C3.D.E'>
# <example value='3.1'/>
# </target>
# </date>
#</measurements>
################################################################################
# Class SingleValueMetric
#
# The basic Metric object contains metadata associated with a value.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# valueName -- name of the parameter value stored in the BSS
# value -- numeric value of this metric
# valueString -- string representation of the value for this metric
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
# attributeName -- name of an optional, additional attribute
# attributeValueString -- string represetnation of the attribute value
################################################################################
setClass("SingleValueMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
valueName = "character",
value = "numeric",
valueString = "character",
quality_flag = "numeric",
quality_flagString = "character",
attributeName = "character",
attributeValueString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1970-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1970-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
valueName = "value",
valueString = "NULL",
quality_flag = -9,
quality_flagString = "-9",
attributeName = "",
attributeValueString = "")
)
# initialze method
setMethod("initialize", "SingleValueMetric",
function(.Object, snclq, starttime, endtime, metricName, value, quality_flag,
attributeName, attributeValueString, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@value <- value
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Set the attributeName if it is passed in
if (!missing(attributeName)) {
.Object@attributeName <- attributeName
}
# Set the attributeValueString if it is passed in
if (!missing(attributeValueString)) {
.Object@attributeValueString <- attributeValueString
}
# metrics whose values are integer
integerMetrics <- c("num_gaps",
"num_glitches",
"num_overlaps",
"num_pings",
"num_spikes",
"num_outliers",
# State Of Health flags
"calibration_signal",
"timing_correction",
"event_begin",
"event_end",
"event_in_progress",
"clock_locked",
"amplifier_saturation",
"digitizer_clipping",
"spikes",
"glitches",
"missing_padded_data",
"telemetry_sync_error",
"digital_filter_charging",
"suspect_time_tag",
"dead_channel_gsn")
# Set the valueString
if (metricName == "example") {
.Object@valueString <- sprintf("%.2f",value)
} else if (metricName %in% integerMetrics) {
.Object@valueString <- sprintf("%d",value)
} else {
# default formatting
.Object@valueString <- sprintf("%.3f",value)
}
# Convert missing value from R style to BSS style
if (.Object@valueString == "NA"){
.Object@valueString <- "NULL"
}
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.SingleValueMetric <- function(object) {
cat ("SingleValueMetric \n")
cat (" metric: " , object@metricName, "\n", sep="")
cat (" snclq: " , object@snclq, "\n", sep="")
cat (" starttime: " , format(object@starttime), "\n", sep="")
cat (" endtime: " , format(object@endtime), "\n", sep="")
cat (" value: " , object@valueString, "\n", sep="")
for (i in seq(length(object@attributeName))) {
name <- object@attributeName[i]
valString <- object@attributeValueString[i]
n <- 14 - stringr::str_length(name)
n <- ifelse (n > 0, n, 2)
if (name != "") {
cat (" ",name,":", rep(" ",n), valString, "\n", sep="")
}
}
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="SingleValueMetric"), function(object) show.SingleValueMetric(object))
################################################################################
# Class GeneralValueMetric
#
# The GeneralValueMetric object contains metadata associated with a list of values.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# elementNames -- vector of names of the XML element containing the parameter value stored in the BSS
# elementValues -- vector of values associated with this metric
# valueStrings -- vector of string representations of the values associated with this metric
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
#
################################################################################
setClassUnion("numORchar",c("numeric","character"))
setClass("GeneralValueMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
elementNames = "character",
elementValues = "numORchar",
valueStrings = "character",
quality_flag = "numeric",
quality_flagString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
elementNames = "x",
elementValues = NULL,
valueStrings = "c()",
quality_flag = -9,
quality_flagString = "-9")
)
# initialize method
setMethod("initialize", "GeneralValueMetric",
function(.Object, snclq, starttime, endtime, metricName, elementNames, elementValues, valueStrings, quality_flag, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@elementNames <- elementNames
.Object@elementValues <- elementValues
if(!missing(valueStrings)) {
.Object@valueStrings <- valueStrings
} else {
if (inherits(elementValues,"character")) {
.Object@valueStrings <- stringr::str_trim(format(elementValues))
} else {
.Object@valueStrings <- format(elementValues, digits=7)
}
}
# Convert missing value from R style to BSS style
.Object@valueStrings <- as.vector(sapply(.Object@valueStrings, function(x) if (x == "NA") { x <- "NULL" } else { x <- x } ))
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.GeneralValueMetric <- function(object) {
cat ("GeneralValueMetric \n")
cat (" metric: " , object@metricName, "\n")
cat (" snclq: " , object@snclq, "\n")
cat (" starttime: " , format(object@starttime), "\n")
cat (" endtime: " , format(object@endtime), "\n")
for (i in seq(length(object@elementNames))) {
name <- object@elementNames[i]
valString <- object@valueStrings[i]
n <- 15 - stringr::str_length(name)
n <- ifelse (n > 0, n, 2)
if (name != "") {
cat (" ",name,":", rep(" ",n), valString, "\n", sep="")
}
}
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="GeneralValueMetric"), function(object) show.GeneralValueMetric(object))
################################################################################
# Class SpectrumMetric
#
# The SpectrumMetric object contains data associated with a discrete spectrum.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# elementName -- name of the XML element containing the parameter value stored in the BSS
# freqs -- vector of spectrum frequencies
# freqStrings -- vector of string representations of the spectrum frequencies
# amps -- vector of spectrum amplitudes
# ampStrings -- vector of string representations of the spectrum amplitudes
# phases -- vector of spectrum phases
# phaseStrings -- vector of string representations of the spectrum phases
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
#
################################################################################
setClass("SpectrumMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
elementName = "character",
freqs = "numeric",
freqStrings = "character",
amps = "numeric",
ampStrings = "character",
phases = "numeric",
phaseStrings = "character",
quality_flag = "numeric",
quality_flagString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
elementName = "spectrum",
freqStrings = "c()",
ampStrings = "c()",
phaseStrings = "c()",
quality_flag = -9,
quality_flagString = "-9")
)
# initialze method
setMethod("initialize", "SpectrumMetric",
function(.Object, snclq, starttime, endtime, metricName, freqs, amps, phases, quality_flag, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@freqs <- freqs
.Object@amps <- amps
.Object@phases <- phases
# Set the Strings
.Object@freqStrings <- sprintf("%g",freqs)
.Object@ampStrings <- sprintf("%g",amps)
.Object@phaseStrings <- sprintf("%g",phases)
# Convert missing value from R style to BSS style
.Object@freqStrings <- stringr::str_replace(.Object@freqStrings,"NA","NULL")
.Object@ampStrings <- stringr::str_replace(.Object@ampStrings,"NA","NULL")
.Object@phaseStrings <- stringr::str_replace(.Object@phaseStrings,"NA","NULL")
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.SpectrumMetric <- function(object) {
cat ("SpectrumMetric \n")
cat (" metric: " , object@metricName, "\n")
cat (" snclq: " , object@snclq, "\n")
cat (" starttime: " , format(object@starttime), "\n")
cat (" endtime: " , format(object@endtime), "\n")
cat (" freqs: " , object@freqStrings, "\n")
cat (" amps: " , object@ampStrings, "\n")
cat (" phases: " , object@phaseStrings, "\n")
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="SpectrumMetric"), function(object) show.SpectrumMetric(object))
################################################################################
# Class MultipleTimeValueMetric
#
# The MultipleTimeValueMetric object contains metadata associated with a list of POSIXct values.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# elementName -- name of the XML element containing the parameter value stored in the BSS
# values -- vector of POSIXct values associated with this metric
# valueStrings -- vector of string representations of the values associated with this metric
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
#
# Here is the first example of what a multi-value metric will looklike:
#
# <measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='N.S.L.C1.Q'>
# <up_down_times>
# <t value="2012-02-10T00:00:00.000"/>
# <t value="2012-02-10T00:01:00.000"/>
# <t value="2012-02-10T00:02:00.000"/>
# <t value="2012-02-10T00:03:00.000"/>
# </up_down_times>
# </target>
# </date>
# </measurements>
#
################################################################################
setClass("MultipleTimeValueMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
elementName = "character",
values = "POSIXct",
valueStrings = "character",
quality_flag = "numeric",
quality_flagString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
elementName = "t",
valueStrings = "c()",
quality_flag = -9,
quality_flagString = "-9")
)
# initialze method
setMethod("initialize", "MultipleTimeValueMetric",
function(.Object, snclq, starttime, endtime, metricName, values, quality_flag, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@values <- values
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Convert values to strings
.Object@valueStrings <- format(values, format="%Y-%m-%dT%H:%M:%OS", tz="GMT")
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.MultipleTimeValueMetric <- function(object) {
cat ("MultipleTimeValueMetric \n")
cat (" metric: " , object@metricName, "\n")
cat (" snclq: " , object@snclq, "\n")
cat (" starttime: " , format(object@starttime), "\n")
cat (" endtime: " , format(object@endtime), "\n")
cat (" values: " , object@valueStrings, "\n")
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="MultipleTimeValueMetric"), function(object) show.MultipleTimeValueMetric(object))
################################################################################
# Function to convert a list of SingleValueMetric objects into a single, tidy
# dataframe with columns: "metricName, value, snclq, starttime, endtime, qualityFlag".
# These match the output from getSingleValueMetrics().
################################################################################
metricList2DF <- function(metricList) {
if (inherits(metricList[[1]],"SingleValueMetric")) {
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
value <- sapply(metricList, slot, 'value')
qualityFlag <- sapply(metricList, slot, 'quality_flag')
# NOTE: attributeName and attributeValueString can be vectors and are therefore
# NOTE: returned as a list of character vectors.
attributeNameList <- lapply(metricList, slot, 'attributeName')
attributeValueStringList <- lapply(metricList, slot, 'attributeValueString')
# Create a dataframe from the vectors created above
df <- as.data.frame(list(metricName,value,snclq,starttime,endtime,qualityFlag),
stringsAsFactors=FALSE)
names(df) <- c("metricName","value","snclq","starttime","endtime","qualityFlag")
# Now add attributes
# NOTE: As we are creating a dataframe, every column must be represented in every row.
# NOTE: If singleValueMetrics have different attributes, we will need to include all
# NOTE: of them as columns and then insert NA's into those rows where they are not found.
attNames <- unique(unlist(attributeNameList))
for (name in attNames) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
# Now fill in attribute values where thay are defined
for (i in seq(length(metricList))) {
names <- metricList[[i]]@attributeName
valStrings <- metricList[[i]]@attributeValueString
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
# Convert columns to appropriate type
df$qualityFlag <- as.numeric(df$qualityFlag)
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
} else if (inherits(metricList[[1]],"GeneralValueMetric")){
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
elementNamesList <- lapply(metricList, slot, 'elementNames')
qualityFlag <- sapply(metricList, slot, 'quality_flag')
df <- as.data.frame(list(metricName,snclq,starttime,endtime,qualityFlag), stringsAsFactors=FALSE)
names(df) <- c("metricName","snclq","starttime","endtime","qualityFlag")
elementNames <- unique(unlist(elementNamesList))
for (name in elementNames) {
if (name != "") {
df[[name]] <- as.numeric(rep("",length(snclq)))
}
}
for (i in seq(length(metricList))) {
elementNames <- metricList[[i]]@elementNames
valueStrings <- metricList[[i]]@valueStrings
for (j in seq(length(elementNames))) {
name <- elementNames[j]
value <- valueStrings[j]
if (name != "") {
df[[name]][i] <- value
}
}
}
# Convert columns to appropriate type
df$qualityFlag <- as.numeric(df$qualityFlag)
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
}
return(df)
}
################################################################################
# Function to convert a list of SingleValueMetric objects into a list of
# dataframes, one per metricName.
################################################################################
metricList2DFList <- function(metricList) {
.Deprecated("metricList2DF")
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
value <- sapply(metricList, slot, 'value')
quality_flagString <- sapply(metricList, slot, 'quality_flagString')
# NOTE: attributeName and attributeValueString can be vectors and are therefore
# NOTE: returned as a list of character vectors.
attributeNameList <- lapply(metricList, slot, 'attributeName')
attributeValueStringList <- lapply(metricList, slot, 'attributeValueString')
# Create a dataframe from the vectors created above
df <- as.data.frame(cbind(snclq,starttime,endtime,metricName,value,quality_flagString),
stringsAsFactors=FALSE)
# Now add attributes
# NOTE: As we are creating a dataframe, every column must be represented in every row.
# NOTE: If singleValueMetrics have different attributes, we will need to include all
# NOTE: of them as columns and then insert NA's into those rows where they are not found.
attNames <- unique(unlist(attributeNameList))
for (name in attNames) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
# Now fill in attribute values where thay are defined
for (i in seq(length(metricList))) {
names <- metricList[[i]]@attributeName
valStrings <- metricList[[i]]@attributeValueString
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
# At this point, all columns are of type "character"
dfList <- list()
for (metric in unique(df$metricName)) {
# Pull out data associated with a single metric
dfName <- paste0(metric,'_DF')
sub <- subset(df, metricName == metric)
sub[[metric]] <- sub$value
sub$quality_flag <- as.numeric(sub$quality_flagString)
# Convert columns to appropriate type
sub$starttime <- as.POSIXct(as.numeric(sub$starttime), origin="1970-01-01", tz="GMT")
sub$endtime <- as.POSIXct(as.numeric(sub$endtime), origin="1970-01-01", tz="GMT")
# Get rid of unneeded columns
sub$metricName <- NULL
sub$value <- NULL
sub$quality_flagString <- NULL
# Get rid of attributes with no values
for (name in attNames) {
if ( !any(sub[[name]] != "") ) {
sub[[name]] <- NULL
}
}
# Add this subset dataframe to the list
dfList[[dfName]] <- sub
}
return(dfList)
}
################################################################################
# Function to convert a list of SingleValueMetric objects into the XML expected by
# the DMC data loader.
################################################################################
metricList2Xml <- function(metricList) {
if (inherits(metricList[[1]],"SingleValueMetric")) {
returnString <- "<measurements>"
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
valueName <- sapply(metricList, slot, 'valueName')
valueString <- sapply(metricList, slot, 'valueString')
quality_flagString <- sapply(metricList, slot, 'quality_flagString')
# NOTE: attributeName and attributeValueString can be vectors and are therefore
# NOTE: returned as a list of character vectors.
attributeNameList <- lapply(metricList, slot, 'attributeName')
attributeValueStringList <- lapply(metricList, slot, 'attributeValueString')
# Create a dataframe from the vectors created above
df <- as.data.frame(list(snclq,starttime,endtime,metricName,valueName,valueString,quality_flagString),
stringsAsFactors=FALSE)
names(df) <- c("snclq","starttime","endtime","metricName","valueName","valueString","quality_flagString")
# Convert columns to appropriate type
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
# Now add attributes
# NOTE: As we are creating a dataframe, every column must be represented in every row.
# NOTE: If singleValueMetrics have different attributes, we will need to include all
# NOTE: of them as columns and then insert NA's into those rows where they are not found.
attNames <- unique(unlist(attributeNameList))
for (name in attNames) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
# Now fill in attribute values where thay are defined
for (i in seq(length(metricList))) {
names <- metricList[[i]]@attributeName
valStrings <- metricList[[i]]@attributeValueString
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
# Add a dateRange string so that we can find all unique date ranges
df$dateRange <- paste(df$starttime,df$endtime)
# Organize the metrics by dateRange as in the XML example above
dateRanges <- sort(unique(df$dateRange))
for (dateRange in dateRanges) {
# Create a subset of the dataframe that only includes the current dateRange
dateSubset <- df[df$dateRange == dateRange,]
# Create the string for this dateRange
# NOTE: This subset may have multiple rows so we only use dates from the first row
# REC -- correct date formatting to ISO
#startString <- as.character(dateSubset$starttime[1])
startString <- format(dateSubset$starttime[1],"%Y-%m-%dT%H:%M:%OS")
#endString <- as.character(dateSubset$endtime[1])
endString <- format(dateSubset$endtime[1],"%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Organize this subset by snclq
snclqs <- sort(unique(dateSubset$snclq))
for (id in snclqs) {
target <- subset(dateSubset, snclq == id)
# Create the string for this snclq
targetString <- paste("<target snclq='",id,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
for (i in seq(nrow(target))) {
# Create the valueString
valueString <- paste(target$valueName[i],"='",target$valueString[i],"'",sep="")
# Create attributerStrings as needed
attributeString <- ''
for (name in attNames) {
if (name != "") {
valString <- target[[name]][i]
if (valString != "") {
attributeString <- paste(attributeString," ",name,"='",valString,"'",sep="")
}
}
}
# Create quality_flagString if needed
if (target$quality_flagString[i] == -9) {
qualityString <- ''
} else {
qualityString <- paste("quality_flag='",target$quality_flagString[i],"'",sep="")
}
# Create the metricString
metricString <- paste("<",target$metricName[i]," ",
valueString," ",
qualityString," ",
attributeString," ",
"/>",sep="")
# if (target$quality_flagString[i] == "-9") {
# # If the quality_flag was not assigned during creation of the metric, don't include it in the XML
# metricString <- paste("<",target$metricName[i]," ",
# target$valueName[i],"='",target$valueString[i],"'",
# attributeString,
# "/>", sep="")
#
# } else {
# # If the quality_flag was assigned, add it to the XML
# metricString <- paste("<",target$metricName[i]," ",
# target$valueName[i],"='",target$valueString[i],"' ",
# "quality_flag='",target$quality_flagString[i],"'",
# attributeString,
# "/>" ,sep="")
# }
returnString <- paste(returnString,metricString,sep="")
} # end of "target" loop for each metric
returnString <- paste(returnString,"</target>",sep="")
} # end of "snclq" loop
returnString <- paste(returnString,"</date>",sep="")
} # end of "date" loop
returnString <- paste(returnString,"</measurements>",sep="")
return(returnString)
} else if (inherits(metricList[[1]],"GeneralValueMetric")) {
returnString <- "<measurements>"
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
elementNameList <- lapply(metricList, slot, 'elementNames')
valueStringList <- lapply(metricList, slot, 'valueStrings')
quality_flagString <- sapply(metricList, slot, 'quality_flagString')
df <- as.data.frame(list(snclq,starttime,endtime,metricName,quality_flagString),
stringsAsFactors=FALSE)
names(df) <- c("snclq","starttime","endtime","metricName","quality_flagString")
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
elementUnique <- unique(unlist(elementNameList))
for (name in elementUnique) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
for (i in seq(length(metricList))) {
names <- metricList[[i]]@elementNames
valStrings <- metricList[[i]]@valueStrings
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
df$dateRange <- paste(df$starttime,df$endtime)
dateRanges <- sort(unique(df$dateRange))
for (dateRange in dateRanges) {
# Create a subset of the dataframe that only includes the current dateRange
dateSubset <- df[df$dateRange == dateRange,]
# Create the string for this dateRange
startString <- format(dateSubset$starttime[1],"%Y-%m-%dT%H:%M:%OS")
endString <- format(dateSubset$endtime[1],"%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Organize this subset by snclq
snclqs <- sort(unique(dateSubset$snclq))
for (id in snclqs) {
target <- subset(dateSubset, snclq == id)
# Create the string for this snclq
targetString <- paste("<target snclq='",id,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
for (i in seq(nrow(target))) {
# Create attributerStrings as needed
elementString <- ''
for (name in elementUnique) {
if (name != "") {
valString <- target[[name]][i]
if (valString != "") {
elementString <- paste(elementString," ",name,"='",valString,"'",sep="")
}
}
}
# Create quality_flagString if needed
if (target$quality_flagString[i] == -9) {
qualityString <- ''
} else {
qualityString <- paste("quality_flag='",target$quality_flagString[i],"'",sep="")
}
# Create the metricString
metricString <- paste("<",target$metricName[i]," ",
elementString," ",
qualityString," ",
"/>",sep="")
returnString <- paste(returnString,metricString,sep="")
} # end of "target" loop for each metric
returnString <- paste(returnString,"</target>",sep="")
} # end of "snclq" loop
returnString <- paste(returnString,"</date>",sep="")
} # end of "date" loop
returnString <- paste(returnString,"</measurements>",sep="")
return(returnString)
}
}
################################################################################
# Function to convert a MultipleTimeValueMetric into the XML expected by the
# DMC data loader.
#
# Here is the first example of what a multi-value metric will look like:
#
# <measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='N.S.L.C1.Q'>
# <up_down_times>
# <t value="2012-02-10T00:00:00.000"/>
# <t value="2012-02-10T00:01:00.000"/>
# <t value="2012-02-10T00:02:00.000"/>
# <t value="2012-02-10T00:03:00.000"/>
# </up_down_times>
# </target>
# </date>
# </measurements>
#
################################################################################
timesMetric2Xml <- function(metric) {
returnString <- "<measurements>"
# Add the <date>
startString <- format(metric@starttime, format="%Y-%m-%dT%H:%M:%OS")
endString <- format(metric@endtime, format="%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Add the <target>
targetString <- paste("<target snclq='",metric@snclq,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
# Add the <~metric_name~>
metricString <- paste("<",metric@metricName,">",sep="")
returnString <- paste(returnString,metricString,sep="")
# Add the individual elements if any exist
if (length(metric@valueStrings) > 0) {
elementsString <- paste("<",metric@elementName," value='",metric@valueStrings,"'/>",sep="",collapse="")
returnString <- paste(returnString,elementsString,sep="")
}
# Close up the tags
metricCloseString <- paste("</",metric@metricName,">",sep="")
returnString <- paste(returnString,metricCloseString,sep="")
returnString <- paste(returnString,"</target>",sep="")
returnString <- paste(returnString,"</date>",sep="")
returnString <- paste(returnString,"</measurements>",sep="")
return(returnString)
}
################################################################################
# Function to convert a SpectrumMetric into the XML expected by the
# DMC data loader.
#
# Here is the first example of what a multi-value metric will looklike:
#
# <measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='N.S.L.C1.Q'>
# <psd>
# <spectrum f="0.01" a="1.045234e4"/>
# ...
# </psd>
# </target>
# </date>
# </measurements>
#
################################################################################
spectrumMetric2Xml <- function(metricList) {
returnString <- ""
for (metric in metricList) {
# Add the <date>
startString <- format(metric@starttime, format="%Y-%m-%dT%H:%M:%OS")
endString <- format(metric@endtime, format="%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Add the <target>
targetString <- paste("<target snclq='",metric@snclq,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
# Add the <~metric_name~>
metricString <- paste("<",metric@metricName,">",sep="")
returnString <- paste(returnString,metricString,sep="")
# Add the individual elements
elementsString <- paste("<", metric@elementName,
" f='", metric@freqStrings,
"' a='", metric@ampStrings,
"' p='", metric@phaseStrings,
"'/>", sep="", collapse="")
returnString <- paste(returnString,elementsString,sep="")
# Close up the tags
metricCloseString <- paste("</",metric@metricName,">",sep="")
returnString <- paste(returnString,metricCloseString,sep="")
returnString <- paste(returnString,"</target>",sep="")
returnString <- paste(returnString,"</date>",sep="")
}
returnString <- paste("<measurements>",returnString,"</measurements>",sep="")
return(returnString)
}
Try the IRISMustangMetrics package in your browser
Any scripts or data that you put into this service are public.
IRISMustangMetrics documentation built on Aug. 22, 2023, 9:11 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 spectrumMetric2Xml timesMetric2Xml metricList2Xml metricList2DFList metricList2DF show.MultipleTimeValueMetric show.SpectrumMetric show.GeneralValueMetric show.SingleValueMetric
Documented in metricList2DF metricList2DFList metricList2Xml spectrumMetric2Xml timesMetric2Xml
## 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 a Metric obj.
#
# This class is part of the MUSTANG project at IRIS DMC.
#
# The Metric class stores generated metrics and allows their output
# as XML.
#
#<measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='A.B.C1.D.E'>
# <example value='1.0'/>
# </target>
# <target snclq='A.B.C2.D.E'>
# <example value='2.0'/>
# </target>
# <target snclq='A.B.C3.D.E'>
# <example value='3.0'/>
# </target>
# </date>
# <date start='2012-02-10T09:20:00.000' end='2012-02-10T18:40:00.000'>
# <target snclq='A.B.C1.D.E'>
# <example value='1.1'/>
# </target>
# <target snclq='A.B.C2.D.E'>
# <example value='2.1'/>
# </target>
# <target snclq='A.B.C3.D.E'>
# <example value='3.1'/>
# </target>
# </date>
#</measurements>
################################################################################
# Class SingleValueMetric
#
# The basic Metric object contains metadata associated with a value.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# valueName -- name of the parameter value stored in the BSS
# value -- numeric value of this metric
# valueString -- string representation of the value for this metric
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
# attributeName -- name of an optional, additional attribute
# attributeValueString -- string represetnation of the attribute value
################################################################################
setClass("SingleValueMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
valueName = "character",
value = "numeric",
valueString = "character",
quality_flag = "numeric",
quality_flagString = "character",
attributeName = "character",
attributeValueString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1970-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1970-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
valueName = "value",
valueString = "NULL",
quality_flag = -9,
quality_flagString = "-9",
attributeName = "",
attributeValueString = "")
)
# initialze method
setMethod("initialize", "SingleValueMetric",
function(.Object, snclq, starttime, endtime, metricName, value, quality_flag,
attributeName, attributeValueString, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@value <- value
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Set the attributeName if it is passed in
if (!missing(attributeName)) {
.Object@attributeName <- attributeName
}
# Set the attributeValueString if it is passed in
if (!missing(attributeValueString)) {
.Object@attributeValueString <- attributeValueString
}
# metrics whose values are integer
integerMetrics <- c("num_gaps",
"num_glitches",
"num_overlaps",
"num_pings",
"num_spikes",
"num_outliers",
# State Of Health flags
"calibration_signal",
"timing_correction",
"event_begin",
"event_end",
"event_in_progress",
"clock_locked",
"amplifier_saturation",
"digitizer_clipping",
"spikes",
"glitches",
"missing_padded_data",
"telemetry_sync_error",
"digital_filter_charging",
"suspect_time_tag",
"dead_channel_gsn")
# Set the valueString
if (metricName == "example") {
.Object@valueString <- sprintf("%.2f",value)
} else if (metricName %in% integerMetrics) {
.Object@valueString <- sprintf("%d",value)
} else {
# default formatting
.Object@valueString <- sprintf("%.3f",value)
}
# Convert missing value from R style to BSS style
if (.Object@valueString == "NA"){
.Object@valueString <- "NULL"
}
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.SingleValueMetric <- function(object) {
cat ("SingleValueMetric \n")
cat (" metric: " , object@metricName, "\n", sep="")
cat (" snclq: " , object@snclq, "\n", sep="")
cat (" starttime: " , format(object@starttime), "\n", sep="")
cat (" endtime: " , format(object@endtime), "\n", sep="")
cat (" value: " , object@valueString, "\n", sep="")
for (i in seq(length(object@attributeName))) {
name <- object@attributeName[i]
valString <- object@attributeValueString[i]
n <- 14 - stringr::str_length(name)
n <- ifelse (n > 0, n, 2)
if (name != "") {
cat (" ",name,":", rep(" ",n), valString, "\n", sep="")
}
}
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="SingleValueMetric"), function(object) show.SingleValueMetric(object))
################################################################################
# Class GeneralValueMetric
#
# The GeneralValueMetric object contains metadata associated with a list of values.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# elementNames -- vector of names of the XML element containing the parameter value stored in the BSS
# elementValues -- vector of values associated with this metric
# valueStrings -- vector of string representations of the values associated with this metric
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
#
################################################################################
setClassUnion("numORchar",c("numeric","character"))
setClass("GeneralValueMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
elementNames = "character",
elementValues = "numORchar",
valueStrings = "character",
quality_flag = "numeric",
quality_flagString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
elementNames = "x",
elementValues = NULL,
valueStrings = "c()",
quality_flag = -9,
quality_flagString = "-9")
)
# initialize method
setMethod("initialize", "GeneralValueMetric",
function(.Object, snclq, starttime, endtime, metricName, elementNames, elementValues, valueStrings, quality_flag, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@elementNames <- elementNames
.Object@elementValues <- elementValues
if(!missing(valueStrings)) {
.Object@valueStrings <- valueStrings
} else {
if (inherits(elementValues,"character")) {
.Object@valueStrings <- stringr::str_trim(format(elementValues))
} else {
.Object@valueStrings <- format(elementValues, digits=7)
}
}
# Convert missing value from R style to BSS style
.Object@valueStrings <- as.vector(sapply(.Object@valueStrings, function(x) if (x == "NA") { x <- "NULL" } else { x <- x } ))
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.GeneralValueMetric <- function(object) {
cat ("GeneralValueMetric \n")
cat (" metric: " , object@metricName, "\n")
cat (" snclq: " , object@snclq, "\n")
cat (" starttime: " , format(object@starttime), "\n")
cat (" endtime: " , format(object@endtime), "\n")
for (i in seq(length(object@elementNames))) {
name <- object@elementNames[i]
valString <- object@valueStrings[i]
n <- 15 - stringr::str_length(name)
n <- ifelse (n > 0, n, 2)
if (name != "") {
cat (" ",name,":", rep(" ",n), valString, "\n", sep="")
}
}
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="GeneralValueMetric"), function(object) show.GeneralValueMetric(object))
################################################################################
# Class SpectrumMetric
#
# The SpectrumMetric object contains data associated with a discrete spectrum.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# elementName -- name of the XML element containing the parameter value stored in the BSS
# freqs -- vector of spectrum frequencies
# freqStrings -- vector of string representations of the spectrum frequencies
# amps -- vector of spectrum amplitudes
# ampStrings -- vector of string representations of the spectrum amplitudes
# phases -- vector of spectrum phases
# phaseStrings -- vector of string representations of the spectrum phases
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
#
################################################################################
setClass("SpectrumMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
elementName = "character",
freqs = "numeric",
freqStrings = "character",
amps = "numeric",
ampStrings = "character",
phases = "numeric",
phaseStrings = "character",
quality_flag = "numeric",
quality_flagString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
elementName = "spectrum",
freqStrings = "c()",
ampStrings = "c()",
phaseStrings = "c()",
quality_flag = -9,
quality_flagString = "-9")
)
# initialze method
setMethod("initialize", "SpectrumMetric",
function(.Object, snclq, starttime, endtime, metricName, freqs, amps, phases, quality_flag, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@freqs <- freqs
.Object@amps <- amps
.Object@phases <- phases
# Set the Strings
.Object@freqStrings <- sprintf("%g",freqs)
.Object@ampStrings <- sprintf("%g",amps)
.Object@phaseStrings <- sprintf("%g",phases)
# Convert missing value from R style to BSS style
.Object@freqStrings <- stringr::str_replace(.Object@freqStrings,"NA","NULL")
.Object@ampStrings <- stringr::str_replace(.Object@ampStrings,"NA","NULL")
.Object@phaseStrings <- stringr::str_replace(.Object@phaseStrings,"NA","NULL")
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.SpectrumMetric <- function(object) {
cat ("SpectrumMetric \n")
cat (" metric: " , object@metricName, "\n")
cat (" snclq: " , object@snclq, "\n")
cat (" starttime: " , format(object@starttime), "\n")
cat (" endtime: " , format(object@endtime), "\n")
cat (" freqs: " , object@freqStrings, "\n")
cat (" amps: " , object@ampStrings, "\n")
cat (" phases: " , object@phaseStrings, "\n")
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="SpectrumMetric"), function(object) show.SpectrumMetric(object))
################################################################################
# Class MultipleTimeValueMetric
#
# The MultipleTimeValueMetric object contains metadata associated with a list of POSIXct values.
#
# snclq -- station.network.channel.location.quality identifier
# starttime -- starttime for the trace used in this metric
# endtime -- endtime for the trace used in this metric
# metricName -- name of this metric
# elementName -- name of the XML element containing the parameter value stored in the BSS
# values -- vector of POSIXct values associated with this metric
# valueStrings -- vector of string representations of the values associated with this metric
# quality_flag -- numeric flag identifying issues in the quality of the calculated metric
# quality_flagString -- string representation of quality_flag
#
# Here is the first example of what a multi-value metric will looklike:
#
# <measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='N.S.L.C1.Q'>
# <up_down_times>
# <t value="2012-02-10T00:00:00.000"/>
# <t value="2012-02-10T00:01:00.000"/>
# <t value="2012-02-10T00:02:00.000"/>
# <t value="2012-02-10T00:03:00.000"/>
# </up_down_times>
# </target>
# </date>
# </measurements>
#
################################################################################
setClass("MultipleTimeValueMetric",
# typed slots (aka attributes) for class Trace
representation(snclq = "character",
starttime = "POSIXct",
endtime = "POSIXct",
metricName = "character",
elementName = "character",
values = "POSIXct",
valueStrings = "character",
quality_flag = "numeric",
quality_flagString = "character"),
# default values for slots
prototype(snclq = "",
starttime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
endtime = as.POSIXct("1900-01-01T00:00:00",format="%Y-%m-%dT%H:%M:%OS", tz="GMT"),
metricName = "",
elementName = "t",
valueStrings = "c()",
quality_flag = -9,
quality_flagString = "-9")
)
# initialze method
setMethod("initialize", "MultipleTimeValueMetric",
function(.Object, snclq, starttime, endtime, metricName, values, quality_flag, ...) {
.Object@snclq <- snclq
.Object@starttime <- starttime
.Object@endtime <- endtime
.Object@metricName <- metricName
.Object@values <- values
# Set the quality_flag if it is passed in
if (!missing(quality_flag)) {
.Object@quality_flag <- quality_flag
}
# Convert values to strings
.Object@valueStrings <- format(values, format="%Y-%m-%dT%H:%M:%OS", tz="GMT")
# Set the quality_flagString using BSS style missing value
.Object@quality_flagString <- as.character(.Object@quality_flag)
return(.Object)
}
)
# show method is called by show() and print() ----------------------------------
show.MultipleTimeValueMetric <- function(object) {
cat ("MultipleTimeValueMetric \n")
cat (" metric: " , object@metricName, "\n")
cat (" snclq: " , object@snclq, "\n")
cat (" starttime: " , format(object@starttime), "\n")
cat (" endtime: " , format(object@endtime), "\n")
cat (" values: " , object@valueStrings, "\n")
}
# NOTE: method signature must match generic signature for 'show' with argument: 'object'
setMethod("show", signature(object="MultipleTimeValueMetric"), function(object) show.MultipleTimeValueMetric(object))
################################################################################
# Function to convert a list of SingleValueMetric objects into a single, tidy
# dataframe with columns: "metricName, value, snclq, starttime, endtime, qualityFlag".
# These match the output from getSingleValueMetrics().
################################################################################
metricList2DF <- function(metricList) {
if (inherits(metricList[[1]],"SingleValueMetric")) {
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
value <- sapply(metricList, slot, 'value')
qualityFlag <- sapply(metricList, slot, 'quality_flag')
# NOTE: attributeName and attributeValueString can be vectors and are therefore
# NOTE: returned as a list of character vectors.
attributeNameList <- lapply(metricList, slot, 'attributeName')
attributeValueStringList <- lapply(metricList, slot, 'attributeValueString')
# Create a dataframe from the vectors created above
df <- as.data.frame(list(metricName,value,snclq,starttime,endtime,qualityFlag),
stringsAsFactors=FALSE)
names(df) <- c("metricName","value","snclq","starttime","endtime","qualityFlag")
# Now add attributes
# NOTE: As we are creating a dataframe, every column must be represented in every row.
# NOTE: If singleValueMetrics have different attributes, we will need to include all
# NOTE: of them as columns and then insert NA's into those rows where they are not found.
attNames <- unique(unlist(attributeNameList))
for (name in attNames) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
# Now fill in attribute values where thay are defined
for (i in seq(length(metricList))) {
names <- metricList[[i]]@attributeName
valStrings <- metricList[[i]]@attributeValueString
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
# Convert columns to appropriate type
df$qualityFlag <- as.numeric(df$qualityFlag)
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
} else if (inherits(metricList[[1]],"GeneralValueMetric")){
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
elementNamesList <- lapply(metricList, slot, 'elementNames')
qualityFlag <- sapply(metricList, slot, 'quality_flag')
df <- as.data.frame(list(metricName,snclq,starttime,endtime,qualityFlag), stringsAsFactors=FALSE)
names(df) <- c("metricName","snclq","starttime","endtime","qualityFlag")
elementNames <- unique(unlist(elementNamesList))
for (name in elementNames) {
if (name != "") {
df[[name]] <- as.numeric(rep("",length(snclq)))
}
}
for (i in seq(length(metricList))) {
elementNames <- metricList[[i]]@elementNames
valueStrings <- metricList[[i]]@valueStrings
for (j in seq(length(elementNames))) {
name <- elementNames[j]
value <- valueStrings[j]
if (name != "") {
df[[name]][i] <- value
}
}
}
# Convert columns to appropriate type
df$qualityFlag <- as.numeric(df$qualityFlag)
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
}
return(df)
}
################################################################################
# Function to convert a list of SingleValueMetric objects into a list of
# dataframes, one per metricName.
################################################################################
metricList2DFList <- function(metricList) {
.Deprecated("metricList2DF")
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
value <- sapply(metricList, slot, 'value')
quality_flagString <- sapply(metricList, slot, 'quality_flagString')
# NOTE: attributeName and attributeValueString can be vectors and are therefore
# NOTE: returned as a list of character vectors.
attributeNameList <- lapply(metricList, slot, 'attributeName')
attributeValueStringList <- lapply(metricList, slot, 'attributeValueString')
# Create a dataframe from the vectors created above
df <- as.data.frame(cbind(snclq,starttime,endtime,metricName,value,quality_flagString),
stringsAsFactors=FALSE)
# Now add attributes
# NOTE: As we are creating a dataframe, every column must be represented in every row.
# NOTE: If singleValueMetrics have different attributes, we will need to include all
# NOTE: of them as columns and then insert NA's into those rows where they are not found.
attNames <- unique(unlist(attributeNameList))
for (name in attNames) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
# Now fill in attribute values where thay are defined
for (i in seq(length(metricList))) {
names <- metricList[[i]]@attributeName
valStrings <- metricList[[i]]@attributeValueString
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
# At this point, all columns are of type "character"
dfList <- list()
for (metric in unique(df$metricName)) {
# Pull out data associated with a single metric
dfName <- paste0(metric,'_DF')
sub <- subset(df, metricName == metric)
sub[[metric]] <- sub$value
sub$quality_flag <- as.numeric(sub$quality_flagString)
# Convert columns to appropriate type
sub$starttime <- as.POSIXct(as.numeric(sub$starttime), origin="1970-01-01", tz="GMT")
sub$endtime <- as.POSIXct(as.numeric(sub$endtime), origin="1970-01-01", tz="GMT")
# Get rid of unneeded columns
sub$metricName <- NULL
sub$value <- NULL
sub$quality_flagString <- NULL
# Get rid of attributes with no values
for (name in attNames) {
if ( !any(sub[[name]] != "") ) {
sub[[name]] <- NULL
}
}
# Add this subset dataframe to the list
dfList[[dfName]] <- sub
}
return(dfList)
}
################################################################################
# Function to convert a list of SingleValueMetric objects into the XML expected by
# the DMC data loader.
################################################################################
metricList2Xml <- function(metricList) {
if (inherits(metricList[[1]],"SingleValueMetric")) {
returnString <- "<measurements>"
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
valueName <- sapply(metricList, slot, 'valueName')
valueString <- sapply(metricList, slot, 'valueString')
quality_flagString <- sapply(metricList, slot, 'quality_flagString')
# NOTE: attributeName and attributeValueString can be vectors and are therefore
# NOTE: returned as a list of character vectors.
attributeNameList <- lapply(metricList, slot, 'attributeName')
attributeValueStringList <- lapply(metricList, slot, 'attributeValueString')
# Create a dataframe from the vectors created above
df <- as.data.frame(list(snclq,starttime,endtime,metricName,valueName,valueString,quality_flagString),
stringsAsFactors=FALSE)
names(df) <- c("snclq","starttime","endtime","metricName","valueName","valueString","quality_flagString")
# Convert columns to appropriate type
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
# Now add attributes
# NOTE: As we are creating a dataframe, every column must be represented in every row.
# NOTE: If singleValueMetrics have different attributes, we will need to include all
# NOTE: of them as columns and then insert NA's into those rows where they are not found.
attNames <- unique(unlist(attributeNameList))
for (name in attNames) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
# Now fill in attribute values where thay are defined
for (i in seq(length(metricList))) {
names <- metricList[[i]]@attributeName
valStrings <- metricList[[i]]@attributeValueString
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
# Add a dateRange string so that we can find all unique date ranges
df$dateRange <- paste(df$starttime,df$endtime)
# Organize the metrics by dateRange as in the XML example above
dateRanges <- sort(unique(df$dateRange))
for (dateRange in dateRanges) {
# Create a subset of the dataframe that only includes the current dateRange
dateSubset <- df[df$dateRange == dateRange,]
# Create the string for this dateRange
# NOTE: This subset may have multiple rows so we only use dates from the first row
# REC -- correct date formatting to ISO
#startString <- as.character(dateSubset$starttime[1])
startString <- format(dateSubset$starttime[1],"%Y-%m-%dT%H:%M:%OS")
#endString <- as.character(dateSubset$endtime[1])
endString <- format(dateSubset$endtime[1],"%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Organize this subset by snclq
snclqs <- sort(unique(dateSubset$snclq))
for (id in snclqs) {
target <- subset(dateSubset, snclq == id)
# Create the string for this snclq
targetString <- paste("<target snclq='",id,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
for (i in seq(nrow(target))) {
# Create the valueString
valueString <- paste(target$valueName[i],"='",target$valueString[i],"'",sep="")
# Create attributerStrings as needed
attributeString <- ''
for (name in attNames) {
if (name != "") {
valString <- target[[name]][i]
if (valString != "") {
attributeString <- paste(attributeString," ",name,"='",valString,"'",sep="")
}
}
}
# Create quality_flagString if needed
if (target$quality_flagString[i] == -9) {
qualityString <- ''
} else {
qualityString <- paste("quality_flag='",target$quality_flagString[i],"'",sep="")
}
# Create the metricString
metricString <- paste("<",target$metricName[i]," ",
valueString," ",
qualityString," ",
attributeString," ",
"/>",sep="")
# if (target$quality_flagString[i] == "-9") {
# # If the quality_flag was not assigned during creation of the metric, don't include it in the XML
# metricString <- paste("<",target$metricName[i]," ",
# target$valueName[i],"='",target$valueString[i],"'",
# attributeString,
# "/>", sep="")
#
# } else {
# # If the quality_flag was assigned, add it to the XML
# metricString <- paste("<",target$metricName[i]," ",
# target$valueName[i],"='",target$valueString[i],"' ",
# "quality_flag='",target$quality_flagString[i],"'",
# attributeString,
# "/>" ,sep="")
# }
returnString <- paste(returnString,metricString,sep="")
} # end of "target" loop for each metric
returnString <- paste(returnString,"</target>",sep="")
} # end of "snclq" loop
returnString <- paste(returnString,"</date>",sep="")
} # end of "date" loop
returnString <- paste(returnString,"</measurements>",sep="")
return(returnString)
} else if (inherits(metricList[[1]],"GeneralValueMetric")) {
returnString <- "<measurements>"
# Extract attributes from the list of Metrics
# NOTE: use 'sapply' to return a vector as opposed to the list returned by 'lapply'
snclq <- sapply(metricList, slot, 'snclq')
starttime <- as.numeric(sapply(metricList, slot, 'starttime'))
endtime <- as.numeric(sapply(metricList, slot, 'endtime'))
metricName <- sapply(metricList, slot, 'metricName')
elementNameList <- lapply(metricList, slot, 'elementNames')
valueStringList <- lapply(metricList, slot, 'valueStrings')
quality_flagString <- sapply(metricList, slot, 'quality_flagString')
df <- as.data.frame(list(snclq,starttime,endtime,metricName,quality_flagString),
stringsAsFactors=FALSE)
names(df) <- c("snclq","starttime","endtime","metricName","quality_flagString")
df$starttime <- as.POSIXct(as.numeric(df$starttime), origin="1970-01-01", tz="GMT")
df$endtime <- as.POSIXct(as.numeric(df$endtime), origin="1970-01-01", tz="GMT")
elementUnique <- unique(unlist(elementNameList))
for (name in elementUnique) {
if (name != "") {
df[[name]] <- rep("",length(snclq))
}
}
for (i in seq(length(metricList))) {
names <- metricList[[i]]@elementNames
valStrings <- metricList[[i]]@valueStrings
for (j in seq(length(names))) {
name <- names[j]
valString <- valStrings[j]
if (name != "") {
df[[name]][i] <- valString
}
}
}
df$dateRange <- paste(df$starttime,df$endtime)
dateRanges <- sort(unique(df$dateRange))
for (dateRange in dateRanges) {
# Create a subset of the dataframe that only includes the current dateRange
dateSubset <- df[df$dateRange == dateRange,]
# Create the string for this dateRange
startString <- format(dateSubset$starttime[1],"%Y-%m-%dT%H:%M:%OS")
endString <- format(dateSubset$endtime[1],"%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Organize this subset by snclq
snclqs <- sort(unique(dateSubset$snclq))
for (id in snclqs) {
target <- subset(dateSubset, snclq == id)
# Create the string for this snclq
targetString <- paste("<target snclq='",id,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
for (i in seq(nrow(target))) {
# Create attributerStrings as needed
elementString <- ''
for (name in elementUnique) {
if (name != "") {
valString <- target[[name]][i]
if (valString != "") {
elementString <- paste(elementString," ",name,"='",valString,"'",sep="")
}
}
}
# Create quality_flagString if needed
if (target$quality_flagString[i] == -9) {
qualityString <- ''
} else {
qualityString <- paste("quality_flag='",target$quality_flagString[i],"'",sep="")
}
# Create the metricString
metricString <- paste("<",target$metricName[i]," ",
elementString," ",
qualityString," ",
"/>",sep="")
returnString <- paste(returnString,metricString,sep="")
} # end of "target" loop for each metric
returnString <- paste(returnString,"</target>",sep="")
} # end of "snclq" loop
returnString <- paste(returnString,"</date>",sep="")
} # end of "date" loop
returnString <- paste(returnString,"</measurements>",sep="")
return(returnString)
}
}
################################################################################
# Function to convert a MultipleTimeValueMetric into the XML expected by the
# DMC data loader.
#
# Here is the first example of what a multi-value metric will look like:
#
# <measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='N.S.L.C1.Q'>
# <up_down_times>
# <t value="2012-02-10T00:00:00.000"/>
# <t value="2012-02-10T00:01:00.000"/>
# <t value="2012-02-10T00:02:00.000"/>
# <t value="2012-02-10T00:03:00.000"/>
# </up_down_times>
# </target>
# </date>
# </measurements>
#
################################################################################
timesMetric2Xml <- function(metric) {
returnString <- "<measurements>"
# Add the <date>
startString <- format(metric@starttime, format="%Y-%m-%dT%H:%M:%OS")
endString <- format(metric@endtime, format="%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Add the <target>
targetString <- paste("<target snclq='",metric@snclq,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
# Add the <~metric_name~>
metricString <- paste("<",metric@metricName,">",sep="")
returnString <- paste(returnString,metricString,sep="")
# Add the individual elements if any exist
if (length(metric@valueStrings) > 0) {
elementsString <- paste("<",metric@elementName," value='",metric@valueStrings,"'/>",sep="",collapse="")
returnString <- paste(returnString,elementsString,sep="")
}
# Close up the tags
metricCloseString <- paste("</",metric@metricName,">",sep="")
returnString <- paste(returnString,metricCloseString,sep="")
returnString <- paste(returnString,"</target>",sep="")
returnString <- paste(returnString,"</date>",sep="")
returnString <- paste(returnString,"</measurements>",sep="")
return(returnString)
}
################################################################################
# Function to convert a SpectrumMetric into the XML expected by the
# DMC data loader.
#
# Here is the first example of what a multi-value metric will looklike:
#
# <measurements>
# <date start='2012-02-10T00:00:00.000' end='2012-02-10T09:20:00.000'>
# <target snclq='N.S.L.C1.Q'>
# <psd>
# <spectrum f="0.01" a="1.045234e4"/>
# ...
# </psd>
# </target>
# </date>
# </measurements>
#
################################################################################
spectrumMetric2Xml <- function(metricList) {
returnString <- ""
for (metric in metricList) {
# Add the <date>
startString <- format(metric@starttime, format="%Y-%m-%dT%H:%M:%OS")
endString <- format(metric@endtime, format="%Y-%m-%dT%H:%M:%OS")
dateString <- paste("<date start='",startString,"' end='",endString,"'>",sep="")
returnString <- paste(returnString,dateString,sep="")
# Add the <target>
targetString <- paste("<target snclq='",metric@snclq,"'>",sep="")
returnString <- paste(returnString,targetString,sep="")
# Add the <~metric_name~>
metricString <- paste("<",metric@metricName,">",sep="")
returnString <- paste(returnString,metricString,sep="")
# Add the individual elements
elementsString <- paste("<", metric@elementName,
" f='", metric@freqStrings,
"' a='", metric@ampStrings,
"' p='", metric@phaseStrings,
"'/>", sep="", collapse="")
returnString <- paste(returnString,elementsString,sep="")
# Close up the tags
metricCloseString <- paste("</",metric@metricName,">",sep="")
returnString <- paste(returnString,metricCloseString,sep="")
returnString <- paste(returnString,"</target>",sep="")
returnString <- paste(returnString,"</date>",sep="")
}
returnString <- paste("<measurements>",returnString,"</measurements>",sep="")
return(returnString)
}
Try the IRISMustangMetrics 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.