Nothing
## ####################################################
## snowprofileTests class definition
#######################################################
## authors: fherla
#' Check class snowprofileTests
#'
#' Check if object is of class [snowprofileTests]
#'
#' @param x object to test
#'
#' @return boolean
#'
#' @export
#'
is.snowprofileTests <- function(x) inherits(x, "snowprofileTests")
#' Constructor for a snowprofileTests object
#'
#' Create a snowprofileTests object.
#'
#' For more information, see
#' Canadian Avalanche Association. (2016). Observation Guidelines and Recording Standards for Weather, Snowpack, and Avalanches (OGRS). Revelstoke, BC, Canada.
#'
#'
#' @param testsFrame a data.frame listing snowpack stability tests. Rows correspond to individual tests and columns describe at least the
#' fields `c("type", "result", "fract_char", "score", "depth")`.
#'
#' * Test **type** and **result** yield the standard 'data code' for reporting snowpack tests according to the OGRS (see Details).
#' Following type and result combinations are allowed:
#' * STV, STE, STM, STH, STN, and mixed forms STE-M, STM-H
#' * CTV, CTE, CTM, CTH, CTN, and mixed forms CTE-M, CTM-H
#' * DTV, DTE, DTM, DTH, DTN, and mixed forms DTE-M, DTM-H
#' * ECTPV, ECTP, ECTN, ECTX
#' * RB, PST, DT tests are currently not supported.
#' * **score**: numeric, number of taps (for CT, ECT)
#' * **fract_char** corresponds to the fracture character, e.g., SP, SC, PC, RP, BRK, ...
#' * **depth**: vertical location of corresponding snowpack layer (from surface)
#' * potential test comment column
#'
#' @param dropNAs Should empty, non-mandatory columns be dropped from the final snowprofileTests object?
#'
#' @return snowprofileTests object
#'
#' @author fherla
#'
#' @seealso [snowprofile], [snowprofileLayers], [snowprofileInstabilitySigns]
#'
#' @examples
#' ## create a data.frame with test observations
#' (testsFrame <- data.frame(type = c("CT", "ST", "ECT"),
#' result = c("E-M", "M", "P"),
#' score = c(10, NA, 12),
#' fract_char = c("SP", NA, NA),
#' depth = c(40, 40, 40),
#' comment = c("some comment on first test", "", "")))
#'
#' ## create snowprofileTests object
#' tests <- snowprofileTests(testsFrame)
#'
#' ## create snowprofile object containing test results and check resulting object:
#' snowprofile(tests = tests)
#'
#' @export
#'
snowprofileTests <- function(testsFrame = data.frame(type = as.character(NA),
result = as.character(NA),
score = as.double(NA),
fract_char = as.character(NA),
depth = as.double(NA),
comment = as.character(NA)),
dropNAs = TRUE) {
## assert data.frame (code breaks with data.table)
if (!is.data.frame(testsFrame)) stop("testsFrame needs to be a data.frame")
testsFrame <- as.data.frame(testsFrame)
## assert column names:
mandatory_colnames <- c("type", "result", "score", "fract_char", "depth")
mcol_idx_missing <- which(!mandatory_colnames %in% colnames(testsFrame))
if (length(mcol_idx_missing) > 0) {
stop(paste("Mandatory field is missing:", paste(mandatory_colnames[mcol_idx_missing], collapse = ", ")))
}
## type conversion:
# emptySPT <- snowprofileTests(dropNAs = FALSE) # would be elegant, but ends in an endless loop
# dtypes <- sapply(emptySPT, function(x) class(x)[1])
dtypes <- c(type = "character", result = "character", score = "numeric", fract_char = "character",
depth = "numeric", comment = "character")
cols <- colnames(testsFrame)
for (col in cols) { # convert standard object columns to correct classes
if (col %in% names(dtypes)){
testsFrame[, col] <- do.call(paste0("as.", unname(dtypes[col])), list(x = testsFrame[, col]))
}
}
## drop NAs and run checks:
if (dropNAs) {
## keep mandatory columns and columns that contain at least one row of observation
testsFrame <- testsFrame[, unique(c(which(colnames(testsFrame) %in% mandatory_colnames), which(colSums(is.na(testsFrame)) < nrow(testsFrame))))]
}
## drop NA rows
testsFrame <- testsFrame[rowSums(is.na(testsFrame)) < ncol(testsFrame), ]
## auto-fill result field for CTs, STs, & DTs if result is NA, but score is given:
fill_idx <- which(is.na(testsFrame$result) & !is.na(testsFrame$score) & testsFrame$type %in% c("CT", "ST", "DT"))
testsFrame[fill_idx, "result"] <- ifelse(testsFrame[fill_idx, "score"] <= 10, "E", as.character(NA))
fill_idx <- which(is.na(testsFrame$result) & !is.na(testsFrame$score) & testsFrame$type %in% c("CT", "ST", "DT"))
testsFrame[fill_idx, "result"] <- ifelse(testsFrame[fill_idx, "score"] <= 20, "M", as.character(NA))
fill_idx <- which(is.na(testsFrame$result) & !is.na(testsFrame$score) & testsFrame$type %in% c("CT", "ST", "DT"))
testsFrame[fill_idx, "result"] <- ifelse(testsFrame[fill_idx, "score"] <= 30, "H", as.character(NA))
## check for meaningful combination of type--result (i.e., data code)
datacodes_supported <- c('STV', 'STE', 'STM', 'STH', 'STN', 'STE-M', 'STM-H',
'CTV', 'CTE', 'CTM', 'CTH', 'CTN', 'CTE-M', 'CTM-H',
'DTV', 'DTE', 'DTM', 'DTH', 'DTN', 'DTE-M', 'DTM-H',
'ECTPV', 'ECTP', 'ECTN', 'ECTX')
datacodes_provided <- paste0(testsFrame$type, testsFrame$result)
id_unsupported <- which(! datacodes_provided %in% datacodes_supported)
if (length(id_unsupported) > 0) warning(paste("Unsupported type--result combination(s):", paste(datacodes_provided[id_unsupported], collapse = ", ")))
class(testsFrame) <- append("snowprofileTests", class(testsFrame))
return(testsFrame)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.