#' Make an "instant" data frame
#'
#' This could be used in a dygraph, for instance.
#'
#' The data frame returned has a column called `instant`, which is a double
#' representing the time (s) since the start of the waveform. The remaining
#' columns represent the the channels in the comtrade object, and are
#' named according to the `channel_name` argument.
#'
#' @param ct `comtrade` S3 object constructed using [`comtrade()`]
#' @param channel_name list or function -
#' list has two members: `analog` and `digital` -
#' each of which is a vector of character column-names.
#' function must take one argument, `ct`, and return such a list of names.
#' A convenience function, [`ct_attr()`] is provided.
#' @param channel_type `character` to indicate which channel types to return.
#' Default is to return both `"analog"` and `"digital"`.
#' @param use_timestamp `logical` to use the timestamp provided
#' in the data file, or to use the sampling-rate provided in the
#' configuration file.
#' @param side `character` to indicate if we want primary or
#' secondary values
#'
#' @return data frame
#' @examples
#' ct_instant(keating_1999)
#' @export
#'
ct_instant <- function(ct, channel_type = c("analog", "digital"),
channel_name = ct_attr("ph"), use_timestamp = FALSE,
side = c("primary", "secondary")){
assertthat::assert_that(
inherits(ct, "comtrade"),
is.function(channel_name) || is.list(channel_name),
is.logical(use_timestamp)
)
side <- match.arg(side)
channel_type <- match.arg(channel_type, several.ok = TRUE)
# if function, use it
if (is.function(channel_name)) {
channel_name <- channel_name(ct)
}
# look at channel_name, make sure that lengths match up
assertthat::assert_that(
identical(length(channel_name[["analog"]]), ct[["config"]][["##A"]]),
identical(length(channel_name[["digital"]]), ct[["config"]][["##D"]])
)
# timestamp and sample-rate
has_sampling_rate <- ct[["config"]][["nrates"]] > 0L
has_timestamp <- any(!is.na(ct[["data"]][["timestamp"]]))
stopifnot(
has_sampling_rate || has_timestamp
)
if (use_timestamp && !has_timestamp){
use_timestamp <- FALSE
warning("timestamp not available, setting use_timestamp to FALSE")
}
if (!use_timestamp && !has_sampling_rate){
use_timestamp <- TRUE
warning("sampling rate not available, setting use_timestamp to TRUE")
}
if (use_timestamp){
# timestamp is expressed in integer microseconds
instant <-
ct[["data"]][["timestamp"]] * ct[["config"]][["timemult"]] / 1.e6
} else {
instant <- get_instant(ct[["config"]][["sampling_rate"]])
}
# names
data <-
ct[["data"]] %>%
dplyr::select_(.dots = list(~-n, ~-timestamp)) %>%
magrittr::set_names(
c(channel_name[["analog"]], channel_name[["digital"]])
)
# add instant
data[["instant"]] <- instant
# reorder columns
data <- data %>%
dplyr::select_(.dots = list(~instant, ~dplyr::everything()))
# scale analog columns
for (i in seq_along(channel_name[["analog"]])) {
ch_name <- channel_name[["analog"]][[i]]
scale_channel <- fn_scale_channel(ct[["config"]], i)
scale_side <- fn_scale_side(ct[["config"]], i, side)
data[[ch_name]] <- data[[ch_name]] %>% scale_channel() %>% scale_side()
}
# select analog, digital columns
colname_keep <- "instant"
if ("analog" %in% channel_type) {
colname_keep <- c(colname_keep, channel_name[["analog"]])
}
if ("digital" %in% channel_type) {
colname_keep <- c(colname_keep, channel_name[["digital"]])
}
data <-
data %>%
dplyr::select_(.dots = colname_keep)
data
}
#' Helper function for channel names
#'
#' @inheritParams ct_instant
#' @param attr character indicating which attribute of channels to use as names
#'
#' @return list with two members: `analog` and `digital` -
#' each of which is a vector of character column-names
#' @examples
#' ct_channel_name(keating_1999, attr = "ch_id")
#' ct_channel_name(keating_1999, attr = "ph")
#' @export
#'
ct_channel_name <- function(ct, attr = c("ch_id", "ph")) {
assertthat::assert_that(
inherits(ct, "comtrade")
)
attr <- match.arg(attr)
list(
analog = ct[["config"]][["analog_channel"]][[attr]],
digital = ct[["config"]][["digital_channel"]][[attr]]
)
}
#' Make a function that gets variable-names
#'
#' This is essentially a wrapper for [`ct_channel_name()`],
#' allowing you to delay the evaluation of the comtrade object.
#'
#' @inheritParams ct_channel_name
#'
#' @return function to get variable-names from config
#' @examples
#' ch_name <- ct_attr("ch_id")
#' ch_name(keating_1999)
#' @export
#'
ct_attr <- function(attr = c("ch_id", "ph")) {
function(ct) {
ct_channel_name(ct, attr = attr)
}
}
#' Get function to scale analog-channel
#'
#' Given a config file and an analog-channel number,
#' return a function to scale the value.
#'
#' @inheritParams comtrade
#' @param i_analog integer, analog channel-number
#'
#' @return function that takes a value and returns a scaled value
#' @keywords internal
#' @export
#'
fn_scale_channel <- function(config, i_analog) {
a <- config[["analog_channel"]][["a"]][[i_analog]]
b <- config[["analog_channel"]][["b"]][[i_analog]]
function(x) {
(a * x) + b
}
}
#' Get function to scale side
#'
#' Given a config file and a side, return a function to scale a value
#'
#' @inheritParams comtrade
#' @inheritParams fn_scale_channel
#' @inheritParams ct_instant
#'
#' @return function that takes a value and returns a scaled value
#' @keywords internal
#' @export
#'
fn_scale_side <- function(config, i_analog, side = c("primary", "secondary")) {
side <- match.arg(side)
scale <- c(
primary = config[["analog_channel"]][["primary"]][[i_analog]],
secondary = config[["analog_channel"]][["secondary"]][[i_analog]]
)
measurement_key <- c(
P = "primary",
S = "secondary"
)
measurement <-
measurement_key %>%
`[[`(as.character(config[["analog_channel"]][["PS"]][[i_analog]]))
function(x) {
x * scale[[side]] / scale[[measurement]]
}
}
get_instant <- function(sampling_rate) {
n <- max(sampling_rate[["endsamp"]])
instant <- rep(0, n)
now <- 0
index_rate <- 1
for (i in seq_along(instant)) {
# advance sampling-rate index if needed
while (sampling_rate[["endsamp"]][[index_rate]] < i) {
index_rate <- index_rate + 1
}
# advance "now"
now <- now + 1 / sampling_rate[["samp"]][[index_rate]]
# capture "now"
instant[i] <- now
}
instant <- instant - instant[1]
instant
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.