From e0f0822fe827fcfeb13d2b77b41d762c4a62dc9e Mon Sep 17 00:00:00 2001 From: bczernecki Date: Fri, 7 Nov 2025 17:48:07 +0100 Subject: [PATCH 01/16] synop parser - part1 --- DESCRIPTION | 1 + NAMESPACE | 2 + R/parser.R | 2126 +++++++++++++++++++++++++++++++++++++++++++++++++ man/parser.Rd | 32 + 4 files changed, 2161 insertions(+) create mode 100644 R/parser.R create mode 100644 man/parser.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 4d86895..ad452f9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,6 +35,7 @@ Imports: curl, data.table, httr, + R6, stringi, XML Suggests: diff --git a/NAMESPACE b/NAMESPACE index c01f4c3..62160bf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,12 +20,14 @@ export(nearest_stations_noaa) export(nearest_stations_ogimet) export(ogimet_daily) export(ogimet_hourly) +export(parser) export(sounding_wyoming) export(spheroid_dist) export(stations_hydro_imgw_telemetry) export(stations_meteo_imgw_telemetry) export(stations_ogimet) export(test_url) +import(R6) import(data.table) import(httr) importFrom(XML,readHTMLTable) diff --git a/R/parser.R b/R/parser.R new file mode 100644 index 0000000..bbcfd99 --- /dev/null +++ b/R/parser.R @@ -0,0 +1,2126 @@ +#' Parse SYNOP messages into structured lists +#' +#' This function wraps the SYNOP decoding logic that was previously distributed +#' with the package in `inst/extdata`. It parses one or more SYNOP messages and +#' returns their structured representation as generated by the `SYNOP` R6 +#' decoder. +#' +#' @param message Character vector with SYNOP messages. +#' @param country Optional single character value passed to the precipitation +#' indicator decoder to adjust country-specific behaviour (e.g. `"RU"`). +#' @param simplify Logical. If `TRUE` (default) and a single message is +#' provided, the function returns the decoded list directly instead of a +#' length-one list. +#' +#' @return A list of decoded SYNOP messages. When `simplify = TRUE` and a single +#' message is supplied, the corresponding decoded list is returned directly. +#' @examples +#' parser("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541") +#' parser(rep("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", 2), simplify = FALSE) +#' @import R6 +#' @export +parser <- function(message, country = NULL, simplify = TRUE) { + if (missing(message) || length(message) == 0) { + stop("`message` must contain at least one SYNOP string.") + } + + if (!is.character(message)) { + stop("`message` must be a character vector.") + } + + if (!is.null(country) && !(is.character(country) && length(country) %in% c(1, length(message)))) { + stop("`country` must be NULL, a single string, or a character vector matching the length of `message`.") + } + + country_vec <- if (is.null(country)) rep(list(NULL), length(message)) else as.list(rep(country, length.out = length(message))) + + results <- mapply( + function(msg, cntry) { + msg <- trimws(msg) + if (nzchar(msg)) { + synop <- SYNOP$new() + synop$country <- cntry + synop$decode(msg) + } else { + warning("Empty SYNOP message supplied; returning NULL.") + NULL + } + }, + message, + country_vec, + SIMPLIFY = FALSE + ) + + if (simplify && length(results) == 1) { + return(results[[1]]) + } + + results +} + +################################################################################ +# observations.R +# +# Observation classes from SYNOP - R version +# +# This is an R port of pymetdecoder/synop/observations.py +# Adapted from Python to R using R6 classes and functional approach +################################################################################ + +################################################################################ +# BASE CLASSES +################################################################################ + +# Base Observation class +Observation <- R6Class("Observation", + public = list( + null_char = "/", + code_len = NULL, + code_table = NULL, + unit = NULL, + valid_range = NULL, + + initialize = function(null_char = "/") { + self$null_char <- null_char + }, + + # Check if value is available (not all null chars) + is_available = function(value, char = NULL) { + if (is.null(char)) char <- self$null_char + if (is.null(value)) return(FALSE) + value_str <- as.character(value) + !all(strsplit(value_str, "")[[1]] == char) + }, + + # Check if value is valid + is_valid = function(value, raise_exception = TRUE, name = NULL, ...) { + tryCatch({ + valid <- private$check_valid(value, ...) + if (!valid && raise_exception) { + stop(paste0(value, " is not a valid code for ", ifelse(is.null(name), class(self)[1], name))) + } + valid + }, error = function(e) { + if (raise_exception) { + stop(e) + } + FALSE + }, warning = function(w) { + if (raise_exception) { + stop(w) + } + FALSE + }) + }, + + # Decode raw value + decode = function(raw, ...) { + kwargs <- list(...) + + # Check if available + if (!self$is_available(raw)) { + return(NULL) + } + + # Check if valid + if (!self$is_valid(raw, raise_exception = FALSE, ...)) { + return(NULL) + } + + # Decode + tryCatch({ + self$decode_internal(raw, ...) + }, error = function(e) { + warning(paste("Unable to decode:", raw)) + NULL + }) + }, + + # Encode observation + encode = function(data, ...) { + kwargs <- list(...) + allow_none <- ifelse(is.null(kwargs$allow_none), FALSE, kwargs$allow_none) + + tryCatch({ + if (is.null(data) || (is.list(data) && is.null(data$value))) { + if (allow_none || !is.null(self$code_table)) { + self$encode_internal(data, ...) + } else { + paste(rep(self$null_char, self$code_len), collapse = "") + } + } else { + self$encode_internal(data, ...) + } + }, error = function(e) { + warning(paste("Unable to encode:", toString(data))) + paste(rep(self$null_char, self$code_len), collapse = "") + }) + }, + + # Internal decode method (to be overridden) + decode_internal = function(raw, ...) { + if (!is.null(self$components) && length(self$components) > 0) { + # Handle components + result <- list() + for (comp in self$components) { + comp_class <- comp[[4]] + comp_obj <- comp_class$new() + result[[comp[[1]]]] <- comp_obj$decode( + substr(raw, comp[[2]] + 1, comp[[2]] + comp[[3]]) + ) + } + result + } else { + self$decode_value(raw, ...) + } + }, + + # Internal encode method (to be overridden) + encode_internal = function(data, ...) { + if (!is.null(self$components)) { + # Handle components + result <- character(0) + for (comp in self$components) { + comp_class <- comp[[4]] + comp_obj <- comp_class$new() + result <- c(result, comp_obj$encode( + if (comp[[1]] %in% names(data)) data[[comp[[1]]]] else NULL + )) + } + paste(result, collapse = "") + } else { + self$encode_value(data, ...) + } + }, + + # Decode value (uses code table if available) + decode_value = function(val, ...) { + kwargs <- list(...) + + # Check if value is available + if (!self$is_available(val)) { + return(NULL) + } + + # Get unit + unit <- if (is.null(kwargs$unit)) self$unit else kwargs$unit + + # Get value from code table + if (!is.null(self$code_table)) { + out_val <- tryCatch({ + self$code_table$decode(val, ...) + }, error = function(e) { + warning(paste("Error decoding with code table:", val, "-", e$message)) + NULL + }, warning = function(w) { + warning(paste("Warning decoding with code table:", val, "-", w$message)) + NULL + }) + + if (!is.null(out_val) && !is.list(out_val)) { + out_val <- list(value = out_val) + } + if (!is.null(out_val) && !("_code" %in% names(out_val))) { + code_val <- suppressWarnings(as.integer(val)) + if (!is.na(code_val)) { + out_val[["_code"]] <- code_val + } + } + } else { + # No code table - just convert to integer + out_val <- tryCatch({ + code_val <- suppressWarnings(as.integer(val)) + if (is.na(code_val)) { + return(NULL) + } + code_val + }, warning = function(w) { + NULL + }, error = function(e) { + NULL + }) + + if (is.null(out_val)) { + return(NULL) + } + + out_val <- list(value = out_val) + } + + if (is.null(out_val)) return(NULL) + + # Convert to int if not a list + if (!is.list(out_val)) { + out_val <- list(value = as.integer(out_val)) + } + + # Perform post conversion + out_val <- self$decode_convert(out_val, ...) + + # Add unit if specified + if (!is.null(unit)) { + out_val$unit <- unit + } + + out_val + }, + + # Encode value + encode_value = function(data, ...) { + # Get value from code table or data + if (!is.null(self$code_table)) { + out_val <- self$code_table$encode(data) + } else { + out_val <- if ("value" %in% names(data)) data$value else data + } + + # Convert value + out_val <- self$encode_convert(out_val, ...) + + # Format code + if (is.null(self$code_len)) { + return(as.character(out_val)) + } + sprintf(paste0("%0", self$code_len, "d"), as.integer(out_val)) + }, + + # Conversion methods (to be overridden) + decode_convert = function(val, ...) { + val + }, + + encode_convert = function(val, ...) { + val + } + ), + + private = list( + check_valid = function(value, ...) { + tryCatch({ + # Check if value is available + if (!self$is_available(value)) { + return(TRUE) + } + + # Check valid range + if (!is.null(self$valid_range)) { + val_num <- suppressWarnings(as.numeric(value)) + if (is.na(val_num)) { + return(FALSE) + } + if (val_num >= self$valid_range[1] && val_num <= self$valid_range[2]) { + return(TRUE) + } + return(FALSE) + } + + # If we reach here, assume valid + TRUE + }, error = function(e) { + FALSE + }, warning = function(w) { + FALSE + }) + } + ) +) + +################################################################################ +# SHARED CLASSES +################################################################################ + +CloudCover <- R6Class("CloudCover", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable2700$new() + self$unit <- "okta" + } + ) +) + +CloudGenus <- R6Class("CloudGenus", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable0500$new() + } + ) +) + +Day <- R6Class("Day", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$valid_range <- c(1, 31) + } + ) +) + +DirectionCardinal <- R6Class("DirectionCardinal", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable0700$new() + } + ) +) + +DirectionDegrees <- R6Class("DirectionDegrees", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$code_table <- CodeTable0877$new() + self$unit <- "deg" + } + ) +) + +Hour <- R6Class("Hour", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$valid_range <- c(0, 24) + } + ) +) + +Minute <- R6Class("Minute", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$valid_range <- c(0, 59) + } + ) +) + +SignedTemperature <- R6Class("SignedTemperature", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + self$unit <- "Cel" + }, + + decode_internal = function(raw, ...) { + kwargs <- list(...) + sign <- kwargs$sign + + if (is.null(sign) || sign == "/") { + return(NULL) + } + + if (!sign %in% c("0", "1")) { + stop(paste(sign, "is not a valid temperature sign")) + } + + self$decode_value(raw, sign = sign) + }, + + decode_convert = function(val, ...) { + kwargs <- list(...) + sign <- kwargs$sign + if (is.null(sign)) return(val) + + factor <- ifelse(sign == "0", 10, -10) + val$value <- val$value / factor + val + }, + + encode_convert = function(val, ...) { + sign_char <- ifelse(val >= 0, "0", "1") + abs_val <- abs(val * 10) + paste0(sign_char, sprintf("%03d", as.integer(abs_val))) + } + ) +) + +Visibility <- R6Class("Visibility", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$code_table <- CodeTable4377$new() + self$unit <- "m" + }, + + encode_internal = function(data, ...) { + kwargs <- list(...) + use90 <- ifelse(is.null(kwargs$use90), + ifelse("use90" %in% names(data), data$use90, FALSE), + kwargs$use90) + self$encode_value(data, use90 = use90) + } + ) +) + +################################################################################ +# CODE TABLE CLASSES (simplified versions) +################################################################################ + +# Base CodeTable class +CodeTable <- R6Class("CodeTable", + public = list( + table_name = NULL, + + decode = function(value, ...) { + tryCatch({ + result <- self$decode_internal(value, ...) + if (!is.null(result)) { + result$`_table` <- self$table_name + } + result + }, error = function(e) { + warning(paste("Unable to decode", value, "in", class(self)[1])) + NULL + }) + }, + + encode = function(value, ...) { + if (is.null(value)) return(NULL) + if (is.list(value) && "_code" %in% names(value)) { + return(value$`_code`) + } + self$encode_internal(value, ...) + }, + + decode_internal = function(value, ...) { + stop("decode_internal must be implemented in subclass") + }, + + encode_internal = function(value, ...) { + stop("encode_internal must be implemented in subclass") + } + ) +) + +# CodeTable2700 - Total cloud cover +CodeTable2700 <- R6Class("CodeTable2700", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "2700" + }, + + decode_internal = function(N, ...) { + n <- as.integer(N) + if (n == 9) { + list(value = NULL, obscured = TRUE, unit = "okta") + } else { + list(value = n, obscured = FALSE, unit = "okta") + } + }, + + encode_internal = function(data, ...) { + if (is.null(data$value)) { + if (data$obscured) return("9") + stop("Cannot encode cloud cover: value is NULL and obscured is FALSE") + } + as.character(data$value) + } + ) +) + +# CodeTable0500 - Genus of cloud +CodeTable0500 <- R6Class("CodeTable0500", + inherit = CodeTable, + public = list( + values = c("Ci", "Cc", "Cs", "Ac", "As", "Ns", "Sc", "St", "Cu", "Cb"), + + initialize = function() { + self$table_name <- "0500" + }, + + decode_internal = function(i, ...) { + idx <- as.integer(i) + 1 + if (idx >= 1 && idx <= length(self$values)) { + list(value = self$values[idx]) + } else { + stop(paste("Invalid cloud genus code:", i)) + } + }, + + encode_internal = function(data, ...) { + val <- if (is.list(data)) data$value else data + idx <- which(self$values == val) + if (length(idx) == 0) { + stop(paste("Invalid cloud genus:", val)) + } + as.character(idx - 1) + } + ) +) + +# CodeTable0700 - Direction or bearing in one figure +CodeTable0700 <- R6Class("CodeTable0700", + inherit = CodeTable, + public = list( + directions = c(NULL, "NE", "E", "SE", "S", "SW", "W", "NW", "N", NULL), + + initialize = function() { + self$table_name <- "0700" + }, + + decode_internal = function(D, ...) { + if (D == "/") { + return(list(value = NULL, isCalmOrStationary = NULL, allDirections = NULL)) + } + + d <- as.integer(D) + isCalmOrStationary <- (d == 0) + allDirections <- (d == 9) + + direction <- if (d >= 0 && d < length(self$directions)) { + self$directions[d + 1] + } else { + NULL + } + + list( + value = direction, + isCalmOrStationary = isCalmOrStationary, + allDirections = allDirections + ) + }, + + encode_internal = function(data, ...) { + if ("isCalmOrStationary" %in% names(data) && data$isCalmOrStationary) { + return("0") + } + if ("allDirections" %in% names(data) && data$allDirections) { + return("9") + } + if ("value" %in% names(data) && !is.null(data$value)) { + idx <- which(self$directions == data$value) - 1 + if (length(idx) > 0) { + return(as.character(idx)) + } + } + stop("Cannot encode direction") + } + ) +) + +# CodeTable0877 - True direction in tens of degrees +CodeTable0877 <- R6Class("CodeTable0877", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "0877" + }, + + decode_internal = function(dd, ...) { + dd_int <- as.integer(dd) + calm <- (dd_int == 0) + varAllUnknown <- (dd_int == 99) + + if (calm) { + direction <- NULL + } else if (varAllUnknown) { + direction <- NULL + } else if (dd_int >= 1 && dd_int <= 36) { + direction <- dd_int * 10 + } else { + stop(paste("Invalid direction code:", dd)) + } + + list( + value = direction, + varAllUnknown = varAllUnknown, + calm = calm + ) + }, + + encode_internal = function(data, ...) { + val <- if (is.list(data)) data$value else data + if (is.null(val)) { + if ("calm" %in% names(data) && data$calm) return("00") + if ("varAllUnknown" %in% names(data) && data$varAllUnknown) return("99") + return("//") + } + code <- round(val / 10) + if (code < 1) code <- 0 + if (code > 36) code <- 36 + sprintf("%02d", code) + } + ) +) + +# CodeTable4377 - Horizontal visibility at surface +CodeTable4377 <- R6Class("CodeTable4377", + inherit = CodeTable, + public = list( + range90 = list( + c(0, 50), c(50, 200), c(200, 500), c(500, 1000), c(1000, 2000), + c(2000, 4000), c(4000, 10000), c(10000, 20000), c(20000, 50000), + c(50000, Inf) + ), + + initialize = function() { + self$table_name <- "4377" + }, + + decode_internal = function(VV, ...) { + vv <- as.integer(VV) + + if (vv >= 51 && vv <= 55) { + stop(paste("Invalid visibility code:", VV)) + } + + visibility <- NULL + quantifier <- NULL + + if (vv == 0) { + visibility <- 100 + quantifier <- "isLess" + } else if (vv <= 50) { + visibility <- vv * 100 + } else if (vv <= 80) { + visibility <- (vv - 50) * 1000 + } else if (vv <= 88) { + visibility <- (vv - 74) * 5000 + } else if (vv == 89) { + visibility <- 70000 + quantifier <- "isGreater" + } else if (vv == 90) { + visibility <- 50 + quantifier <- "isLess" + } else if (vv == 91) { + visibility <- 50 + } else if (vv == 92) { + visibility <- 200 + } else if (vv == 93) { + visibility <- 500 + } else if (vv == 94) { + visibility <- 1000 + } else if (vv == 95) { + visibility <- 2000 + } else if (vv == 96) { + visibility <- 4000 + } else if (vv == 97) { + visibility <- 10000 + } else if (vv == 98) { + visibility <- 20000 + } else if (vv == 99) { + visibility <- 50000 + quantifier <- "isGreaterOrEqual" + } else { + stop(paste("Invalid visibility code:", VV)) + } + + use90 <- (vv >= 90) + list( + value = visibility, + quantifier = quantifier, + use90 = use90 + ) + }, + + encode_internal = function(data, use90 = FALSE, ...) { + value <- if (is.list(data)) data$value else data + quantifier <- if (is.list(data) && "quantifier" %in% names(data)) data$quantifier else NULL + + if (use90) { + for (idx in seq_along(self$range90)) { + r <- self$range90[[idx]] + if (value >= r[1] && value < r[2]) { + return(sprintf("%02d", idx + 89)) + } + } + } else { + if (value < 100) { + code <- 0 + } else if (value <= 5000) { + code <- floor(value / 100) + } else if (value <= 30000) { + code <- floor(value / 1000) + 50 + } else if (value <= 70000 && is.null(quantifier)) { + code <- floor(value / 5000) + 74 + } else { + code <- 89 + } + return(sprintf("%02d", code)) + } + + stop(paste("Cannot encode visibility:", value)) + } + ) +) + +################################################################################ +# MAIN OBSERVATION CLASSES +################################################################################ + +# Temperature observation +Temperature <- R6Class("Temperature", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + sn <- substr(group, 2, 2) + TTT <- substr(group, 3, 5) + + # Fix trailing "/" (issue #10) + if (TTT != "///") { + TTT <- sub("/$", "0", TTT) + } + + if (!sn %in% c("0", "1", "/")) { + warning(paste(group, "is an invalid temperature group")) + return(NULL) + } + + temp_obs <- SignedTemperature$new() + temp_obs$decode(TTT, sign = sn) + }, + + encode_internal = function(data, ...) { + temp_obs <- SignedTemperature$new() + temp_obs$encode(data) + } + ) +) + +# Pressure observation +Pressure <- R6Class("Pressure", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + self$unit <- "hPa" + }, + + decode_convert = function(val, ...) { + val_int <- as.integer(val$value) + val$value <- (val_int / 10) + ifelse(val_int > 5000, 0, 1000) + val + }, + + encode_convert = function(val, ...) { + abs(val * 10) - ifelse(val >= 1000, 10000, 0) + } + ) +) + +# Surface wind observation +SurfaceWind <- R6Class("SurfaceWind", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(ddff, ...) { + dd <- substr(ddff, 1, 2) + ff <- substr(ddff, 3, 4) + + dir_obs <- DirectionDegrees$new() + direction <- dir_obs$decode(dd) + + speed_obs <- WindSpeed$new() + speed <- speed_obs$decode(ff) + + # Sanity check: if wind is calm, it can't have a speed + if (!is.null(direction) && !is.null(direction$calm) && direction$calm && + !is.null(speed) && !is.null(speed$value) && speed$value > 0) { + warning(paste("Wind is calm, yet has a speed (dd:", dd, ", ff:", ff, ")")) + speed <- NULL + } + + list(direction = direction, speed = speed) + }, + + encode_internal = function(data, ...) { + dir_obs <- DirectionDegrees$new() + speed_obs <- WindSpeed$new() + + dd <- dir_obs$encode(if ("direction" %in% names(data)) data$direction else NULL, allow_none = TRUE) + ff <- speed_obs$encode(if ("speed" %in% names(data)) data$speed else NULL) + + paste0(dd, ff) + } + ) +) + +# Wind speed (simplified) +WindSpeed <- R6Class("WindSpeed", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(ff, ...) { + # Decode wind speed - ff is just a numeric value + # Use the base decode_value method which handles numeric conversion + self$decode_value(ff, ...) + }, + + encode_internal = function(data, ...) { + if (is.null(data)) { + return(paste(rep(self$null_char, self$code_len), collapse = "")) + } + value <- if (is.list(data)) data$value else data + if (!is.null(value) && value > 99) { + return(paste0("99 00", sprintf("%02d", value))) + } + sprintf("%02d", as.integer(value)) + } + ) +) + +################################################################################ +# SYNOP REPORT CLASS +################################################################################ + +# Base Report class +Report <- R6Class("Report", + public = list( + not_implemented = list(), + + decode = function(message) { + tryCatch({ + self$decode_internal(message) + }, error = function(e) { + stop(paste("Decode error:", e$message)) + }) + }, + + decode_internal = function(message) { + stop("decode_internal must be implemented in subclass") + } + ) +) + +# SYNOP class - main class for decoding SYNOP messages +SYNOP <- R6Class("SYNOP", + inherit = Report, + public = list( + country = NULL, + + initialize = function() { + self$not_implemented <- list() + self$country <- NULL + }, + + decode_internal = function(message) { + # Initialize data + data <- list() + + # Split message into groups + groups <- strsplit(message, " ")[[1]] + group_idx <- 1 + + # Helper function to get next group + get_next_group <- function() { + if (group_idx <= length(groups)) { + group <- groups[group_idx] + group_idx <<- group_idx + 1 + return(group) + } + return(NULL) + } + + # Alias for convenience + next_group <- get_next_group + + # SECTION 0: Station type, time, and identification + station_type <- next_group() + if (is.null(station_type)) { + stop("Invalid SYNOP: missing station type") + } + + # For simplicity, assume AAXX format + data$station_type <- list(value = station_type) + + # Get observation time and wind indicator (YYGGi) + yygii <- next_group() + if (is.null(yygii) || nchar(yygii) < 5) { + stop("Invalid SYNOP: missing YYGGi group") + } + + # Decode observation time + obs_time <- ObservationTime$new() + data$obs_time <- obs_time$decode(substr(yygii, 1, 4)) + + # Decode wind indicator + wind_ind <- WindIndicator$new() + data$wind_indicator <- wind_ind$decode(substr(yygii, 5, 5)) + + # Get station ID + station_id_group <- next_group() + if (is.null(station_id_group)) { + stop("Invalid SYNOP: missing station ID") + } + + data$station_id <- list(value = station_id_group) + + # Decode region + tryCatch({ + region <- Region$new() + result <- region$decode(station_id_group) + if (!is.null(result)) { + data$region <- result + } + }, error = function(e) { + warning(paste("Error decoding region:", e$message)) + }) + + # Check if next group is NIL (station did not send data) + next_check <- next_group() + if (!is.null(next_check) && (next_check == "NIL" || grepl("^NIL", next_check))) { + # Station did not send data - set remaining fields to NA + data$precipitation_indicator <- NA + data$weather_indicator <- NA + data$lowest_cloud_base <- NA + data$visibility <- NA + data$cloud_cover <- NA + data$surface_wind <- NA + data$air_temperature <- NA + data$dewpoint_temperature <- NA + data$relative_humidity <- NA + data$station_pressure <- NA + data$sea_level_pressure <- NA + data$pressure_tendency <- NA + data$precipitation_s1 <- NA + data$present_weather <- NA + data$past_weather <- NA + data$cloud_types <- NA + return(data) + } + + # SECTION 1: Main observations + section1 <- next_check # Use the group we already got + if (is.null(section1) || nchar(section1) < 5) { + # If section1 is invalid, try to continue anyway + warning("Invalid or missing section 1") + return(data) + } + + # Decode precipitation indicator, weather indicator, cloud base, visibility + tryCatch({ + precip_ind <- PrecipitationIndicator$new() + result <- precip_ind$decode(substr(section1, 1, 1), country = self$country) + if (!is.null(result)) { + data$precipitation_indicator <- result + } + }, error = function(e) { + warning(paste("Error decoding precipitation indicator:", e$message)) + }) + + tryCatch({ + weather_ind <- WeatherIndicator$new() + result <- weather_ind$decode(substr(section1, 2, 2)) + if (!is.null(result)) { + data$weather_indicator <- result + } + }, error = function(e) { + warning(paste("Error decoding weather indicator:", e$message)) + }) + + tryCatch({ + lowest_cloud <- LowestCloudBase$new() + result <- lowest_cloud$decode(substr(section1, 3, 3)) + if (!is.null(result)) { + data$lowest_cloud_base <- result + } + }, error = function(e) { + warning(paste("Error decoding lowest cloud base:", e$message)) + }) + + tryCatch({ + vis <- Visibility$new() + result <- vis$decode(substr(section1, 4, 5)) + if (!is.null(result)) { + data$visibility <- result + } + }, error = function(e) { + warning(paste("Error decoding visibility:", e$message)) + }) + + # Get cloud cover and wind (Nddff) + nddff <- next_group() + if (!is.null(nddff) && nchar(nddff) >= 5) { + tryCatch({ + cloud <- CloudCover$new() + result <- cloud$decode(substr(nddff, 1, 1)) + if (!is.null(result)) { + data$cloud_cover <- result + } + }, error = function(e) { + warning(paste("Error decoding cloud cover from:", nddff, "-", e$message)) + }) + + tryCatch({ + wind <- SurfaceWind$new() + wind_data <- wind$decode(substr(nddff, 2, 5)) + if (!is.null(wind_data)) { + if (!is.null(data$wind_indicator)) { + if (!is.null(wind_data$speed)) { + wind_data$speed$unit <- data$wind_indicator$unit + } + } + data$surface_wind <- wind_data + } + }, error = function(e) { + warning(paste("Error decoding surface wind from:", nddff, "-", e$message)) + }) + } + + # Parse section 1 groups (1sTTT, 2sTTT, 3P0P0P0, 4PPPP, etc.) + next_grp <- next_group() + while (!is.null(next_grp)) { + if (grepl("^333|^444|^555", next_grp)) { + # Start of next section + break + } + + # Try to get header, handle errors gracefully + header <- tryCatch({ + as.integer(substr(next_grp, 1, 1)) + }, error = function(e) { + warning(paste("Unable to parse header from group:", next_grp)) + next_grp <<- next_group() + return(NULL) + }, warning = function(w) { + warning(paste("Warning parsing header from group:", next_grp)) + next_grp <<- next_group() + return(NULL) + }) + + if (is.null(header) || is.na(header)) { + next_grp <- next_group() + # Skip to next iteration + if (is.null(next_grp)) break + next + } + + tryCatch({ + if (header == 1) { + # Air temperature + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$air_temperature <- result + } + } else if (header == 2) { + # Dewpoint temperature or relative humidity + sn <- substr(next_grp, 2, 2) + if (sn == "9") { + rel_hum <- RelativeHumidity$new() + result <- rel_hum$decode(substr(next_grp, 3, 5)) + if (!is.null(result)) { + data$relative_humidity <- result + } + } else { + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$dewpoint_temperature <- result + } + } + } else if (header == 3) { + # Station pressure + press <- Pressure$new() + result <- press$decode(substr(next_grp, 2, 5)) + if (!is.null(result)) { + data$station_pressure <- result + } + } else if (header == 4) { + # Sea level pressure + press <- Pressure$new() + result <- press$decode(substr(next_grp, 2, 5)) + if (!is.null(result)) { + data$sea_level_pressure <- result + } + } else if (header == 5) { + # Pressure tendency + press_tend <- PressureTendency$new() + result <- press_tend$decode(next_grp) + if (!is.null(result)) { + data$pressure_tendency <- result + } + } else if (header == 6) { + # Precipitation + if (!is.null(data$precipitation_indicator) && + data$precipitation_indicator$in_group_1) { + precip <- Precipitation$new() + result <- precip$decode(next_grp) + if (!is.null(result)) { + data$precipitation_s1 <- result + } + } + } else if (header == 7) { + # Present and past weather + if (nchar(next_grp) >= 5) { + ww <- Weather$new() + result <- ww$decode(substr(next_grp, 2, 3), + time_before = list(value = 6, unit = "h"), + type = "present", + weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) + if (!is.null(result)) { + data$present_weather <- result + } + result2 <- ww$decode(substr(next_grp, 4, 4), type = "past", + weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) + result3 <- ww$decode(substr(next_grp, 5, 5), type = "past", + weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) + if (!is.null(result2) || !is.null(result3)) { + data$past_weather <- list(result2, result3) + } + } + } else if (header == 8) { + # Cloud types + cloud_types <- CloudType$new() + result <- cloud_types$decode(next_grp) + if (!is.null(result)) { + data$cloud_types <- result + } + } + }, error = function(e) { + warning(paste("Error decoding group:", next_grp, "-", e$message)) + # Continue to next group + }, warning = function(w) { + warning(paste("Warning decoding group:", next_grp, "-", w$message)) + # Continue to next group + }) + + next_grp <- next_group() + } + + # SECTION 3: Additional observations + if (!is.null(next_grp) && next_grp == "333") { + next_grp <- next_group() + cloud_layers <- list() + highest_gusts <- list() + group_9 <- list() # Collect group 9 codes + + while (!is.null(next_grp) && !grepl("^444|^555", next_grp)) { + # Try to get header, handle errors gracefully + header <- tryCatch({ + as.integer(substr(next_grp, 1, 1)) + }, error = function(e) { + warning(paste("Unable to parse header from group:", next_grp)) + return(NULL) + }, warning = function(w) { + warning(paste("Warning parsing header from group:", next_grp)) + return(NULL) + }) + + if (is.null(header) || is.na(header)) { + next_grp <- next_group() + # Skip to next iteration + if (is.null(next_grp)) break + next + } + + tryCatch({ + # Check if it's a group 9 code (9xxxx) + if (header == 9) { + group_9[[length(group_9) + 1]] <- next_grp + } else if (header == 8) { + # Cloud layers + cloud_layer <- CloudLayer$new() + result <- cloud_layer$decode(next_grp) + if (!is.null(result)) { + cloud_layers[[length(cloud_layers) + 1]] <- result + } + } else if (header == 1) { + # Maximum temperature + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$maximum_temperature <- result + } + } else if (header == 2) { + # Minimum temperature + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$minimum_temperature <- result + } + } + }, error = function(e) { + warning(paste("Error decoding group:", next_grp, "-", e$message)) + # Continue to next group + }, warning = function(w) { + warning(paste("Warning decoding group:", next_grp, "-", w$message)) + # Continue to next group + }) + + next_grp <- next_group() + } + + # Parse group 9 codes (including highest gusts) + if (length(group_9) > 0) { + idx <- 1 + while (idx <= length(group_9)) { + g <- group_9[[idx]] + tryCatch({ + if (nchar(g) >= 3) { + j1 <- substr(g, 2, 2) # Second character + j2 <- substr(g, 3, 3) # Third character + + if (j1 == "1") { + # Group 91xx - highest gusts + if (j2 == "0") { + # 910ff - gust with 10 min period + if (is.null(data$highest_gust)) { + data$highest_gust <- list() + } + gust <- HighestGust$new() + gust_data <- gust$decode(g, + unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, + measure_period = list(value = 10, unit = "min") + ) + if (!is.null(gust_data)) { + data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + } + idx <- idx + 1 + } else if (j2 == "1") { + # 911ff - gust with time before obs + # Check if next group is direction (915dd) + if (idx < length(group_9)) { + next_g <- group_9[[idx + 1]] + if (substr(next_g, 1, 3) == "915") { + gust_group <- paste(g, next_g, sep = " ") + idx <- idx + 2 # Skip next group + } else { + gust_group <- g + idx <- idx + 1 + } + } else { + gust_group <- g + idx <- idx + 1 + } + + if (is.null(data$highest_gust)) { + data$highest_gust <- list() + } + gust <- HighestGust$new() + gust_data <- gust$decode(gust_group, + unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, + time_before = list(value = 6, unit = "h") # Default time before + ) + if (!is.null(gust_data)) { + data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + } + } else { + idx <- idx + 1 + } + } else { + idx <- idx + 1 + } + } else { + idx <- idx + 1 + } + }, error = function(e) { + warning(paste("Error decoding group 9 code:", g, "-", e$message)) + idx <<- idx + 1 + }, warning = function(w) { + warning(paste("Warning decoding group 9 code:", g, "-", w$message)) + idx <<- idx + 1 + }) + } + } + + if (length(cloud_layers) > 0) { + data$cloud_layer <- cloud_layers + } + } + + return(data) + } + ) +) + +################################################################################ +# ADDITIONAL CLASSES NEEDED FOR SYNOP +################################################################################ + +# ObservationTime +ObservationTime <- R6Class("ObservationTime", + inherit = Observation, + public = list( + components = list( + list("day", 0, 2, Day), + list("hour", 2, 2, Hour) + ), + + initialize = function() { + super$initialize() + self$code_len <- 4 + } + ) +) + +# WindIndicator +WindIndicator <- R6Class("WindIndicator", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$valid_range <- c(1, 7) + }, + + decode_internal = function(iw, ...) { + iw_int <- as.integer(iw) + if (iw == "/") { + list(value = NULL, unit = NULL, estimated = NULL) + } else { + list( + value = iw_int, + unit = ifelse(iw_int < 2, "m/s", "KT"), + estimated = (iw_int %in% c(0, 3)) + ) + } + } + ) +) + +# Region +Region <- R6Class("Region", + inherit = Observation, + public = list( + decode_internal = function(raw, ...) { + raw_int <- as.integer(raw) + + regions <- list( + I = list(c(60000, 69998)), + II = list(c(20000, 20099), c(20200, 21998), c(23001, 25998), + c(28001, 32998), c(35001, 36998), c(38001, 39998), + c(40350, 48599), c(48800, 49998), c(50001, 59998)), + III = list(c(80001, 88998)), + IV = list(c(70001, 79998)), + V = list(c(48600, 48799), c(90001, 98998)), + VI = list(c(1, 19998), c(20100, 20199), c(22001, 22998), + c(26001, 27998), c(33001, 34998), c(37001, 37998), + c(40001, 40349)), + Antarctic = list(c(89001, 89998)) + ) + + for (reg_name in names(regions)) { + for (range in regions[[reg_name]]) { + if (raw_int >= range[1] && raw_int <= range[2]) { + return(list(value = reg_name)) + } + } + } + + stop(paste("Invalid region code:", raw)) + } + ) +) + +# PrecipitationIndicator +PrecipitationIndicator <- R6Class("PrecipitationIndicator", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + }, + + decode_internal = function(i, ...) { + kwargs <- list(...) + country <- kwargs$country + i_int <- as.integer(i) + + list( + value = i_int, + in_group_1 = (i %in% c("0", "1")) || (i == "6" && !is.null(country) && country == "RU"), + in_group_3 = (i %in% c("0", "2")) || (i == "7" && !is.null(country) && country == "RU") + ) + } + ) +) + +# WeatherIndicator +WeatherIndicator <- R6Class("WeatherIndicator", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$valid_range <- c(1, 7) + }, + + decode_internal = function(ix, ...) { + ix_int <- ifelse(ix == "/", NULL, as.integer(ix)) + + list( + value = ix_int, + automatic = ifelse(is.null(ix_int) || ix_int < 3, FALSE, TRUE) + ) + } + ) +) + +# LowestCloudBase +LowestCloudBase <- R6Class("LowestCloudBase", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable1600$new() + self$unit <- "m" + } + ) +) + +# CodeTable1600 +CodeTable1600 <- R6Class("CodeTable1600", + inherit = CodeTable, + public = list( + ranges = list( + c(0, 50), c(50, 100), c(100, 200), c(200, 300), c(300, 600), + c(600, 1000), c(1000, 1500), c(1500, 2000), c(2000, 2500), c(2500, Inf) + ), + + initialize = function() { + self$table_name <- "1600" + }, + + decode_internal = function(h, ...) { + h_int <- as.integer(h) + if (h_int >= 0 && h_int < length(self$ranges)) { + range <- self$ranges[[h_int + 1]] + quantifier <- ifelse(is.infinite(range[2]), "isGreaterOrEqual", NULL) + list(min = range[1], max = ifelse(is.infinite(range[2]), NULL, range[2]), + quantifier = quantifier) + } else { + stop(paste("Invalid cloud base code:", h)) + } + } + ) +) + +# Precipitation +Precipitation <- R6Class("Precipitation", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + kwargs <- list(...) + tenths <- ifelse(is.null(kwargs$tenths), FALSE, kwargs$tenths) + + if (tenths) { + rrrr <- substr(group, 2, 5) + amount <- Amount24$new() + list( + amount = amount$decode(rrrr), + time_before_obs = list(value = 24, unit = "h") + ) + } else { + rrr <- substr(group, 2, 4) + t <- substr(group, 5, 5) + amount <- Amount$new() + list( + amount = amount$decode(rrr), + time_before_obs = TimeBeforeObs$new()$decode(t) + ) + } + } + ) +) + +# Amount (simplified) +Amount <- R6Class("Amount", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 3 + self$code_table <- CodeTable3590$new() + self$unit <- "mm" + } + ) +) + +# Amount24 +Amount24 <- R6Class("Amount24", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + self$code_table <- CodeTable3590A$new() + self$unit <- "mm" + } + ) +) + +# CodeTable3590 (simplified) +CodeTable3590 <- R6Class("CodeTable3590", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "3590" + }, + + decode_internal = function(RRR, ...) { + rrr_int <- as.integer(RRR) + if (rrr_int <= 988) { + list(value = rrr_int, quantifier = NULL, trace = FALSE) + } else if (rrr_int == 989) { + list(value = rrr_int, quantifier = "isGreaterOrEqual", trace = FALSE) + } else if (rrr_int == 990) { + list(value = 0, quantifier = NULL, trace = TRUE) + } else if (rrr_int >= 991 && rrr_int <= 999) { + list(value = (rrr_int - 990) / 10.0, quantifier = NULL, trace = FALSE) + } else { + stop(paste("Invalid precipitation code:", RRR)) + } + } + ) +) + +# CodeTable3590A (simplified) +CodeTable3590A <- R6Class("CodeTable3590A", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "3590A" + }, + + decode_internal = function(RRRR, ...) { + rrrr_int <- as.integer(RRRR) + if (rrrr_int <= 9998) { + list(value = round(rrrr_int * 0.1, 1), quantifier = NULL, trace = FALSE) + } else if (rrrr_int == 9999) { + list(value = 0, quantifier = NULL, trace = TRUE) + } else { + stop(paste("Invalid precipitation code:", RRRR)) + } + } + ) +) + +# TimeBeforeObs (simplified) +TimeBeforeObs <- R6Class("TimeBeforeObs", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable4019$new() + self$unit <- "h" + } + ) +) + +# CodeTable4019 +CodeTable4019 <- R6Class("CodeTable4019", + inherit = CodeTable, + public = list( + values = c(NULL, 6, 12, 18, 24, 1, 2, 3, 9, 15), + + initialize = function() { + self$table_name <- "4019" + }, + + decode_internal = function(t, ...) { + t_int <- as.integer(t) + 1 + if (t_int >= 1 && t_int <= length(self$values)) { + val <- self$values[[t_int]] + if (!is.null(val)) { + list(value = val, unit = "h") + } else { + NULL + } + } else { + NULL + } + } + ) +) + +# PressureTendency +PressureTendency <- R6Class("PressureTendency", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + a <- substr(group, 2, 2) + ppp <- substr(group, 3, 5) + + tendency <- Tendency$new() + change <- Change$new() + + list( + tendency = tendency$decode(a), + change = change$decode(ppp, tendency = tendency$decode(a)) + ) + } + ) +) + +# Tendency (simplified) +Tendency <- R6Class("Tendency", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$valid_range <- c(0, 8) + } + ) +) + +# Change (simplified) +Change <- R6Class("Change", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 3 + self$unit <- "hPa" + }, + + decode_convert = function(val, ...) { + kwargs <- list(...) + tendency <- kwargs$tendency + + if (is.list(tendency) && "value" %in% names(tendency)) { + factor <- ifelse(tendency$value < 5, 10.0, -10.0) + val$value <- val$value / factor + } + val + } + ) +) + +# Weather +Weather <- R6Class("Weather", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(group, ...) { + kwargs <- list(...) + w_type <- kwargs$type + ix <- kwargs$weather_indicator + + if (w_type == "present") { + table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4680", "4677") + } else if (w_type == "past") { + table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4531", "4561") + } else { + stop(paste("Invalid weather type:", w_type)) + } + + group_int <- as.integer(group) + if (is.na(group_int)) { + return(NULL) + } + + result <- list(value = group_int, `_table` = table) + if (!is.null(kwargs$time_before)) { + result$time_before_obs <- kwargs$time_before + } + + result + } + ) +) + +# CloudType +CloudType <- R6Class("CloudType", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + nh <- substr(group, 2, 2) + cl <- substr(group, 3, 3) + cm <- substr(group, 4, 4) + ch <- substr(group, 5, 5) + + low_cloud <- LowCloud$new() + middle_cloud <- MiddleCloud$new() + high_cloud <- HighCloud$new() + cloud_cover <- CloudCover$new() + + result <- list( + low_cloud_type = low_cloud$decode(cl), + middle_cloud_type = middle_cloud$decode(cm), + high_cloud_type = high_cloud$decode(ch) + ) + + cover <- cloud_cover$decode(nh) + if (nh != "/") { + if (!is.null(result$low_cloud_type) && + result$low_cloud_type$value >= 1 && + result$low_cloud_type$value <= 9) { + result$low_cloud_amount <- cover + } else if (!is.null(result$middle_cloud_type) && + result$middle_cloud_type$value >= 0 && + result$middle_cloud_type$value <= 9) { + result$middle_cloud_amount <- cover + } else { + result$cloud_amount <- cover + } + } + + result + } + ) +) + +# LowCloud, MiddleCloud, HighCloud (simplified) +LowCloud <- R6Class("LowCloud", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + } + ) +) + +MiddleCloud <- R6Class("MiddleCloud", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + } + ) +) + +HighCloud <- R6Class("HighCloud", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + } + ) +) + +# CloudLayer +CloudLayer <- R6Class("CloudLayer", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + n <- substr(group, 2, 2) + c <- substr(group, 3, 3) + hh <- substr(group, 4, 5) + + cloud_cover <- CloudCover$new() + cloud_genus <- CloudGenus$new() + height <- Height$new() + + list( + cloud_cover = cloud_cover$decode(n), + cloud_genus = cloud_genus$decode(c), + cloud_height = height$decode(hh) + ) + } + ) +) + +# Height (simplified) +Height <- R6Class("Height", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$code_table <- CodeTable1677$new() + self$unit <- "m" + } + ) +) + +# CodeTable1677 (simplified) +CodeTable1677 <- R6Class("CodeTable1677", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "1677" + }, + + decode_internal = function(hh, ...) { + hh_int <- as.integer(hh) + quantifier <- NULL + + if (hh_int == 0) { + list(value = 30, quantifier = "isLess") + } else if (hh_int >= 1 && hh_int <= 50) { + list(value = hh_int * 30, quantifier = NULL) + } else if (hh_int >= 56 && hh_int <= 80) { + list(value = (hh_int - 50) * 300, quantifier = NULL) + } else if (hh_int >= 81 && hh_int <= 88) { + list(value = ((hh_int - 80) * 1500) + 9000, quantifier = NULL) + } else if (hh_int == 89) { + list(value = 21000, quantifier = "isGreater") + } else if (hh_int == 99) { + list(value = 21000, quantifier = "isGreater") + } else { + stop(paste("Invalid height code:", hh)) + } + } + ) +) + +# RelativeHumidity +RelativeHumidity <- R6Class("RelativeHumidity", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 3 + self$valid_range <- c(0, 100) + self$unit <- "%" + } + ) +) + +# HighestGust - Highest wind gust +HighestGust <- R6Class("HighestGust", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(group, ...) { + kwargs <- list(...) + + # Split group into separate groups if needed + groups <- strsplit(group, " ")[[1]] + + # Get type, speed and direction + # Format: 910ff or 911ff, optionally followed by 915dd + t <- NULL + ff <- NULL + dd <- NULL + + if (length(groups) > 0) { + # First group: 910ff or 911ff + first_group <- groups[1] + if (nchar(first_group) >= 5) { + t <- substr(first_group, 3, 3) + ff <- substr(first_group, 4, 5) + } + } + + # Second group: 915dd (direction) + if (length(groups) > 1) { + second_group <- groups[2] + if (nchar(second_group) >= 5 && substr(second_group, 1, 3) == "915") { + dd <- substr(second_group, 4, 5) + } + } + + # Return values + time_before <- kwargs$time_before + measure_period <- kwargs$measure_period + + gust_obs <- Gust$new() + dir_obs <- DirectionDegrees$new() + + data <- list( + speed = gust_obs$decode(ff, unit = kwargs$unit), + direction = dir_obs$decode(dd) + ) + + if (!is.null(time_before)) { + data$time_before_obs <- time_before + } + if (!is.null(measure_period)) { + data$measure_period <- measure_period + } + + data + }, + + encode_internal = function(data, ...) { + kwargs <- list(...) + time_before <- kwargs$time_before + measure_period <- kwargs$measure_period + output <- character(0) + + # Handle list of gusts or single gust + if (is.list(data) && "speed" %in% names(data)) { + data <- list(data) # Convert single gust to list + } + + for (d in data) { + # Convert time before obs, if required + if ("time_before_obs" %in% names(d)) { + if (is.null(time_before) || + (!is.null(time_before) && !identical(d$time_before_obs, time_before))) { + time_before_obs <- TimeBeforeObs$new() + tt <- time_before_obs$encode(d$time_before_obs) + if (tt != "//") { + output <- c(output, paste0("907", tt)) + } + } + prefix <- "911" + } else if ("measure_period" %in% names(d)) { + if (identical(d$measure_period, list(value = 10, unit = "min"))) { + prefix <- "910" + } else { + stop("Invalid value for measure_period") + } + } else { + prefix <- "910" # Default + } + + # Convert the gust + gust_obs <- Gust$new() + ff <- gust_obs$encode(if ("speed" %in% names(d)) d$speed else NULL) + output <- c(output, paste0(prefix, ff)) + + # Convert the direction + if ("direction" %in% names(d) && !is.null(d$direction)) { + dir_obs <- DirectionDegrees$new() + dd <- dir_obs$encode(d$direction) + output <- c(output, paste0("915", dd)) + } + } + + paste(output, collapse = " ") + } + ) +) + +# Gust - Wind gust speed (internal class for HighestGust) +Gust <- R6Class("Gust", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(ff, ...) { + # Decode wind gust speed - same as WindSpeed + self$decode_value(ff, ...) + }, + + encode_internal = function(data, ...) { + # Encode wind gust speed - same as WindSpeed + if (is.null(data)) { + return(paste(rep(self$null_char, self$code_len), collapse = "")) + } + value <- if (is.list(data)) data$value else data + if (!is.null(value) && value > 99) { + return(paste0("99 00", sprintf("%02d", value))) + } + sprintf("%02d", as.integer(value)) + } + ) +) + +################################################################################ +# EXPORT FUNCTIONS +################################################################################ + +# Helper function to create observation instances +create_observation <- function(class_name, ...) { + class_map <- list( + "CloudCover" = CloudCover, + "CloudGenus" = CloudGenus, + "Day" = Day, + "DirectionCardinal" = DirectionCardinal, + "DirectionDegrees" = DirectionDegrees, + "Hour" = Hour, + "Minute" = Minute, + "SignedTemperature" = SignedTemperature, + "Visibility" = Visibility, + "Temperature" = Temperature, + "Pressure" = Pressure, + "SurfaceWind" = SurfaceWind, + "WindSpeed" = WindSpeed, + "SYNOP" = SYNOP + ) + + if (!class_name %in% names(class_map)) { + stop(paste("Unknown observation class:", class_name)) + } + + class_map[[class_name]]$new(...) +} + +# Example usage function +example_usage <- function() { + # Example: Decode temperature + # Format: 1sTTT where s=0 (positive) or s=1 (negative), TTT=temperature + temp <- Temperature$new() + result <- temp$decode("10094") # Sign=0 (positive), TTT=094 -> 9.4°C + print(result) + + # Negative temperature + result2 <- temp$decode("11094") # Sign=1 (negative), TTT=094 -> -9.4°C + print(result2) + + # Example: Encode temperature + encoded <- temp$encode(list(value = 19.4)) + print(encoded) + + # Example: Decode cloud cover + cloud <- CloudCover$new() + result <- cloud$decode("6") + print(result) + + # Example: Decode surface wind + wind <- SurfaceWind$new() + result <- wind$decode("1506") + print(result) + + # Example: Decode full SYNOP + synop <- SYNOP$new() + synop_msg <- "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 81656 86070" + output <- synop$decode(synop_msg) + print(output) +} + + diff --git a/man/parser.Rd b/man/parser.Rd new file mode 100644 index 0000000..7c8e110 --- /dev/null +++ b/man/parser.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/parser.R +\name{parser} +\alias{parser} +\title{Parse SYNOP messages into structured lists} +\usage{ +parser(message, country = NULL, simplify = TRUE) +} +\arguments{ +\item{message}{Character vector with SYNOP messages.} + +\item{country}{Optional single character value passed to the precipitation +indicator decoder to adjust country-specific behaviour (e.g. \code{"RU"}).} + +\item{simplify}{Logical. If \code{TRUE} (default) and a single message is +provided, the function returns the decoded list directly instead of a +length-one list.} +} +\value{ +A list of decoded SYNOP messages. When \code{simplify = TRUE} and a single +message is supplied, the corresponding decoded list is returned directly. +} +\description{ +This function wraps the SYNOP decoding logic that was previously distributed +with the package in \code{inst/extdata}. It parses one or more SYNOP messages and +returns their structured representation as generated by the \code{SYNOP} R6 +decoder. +} +\examples{ +parser("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541") +parser(rep("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", 2), simplify = FALSE) +} From 02ac078dc5225473d965755f38ad2ce106e97ce4 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Mon, 19 Jan 2026 16:27:24 +0100 Subject: [PATCH 02/16] add gc --- R/hydro_imgw_daily.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/hydro_imgw_daily.R b/R/hydro_imgw_daily.R index 54079be..72ccdf6 100644 --- a/R/hydro_imgw_daily.R +++ b/R/hydro_imgw_daily.R @@ -182,6 +182,7 @@ hydro_imgw_daily_bp = function(year, all_data = all_data[, c(1:3, ncol(all_data), 4:(ncol(all_data) - 1)), ] all_data = hydro_shortening_imgw(all_data, col_names = col_names, ...) + gc() return(all_data) } \ No newline at end of file From 9e1430c27e45266933cc172e523ed81ef1eda693 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Mon, 19 Jan 2026 16:35:52 +0100 Subject: [PATCH 03/16] add data.table to merge --- R/hydro_imgw_daily.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/hydro_imgw_daily.R b/R/hydro_imgw_daily.R index 72ccdf6..6bffa06 100644 --- a/R/hydro_imgw_daily.R +++ b/R/hydro_imgw_daily.R @@ -135,7 +135,7 @@ hydro_imgw_daily_bp = function(year, } #end of loop for (usually monthly) zip files in a given year - all_data[[length(all_data) + 1]] = merge(codz_data, zjaw_data, + all_data[[length(all_data) + 1]] = data.table::merge(codz_data, zjaw_data, by = intersect(colnames(codz_data), colnames(zjaw_data)), all.x = TRUE) @@ -148,7 +148,7 @@ hydro_imgw_daily_bp = function(year, all_data[all_data == 999] = NA if (coords) { - all_data = merge(climate::imgw_hydro_stations, all_data, + all_data = data.table::merge(climate::imgw_hydro_stations, all_data, by.x = "id", by.y = "Kod stacji", all.y = TRUE) From cd30597a121bef73241394128f16259f290982a3 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Mon, 19 Jan 2026 16:43:40 +0100 Subject: [PATCH 04/16] enforce data table class --- R/hydro_imgw_daily.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/hydro_imgw_daily.R b/R/hydro_imgw_daily.R index 6bffa06..a6e7f69 100644 --- a/R/hydro_imgw_daily.R +++ b/R/hydro_imgw_daily.R @@ -135,7 +135,9 @@ hydro_imgw_daily_bp = function(year, } #end of loop for (usually monthly) zip files in a given year - all_data[[length(all_data) + 1]] = data.table::merge(codz_data, zjaw_data, + browser() + all_data[[length(all_data) + 1]] = merge(data.table(codz_data), + data.table(zjaw_data), by = intersect(colnames(codz_data), colnames(zjaw_data)), all.x = TRUE) @@ -148,7 +150,7 @@ hydro_imgw_daily_bp = function(year, all_data[all_data == 999] = NA if (coords) { - all_data = data.table::merge(climate::imgw_hydro_stations, all_data, + all_data = merge(climate::imgw_hydro_stations, all_data, by.x = "id", by.y = "Kod stacji", all.y = TRUE) From 91473262bee599cf630b761d12566557ecc39c1d Mon Sep 17 00:00:00 2001 From: bczernecki Date: Tue, 20 Jan 2026 23:31:48 +0100 Subject: [PATCH 05/16] fix: trimws --- R/hydro_imgw_daily.R | 3 --- R/meteo_imgw_daily.R | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/R/hydro_imgw_daily.R b/R/hydro_imgw_daily.R index a6e7f69..3752244 100644 --- a/R/hydro_imgw_daily.R +++ b/R/hydro_imgw_daily.R @@ -135,7 +135,6 @@ hydro_imgw_daily_bp = function(year, } #end of loop for (usually monthly) zip files in a given year - browser() all_data[[length(all_data) + 1]] = merge(data.table(codz_data), data.table(zjaw_data), by = intersect(colnames(codz_data), colnames(zjaw_data)), @@ -182,9 +181,7 @@ hydro_imgw_daily_bp = function(year, data_df$yy = ifelse(data_df[, 2] >= 11, data_df[, 1] - 1, data_df[, 1]) all_data$Data = as.Date(ISOdate(year = data_df$yy, month = data_df[, 2], day = data_df[, 3])) all_data = all_data[, c(1:3, ncol(all_data), 4:(ncol(all_data) - 1)), ] - all_data = hydro_shortening_imgw(all_data, col_names = col_names, ...) - gc() return(all_data) } \ No newline at end of file diff --git a/R/meteo_imgw_daily.R b/R/meteo_imgw_daily.R index 10f91cd..a89395b 100644 --- a/R/meteo_imgw_daily.R +++ b/R/meteo_imgw_daily.R @@ -140,7 +140,7 @@ meteo_imgw_daily_bp = function(rank, ttt = ttt[order(ttt$`Nazwa stacji.x`, ttt$Rok, ttt$Miesiac, ttt$Dzien), ] ### ta część kodu powtarza sie po dużej petli od rank if (!is.null(station)) { - all_data[[length(all_data) + 1]] = ttt[ttt$`Nazwa stacji.x` %in% station, ] + all_data[[length(all_data) + 1]] = ttt[trimws(ttt$`Nazwa stacji.x`) %in% station, ] } else { all_data[[length(all_data) + 1]] = ttt } From c2a060affadfb041bfcfbfce27255ba7a22ae404 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sat, 9 May 2026 00:07:25 +0200 Subject: [PATCH 06/16] add parser --- inst/parser.R | 2126 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2126 insertions(+) create mode 100644 inst/parser.R diff --git a/inst/parser.R b/inst/parser.R new file mode 100644 index 0000000..bbcfd99 --- /dev/null +++ b/inst/parser.R @@ -0,0 +1,2126 @@ +#' Parse SYNOP messages into structured lists +#' +#' This function wraps the SYNOP decoding logic that was previously distributed +#' with the package in `inst/extdata`. It parses one or more SYNOP messages and +#' returns their structured representation as generated by the `SYNOP` R6 +#' decoder. +#' +#' @param message Character vector with SYNOP messages. +#' @param country Optional single character value passed to the precipitation +#' indicator decoder to adjust country-specific behaviour (e.g. `"RU"`). +#' @param simplify Logical. If `TRUE` (default) and a single message is +#' provided, the function returns the decoded list directly instead of a +#' length-one list. +#' +#' @return A list of decoded SYNOP messages. When `simplify = TRUE` and a single +#' message is supplied, the corresponding decoded list is returned directly. +#' @examples +#' parser("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541") +#' parser(rep("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", 2), simplify = FALSE) +#' @import R6 +#' @export +parser <- function(message, country = NULL, simplify = TRUE) { + if (missing(message) || length(message) == 0) { + stop("`message` must contain at least one SYNOP string.") + } + + if (!is.character(message)) { + stop("`message` must be a character vector.") + } + + if (!is.null(country) && !(is.character(country) && length(country) %in% c(1, length(message)))) { + stop("`country` must be NULL, a single string, or a character vector matching the length of `message`.") + } + + country_vec <- if (is.null(country)) rep(list(NULL), length(message)) else as.list(rep(country, length.out = length(message))) + + results <- mapply( + function(msg, cntry) { + msg <- trimws(msg) + if (nzchar(msg)) { + synop <- SYNOP$new() + synop$country <- cntry + synop$decode(msg) + } else { + warning("Empty SYNOP message supplied; returning NULL.") + NULL + } + }, + message, + country_vec, + SIMPLIFY = FALSE + ) + + if (simplify && length(results) == 1) { + return(results[[1]]) + } + + results +} + +################################################################################ +# observations.R +# +# Observation classes from SYNOP - R version +# +# This is an R port of pymetdecoder/synop/observations.py +# Adapted from Python to R using R6 classes and functional approach +################################################################################ + +################################################################################ +# BASE CLASSES +################################################################################ + +# Base Observation class +Observation <- R6Class("Observation", + public = list( + null_char = "/", + code_len = NULL, + code_table = NULL, + unit = NULL, + valid_range = NULL, + + initialize = function(null_char = "/") { + self$null_char <- null_char + }, + + # Check if value is available (not all null chars) + is_available = function(value, char = NULL) { + if (is.null(char)) char <- self$null_char + if (is.null(value)) return(FALSE) + value_str <- as.character(value) + !all(strsplit(value_str, "")[[1]] == char) + }, + + # Check if value is valid + is_valid = function(value, raise_exception = TRUE, name = NULL, ...) { + tryCatch({ + valid <- private$check_valid(value, ...) + if (!valid && raise_exception) { + stop(paste0(value, " is not a valid code for ", ifelse(is.null(name), class(self)[1], name))) + } + valid + }, error = function(e) { + if (raise_exception) { + stop(e) + } + FALSE + }, warning = function(w) { + if (raise_exception) { + stop(w) + } + FALSE + }) + }, + + # Decode raw value + decode = function(raw, ...) { + kwargs <- list(...) + + # Check if available + if (!self$is_available(raw)) { + return(NULL) + } + + # Check if valid + if (!self$is_valid(raw, raise_exception = FALSE, ...)) { + return(NULL) + } + + # Decode + tryCatch({ + self$decode_internal(raw, ...) + }, error = function(e) { + warning(paste("Unable to decode:", raw)) + NULL + }) + }, + + # Encode observation + encode = function(data, ...) { + kwargs <- list(...) + allow_none <- ifelse(is.null(kwargs$allow_none), FALSE, kwargs$allow_none) + + tryCatch({ + if (is.null(data) || (is.list(data) && is.null(data$value))) { + if (allow_none || !is.null(self$code_table)) { + self$encode_internal(data, ...) + } else { + paste(rep(self$null_char, self$code_len), collapse = "") + } + } else { + self$encode_internal(data, ...) + } + }, error = function(e) { + warning(paste("Unable to encode:", toString(data))) + paste(rep(self$null_char, self$code_len), collapse = "") + }) + }, + + # Internal decode method (to be overridden) + decode_internal = function(raw, ...) { + if (!is.null(self$components) && length(self$components) > 0) { + # Handle components + result <- list() + for (comp in self$components) { + comp_class <- comp[[4]] + comp_obj <- comp_class$new() + result[[comp[[1]]]] <- comp_obj$decode( + substr(raw, comp[[2]] + 1, comp[[2]] + comp[[3]]) + ) + } + result + } else { + self$decode_value(raw, ...) + } + }, + + # Internal encode method (to be overridden) + encode_internal = function(data, ...) { + if (!is.null(self$components)) { + # Handle components + result <- character(0) + for (comp in self$components) { + comp_class <- comp[[4]] + comp_obj <- comp_class$new() + result <- c(result, comp_obj$encode( + if (comp[[1]] %in% names(data)) data[[comp[[1]]]] else NULL + )) + } + paste(result, collapse = "") + } else { + self$encode_value(data, ...) + } + }, + + # Decode value (uses code table if available) + decode_value = function(val, ...) { + kwargs <- list(...) + + # Check if value is available + if (!self$is_available(val)) { + return(NULL) + } + + # Get unit + unit <- if (is.null(kwargs$unit)) self$unit else kwargs$unit + + # Get value from code table + if (!is.null(self$code_table)) { + out_val <- tryCatch({ + self$code_table$decode(val, ...) + }, error = function(e) { + warning(paste("Error decoding with code table:", val, "-", e$message)) + NULL + }, warning = function(w) { + warning(paste("Warning decoding with code table:", val, "-", w$message)) + NULL + }) + + if (!is.null(out_val) && !is.list(out_val)) { + out_val <- list(value = out_val) + } + if (!is.null(out_val) && !("_code" %in% names(out_val))) { + code_val <- suppressWarnings(as.integer(val)) + if (!is.na(code_val)) { + out_val[["_code"]] <- code_val + } + } + } else { + # No code table - just convert to integer + out_val <- tryCatch({ + code_val <- suppressWarnings(as.integer(val)) + if (is.na(code_val)) { + return(NULL) + } + code_val + }, warning = function(w) { + NULL + }, error = function(e) { + NULL + }) + + if (is.null(out_val)) { + return(NULL) + } + + out_val <- list(value = out_val) + } + + if (is.null(out_val)) return(NULL) + + # Convert to int if not a list + if (!is.list(out_val)) { + out_val <- list(value = as.integer(out_val)) + } + + # Perform post conversion + out_val <- self$decode_convert(out_val, ...) + + # Add unit if specified + if (!is.null(unit)) { + out_val$unit <- unit + } + + out_val + }, + + # Encode value + encode_value = function(data, ...) { + # Get value from code table or data + if (!is.null(self$code_table)) { + out_val <- self$code_table$encode(data) + } else { + out_val <- if ("value" %in% names(data)) data$value else data + } + + # Convert value + out_val <- self$encode_convert(out_val, ...) + + # Format code + if (is.null(self$code_len)) { + return(as.character(out_val)) + } + sprintf(paste0("%0", self$code_len, "d"), as.integer(out_val)) + }, + + # Conversion methods (to be overridden) + decode_convert = function(val, ...) { + val + }, + + encode_convert = function(val, ...) { + val + } + ), + + private = list( + check_valid = function(value, ...) { + tryCatch({ + # Check if value is available + if (!self$is_available(value)) { + return(TRUE) + } + + # Check valid range + if (!is.null(self$valid_range)) { + val_num <- suppressWarnings(as.numeric(value)) + if (is.na(val_num)) { + return(FALSE) + } + if (val_num >= self$valid_range[1] && val_num <= self$valid_range[2]) { + return(TRUE) + } + return(FALSE) + } + + # If we reach here, assume valid + TRUE + }, error = function(e) { + FALSE + }, warning = function(w) { + FALSE + }) + } + ) +) + +################################################################################ +# SHARED CLASSES +################################################################################ + +CloudCover <- R6Class("CloudCover", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable2700$new() + self$unit <- "okta" + } + ) +) + +CloudGenus <- R6Class("CloudGenus", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable0500$new() + } + ) +) + +Day <- R6Class("Day", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$valid_range <- c(1, 31) + } + ) +) + +DirectionCardinal <- R6Class("DirectionCardinal", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable0700$new() + } + ) +) + +DirectionDegrees <- R6Class("DirectionDegrees", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$code_table <- CodeTable0877$new() + self$unit <- "deg" + } + ) +) + +Hour <- R6Class("Hour", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$valid_range <- c(0, 24) + } + ) +) + +Minute <- R6Class("Minute", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$valid_range <- c(0, 59) + } + ) +) + +SignedTemperature <- R6Class("SignedTemperature", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + self$unit <- "Cel" + }, + + decode_internal = function(raw, ...) { + kwargs <- list(...) + sign <- kwargs$sign + + if (is.null(sign) || sign == "/") { + return(NULL) + } + + if (!sign %in% c("0", "1")) { + stop(paste(sign, "is not a valid temperature sign")) + } + + self$decode_value(raw, sign = sign) + }, + + decode_convert = function(val, ...) { + kwargs <- list(...) + sign <- kwargs$sign + if (is.null(sign)) return(val) + + factor <- ifelse(sign == "0", 10, -10) + val$value <- val$value / factor + val + }, + + encode_convert = function(val, ...) { + sign_char <- ifelse(val >= 0, "0", "1") + abs_val <- abs(val * 10) + paste0(sign_char, sprintf("%03d", as.integer(abs_val))) + } + ) +) + +Visibility <- R6Class("Visibility", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$code_table <- CodeTable4377$new() + self$unit <- "m" + }, + + encode_internal = function(data, ...) { + kwargs <- list(...) + use90 <- ifelse(is.null(kwargs$use90), + ifelse("use90" %in% names(data), data$use90, FALSE), + kwargs$use90) + self$encode_value(data, use90 = use90) + } + ) +) + +################################################################################ +# CODE TABLE CLASSES (simplified versions) +################################################################################ + +# Base CodeTable class +CodeTable <- R6Class("CodeTable", + public = list( + table_name = NULL, + + decode = function(value, ...) { + tryCatch({ + result <- self$decode_internal(value, ...) + if (!is.null(result)) { + result$`_table` <- self$table_name + } + result + }, error = function(e) { + warning(paste("Unable to decode", value, "in", class(self)[1])) + NULL + }) + }, + + encode = function(value, ...) { + if (is.null(value)) return(NULL) + if (is.list(value) && "_code" %in% names(value)) { + return(value$`_code`) + } + self$encode_internal(value, ...) + }, + + decode_internal = function(value, ...) { + stop("decode_internal must be implemented in subclass") + }, + + encode_internal = function(value, ...) { + stop("encode_internal must be implemented in subclass") + } + ) +) + +# CodeTable2700 - Total cloud cover +CodeTable2700 <- R6Class("CodeTable2700", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "2700" + }, + + decode_internal = function(N, ...) { + n <- as.integer(N) + if (n == 9) { + list(value = NULL, obscured = TRUE, unit = "okta") + } else { + list(value = n, obscured = FALSE, unit = "okta") + } + }, + + encode_internal = function(data, ...) { + if (is.null(data$value)) { + if (data$obscured) return("9") + stop("Cannot encode cloud cover: value is NULL and obscured is FALSE") + } + as.character(data$value) + } + ) +) + +# CodeTable0500 - Genus of cloud +CodeTable0500 <- R6Class("CodeTable0500", + inherit = CodeTable, + public = list( + values = c("Ci", "Cc", "Cs", "Ac", "As", "Ns", "Sc", "St", "Cu", "Cb"), + + initialize = function() { + self$table_name <- "0500" + }, + + decode_internal = function(i, ...) { + idx <- as.integer(i) + 1 + if (idx >= 1 && idx <= length(self$values)) { + list(value = self$values[idx]) + } else { + stop(paste("Invalid cloud genus code:", i)) + } + }, + + encode_internal = function(data, ...) { + val <- if (is.list(data)) data$value else data + idx <- which(self$values == val) + if (length(idx) == 0) { + stop(paste("Invalid cloud genus:", val)) + } + as.character(idx - 1) + } + ) +) + +# CodeTable0700 - Direction or bearing in one figure +CodeTable0700 <- R6Class("CodeTable0700", + inherit = CodeTable, + public = list( + directions = c(NULL, "NE", "E", "SE", "S", "SW", "W", "NW", "N", NULL), + + initialize = function() { + self$table_name <- "0700" + }, + + decode_internal = function(D, ...) { + if (D == "/") { + return(list(value = NULL, isCalmOrStationary = NULL, allDirections = NULL)) + } + + d <- as.integer(D) + isCalmOrStationary <- (d == 0) + allDirections <- (d == 9) + + direction <- if (d >= 0 && d < length(self$directions)) { + self$directions[d + 1] + } else { + NULL + } + + list( + value = direction, + isCalmOrStationary = isCalmOrStationary, + allDirections = allDirections + ) + }, + + encode_internal = function(data, ...) { + if ("isCalmOrStationary" %in% names(data) && data$isCalmOrStationary) { + return("0") + } + if ("allDirections" %in% names(data) && data$allDirections) { + return("9") + } + if ("value" %in% names(data) && !is.null(data$value)) { + idx <- which(self$directions == data$value) - 1 + if (length(idx) > 0) { + return(as.character(idx)) + } + } + stop("Cannot encode direction") + } + ) +) + +# CodeTable0877 - True direction in tens of degrees +CodeTable0877 <- R6Class("CodeTable0877", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "0877" + }, + + decode_internal = function(dd, ...) { + dd_int <- as.integer(dd) + calm <- (dd_int == 0) + varAllUnknown <- (dd_int == 99) + + if (calm) { + direction <- NULL + } else if (varAllUnknown) { + direction <- NULL + } else if (dd_int >= 1 && dd_int <= 36) { + direction <- dd_int * 10 + } else { + stop(paste("Invalid direction code:", dd)) + } + + list( + value = direction, + varAllUnknown = varAllUnknown, + calm = calm + ) + }, + + encode_internal = function(data, ...) { + val <- if (is.list(data)) data$value else data + if (is.null(val)) { + if ("calm" %in% names(data) && data$calm) return("00") + if ("varAllUnknown" %in% names(data) && data$varAllUnknown) return("99") + return("//") + } + code <- round(val / 10) + if (code < 1) code <- 0 + if (code > 36) code <- 36 + sprintf("%02d", code) + } + ) +) + +# CodeTable4377 - Horizontal visibility at surface +CodeTable4377 <- R6Class("CodeTable4377", + inherit = CodeTable, + public = list( + range90 = list( + c(0, 50), c(50, 200), c(200, 500), c(500, 1000), c(1000, 2000), + c(2000, 4000), c(4000, 10000), c(10000, 20000), c(20000, 50000), + c(50000, Inf) + ), + + initialize = function() { + self$table_name <- "4377" + }, + + decode_internal = function(VV, ...) { + vv <- as.integer(VV) + + if (vv >= 51 && vv <= 55) { + stop(paste("Invalid visibility code:", VV)) + } + + visibility <- NULL + quantifier <- NULL + + if (vv == 0) { + visibility <- 100 + quantifier <- "isLess" + } else if (vv <= 50) { + visibility <- vv * 100 + } else if (vv <= 80) { + visibility <- (vv - 50) * 1000 + } else if (vv <= 88) { + visibility <- (vv - 74) * 5000 + } else if (vv == 89) { + visibility <- 70000 + quantifier <- "isGreater" + } else if (vv == 90) { + visibility <- 50 + quantifier <- "isLess" + } else if (vv == 91) { + visibility <- 50 + } else if (vv == 92) { + visibility <- 200 + } else if (vv == 93) { + visibility <- 500 + } else if (vv == 94) { + visibility <- 1000 + } else if (vv == 95) { + visibility <- 2000 + } else if (vv == 96) { + visibility <- 4000 + } else if (vv == 97) { + visibility <- 10000 + } else if (vv == 98) { + visibility <- 20000 + } else if (vv == 99) { + visibility <- 50000 + quantifier <- "isGreaterOrEqual" + } else { + stop(paste("Invalid visibility code:", VV)) + } + + use90 <- (vv >= 90) + list( + value = visibility, + quantifier = quantifier, + use90 = use90 + ) + }, + + encode_internal = function(data, use90 = FALSE, ...) { + value <- if (is.list(data)) data$value else data + quantifier <- if (is.list(data) && "quantifier" %in% names(data)) data$quantifier else NULL + + if (use90) { + for (idx in seq_along(self$range90)) { + r <- self$range90[[idx]] + if (value >= r[1] && value < r[2]) { + return(sprintf("%02d", idx + 89)) + } + } + } else { + if (value < 100) { + code <- 0 + } else if (value <= 5000) { + code <- floor(value / 100) + } else if (value <= 30000) { + code <- floor(value / 1000) + 50 + } else if (value <= 70000 && is.null(quantifier)) { + code <- floor(value / 5000) + 74 + } else { + code <- 89 + } + return(sprintf("%02d", code)) + } + + stop(paste("Cannot encode visibility:", value)) + } + ) +) + +################################################################################ +# MAIN OBSERVATION CLASSES +################################################################################ + +# Temperature observation +Temperature <- R6Class("Temperature", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + sn <- substr(group, 2, 2) + TTT <- substr(group, 3, 5) + + # Fix trailing "/" (issue #10) + if (TTT != "///") { + TTT <- sub("/$", "0", TTT) + } + + if (!sn %in% c("0", "1", "/")) { + warning(paste(group, "is an invalid temperature group")) + return(NULL) + } + + temp_obs <- SignedTemperature$new() + temp_obs$decode(TTT, sign = sn) + }, + + encode_internal = function(data, ...) { + temp_obs <- SignedTemperature$new() + temp_obs$encode(data) + } + ) +) + +# Pressure observation +Pressure <- R6Class("Pressure", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + self$unit <- "hPa" + }, + + decode_convert = function(val, ...) { + val_int <- as.integer(val$value) + val$value <- (val_int / 10) + ifelse(val_int > 5000, 0, 1000) + val + }, + + encode_convert = function(val, ...) { + abs(val * 10) - ifelse(val >= 1000, 10000, 0) + } + ) +) + +# Surface wind observation +SurfaceWind <- R6Class("SurfaceWind", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(ddff, ...) { + dd <- substr(ddff, 1, 2) + ff <- substr(ddff, 3, 4) + + dir_obs <- DirectionDegrees$new() + direction <- dir_obs$decode(dd) + + speed_obs <- WindSpeed$new() + speed <- speed_obs$decode(ff) + + # Sanity check: if wind is calm, it can't have a speed + if (!is.null(direction) && !is.null(direction$calm) && direction$calm && + !is.null(speed) && !is.null(speed$value) && speed$value > 0) { + warning(paste("Wind is calm, yet has a speed (dd:", dd, ", ff:", ff, ")")) + speed <- NULL + } + + list(direction = direction, speed = speed) + }, + + encode_internal = function(data, ...) { + dir_obs <- DirectionDegrees$new() + speed_obs <- WindSpeed$new() + + dd <- dir_obs$encode(if ("direction" %in% names(data)) data$direction else NULL, allow_none = TRUE) + ff <- speed_obs$encode(if ("speed" %in% names(data)) data$speed else NULL) + + paste0(dd, ff) + } + ) +) + +# Wind speed (simplified) +WindSpeed <- R6Class("WindSpeed", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(ff, ...) { + # Decode wind speed - ff is just a numeric value + # Use the base decode_value method which handles numeric conversion + self$decode_value(ff, ...) + }, + + encode_internal = function(data, ...) { + if (is.null(data)) { + return(paste(rep(self$null_char, self$code_len), collapse = "")) + } + value <- if (is.list(data)) data$value else data + if (!is.null(value) && value > 99) { + return(paste0("99 00", sprintf("%02d", value))) + } + sprintf("%02d", as.integer(value)) + } + ) +) + +################################################################################ +# SYNOP REPORT CLASS +################################################################################ + +# Base Report class +Report <- R6Class("Report", + public = list( + not_implemented = list(), + + decode = function(message) { + tryCatch({ + self$decode_internal(message) + }, error = function(e) { + stop(paste("Decode error:", e$message)) + }) + }, + + decode_internal = function(message) { + stop("decode_internal must be implemented in subclass") + } + ) +) + +# SYNOP class - main class for decoding SYNOP messages +SYNOP <- R6Class("SYNOP", + inherit = Report, + public = list( + country = NULL, + + initialize = function() { + self$not_implemented <- list() + self$country <- NULL + }, + + decode_internal = function(message) { + # Initialize data + data <- list() + + # Split message into groups + groups <- strsplit(message, " ")[[1]] + group_idx <- 1 + + # Helper function to get next group + get_next_group <- function() { + if (group_idx <= length(groups)) { + group <- groups[group_idx] + group_idx <<- group_idx + 1 + return(group) + } + return(NULL) + } + + # Alias for convenience + next_group <- get_next_group + + # SECTION 0: Station type, time, and identification + station_type <- next_group() + if (is.null(station_type)) { + stop("Invalid SYNOP: missing station type") + } + + # For simplicity, assume AAXX format + data$station_type <- list(value = station_type) + + # Get observation time and wind indicator (YYGGi) + yygii <- next_group() + if (is.null(yygii) || nchar(yygii) < 5) { + stop("Invalid SYNOP: missing YYGGi group") + } + + # Decode observation time + obs_time <- ObservationTime$new() + data$obs_time <- obs_time$decode(substr(yygii, 1, 4)) + + # Decode wind indicator + wind_ind <- WindIndicator$new() + data$wind_indicator <- wind_ind$decode(substr(yygii, 5, 5)) + + # Get station ID + station_id_group <- next_group() + if (is.null(station_id_group)) { + stop("Invalid SYNOP: missing station ID") + } + + data$station_id <- list(value = station_id_group) + + # Decode region + tryCatch({ + region <- Region$new() + result <- region$decode(station_id_group) + if (!is.null(result)) { + data$region <- result + } + }, error = function(e) { + warning(paste("Error decoding region:", e$message)) + }) + + # Check if next group is NIL (station did not send data) + next_check <- next_group() + if (!is.null(next_check) && (next_check == "NIL" || grepl("^NIL", next_check))) { + # Station did not send data - set remaining fields to NA + data$precipitation_indicator <- NA + data$weather_indicator <- NA + data$lowest_cloud_base <- NA + data$visibility <- NA + data$cloud_cover <- NA + data$surface_wind <- NA + data$air_temperature <- NA + data$dewpoint_temperature <- NA + data$relative_humidity <- NA + data$station_pressure <- NA + data$sea_level_pressure <- NA + data$pressure_tendency <- NA + data$precipitation_s1 <- NA + data$present_weather <- NA + data$past_weather <- NA + data$cloud_types <- NA + return(data) + } + + # SECTION 1: Main observations + section1 <- next_check # Use the group we already got + if (is.null(section1) || nchar(section1) < 5) { + # If section1 is invalid, try to continue anyway + warning("Invalid or missing section 1") + return(data) + } + + # Decode precipitation indicator, weather indicator, cloud base, visibility + tryCatch({ + precip_ind <- PrecipitationIndicator$new() + result <- precip_ind$decode(substr(section1, 1, 1), country = self$country) + if (!is.null(result)) { + data$precipitation_indicator <- result + } + }, error = function(e) { + warning(paste("Error decoding precipitation indicator:", e$message)) + }) + + tryCatch({ + weather_ind <- WeatherIndicator$new() + result <- weather_ind$decode(substr(section1, 2, 2)) + if (!is.null(result)) { + data$weather_indicator <- result + } + }, error = function(e) { + warning(paste("Error decoding weather indicator:", e$message)) + }) + + tryCatch({ + lowest_cloud <- LowestCloudBase$new() + result <- lowest_cloud$decode(substr(section1, 3, 3)) + if (!is.null(result)) { + data$lowest_cloud_base <- result + } + }, error = function(e) { + warning(paste("Error decoding lowest cloud base:", e$message)) + }) + + tryCatch({ + vis <- Visibility$new() + result <- vis$decode(substr(section1, 4, 5)) + if (!is.null(result)) { + data$visibility <- result + } + }, error = function(e) { + warning(paste("Error decoding visibility:", e$message)) + }) + + # Get cloud cover and wind (Nddff) + nddff <- next_group() + if (!is.null(nddff) && nchar(nddff) >= 5) { + tryCatch({ + cloud <- CloudCover$new() + result <- cloud$decode(substr(nddff, 1, 1)) + if (!is.null(result)) { + data$cloud_cover <- result + } + }, error = function(e) { + warning(paste("Error decoding cloud cover from:", nddff, "-", e$message)) + }) + + tryCatch({ + wind <- SurfaceWind$new() + wind_data <- wind$decode(substr(nddff, 2, 5)) + if (!is.null(wind_data)) { + if (!is.null(data$wind_indicator)) { + if (!is.null(wind_data$speed)) { + wind_data$speed$unit <- data$wind_indicator$unit + } + } + data$surface_wind <- wind_data + } + }, error = function(e) { + warning(paste("Error decoding surface wind from:", nddff, "-", e$message)) + }) + } + + # Parse section 1 groups (1sTTT, 2sTTT, 3P0P0P0, 4PPPP, etc.) + next_grp <- next_group() + while (!is.null(next_grp)) { + if (grepl("^333|^444|^555", next_grp)) { + # Start of next section + break + } + + # Try to get header, handle errors gracefully + header <- tryCatch({ + as.integer(substr(next_grp, 1, 1)) + }, error = function(e) { + warning(paste("Unable to parse header from group:", next_grp)) + next_grp <<- next_group() + return(NULL) + }, warning = function(w) { + warning(paste("Warning parsing header from group:", next_grp)) + next_grp <<- next_group() + return(NULL) + }) + + if (is.null(header) || is.na(header)) { + next_grp <- next_group() + # Skip to next iteration + if (is.null(next_grp)) break + next + } + + tryCatch({ + if (header == 1) { + # Air temperature + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$air_temperature <- result + } + } else if (header == 2) { + # Dewpoint temperature or relative humidity + sn <- substr(next_grp, 2, 2) + if (sn == "9") { + rel_hum <- RelativeHumidity$new() + result <- rel_hum$decode(substr(next_grp, 3, 5)) + if (!is.null(result)) { + data$relative_humidity <- result + } + } else { + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$dewpoint_temperature <- result + } + } + } else if (header == 3) { + # Station pressure + press <- Pressure$new() + result <- press$decode(substr(next_grp, 2, 5)) + if (!is.null(result)) { + data$station_pressure <- result + } + } else if (header == 4) { + # Sea level pressure + press <- Pressure$new() + result <- press$decode(substr(next_grp, 2, 5)) + if (!is.null(result)) { + data$sea_level_pressure <- result + } + } else if (header == 5) { + # Pressure tendency + press_tend <- PressureTendency$new() + result <- press_tend$decode(next_grp) + if (!is.null(result)) { + data$pressure_tendency <- result + } + } else if (header == 6) { + # Precipitation + if (!is.null(data$precipitation_indicator) && + data$precipitation_indicator$in_group_1) { + precip <- Precipitation$new() + result <- precip$decode(next_grp) + if (!is.null(result)) { + data$precipitation_s1 <- result + } + } + } else if (header == 7) { + # Present and past weather + if (nchar(next_grp) >= 5) { + ww <- Weather$new() + result <- ww$decode(substr(next_grp, 2, 3), + time_before = list(value = 6, unit = "h"), + type = "present", + weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) + if (!is.null(result)) { + data$present_weather <- result + } + result2 <- ww$decode(substr(next_grp, 4, 4), type = "past", + weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) + result3 <- ww$decode(substr(next_grp, 5, 5), type = "past", + weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) + if (!is.null(result2) || !is.null(result3)) { + data$past_weather <- list(result2, result3) + } + } + } else if (header == 8) { + # Cloud types + cloud_types <- CloudType$new() + result <- cloud_types$decode(next_grp) + if (!is.null(result)) { + data$cloud_types <- result + } + } + }, error = function(e) { + warning(paste("Error decoding group:", next_grp, "-", e$message)) + # Continue to next group + }, warning = function(w) { + warning(paste("Warning decoding group:", next_grp, "-", w$message)) + # Continue to next group + }) + + next_grp <- next_group() + } + + # SECTION 3: Additional observations + if (!is.null(next_grp) && next_grp == "333") { + next_grp <- next_group() + cloud_layers <- list() + highest_gusts <- list() + group_9 <- list() # Collect group 9 codes + + while (!is.null(next_grp) && !grepl("^444|^555", next_grp)) { + # Try to get header, handle errors gracefully + header <- tryCatch({ + as.integer(substr(next_grp, 1, 1)) + }, error = function(e) { + warning(paste("Unable to parse header from group:", next_grp)) + return(NULL) + }, warning = function(w) { + warning(paste("Warning parsing header from group:", next_grp)) + return(NULL) + }) + + if (is.null(header) || is.na(header)) { + next_grp <- next_group() + # Skip to next iteration + if (is.null(next_grp)) break + next + } + + tryCatch({ + # Check if it's a group 9 code (9xxxx) + if (header == 9) { + group_9[[length(group_9) + 1]] <- next_grp + } else if (header == 8) { + # Cloud layers + cloud_layer <- CloudLayer$new() + result <- cloud_layer$decode(next_grp) + if (!is.null(result)) { + cloud_layers[[length(cloud_layers) + 1]] <- result + } + } else if (header == 1) { + # Maximum temperature + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$maximum_temperature <- result + } + } else if (header == 2) { + # Minimum temperature + temp <- Temperature$new() + result <- temp$decode(next_grp) + if (!is.null(result)) { + data$minimum_temperature <- result + } + } + }, error = function(e) { + warning(paste("Error decoding group:", next_grp, "-", e$message)) + # Continue to next group + }, warning = function(w) { + warning(paste("Warning decoding group:", next_grp, "-", w$message)) + # Continue to next group + }) + + next_grp <- next_group() + } + + # Parse group 9 codes (including highest gusts) + if (length(group_9) > 0) { + idx <- 1 + while (idx <= length(group_9)) { + g <- group_9[[idx]] + tryCatch({ + if (nchar(g) >= 3) { + j1 <- substr(g, 2, 2) # Second character + j2 <- substr(g, 3, 3) # Third character + + if (j1 == "1") { + # Group 91xx - highest gusts + if (j2 == "0") { + # 910ff - gust with 10 min period + if (is.null(data$highest_gust)) { + data$highest_gust <- list() + } + gust <- HighestGust$new() + gust_data <- gust$decode(g, + unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, + measure_period = list(value = 10, unit = "min") + ) + if (!is.null(gust_data)) { + data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + } + idx <- idx + 1 + } else if (j2 == "1") { + # 911ff - gust with time before obs + # Check if next group is direction (915dd) + if (idx < length(group_9)) { + next_g <- group_9[[idx + 1]] + if (substr(next_g, 1, 3) == "915") { + gust_group <- paste(g, next_g, sep = " ") + idx <- idx + 2 # Skip next group + } else { + gust_group <- g + idx <- idx + 1 + } + } else { + gust_group <- g + idx <- idx + 1 + } + + if (is.null(data$highest_gust)) { + data$highest_gust <- list() + } + gust <- HighestGust$new() + gust_data <- gust$decode(gust_group, + unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, + time_before = list(value = 6, unit = "h") # Default time before + ) + if (!is.null(gust_data)) { + data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + } + } else { + idx <- idx + 1 + } + } else { + idx <- idx + 1 + } + } else { + idx <- idx + 1 + } + }, error = function(e) { + warning(paste("Error decoding group 9 code:", g, "-", e$message)) + idx <<- idx + 1 + }, warning = function(w) { + warning(paste("Warning decoding group 9 code:", g, "-", w$message)) + idx <<- idx + 1 + }) + } + } + + if (length(cloud_layers) > 0) { + data$cloud_layer <- cloud_layers + } + } + + return(data) + } + ) +) + +################################################################################ +# ADDITIONAL CLASSES NEEDED FOR SYNOP +################################################################################ + +# ObservationTime +ObservationTime <- R6Class("ObservationTime", + inherit = Observation, + public = list( + components = list( + list("day", 0, 2, Day), + list("hour", 2, 2, Hour) + ), + + initialize = function() { + super$initialize() + self$code_len <- 4 + } + ) +) + +# WindIndicator +WindIndicator <- R6Class("WindIndicator", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$valid_range <- c(1, 7) + }, + + decode_internal = function(iw, ...) { + iw_int <- as.integer(iw) + if (iw == "/") { + list(value = NULL, unit = NULL, estimated = NULL) + } else { + list( + value = iw_int, + unit = ifelse(iw_int < 2, "m/s", "KT"), + estimated = (iw_int %in% c(0, 3)) + ) + } + } + ) +) + +# Region +Region <- R6Class("Region", + inherit = Observation, + public = list( + decode_internal = function(raw, ...) { + raw_int <- as.integer(raw) + + regions <- list( + I = list(c(60000, 69998)), + II = list(c(20000, 20099), c(20200, 21998), c(23001, 25998), + c(28001, 32998), c(35001, 36998), c(38001, 39998), + c(40350, 48599), c(48800, 49998), c(50001, 59998)), + III = list(c(80001, 88998)), + IV = list(c(70001, 79998)), + V = list(c(48600, 48799), c(90001, 98998)), + VI = list(c(1, 19998), c(20100, 20199), c(22001, 22998), + c(26001, 27998), c(33001, 34998), c(37001, 37998), + c(40001, 40349)), + Antarctic = list(c(89001, 89998)) + ) + + for (reg_name in names(regions)) { + for (range in regions[[reg_name]]) { + if (raw_int >= range[1] && raw_int <= range[2]) { + return(list(value = reg_name)) + } + } + } + + stop(paste("Invalid region code:", raw)) + } + ) +) + +# PrecipitationIndicator +PrecipitationIndicator <- R6Class("PrecipitationIndicator", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + }, + + decode_internal = function(i, ...) { + kwargs <- list(...) + country <- kwargs$country + i_int <- as.integer(i) + + list( + value = i_int, + in_group_1 = (i %in% c("0", "1")) || (i == "6" && !is.null(country) && country == "RU"), + in_group_3 = (i %in% c("0", "2")) || (i == "7" && !is.null(country) && country == "RU") + ) + } + ) +) + +# WeatherIndicator +WeatherIndicator <- R6Class("WeatherIndicator", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$valid_range <- c(1, 7) + }, + + decode_internal = function(ix, ...) { + ix_int <- ifelse(ix == "/", NULL, as.integer(ix)) + + list( + value = ix_int, + automatic = ifelse(is.null(ix_int) || ix_int < 3, FALSE, TRUE) + ) + } + ) +) + +# LowestCloudBase +LowestCloudBase <- R6Class("LowestCloudBase", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable1600$new() + self$unit <- "m" + } + ) +) + +# CodeTable1600 +CodeTable1600 <- R6Class("CodeTable1600", + inherit = CodeTable, + public = list( + ranges = list( + c(0, 50), c(50, 100), c(100, 200), c(200, 300), c(300, 600), + c(600, 1000), c(1000, 1500), c(1500, 2000), c(2000, 2500), c(2500, Inf) + ), + + initialize = function() { + self$table_name <- "1600" + }, + + decode_internal = function(h, ...) { + h_int <- as.integer(h) + if (h_int >= 0 && h_int < length(self$ranges)) { + range <- self$ranges[[h_int + 1]] + quantifier <- ifelse(is.infinite(range[2]), "isGreaterOrEqual", NULL) + list(min = range[1], max = ifelse(is.infinite(range[2]), NULL, range[2]), + quantifier = quantifier) + } else { + stop(paste("Invalid cloud base code:", h)) + } + } + ) +) + +# Precipitation +Precipitation <- R6Class("Precipitation", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + kwargs <- list(...) + tenths <- ifelse(is.null(kwargs$tenths), FALSE, kwargs$tenths) + + if (tenths) { + rrrr <- substr(group, 2, 5) + amount <- Amount24$new() + list( + amount = amount$decode(rrrr), + time_before_obs = list(value = 24, unit = "h") + ) + } else { + rrr <- substr(group, 2, 4) + t <- substr(group, 5, 5) + amount <- Amount$new() + list( + amount = amount$decode(rrr), + time_before_obs = TimeBeforeObs$new()$decode(t) + ) + } + } + ) +) + +# Amount (simplified) +Amount <- R6Class("Amount", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 3 + self$code_table <- CodeTable3590$new() + self$unit <- "mm" + } + ) +) + +# Amount24 +Amount24 <- R6Class("Amount24", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + self$code_table <- CodeTable3590A$new() + self$unit <- "mm" + } + ) +) + +# CodeTable3590 (simplified) +CodeTable3590 <- R6Class("CodeTable3590", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "3590" + }, + + decode_internal = function(RRR, ...) { + rrr_int <- as.integer(RRR) + if (rrr_int <= 988) { + list(value = rrr_int, quantifier = NULL, trace = FALSE) + } else if (rrr_int == 989) { + list(value = rrr_int, quantifier = "isGreaterOrEqual", trace = FALSE) + } else if (rrr_int == 990) { + list(value = 0, quantifier = NULL, trace = TRUE) + } else if (rrr_int >= 991 && rrr_int <= 999) { + list(value = (rrr_int - 990) / 10.0, quantifier = NULL, trace = FALSE) + } else { + stop(paste("Invalid precipitation code:", RRR)) + } + } + ) +) + +# CodeTable3590A (simplified) +CodeTable3590A <- R6Class("CodeTable3590A", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "3590A" + }, + + decode_internal = function(RRRR, ...) { + rrrr_int <- as.integer(RRRR) + if (rrrr_int <= 9998) { + list(value = round(rrrr_int * 0.1, 1), quantifier = NULL, trace = FALSE) + } else if (rrrr_int == 9999) { + list(value = 0, quantifier = NULL, trace = TRUE) + } else { + stop(paste("Invalid precipitation code:", RRRR)) + } + } + ) +) + +# TimeBeforeObs (simplified) +TimeBeforeObs <- R6Class("TimeBeforeObs", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$code_table <- CodeTable4019$new() + self$unit <- "h" + } + ) +) + +# CodeTable4019 +CodeTable4019 <- R6Class("CodeTable4019", + inherit = CodeTable, + public = list( + values = c(NULL, 6, 12, 18, 24, 1, 2, 3, 9, 15), + + initialize = function() { + self$table_name <- "4019" + }, + + decode_internal = function(t, ...) { + t_int <- as.integer(t) + 1 + if (t_int >= 1 && t_int <= length(self$values)) { + val <- self$values[[t_int]] + if (!is.null(val)) { + list(value = val, unit = "h") + } else { + NULL + } + } else { + NULL + } + } + ) +) + +# PressureTendency +PressureTendency <- R6Class("PressureTendency", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + a <- substr(group, 2, 2) + ppp <- substr(group, 3, 5) + + tendency <- Tendency$new() + change <- Change$new() + + list( + tendency = tendency$decode(a), + change = change$decode(ppp, tendency = tendency$decode(a)) + ) + } + ) +) + +# Tendency (simplified) +Tendency <- R6Class("Tendency", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + self$valid_range <- c(0, 8) + } + ) +) + +# Change (simplified) +Change <- R6Class("Change", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 3 + self$unit <- "hPa" + }, + + decode_convert = function(val, ...) { + kwargs <- list(...) + tendency <- kwargs$tendency + + if (is.list(tendency) && "value" %in% names(tendency)) { + factor <- ifelse(tendency$value < 5, 10.0, -10.0) + val$value <- val$value / factor + } + val + } + ) +) + +# Weather +Weather <- R6Class("Weather", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(group, ...) { + kwargs <- list(...) + w_type <- kwargs$type + ix <- kwargs$weather_indicator + + if (w_type == "present") { + table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4680", "4677") + } else if (w_type == "past") { + table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4531", "4561") + } else { + stop(paste("Invalid weather type:", w_type)) + } + + group_int <- as.integer(group) + if (is.na(group_int)) { + return(NULL) + } + + result <- list(value = group_int, `_table` = table) + if (!is.null(kwargs$time_before)) { + result$time_before_obs <- kwargs$time_before + } + + result + } + ) +) + +# CloudType +CloudType <- R6Class("CloudType", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + nh <- substr(group, 2, 2) + cl <- substr(group, 3, 3) + cm <- substr(group, 4, 4) + ch <- substr(group, 5, 5) + + low_cloud <- LowCloud$new() + middle_cloud <- MiddleCloud$new() + high_cloud <- HighCloud$new() + cloud_cover <- CloudCover$new() + + result <- list( + low_cloud_type = low_cloud$decode(cl), + middle_cloud_type = middle_cloud$decode(cm), + high_cloud_type = high_cloud$decode(ch) + ) + + cover <- cloud_cover$decode(nh) + if (nh != "/") { + if (!is.null(result$low_cloud_type) && + result$low_cloud_type$value >= 1 && + result$low_cloud_type$value <= 9) { + result$low_cloud_amount <- cover + } else if (!is.null(result$middle_cloud_type) && + result$middle_cloud_type$value >= 0 && + result$middle_cloud_type$value <= 9) { + result$middle_cloud_amount <- cover + } else { + result$cloud_amount <- cover + } + } + + result + } + ) +) + +# LowCloud, MiddleCloud, HighCloud (simplified) +LowCloud <- R6Class("LowCloud", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + } + ) +) + +MiddleCloud <- R6Class("MiddleCloud", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + } + ) +) + +HighCloud <- R6Class("HighCloud", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 1 + } + ) +) + +# CloudLayer +CloudLayer <- R6Class("CloudLayer", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 4 + }, + + decode_internal = function(group, ...) { + n <- substr(group, 2, 2) + c <- substr(group, 3, 3) + hh <- substr(group, 4, 5) + + cloud_cover <- CloudCover$new() + cloud_genus <- CloudGenus$new() + height <- Height$new() + + list( + cloud_cover = cloud_cover$decode(n), + cloud_genus = cloud_genus$decode(c), + cloud_height = height$decode(hh) + ) + } + ) +) + +# Height (simplified) +Height <- R6Class("Height", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + self$code_table <- CodeTable1677$new() + self$unit <- "m" + } + ) +) + +# CodeTable1677 (simplified) +CodeTable1677 <- R6Class("CodeTable1677", + inherit = CodeTable, + public = list( + initialize = function() { + self$table_name <- "1677" + }, + + decode_internal = function(hh, ...) { + hh_int <- as.integer(hh) + quantifier <- NULL + + if (hh_int == 0) { + list(value = 30, quantifier = "isLess") + } else if (hh_int >= 1 && hh_int <= 50) { + list(value = hh_int * 30, quantifier = NULL) + } else if (hh_int >= 56 && hh_int <= 80) { + list(value = (hh_int - 50) * 300, quantifier = NULL) + } else if (hh_int >= 81 && hh_int <= 88) { + list(value = ((hh_int - 80) * 1500) + 9000, quantifier = NULL) + } else if (hh_int == 89) { + list(value = 21000, quantifier = "isGreater") + } else if (hh_int == 99) { + list(value = 21000, quantifier = "isGreater") + } else { + stop(paste("Invalid height code:", hh)) + } + } + ) +) + +# RelativeHumidity +RelativeHumidity <- R6Class("RelativeHumidity", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 3 + self$valid_range <- c(0, 100) + self$unit <- "%" + } + ) +) + +# HighestGust - Highest wind gust +HighestGust <- R6Class("HighestGust", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(group, ...) { + kwargs <- list(...) + + # Split group into separate groups if needed + groups <- strsplit(group, " ")[[1]] + + # Get type, speed and direction + # Format: 910ff or 911ff, optionally followed by 915dd + t <- NULL + ff <- NULL + dd <- NULL + + if (length(groups) > 0) { + # First group: 910ff or 911ff + first_group <- groups[1] + if (nchar(first_group) >= 5) { + t <- substr(first_group, 3, 3) + ff <- substr(first_group, 4, 5) + } + } + + # Second group: 915dd (direction) + if (length(groups) > 1) { + second_group <- groups[2] + if (nchar(second_group) >= 5 && substr(second_group, 1, 3) == "915") { + dd <- substr(second_group, 4, 5) + } + } + + # Return values + time_before <- kwargs$time_before + measure_period <- kwargs$measure_period + + gust_obs <- Gust$new() + dir_obs <- DirectionDegrees$new() + + data <- list( + speed = gust_obs$decode(ff, unit = kwargs$unit), + direction = dir_obs$decode(dd) + ) + + if (!is.null(time_before)) { + data$time_before_obs <- time_before + } + if (!is.null(measure_period)) { + data$measure_period <- measure_period + } + + data + }, + + encode_internal = function(data, ...) { + kwargs <- list(...) + time_before <- kwargs$time_before + measure_period <- kwargs$measure_period + output <- character(0) + + # Handle list of gusts or single gust + if (is.list(data) && "speed" %in% names(data)) { + data <- list(data) # Convert single gust to list + } + + for (d in data) { + # Convert time before obs, if required + if ("time_before_obs" %in% names(d)) { + if (is.null(time_before) || + (!is.null(time_before) && !identical(d$time_before_obs, time_before))) { + time_before_obs <- TimeBeforeObs$new() + tt <- time_before_obs$encode(d$time_before_obs) + if (tt != "//") { + output <- c(output, paste0("907", tt)) + } + } + prefix <- "911" + } else if ("measure_period" %in% names(d)) { + if (identical(d$measure_period, list(value = 10, unit = "min"))) { + prefix <- "910" + } else { + stop("Invalid value for measure_period") + } + } else { + prefix <- "910" # Default + } + + # Convert the gust + gust_obs <- Gust$new() + ff <- gust_obs$encode(if ("speed" %in% names(d)) d$speed else NULL) + output <- c(output, paste0(prefix, ff)) + + # Convert the direction + if ("direction" %in% names(d) && !is.null(d$direction)) { + dir_obs <- DirectionDegrees$new() + dd <- dir_obs$encode(d$direction) + output <- c(output, paste0("915", dd)) + } + } + + paste(output, collapse = " ") + } + ) +) + +# Gust - Wind gust speed (internal class for HighestGust) +Gust <- R6Class("Gust", + inherit = Observation, + public = list( + initialize = function() { + super$initialize() + self$code_len <- 2 + }, + + decode_internal = function(ff, ...) { + # Decode wind gust speed - same as WindSpeed + self$decode_value(ff, ...) + }, + + encode_internal = function(data, ...) { + # Encode wind gust speed - same as WindSpeed + if (is.null(data)) { + return(paste(rep(self$null_char, self$code_len), collapse = "")) + } + value <- if (is.list(data)) data$value else data + if (!is.null(value) && value > 99) { + return(paste0("99 00", sprintf("%02d", value))) + } + sprintf("%02d", as.integer(value)) + } + ) +) + +################################################################################ +# EXPORT FUNCTIONS +################################################################################ + +# Helper function to create observation instances +create_observation <- function(class_name, ...) { + class_map <- list( + "CloudCover" = CloudCover, + "CloudGenus" = CloudGenus, + "Day" = Day, + "DirectionCardinal" = DirectionCardinal, + "DirectionDegrees" = DirectionDegrees, + "Hour" = Hour, + "Minute" = Minute, + "SignedTemperature" = SignedTemperature, + "Visibility" = Visibility, + "Temperature" = Temperature, + "Pressure" = Pressure, + "SurfaceWind" = SurfaceWind, + "WindSpeed" = WindSpeed, + "SYNOP" = SYNOP + ) + + if (!class_name %in% names(class_map)) { + stop(paste("Unknown observation class:", class_name)) + } + + class_map[[class_name]]$new(...) +} + +# Example usage function +example_usage <- function() { + # Example: Decode temperature + # Format: 1sTTT where s=0 (positive) or s=1 (negative), TTT=temperature + temp <- Temperature$new() + result <- temp$decode("10094") # Sign=0 (positive), TTT=094 -> 9.4°C + print(result) + + # Negative temperature + result2 <- temp$decode("11094") # Sign=1 (negative), TTT=094 -> -9.4°C + print(result2) + + # Example: Encode temperature + encoded <- temp$encode(list(value = 19.4)) + print(encoded) + + # Example: Decode cloud cover + cloud <- CloudCover$new() + result <- cloud$decode("6") + print(result) + + # Example: Decode surface wind + wind <- SurfaceWind$new() + result <- wind$decode("1506") + print(result) + + # Example: Decode full SYNOP + synop <- SYNOP$new() + synop_msg <- "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 81656 86070" + output <- synop$decode(synop_msg) + print(output) +} + + From 09cff0996a8117128a03da4f0a6c441f3f3c7804 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sat, 9 May 2026 02:23:01 +0200 Subject: [PATCH 07/16] fix hydro --- .Rbuildignore | 2 ++ .github/copilot-instructions.md | 57 +++++++++++++++++++++++++++++++++ CLAUDE.md | 39 ++++++++++++++++++++++ NEWS.md | 1 + R/clean_metadata_hydro.R | 3 +- R/hydro_imgw_daily.R | 31 +++++++++++++++--- R/hydro_imgw_monthly.R | 22 ++++++++++--- R/parser.R | 46 +++++++++++++++++++------- vignettes/articles/pl.Rmd | 8 ++--- 9 files changed, 182 insertions(+), 27 deletions(-) create mode 100644 .github/copilot-instructions.md create mode 100644 CLAUDE.md diff --git a/.Rbuildignore b/.Rbuildignore index 87389cf..699112d 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -10,6 +10,7 @@ ^data-raw$ ^vignettes/articles$ ^\.github$ +^\.github/copilot-instructions\.md$ ^\.Rhistory$ ^\.lintr$ vignettes/articles/usecase.Rmd @@ -19,3 +20,4 @@ vignettes/articles/usecase.Rmd ^.covrignore$ ^\.positai$ ^\.claude$ +^\.CLAUDE.md$ diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md new file mode 100644 index 0000000..b21f957 --- /dev/null +++ b/.github/copilot-instructions.md @@ -0,0 +1,57 @@ +# Copilot instructions for `climate` + +`climate` is a CRAN R package for downloading in-situ meteorological and hydrological data from OGIMET, IMGW-PIB, NOAA, and University of Wyoming sources. The package targets R >= 4.1.0 and uses roxygen2 with markdown enabled. + +## Build, test, and lint commands + +Run commands from the package root. + +- Load the package for interactive work: `R -q -e 'devtools::load_all()'` +- Regenerate `man/` and `NAMESPACE` after roxygen changes: `R -q -e 'devtools::document()'` +- Run the full test suite: `R -q -e 'devtools::test()'` +- Run a single test file: `R -q -e 'testthat::test_file("tests/testthat/test-meteo_imgw.R")'` +- Run package linting: `R -q -e 'lintr::lint_package()'` +- Run a local package check: `R -q -e 'devtools::check()'` +- Run the CI-style check locally when needed: `R -q -e 'rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran", "--run-donttest"), error_on = "warning", check_dir = "check")'` +- Run coverage: `R -q -e 'covr::package_coverage()'` + +## High-level architecture + +- Public download functions are thin wrappers that dispatch by `interval` to interval-specific implementations. Keep wrapper signatures and the underlying `*_hourly()`, `*_daily()`, and `*_monthly()` functions in sync. Examples: + - `meteo_imgw()` -> `meteo_imgw_hourly()`, `meteo_imgw_daily()`, `meteo_imgw_monthly()` + - `hydro_imgw()` -> `hydro_imgw_daily()`, `hydro_imgw_monthly()` + - `meteo_ogimet()` -> `ogimet_hourly()`, `ogimet_daily()` + +- The package has separate ingestion paths for each upstream source family: + - **IMGW archive downloads**: archive ZIP files are downloaded from `danepubliczne.imgw.pl`, unpacked, read through `imgw_read()`, then normalized and optionally joined with built-in station metadata. + - **IMGW datastore / telemetry downloads**: `meteo_imgw_datastore()` and `hydro_imgw_datastore()` fetch large monthly telemetry archives from the datastore endpoint. These are raw, high-volume datasets and are handled separately from the archive-style IMGW functions. + - **OGIMET**: HTML is scraped with `XML::readHTMLTable`; station identity is based on WMO IDs. Hourly precipitation post-processing is handled by `precip_split()`. + - **NOAA / Wyoming**: direct file or page downloads for ISH hourly data, Mauna Loa CO2, and Wyoming soundings. + +- IMGW column renaming is a distinct normalization layer. Most IMGW functions accept `col_names = "short" | "full" | "polish"` and pass results through `meteo_shortening_imgw()` or `hydro_shortening_imgw()`. The mapping tables live in built-in datasets backed by `data-raw/`. + +- Package data and docs follow standard R package patterns: + - exported code in `R/` + - tests in `tests/testthat/` + - built-in datasets in `data/`, generated from `data-raw/` + - roxygen-generated docs in `man/` + +## Key conventions + +- Do not hand-edit `man/` or `NAMESPACE`; update roxygen comments and run `devtools::document()`. + +- Do not hand-edit `data/*.rda`; regenerate datasets from the relevant scripts in `data-raw/` and then use `usethis::use_data(...)`. + +- Preserve graceful network-failure behavior. User-facing download functions commonly keep `allow_failure = TRUE` and wrap the real worker in a `tryCatch`, while the underlying implementation lives in a `*_bp` helper. Reuse `test_url()` for download gating instead of introducing hard failures for transient network issues. + +- Tests that touch the network are written to be offline-safe. Follow the existing pattern at the top of network tests: `if (!curl::has_internet()) return(invisible(NULL))`. + +- IMGW station handling is source-specific. Meteorological IMGW archive functions expect station names in uppercase, not numeric IDs; renamed stations may need multiple names such as `c("POZNAŃ", "POZNAŃ-ŁAWICA")`. + +- Preserve the encoding fallback logic in `imgw_read()`. IMGW files vary in delimiter and encoding, so the CP1250 / UTF-8 / transliteration branches are intentional. + +- If you add a new IMGW column, update both the abbreviation source data in `data-raw/` and the runtime shortening layer in `R/meteo_shortening_imgw.R` or `R/hydro_shortening_imgw.R`. + +- If you introduce new data.table non-standard evaluation symbols, add them to `R/globals.R` to avoid `R CMD check` NOTES. + +- `R/parser.R` is the exported parser implementation. If `inst/parser.R` exists, treat it as a sandbox/helper script rather than the package API surface. diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..7379afe --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,39 @@ +# CLAUDE.md + +This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. + +## Project + +`climate` is a CRAN R package that scrapes and downloads in-situ meteorological and hydrological data from public repositories: OGIMET, University of Wyoming soundings, NOAA ISH and CO2 (Mauna Loa), and IMGW-PIB (Poland). Standard R-package layout: code in `R/`, roxygen-generated docs in `man/`, tests in `tests/testthat/`, built-in datasets in `data/` (RDAs generated from `data-raw/`), example data in `inst/extdata/`, vignettes in `vignettes/`. Minimum R is 4.1.0; documentation is generated with roxygen2 markdown mode (do not hand-edit `man/` or `NAMESPACE`). + +## Common commands + +Run from the package root in R: + +- `devtools::load_all()` — interactive load for development. +- `devtools::document()` — regenerate `man/` and `NAMESPACE` after touching roxygen blocks. +- `devtools::test()` — run the full test suite (testthat). +- `testthat::test_file("tests/testthat/test-meteo_imgw.R")` — run a single test file. +- `devtools::check()` (or `R CMD check`) — full package check; CI runs this on macOS/Windows/Ubuntu (R devel, release, 4.1). +- `lintr::lint_package()` — uses the custom `.lintr` (line length 120, cyclocomp limit 33, several default linters disabled). Respect those limits when adding code. +- `covr::package_coverage()` — coverage. Project target is 60%; `R/sounding_wyoming.R`, `R/imgw_read.R`, and `R/onAttach.R` are excluded via `.covrignore`. +- Built-in datasets are regenerated by sourcing the relevant scripts in `data-raw/` and re-running `usethis::use_data(...)`; do not edit `data/*.rda` by hand. + +## Architecture + +**Wrapper-then-implementation pattern.** Public entry points dispatch on `interval` to per-resolution implementations: `meteo_imgw()` → `meteo_imgw_hourly/daily/monthly()`, `hydro_imgw()` → `hydro_imgw_daily/monthly()`, `meteo_ogimet()` → `ogimet_hourly/daily()`. When adding a parameter to a wrapper, plumb it through every implementation it dispatches to. + +**Three independent data-source families**, each with its own download/parse path: + +- **IMGW-PIB** (Polish): downloads ZIPs from `danepubliczne.imgw.pl`, unzips, then reads CSVs through `imgw_read.R`. The reader has multi-step encoding fallbacks (CP1250, UTF-8, optional `iconv ISO-8859-2 → ASCII//TRANSLIT`); preserve those branches when editing — Polish station names contain diacritics and station files vary in delimiter/encoding. Stations are selected by NAME in capital letters (e.g. `"POZNAŃ"`), not by numeric ID. Some renamed stations require multiple names, e.g. `c("POZNAŃ", "POZNAŃ-ŁAWICA")`. Metadata lives in the built-in `imgw_meteo_stations` / `imgw_hydro_stations` datasets and in `R/clean_metadata_*.R`. +- **OGIMET**: HTML scraping via `XML::readHTMLTable` from `ogimet.com`. Stations are identified by WMO ID. `precip_split` / `R/precip_split.R` handles 6/12/24h precipitation disaggregation for hourly data. +- **NOAA / Wyoming**: direct file downloads (ISH gzipped fixed-width, CO2 text, sounding HTML). + +**Column-name shortening layer.** Most IMGW download functions accept `col_names = "short" | "full" | "polish"` and pass the raw frame through `meteo_shortening_imgw()` / `hydro_shortening_imgw()` (in `R/*_shortening_imgw.R`). Full and short names are looked up against `imgw_meteo_abbrev` / `imgw_hydro_abbrev` (built-in data). When you add a new IMGW column, update both the abbrev table (`data-raw/`) and the shortener. + +**Graceful network failure** is required for CRAN. Use `test_url()` (`R/test_url.R`) to gate downloads, and follow the existing `allow_failure = TRUE` pattern: wrap the real worker (`*_bp` "best practice" inner function) in `tryCatch` so user-facing functions return `NULL`/`invisible()` with a `message()` instead of erroring. Tests follow the same convention — every network test starts with `if (!curl::has_internet()) return(invisible(NULL))`. Don't add tests that fail when offline. + +**Other notes.** +- `R/globals.R` holds `utils::globalVariables(...)` declarations needed because of data.table's NSE; add new NSE symbols there to keep `R CMD check` clean. +- `R/onAttach.R` prints a startup message; it's covr-ignored and behind `interactive() && runif < 0.25`. +- `inst/parser.R` and `R/parser.R` exist separately — `R/parser.R` is the exported package function; `inst/parser.R` is a sandbox script (currently untracked per `git status`). Don't conflate them. diff --git a/NEWS.md b/NEWS.md index c051e26..8efcbff 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ ## TODO/in progress: * adding parser for SYNOP messages from OGIMET webportal to speed up downloading and avoid server overload; the new parser allows to download data for multiple stations in a single query +* adding label description to `hydro_imgw()` datasets to easen understanding of the data and avoid confusion with units (e.g. "Q [m3/s]" instead of "Q") diff --git a/R/clean_metadata_hydro.R b/R/clean_metadata_hydro.R index 3dd9a22..5bace84 100644 --- a/R/clean_metadata_hydro.R +++ b/R/clean_metadata_hydro.R @@ -11,12 +11,13 @@ clean_metadata_hydro = function(address, interval) { temp = tempfile() test_url(link = address, output = temp) - a = read.csv(temp, header = FALSE, stringsAsFactors = FALSE)$V1 + a = read.csv(temp, header = FALSE, stringsAsFactors = FALSE, fileEncoding = "Windows-1250")$V1 inds = grepl("^[A-Z]{2}.{5}", a) code = trimws(substr(a, 1, 7))[inds] name = trimws(substr(a, 10, nchar(a)))[inds] a = data.frame(parameters = code, label = name) + a$label = stringi::stri_trans_general(a$label, 'LATIN-ASCII') return(a) } diff --git a/R/hydro_imgw_daily.R b/R/hydro_imgw_daily.R index 09f2a29..159ec04 100644 --- a/R/hydro_imgw_daily.R +++ b/R/hydro_imgw_daily.R @@ -115,7 +115,10 @@ hydro_imgw_daily_bp = function(year, data1 = data1[, c(1:7, 10, 8:9)] } - colnames(data1) = meta[[1]][, 1] + colnames(data1) = meta[[1]]$parameters + for (labs in seq_along(meta[[1]]$parameters)) { + attr(data1[[labs]], "label") = meta[[1]]$label[[labs]] + } codz_data = rbind(codz_data, data1) } # end of codz_ @@ -129,7 +132,10 @@ hydro_imgw_daily_bp = function(year, unzip(zipfile = temp, exdir = temp2) file2 = paste(temp2, dir(temp2), sep = "/")[1] data2 = imgw_read(translit, file2) - colnames(data2) = gsub(x = meta[[2]][, 1], "^ZJ", "CO") # rename colnames starting with ^ZJ to be changed to ^CO: + colnames(data2) = gsub(x = meta[[2]]$parameters, "^ZJ", "CO") # rename colnames starting with ^ZJ to be changed to ^CO: + for (labs in seq_along(meta[[2]]$parameters)) { + attr(data2[[labs]], "label") = meta[[2]]$label[[labs]] + } zjaw_data = rbind(zjaw_data, data2) } @@ -157,9 +163,9 @@ hydro_imgw_daily_bp = function(year, } # end of loop for years (if more than 1 specified) all_data = do.call(rbind, all_data) - all_data[all_data == 9999] = NA - all_data[all_data == 99999.999] = NA - all_data[all_data == 99.9] = NA + all_data[all_data == 9999] = NA + all_data[all_data == 99999.999] = NA + all_data[all_data == 99.9] = NA all_data[all_data == 999] = NA if (coords) { @@ -182,5 +188,20 @@ hydro_imgw_daily_bp = function(year, #all_data = hydro_shortening_imgw(all_data, col_names = col_names, ...) all_data = unique(all_data) rownames(all_data) = 1:nrow(all_data) + + # Final pass: re-apply label attributes (rbind / data.table conversions / merge can drop them). + for (i in seq_len(nrow(meta[[1]]))) { + p = meta[[1]]$parameters[i] + if (p %in% colnames(all_data)) { + attr(all_data[[p]], "label") = meta[[1]]$label[i] + } + } + for (i in seq_len(nrow(meta[[2]]))) { + p = gsub("^ZJ", "CO", meta[[2]]$parameters[i]) + if (p %in% colnames(all_data)) { + attr(all_data[[p]], "label") = meta[[2]]$label[i] + } + } + return(all_data) } \ No newline at end of file diff --git a/R/hydro_imgw_monthly.R b/R/hydro_imgw_monthly.R index 8f86377..0bba899 100644 --- a/R/hydro_imgw_monthly.R +++ b/R/hydro_imgw_monthly.R @@ -86,14 +86,18 @@ hydro_imgw_monthly_bp = function(year, unzip(zipfile = temp, exdir = temp2) file1 = paste(temp2, dir(temp2), sep = "/")[1] data1 = imgw_read(translit, file1) - colnames(data1) = meta[, 1] + colnames(data1) = meta$parameters + for (labs in seq_along(meta$parameters)) { + attr(data1[[labs]], "label") = meta$label[[labs]] + } all_data[[i]] = data1 } all_data = do.call(rbind, all_data) - - all_data[all_data == 9999] = NA - all_data[all_data == 99999.999] = NA - all_data[all_data == 99.9] = NA + all_data[all_data == 9999] = NA + all_data[all_data == 99999.999] = NA + all_data[all_data == 99.9] = NA + all_data[all_data == 999] = NA + colnames(all_data) = meta[, 1] # coords if (coords) { @@ -127,5 +131,13 @@ hydro_imgw_monthly_bp = function(year, #all_data = hydro_shortening_imgw(all_data, col_names = col_names, ...) + # Final pass: re-apply label attributes (rbind / merge can drop them). + for (i in seq_len(nrow(meta))) { + p = meta$parameters[i] + if (p %in% colnames(all_data)) { + attr(all_data[[p]], "label") = meta$label[i] + } + } + return(all_data) } diff --git a/R/parser.R b/R/parser.R index bbcfd99..52bf385 100644 --- a/R/parser.R +++ b/R/parser.R @@ -571,27 +571,29 @@ CodeTable0500 <- R6Class("CodeTable0500", CodeTable0700 <- R6Class("CodeTable0700", inherit = CodeTable, public = list( - directions = c(NULL, "NE", "E", "SE", "S", "SW", "W", "NW", "N", NULL), - + # NA placeholders preserve indexing: 0 = calm, 9 = allDirections (no compass value) + directions = c(NA_character_, "NE", "E", "SE", "S", "SW", "W", "NW", "N", NA_character_), + initialize = function() { self$table_name <- "0700" }, - + decode_internal = function(D, ...) { if (D == "/") { return(list(value = NULL, isCalmOrStationary = NULL, allDirections = NULL)) } - + d <- as.integer(D) isCalmOrStationary <- (d == 0) allDirections <- (d == 9) - + direction <- if (d >= 0 && d < length(self$directions)) { - self$directions[d + 1] + v <- self$directions[d + 1] + if (is.na(v)) NULL else v } else { NULL } - + list( value = direction, isCalmOrStationary = isCalmOrStationary, @@ -1262,6 +1264,22 @@ SYNOP <- R6Class("SYNOP", if (!is.null(result)) { data$minimum_temperature <- result } + } else if (header == 5) { + # Section 3 group 5: only 55SSS (daily sunshine in 1/10 h) is implemented. + # Pressure-change subgroups (j1 in 1..4) and radiation (j1 in 6..9) are skipped. + if (substr(next_grp, 2, 2) == "5" && nchar(next_grp) >= 5) { + sss <- substr(next_grp, 3, 5) + if (sss != "///") { + sss_int <- suppressWarnings(as.integer(sss)) + if (!is.na(sss_int) && sss_int >= 0 && sss_int <= 240) { + data$sunshine <- list( + value = sss_int / 10, + unit = "h", + time_before_obs = list(value = 24, unit = "h") + ) + } + } + } } }, error = function(e) { warning(paste("Error decoding group:", next_grp, "-", e$message)) @@ -1501,18 +1519,22 @@ CodeTable1600 <- R6Class("CodeTable1600", c(0, 50), c(50, 100), c(100, 200), c(200, 300), c(300, 600), c(600, 1000), c(1000, 1500), c(1500, 2000), c(2000, 2500), c(2500, Inf) ), - + initialize = function() { self$table_name <- "1600" }, - + decode_internal = function(h, ...) { h_int <- as.integer(h) if (h_int >= 0 && h_int < length(self$ranges)) { range <- self$ranges[[h_int + 1]] - quantifier <- ifelse(is.infinite(range[2]), "isGreaterOrEqual", NULL) - list(min = range[1], max = ifelse(is.infinite(range[2]), NULL, range[2]), - quantifier = quantifier) + # ifelse(test, yes, NULL) raises a warning that gets caught upstream and + # silently drops the result, so use plain if/else here. + if (is.infinite(range[2])) { + list(min = range[1], max = NULL, quantifier = "isGreaterOrEqual") + } else { + list(min = range[1], max = range[2], quantifier = NULL) + } } else { stop(paste("Invalid cloud base code:", h)) } diff --git a/vignettes/articles/pl.Rmd b/vignettes/articles/pl.Rmd index 74763b3..8df2d56 100644 --- a/vignettes/articles/pl.Rmd +++ b/vignettes/articles/pl.Rmd @@ -83,10 +83,10 @@ kolejnych kolumnach. ```{r filtering, eval=TRUE, include=TRUE} h2 = h %>% - filter(MCWSKEX == 3) %>% - select(id, PSNZWP, X, Y, MCROKH, MCPRZP) %>% - group_by(MCROKH, id, PSNZWP, X, Y) %>% - summarise(srednie_roczne_Q = round(mean(MCPRZP, na.rm = TRUE),1)) %>% + dplyr::filter(MCWSKEX == 3) %>% + dplyr::select(id, PSNZWP, X, Y, MCROKH, MCPRZP) %>% + dplyr::group_by(MCROKH, id, PSNZWP, X, Y) %>% + dplyr::summarise(srednie_roczne_Q = round(mean(MCPRZP, na.rm = TRUE),1)) %>% spread(MCROKH, srednie_roczne_Q) ``` From 137a6e4c8fc301daf415ecf3349c1bb175849824 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sat, 9 May 2026 15:59:08 +0200 Subject: [PATCH 08/16] fix vignette --- .gitignore | 1 + vignettes/articles/usecase_ogimet.Rmd | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index e951b95..17050e8 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ pkgdown .Renviron test-out.txt .positai +.aider* diff --git a/vignettes/articles/usecase_ogimet.Rmd b/vignettes/articles/usecase_ogimet.Rmd index 0eb99d4..7d31e0b 100644 --- a/vignettes/articles/usecase_ogimet.Rmd +++ b/vignettes/articles/usecase_ogimet.Rmd @@ -38,9 +38,9 @@ windRose(mydata = df, ws = "ws", wd = "dir", type = "season", paddle = FALSE, main = "Svalbard Lufthavn (2018)", ws.int = 3, dig.lab = 3, layout = c(4, 1)) # do we miss any data? -summaryPlot(df[ ,c("date", "TC", "ws", "gust")]) +openair::summaryPlot(df[ ,c("date", "TC", "ws", "gust")]) # which sectors are responsible for warm/cold air mass advection: -polarPlot(df, pollutant = "TC", x = "ws", wd = "dir", k = 50, force.positive = FALSE, +openair::polarPlot(df, pollutant = "TC", x = "ws", wd = "dir", k = 50, force.positive = FALSE, type = "season", layout = c(4, 1), resolution = "fine", normalise = FALSE) ``` From 3997c92eda84444ecd53535c71d3e3e9ac35158c Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sat, 9 May 2026 16:24:00 +0200 Subject: [PATCH 09/16] unify assign operators --- .github/agents/r-package-improver.agent.md | 79 ++ NEWS.md | 1 + R/ogimet_daily.R | 13 +- R/ogimet_hourly.R | 2 +- R/parser.R | 988 +++++++++--------- R/zzz.R | 2 +- data-raw/01_example.R | 2 +- data-raw/02_example.R | 12 +- data-raw/04_example.R | 4 +- data-raw/05_example.R | 14 +- data-raw/parametry_przyklad_synop.R | 16 +- data-raw/unique_meteo_parameters.R | 22 +- inst/parser.R | 976 ++++++++--------- man/parser.Rd | 5 +- tests/testthat/test-hydro_imgw.R | 2 +- tests/testthat/test-hydro_metadata_imgw.R | 4 +- tests/testthat/test-meteo_imgw.R | 30 +- tests/testthat/test-nearest_stations_ogimet.R | 6 +- vignettes/articles/usecase_ogimet.Rmd | 14 +- vignettes/getstarted.Rmd | 4 +- 20 files changed, 1138 insertions(+), 1058 deletions(-) create mode 100644 .github/agents/r-package-improver.agent.md diff --git a/.github/agents/r-package-improver.agent.md b/.github/agents/r-package-improver.agent.md new file mode 100644 index 0000000..7852518 --- /dev/null +++ b/.github/agents/r-package-improver.agent.md @@ -0,0 +1,79 @@ +--- +description: "Use this agent when the user wants to improve the quality, performance, or maintainability of R package code.\n\nTrigger phrases include:\n- 'improve this R code'\n- 'optimize this function'\n- 'help me write better tests'\n- 'make this more efficient'\n- 'follow R best practices'\n- 'refactor this code'\n- 'improve documentation'\n- 'check if this follows package standards'\n- 'help me improve package quality'\n\nExamples:\n- User shows code and says 'can you help me make this function more efficient?' → invoke this agent to analyze performance and suggest optimizations\n- User asks 'I need to add more comprehensive tests to this function' → invoke this agent to identify gaps and recommend test cases\n- User says 'is this following R package best practices?' → invoke this agent to review structure, style, and conventions\n- User shows a function and asks 'how can I improve this?' → invoke this agent to provide holistic improvement recommendations" +name: r-package-improver +--- + +# r-package-improver instructions + +You are an expert R package developer with deep knowledge of R programming best practices, package architecture, testing frameworks, and CRAN standards. You help developers write cleaner, more efficient, and more maintainable R code. + +Your responsibilities: +- Analyze R code for quality, performance, and adherence to best practices +- Identify code style violations and suggest corrections +- Recommend performance optimizations with measurable impact +- Improve test coverage and test quality +- Enhance documentation clarity and completeness +- Suggest refactoring opportunities for maintainability +- Ensure CRAN compliance and package standards + +Core principles: +1. Know R idioms: Use vectorization over loops, apply family over iteration, data.table/tidyverse patterns where appropriate +2. Memory efficiency: Identify unnecessary object copies, suggest efficient data structures +3. Error handling: Recommend defensive programming, proper error messages +4. Testing: Suggest testthat patterns, edge cases, and meaningful assertions +5. Documentation: Ensure Roxygen tags are complete, examples are runnable, parameters documented +6. Style consistency: Follow tidyverse or base R conventions consistently + +Methodology: +1. Examine the code context: What does it do? What's its intended use? Performance requirements? +2. Identify improvement opportunities by category: performance, style, testing, documentation, maintainability +3. Prioritize by impact: Focus on changes that improve readability, reduce bugs, or significantly improve performance +4. Provide specific, actionable recommendations with before/after examples +5. Consider the package ecosystem: What dependencies exist? Are there better alternatives? + +When analyzing code, evaluate: +- Vectorization opportunities (replacing loops or apply calls with vector operations) +- Memory usage (avoid unnecessary copies, use efficient data structures) +- Naming conventions (snake_case for functions/variables, PascalCase rarely used) +- Function length (consider breaking into smaller, testable units) +- Error handling (input validation, informative error messages) +- Test coverage (edge cases, error conditions, realistic inputs) +- Documentation completeness (all parameters, return value, examples) +- Package structure compliance (R/ directory, tests/testthat/, man/ auto-generated) + +Output format: +- Prioritized list of improvements with impact/effort assessment +- For each recommendation: + - Category (Performance/Style/Testing/Documentation/Maintainability) + - Current issue with example code snippet + - Recommended solution with before/after comparison + - Rationale (why this improves the code) +- Summary of overall impact +- Order suggestions by: high-impact/low-effort first, then high-impact/medium-effort + +Common R package improvements to look for: +- Replace for loops with vectorized operations or lapply/mapply +- Use seq_along() instead of seq(1:length(x)) +- Avoid stringsAsFactors issues in functions +- Use proper argument validation at function entry +- Add testthat tests covering edge cases and error conditions +- Improve Roxygen documentation with @param, @return, @examples +- Use consistent coding style (indentation, spacing, naming) +- Avoid global variable assignments (<<-) +- Use :: for namespace clarity when calling other packages +- Consider S3/S4 methods if appropriate + +Quality assurance: +- Verify recommendations are specific to R language/packages (not generic) +- Ensure all code examples are syntactically correct +- Check that suggestions follow tidyverse/CRAN conventions when applicable +- Confirm recommendations won't break existing functionality +- Test code examples mentally or verify they're runnable + +When to ask for clarification: +- If the code's purpose or requirements are unclear +- If you need to know performance targets or constraints +- If multiple approaches exist and you need preference guidance +- If you need context about existing test coverage +- If the package's dependencies or target audience affect recommendations +- If you need to understand the codebase's conventions before making suggestions diff --git a/NEWS.md b/NEWS.md index 8efcbff..984e727 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,7 @@ * adding parser for SYNOP messages from OGIMET webportal to speed up downloading and avoid server overload; the new parser allows to download data for multiple stations in a single query * adding label description to `hydro_imgw()` datasets to easen understanding of the data and avoid confusion with units (e.g. "Q [m3/s]" instead of "Q") +* minor fixes in R code syntax and documentation diff --git a/R/ogimet_daily.R b/R/ogimet_daily.R index a53774f..ca2fb72 100644 --- a/R/ogimet_daily.R +++ b/R/ogimet_daily.R @@ -54,7 +54,7 @@ ogimet_daily_bp = function(date = date, "UTC each day. Use the >>hour<< argument to change it \n" ) ) - data_station <- + data_station = data.frame( "Date" = character(), "TemperatureCMax" = character(), @@ -247,7 +247,6 @@ ogimet_daily_bp = function(date = date, }# end of looping for stations if (nrow(data_station) > 0) { - data_station = data_station[!duplicated(data_station), ] # converting character to proper field representation: @@ -255,13 +254,11 @@ ogimet_daily_bp = function(date = date, # get rid off "---" standing for missing/blank fields: data_station[which(data_station == "--" | data_station == "---" | data_station == "----" | data_station == "-----", arr.ind = TRUE)] = NA + cnames = c("TemperatureCMax", "TemperatureCMin", "TemperatureCAvg","TdAvgC" ,"HrAvg", + "WindkmhInt","WindkmhGust" ,"PresslevHp", "Precmm" , + "TotClOct", "lowClOct" ,"VisKm","station_ID") # other columns to numeric: - suppressWarnings(data_station[,c("TemperatureCMax", "TemperatureCMin", "TemperatureCAvg","TdAvgC" ,"HrAvg", - "WindkmhInt","WindkmhGust" ,"PresslevHp", "Precmm" , - "TotClOct", "lowClOct" ,"VisKm","station_ID")] <- - as.data.frame(sapply(data_station[,c("TemperatureCMax", "TemperatureCMin", "TemperatureCAvg","TdAvgC" ,"HrAvg", - "WindkmhInt","WindkmhGust" ,"PresslevHp", "Precmm" , - "TotClOct", "lowClOct" ,"VisKm","station_ID")], as.numeric))) + data_station[, cnames] = as.data.frame(sapply(data_station[, cnames], as.numeric)) # changing order of columns and removing blank records: if (coords) { diff --git a/R/ogimet_hourly.R b/R/ogimet_hourly.R index 6e3db39..5c435b7 100644 --- a/R/ogimet_hourly.R +++ b/R/ogimet_hourly.R @@ -202,7 +202,7 @@ ogimet_hourly_bp = function(date = date, "HKm", "InsoD1", "Viskm", "Snowcm", "station_ID") columns = colnames(data_station)[(colnames(data_station) %in% columns)] suppressWarnings(data_station[, columns] <- - as.data.frame(sapply(data_station[,columns], as.numeric))) + as.data.frame(sapply(data_station[, columns], as.numeric))) # changing order of columns and removing blank records: if (coords) { diff --git a/R/parser.R b/R/parser.R index 52bf385..f16935c 100644 --- a/R/parser.R +++ b/R/parser.R @@ -15,11 +15,13 @@ #' @return A list of decoded SYNOP messages. When `simplify = TRUE` and a single #' message is supplied, the corresponding decoded list is returned directly. #' @examples -#' parser("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541") -#' parser(rep("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", 2), simplify = FALSE) +#' synop_code = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541" +#' parser(synop_code) +#' parser(rep(synop_code, 2), simplify = FALSE) #' @import R6 #' @export -parser <- function(message, country = NULL, simplify = TRUE) { + +parser = function(message, country = NULL, simplify = TRUE) { if (missing(message) || length(message) == 0) { stop("`message` must contain at least one SYNOP string.") } @@ -32,14 +34,14 @@ parser <- function(message, country = NULL, simplify = TRUE) { stop("`country` must be NULL, a single string, or a character vector matching the length of `message`.") } - country_vec <- if (is.null(country)) rep(list(NULL), length(message)) else as.list(rep(country, length.out = length(message))) + country_vec = if (is.null(country)) rep(list(NULL), length(message)) else as.list(rep(country, length.out = length(message))) - results <- mapply( + results = mapply( function(msg, cntry) { - msg <- trimws(msg) + msg = trimws(msg) if (nzchar(msg)) { - synop <- SYNOP$new() - synop$country <- cntry + synop = SYNOP$new() + synop$country = cntry synop$decode(msg) } else { warning("Empty SYNOP message supplied; returning NULL.") @@ -72,7 +74,7 @@ parser <- function(message, country = NULL, simplify = TRUE) { ################################################################################ # Base Observation class -Observation <- R6Class("Observation", +Observation = R6Class("Observation", public = list( null_char = "/", code_len = NULL, @@ -81,21 +83,21 @@ Observation <- R6Class("Observation", valid_range = NULL, initialize = function(null_char = "/") { - self$null_char <- null_char + self$null_char = null_char }, # Check if value is available (not all null chars) is_available = function(value, char = NULL) { - if (is.null(char)) char <- self$null_char + if (is.null(char)) char = self$null_char if (is.null(value)) return(FALSE) - value_str <- as.character(value) + value_str = as.character(value) !all(strsplit(value_str, "")[[1]] == char) }, # Check if value is valid is_valid = function(value, raise_exception = TRUE, name = NULL, ...) { tryCatch({ - valid <- private$check_valid(value, ...) + valid = private$check_valid(value, ...) if (!valid && raise_exception) { stop(paste0(value, " is not a valid code for ", ifelse(is.null(name), class(self)[1], name))) } @@ -115,7 +117,7 @@ Observation <- R6Class("Observation", # Decode raw value decode = function(raw, ...) { - kwargs <- list(...) + kwargs = list(...) # Check if available if (!self$is_available(raw)) { @@ -138,8 +140,8 @@ Observation <- R6Class("Observation", # Encode observation encode = function(data, ...) { - kwargs <- list(...) - allow_none <- ifelse(is.null(kwargs$allow_none), FALSE, kwargs$allow_none) + kwargs = list(...) + allow_none = ifelse(is.null(kwargs$allow_none), FALSE, kwargs$allow_none) tryCatch({ if (is.null(data) || (is.list(data) && is.null(data$value))) { @@ -161,11 +163,11 @@ Observation <- R6Class("Observation", decode_internal = function(raw, ...) { if (!is.null(self$components) && length(self$components) > 0) { # Handle components - result <- list() + result = list() for (comp in self$components) { - comp_class <- comp[[4]] - comp_obj <- comp_class$new() - result[[comp[[1]]]] <- comp_obj$decode( + comp_class = comp[[4]] + comp_obj = comp_class$new() + result[[comp[[1]]]] = comp_obj$decode( substr(raw, comp[[2]] + 1, comp[[2]] + comp[[3]]) ) } @@ -179,11 +181,11 @@ Observation <- R6Class("Observation", encode_internal = function(data, ...) { if (!is.null(self$components)) { # Handle components - result <- character(0) + result = character(0) for (comp in self$components) { - comp_class <- comp[[4]] - comp_obj <- comp_class$new() - result <- c(result, comp_obj$encode( + comp_class = comp[[4]] + comp_obj = comp_class$new() + result = c(result, comp_obj$encode( if (comp[[1]] %in% names(data)) data[[comp[[1]]]] else NULL )) } @@ -195,7 +197,7 @@ Observation <- R6Class("Observation", # Decode value (uses code table if available) decode_value = function(val, ...) { - kwargs <- list(...) + kwargs = list(...) # Check if value is available if (!self$is_available(val)) { @@ -203,11 +205,11 @@ Observation <- R6Class("Observation", } # Get unit - unit <- if (is.null(kwargs$unit)) self$unit else kwargs$unit + unit = if (is.null(kwargs$unit)) self$unit else kwargs$unit # Get value from code table if (!is.null(self$code_table)) { - out_val <- tryCatch({ + out_val = tryCatch({ self$code_table$decode(val, ...) }, error = function(e) { warning(paste("Error decoding with code table:", val, "-", e$message)) @@ -218,18 +220,18 @@ Observation <- R6Class("Observation", }) if (!is.null(out_val) && !is.list(out_val)) { - out_val <- list(value = out_val) + out_val = list(value = out_val) } if (!is.null(out_val) && !("_code" %in% names(out_val))) { - code_val <- suppressWarnings(as.integer(val)) + code_val = suppressWarnings(as.integer(val)) if (!is.na(code_val)) { - out_val[["_code"]] <- code_val + out_val[["_code"]] = code_val } } } else { # No code table - just convert to integer - out_val <- tryCatch({ - code_val <- suppressWarnings(as.integer(val)) + out_val = tryCatch({ + code_val = suppressWarnings(as.integer(val)) if (is.na(code_val)) { return(NULL) } @@ -244,22 +246,22 @@ Observation <- R6Class("Observation", return(NULL) } - out_val <- list(value = out_val) + out_val = list(value = out_val) } if (is.null(out_val)) return(NULL) # Convert to int if not a list if (!is.list(out_val)) { - out_val <- list(value = as.integer(out_val)) + out_val = list(value = as.integer(out_val)) } # Perform post conversion - out_val <- self$decode_convert(out_val, ...) + out_val = self$decode_convert(out_val, ...) # Add unit if specified if (!is.null(unit)) { - out_val$unit <- unit + out_val$unit = unit } out_val @@ -269,13 +271,13 @@ Observation <- R6Class("Observation", encode_value = function(data, ...) { # Get value from code table or data if (!is.null(self$code_table)) { - out_val <- self$code_table$encode(data) + out_val = self$code_table$encode(data) } else { - out_val <- if ("value" %in% names(data)) data$value else data + out_val = if ("value" %in% names(data)) data$value else data } # Convert value - out_val <- self$encode_convert(out_val, ...) + out_val = self$encode_convert(out_val, ...) # Format code if (is.null(self$code_len)) { @@ -304,7 +306,7 @@ Observation <- R6Class("Observation", # Check valid range if (!is.null(self$valid_range)) { - val_num <- suppressWarnings(as.numeric(value)) + val_num = suppressWarnings(as.numeric(value)) if (is.na(val_num)) { return(FALSE) } @@ -329,97 +331,97 @@ Observation <- R6Class("Observation", # SHARED CLASSES ################################################################################ -CloudCover <- R6Class("CloudCover", +CloudCover = R6Class("CloudCover", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable2700$new() - self$unit <- "okta" + self$code_len = 1 + self$code_table = CodeTable2700$new() + self$unit = "okta" } ) ) -CloudGenus <- R6Class("CloudGenus", +CloudGenus = R6Class("CloudGenus", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable0500$new() + self$code_len = 1 + self$code_table = CodeTable0500$new() } ) ) -Day <- R6Class("Day", +Day = R6Class("Day", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$valid_range <- c(1, 31) + self$code_len = 2 + self$valid_range = c(1, 31) } ) ) -DirectionCardinal <- R6Class("DirectionCardinal", +DirectionCardinal = R6Class("DirectionCardinal", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable0700$new() + self$code_len = 1 + self$code_table = CodeTable0700$new() } ) ) -DirectionDegrees <- R6Class("DirectionDegrees", +DirectionDegrees = R6Class("DirectionDegrees", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$code_table <- CodeTable0877$new() - self$unit <- "deg" + self$code_len = 2 + self$code_table = CodeTable0877$new() + self$unit = "deg" } ) ) -Hour <- R6Class("Hour", +Hour = R6Class("Hour", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$valid_range <- c(0, 24) + self$code_len = 2 + self$valid_range = c(0, 24) } ) ) -Minute <- R6Class("Minute", +Minute = R6Class("Minute", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$valid_range <- c(0, 59) + self$code_len = 2 + self$valid_range = c(0, 59) } ) ) -SignedTemperature <- R6Class("SignedTemperature", +SignedTemperature = R6Class("SignedTemperature", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 - self$unit <- "Cel" + self$code_len = 4 + self$unit = "Cel" }, decode_internal = function(raw, ...) { - kwargs <- list(...) - sign <- kwargs$sign + kwargs = list(...) + sign = kwargs$sign if (is.null(sign) || sign == "/") { return(NULL) @@ -433,36 +435,36 @@ SignedTemperature <- R6Class("SignedTemperature", }, decode_convert = function(val, ...) { - kwargs <- list(...) - sign <- kwargs$sign + kwargs = list(...) + sign = kwargs$sign if (is.null(sign)) return(val) - factor <- ifelse(sign == "0", 10, -10) - val$value <- val$value / factor + factor = ifelse(sign == "0", 10, -10) + val$value = val$value / factor val }, encode_convert = function(val, ...) { - sign_char <- ifelse(val >= 0, "0", "1") - abs_val <- abs(val * 10) + sign_char = ifelse(val >= 0, "0", "1") + abs_val = abs(val * 10) paste0(sign_char, sprintf("%03d", as.integer(abs_val))) } ) ) -Visibility <- R6Class("Visibility", +Visibility = R6Class("Visibility", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$code_table <- CodeTable4377$new() - self$unit <- "m" + self$code_len = 2 + self$code_table = CodeTable4377$new() + self$unit = "m" }, encode_internal = function(data, ...) { - kwargs <- list(...) - use90 <- ifelse(is.null(kwargs$use90), + kwargs = list(...) + use90 = ifelse(is.null(kwargs$use90), ifelse("use90" %in% names(data), data$use90, FALSE), kwargs$use90) self$encode_value(data, use90 = use90) @@ -475,15 +477,15 @@ Visibility <- R6Class("Visibility", ################################################################################ # Base CodeTable class -CodeTable <- R6Class("CodeTable", +CodeTable = R6Class("CodeTable", public = list( table_name = NULL, decode = function(value, ...) { tryCatch({ - result <- self$decode_internal(value, ...) + result = self$decode_internal(value, ...) if (!is.null(result)) { - result$`_table` <- self$table_name + result$`_table` = self$table_name } result }, error = function(e) { @@ -511,15 +513,15 @@ CodeTable <- R6Class("CodeTable", ) # CodeTable2700 - Total cloud cover -CodeTable2700 <- R6Class("CodeTable2700", +CodeTable2700 = R6Class("CodeTable2700", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "2700" + self$table_name = "2700" }, decode_internal = function(N, ...) { - n <- as.integer(N) + n = as.integer(N) if (n == 9) { list(value = NULL, obscured = TRUE, unit = "okta") } else { @@ -538,17 +540,17 @@ CodeTable2700 <- R6Class("CodeTable2700", ) # CodeTable0500 - Genus of cloud -CodeTable0500 <- R6Class("CodeTable0500", +CodeTable0500 = R6Class("CodeTable0500", inherit = CodeTable, public = list( values = c("Ci", "Cc", "Cs", "Ac", "As", "Ns", "Sc", "St", "Cu", "Cb"), initialize = function() { - self$table_name <- "0500" + self$table_name = "0500" }, decode_internal = function(i, ...) { - idx <- as.integer(i) + 1 + idx = as.integer(i) + 1 if (idx >= 1 && idx <= length(self$values)) { list(value = self$values[idx]) } else { @@ -557,8 +559,8 @@ CodeTable0500 <- R6Class("CodeTable0500", }, encode_internal = function(data, ...) { - val <- if (is.list(data)) data$value else data - idx <- which(self$values == val) + val = if (is.list(data)) data$value else data + idx = which(self$values == val) if (length(idx) == 0) { stop(paste("Invalid cloud genus:", val)) } @@ -568,14 +570,14 @@ CodeTable0500 <- R6Class("CodeTable0500", ) # CodeTable0700 - Direction or bearing in one figure -CodeTable0700 <- R6Class("CodeTable0700", +CodeTable0700 = R6Class("CodeTable0700", inherit = CodeTable, public = list( # NA placeholders preserve indexing: 0 = calm, 9 = allDirections (no compass value) directions = c(NA_character_, "NE", "E", "SE", "S", "SW", "W", "NW", "N", NA_character_), initialize = function() { - self$table_name <- "0700" + self$table_name = "0700" }, decode_internal = function(D, ...) { @@ -583,12 +585,12 @@ CodeTable0700 <- R6Class("CodeTable0700", return(list(value = NULL, isCalmOrStationary = NULL, allDirections = NULL)) } - d <- as.integer(D) - isCalmOrStationary <- (d == 0) - allDirections <- (d == 9) + d = as.integer(D) + isCalmOrStationary = (d == 0) + allDirections = (d == 9) - direction <- if (d >= 0 && d < length(self$directions)) { - v <- self$directions[d + 1] + direction = if (d >= 0 && d < length(self$directions)) { + v = self$directions[d + 1] if (is.na(v)) NULL else v } else { NULL @@ -609,7 +611,7 @@ CodeTable0700 <- R6Class("CodeTable0700", return("9") } if ("value" %in% names(data) && !is.null(data$value)) { - idx <- which(self$directions == data$value) - 1 + idx = which(self$directions == data$value) - 1 if (length(idx) > 0) { return(as.character(idx)) } @@ -620,24 +622,24 @@ CodeTable0700 <- R6Class("CodeTable0700", ) # CodeTable0877 - True direction in tens of degrees -CodeTable0877 <- R6Class("CodeTable0877", +CodeTable0877 = R6Class("CodeTable0877", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "0877" + self$table_name = "0877" }, decode_internal = function(dd, ...) { - dd_int <- as.integer(dd) - calm <- (dd_int == 0) - varAllUnknown <- (dd_int == 99) + dd_int = as.integer(dd) + calm = (dd_int == 0) + varAllUnknown = (dd_int == 99) if (calm) { - direction <- NULL + direction = NULL } else if (varAllUnknown) { - direction <- NULL + direction = NULL } else if (dd_int >= 1 && dd_int <= 36) { - direction <- dd_int * 10 + direction = dd_int * 10 } else { stop(paste("Invalid direction code:", dd)) } @@ -650,22 +652,22 @@ CodeTable0877 <- R6Class("CodeTable0877", }, encode_internal = function(data, ...) { - val <- if (is.list(data)) data$value else data + val = if (is.list(data)) data$value else data if (is.null(val)) { if ("calm" %in% names(data) && data$calm) return("00") if ("varAllUnknown" %in% names(data) && data$varAllUnknown) return("99") return("//") } - code <- round(val / 10) - if (code < 1) code <- 0 - if (code > 36) code <- 36 + code = round(val / 10) + if (code < 1) code = 0 + if (code > 36) code = 36 sprintf("%02d", code) } ) ) # CodeTable4377 - Horizontal visibility at surface -CodeTable4377 <- R6Class("CodeTable4377", +CodeTable4377 = R6Class("CodeTable4377", inherit = CodeTable, public = list( range90 = list( @@ -675,58 +677,58 @@ CodeTable4377 <- R6Class("CodeTable4377", ), initialize = function() { - self$table_name <- "4377" + self$table_name = "4377" }, decode_internal = function(VV, ...) { - vv <- as.integer(VV) + vv = as.integer(VV) if (vv >= 51 && vv <= 55) { stop(paste("Invalid visibility code:", VV)) } - visibility <- NULL - quantifier <- NULL + visibility = NULL + quantifier = NULL if (vv == 0) { - visibility <- 100 - quantifier <- "isLess" + visibility = 100 + quantifier = "isLess" } else if (vv <= 50) { - visibility <- vv * 100 + visibility = vv * 100 } else if (vv <= 80) { - visibility <- (vv - 50) * 1000 + visibility = (vv - 50) * 1000 } else if (vv <= 88) { - visibility <- (vv - 74) * 5000 + visibility = (vv - 74) * 5000 } else if (vv == 89) { - visibility <- 70000 - quantifier <- "isGreater" + visibility = 70000 + quantifier = "isGreater" } else if (vv == 90) { - visibility <- 50 - quantifier <- "isLess" + visibility = 50 + quantifier = "isLess" } else if (vv == 91) { - visibility <- 50 + visibility = 50 } else if (vv == 92) { - visibility <- 200 + visibility = 200 } else if (vv == 93) { - visibility <- 500 + visibility = 500 } else if (vv == 94) { - visibility <- 1000 + visibility = 1000 } else if (vv == 95) { - visibility <- 2000 + visibility = 2000 } else if (vv == 96) { - visibility <- 4000 + visibility = 4000 } else if (vv == 97) { - visibility <- 10000 + visibility = 10000 } else if (vv == 98) { - visibility <- 20000 + visibility = 20000 } else if (vv == 99) { - visibility <- 50000 - quantifier <- "isGreaterOrEqual" + visibility = 50000 + quantifier = "isGreaterOrEqual" } else { stop(paste("Invalid visibility code:", VV)) } - use90 <- (vv >= 90) + use90 = (vv >= 90) list( value = visibility, quantifier = quantifier, @@ -735,27 +737,27 @@ CodeTable4377 <- R6Class("CodeTable4377", }, encode_internal = function(data, use90 = FALSE, ...) { - value <- if (is.list(data)) data$value else data - quantifier <- if (is.list(data) && "quantifier" %in% names(data)) data$quantifier else NULL + value = if (is.list(data)) data$value else data + quantifier = if (is.list(data) && "quantifier" %in% names(data)) data$quantifier else NULL if (use90) { for (idx in seq_along(self$range90)) { - r <- self$range90[[idx]] + r = self$range90[[idx]] if (value >= r[1] && value < r[2]) { return(sprintf("%02d", idx + 89)) } } } else { if (value < 100) { - code <- 0 + code = 0 } else if (value <= 5000) { - code <- floor(value / 100) + code = floor(value / 100) } else if (value <= 30000) { - code <- floor(value / 1000) + 50 + code = floor(value / 1000) + 50 } else if (value <= 70000 && is.null(quantifier)) { - code <- floor(value / 5000) + 74 + code = floor(value / 5000) + 74 } else { - code <- 89 + code = 89 } return(sprintf("%02d", code)) } @@ -770,21 +772,21 @@ CodeTable4377 <- R6Class("CodeTable4377", ################################################################################ # Temperature observation -Temperature <- R6Class("Temperature", +Temperature = R6Class("Temperature", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - sn <- substr(group, 2, 2) - TTT <- substr(group, 3, 5) + sn = substr(group, 2, 2) + TTT = substr(group, 3, 5) # Fix trailing "/" (issue #10) if (TTT != "///") { - TTT <- sub("/$", "0", TTT) + TTT = sub("/$", "0", TTT) } if (!sn %in% c("0", "1", "/")) { @@ -792,30 +794,30 @@ Temperature <- R6Class("Temperature", return(NULL) } - temp_obs <- SignedTemperature$new() + temp_obs = SignedTemperature$new() temp_obs$decode(TTT, sign = sn) }, encode_internal = function(data, ...) { - temp_obs <- SignedTemperature$new() + temp_obs = SignedTemperature$new() temp_obs$encode(data) } ) ) # Pressure observation -Pressure <- R6Class("Pressure", +Pressure = R6Class("Pressure", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 - self$unit <- "hPa" + self$code_len = 4 + self$unit = "hPa" }, decode_convert = function(val, ...) { - val_int <- as.integer(val$value) - val$value <- (val_int / 10) + ifelse(val_int > 5000, 0, 1000) + val_int = as.integer(val$value) + val$value = (val_int / 10) + ifelse(val_int > 5000, 0, 1000) val }, @@ -826,40 +828,40 @@ Pressure <- R6Class("Pressure", ) # Surface wind observation -SurfaceWind <- R6Class("SurfaceWind", +SurfaceWind = R6Class("SurfaceWind", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(ddff, ...) { - dd <- substr(ddff, 1, 2) - ff <- substr(ddff, 3, 4) + dd = substr(ddff, 1, 2) + ff = substr(ddff, 3, 4) - dir_obs <- DirectionDegrees$new() - direction <- dir_obs$decode(dd) + dir_obs = DirectionDegrees$new() + direction = dir_obs$decode(dd) - speed_obs <- WindSpeed$new() - speed <- speed_obs$decode(ff) + speed_obs = WindSpeed$new() + speed = speed_obs$decode(ff) # Sanity check: if wind is calm, it can't have a speed if (!is.null(direction) && !is.null(direction$calm) && direction$calm && !is.null(speed) && !is.null(speed$value) && speed$value > 0) { warning(paste("Wind is calm, yet has a speed (dd:", dd, ", ff:", ff, ")")) - speed <- NULL + speed = NULL } list(direction = direction, speed = speed) }, encode_internal = function(data, ...) { - dir_obs <- DirectionDegrees$new() - speed_obs <- WindSpeed$new() + dir_obs = DirectionDegrees$new() + speed_obs = WindSpeed$new() - dd <- dir_obs$encode(if ("direction" %in% names(data)) data$direction else NULL, allow_none = TRUE) - ff <- speed_obs$encode(if ("speed" %in% names(data)) data$speed else NULL) + dd = dir_obs$encode(if ("direction" %in% names(data)) data$direction else NULL, allow_none = TRUE) + ff = speed_obs$encode(if ("speed" %in% names(data)) data$speed else NULL) paste0(dd, ff) } @@ -867,12 +869,12 @@ SurfaceWind <- R6Class("SurfaceWind", ) # Wind speed (simplified) -WindSpeed <- R6Class("WindSpeed", +WindSpeed = R6Class("WindSpeed", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(ff, ...) { @@ -885,7 +887,7 @@ WindSpeed <- R6Class("WindSpeed", if (is.null(data)) { return(paste(rep(self$null_char, self$code_len), collapse = "")) } - value <- if (is.list(data)) data$value else data + value = if (is.list(data)) data$value else data if (!is.null(value) && value > 99) { return(paste0("99 00", sprintf("%02d", value))) } @@ -899,7 +901,7 @@ WindSpeed <- R6Class("WindSpeed", ################################################################################ # Base Report class -Report <- R6Class("Report", +Report = R6Class("Report", public = list( not_implemented = list(), @@ -918,104 +920,104 @@ Report <- R6Class("Report", ) # SYNOP class - main class for decoding SYNOP messages -SYNOP <- R6Class("SYNOP", +SYNOP = R6Class("SYNOP", inherit = Report, public = list( country = NULL, initialize = function() { - self$not_implemented <- list() - self$country <- NULL + self$not_implemented = list() + self$country = NULL }, decode_internal = function(message) { # Initialize data - data <- list() + data = list() # Split message into groups - groups <- strsplit(message, " ")[[1]] - group_idx <- 1 + groups = strsplit(message, " ")[[1]] + group_idx = 1 # Helper function to get next group - get_next_group <- function() { + get_next_group = function() { if (group_idx <= length(groups)) { - group <- groups[group_idx] - group_idx <<- group_idx + 1 + group = groups[group_idx] + group_idx <= group_idx + 1 return(group) } return(NULL) } # Alias for convenience - next_group <- get_next_group + next_group = get_next_group # SECTION 0: Station type, time, and identification - station_type <- next_group() + station_type = next_group() if (is.null(station_type)) { stop("Invalid SYNOP: missing station type") } # For simplicity, assume AAXX format - data$station_type <- list(value = station_type) + data$station_type = list(value = station_type) # Get observation time and wind indicator (YYGGi) - yygii <- next_group() + yygii = next_group() if (is.null(yygii) || nchar(yygii) < 5) { stop("Invalid SYNOP: missing YYGGi group") } # Decode observation time - obs_time <- ObservationTime$new() - data$obs_time <- obs_time$decode(substr(yygii, 1, 4)) + obs_time = ObservationTime$new() + data$obs_time = obs_time$decode(substr(yygii, 1, 4)) # Decode wind indicator - wind_ind <- WindIndicator$new() - data$wind_indicator <- wind_ind$decode(substr(yygii, 5, 5)) + wind_ind = WindIndicator$new() + data$wind_indicator = wind_ind$decode(substr(yygii, 5, 5)) # Get station ID - station_id_group <- next_group() + station_id_group = next_group() if (is.null(station_id_group)) { stop("Invalid SYNOP: missing station ID") } - data$station_id <- list(value = station_id_group) + data$station_id = list(value = station_id_group) # Decode region tryCatch({ - region <- Region$new() - result <- region$decode(station_id_group) + region = Region$new() + result = region$decode(station_id_group) if (!is.null(result)) { - data$region <- result + data$region = result } }, error = function(e) { warning(paste("Error decoding region:", e$message)) }) # Check if next group is NIL (station did not send data) - next_check <- next_group() + next_check = next_group() if (!is.null(next_check) && (next_check == "NIL" || grepl("^NIL", next_check))) { # Station did not send data - set remaining fields to NA - data$precipitation_indicator <- NA - data$weather_indicator <- NA - data$lowest_cloud_base <- NA - data$visibility <- NA - data$cloud_cover <- NA - data$surface_wind <- NA - data$air_temperature <- NA - data$dewpoint_temperature <- NA - data$relative_humidity <- NA - data$station_pressure <- NA - data$sea_level_pressure <- NA - data$pressure_tendency <- NA - data$precipitation_s1 <- NA - data$present_weather <- NA - data$past_weather <- NA - data$cloud_types <- NA + data$precipitation_indicator = NA + data$weather_indicator = NA + data$lowest_cloud_base = NA + data$visibility = NA + data$cloud_cover = NA + data$surface_wind = NA + data$air_temperature = NA + data$dewpoint_temperature = NA + data$relative_humidity = NA + data$station_pressure = NA + data$sea_level_pressure = NA + data$pressure_tendency = NA + data$precipitation_s1 = NA + data$present_weather = NA + data$past_weather = NA + data$cloud_types = NA return(data) } # SECTION 1: Main observations - section1 <- next_check # Use the group we already got + section1 = next_check # Use the group we already got if (is.null(section1) || nchar(section1) < 5) { # If section1 is invalid, try to continue anyway warning("Invalid or missing section 1") @@ -1024,68 +1026,68 @@ SYNOP <- R6Class("SYNOP", # Decode precipitation indicator, weather indicator, cloud base, visibility tryCatch({ - precip_ind <- PrecipitationIndicator$new() - result <- precip_ind$decode(substr(section1, 1, 1), country = self$country) + precip_ind = PrecipitationIndicator$new() + result = precip_ind$decode(substr(section1, 1, 1), country = self$country) if (!is.null(result)) { - data$precipitation_indicator <- result + data$precipitation_indicator = result } }, error = function(e) { warning(paste("Error decoding precipitation indicator:", e$message)) }) tryCatch({ - weather_ind <- WeatherIndicator$new() - result <- weather_ind$decode(substr(section1, 2, 2)) + weather_ind = WeatherIndicator$new() + result = weather_ind$decode(substr(section1, 2, 2)) if (!is.null(result)) { - data$weather_indicator <- result + data$weather_indicator = result } }, error = function(e) { warning(paste("Error decoding weather indicator:", e$message)) }) tryCatch({ - lowest_cloud <- LowestCloudBase$new() - result <- lowest_cloud$decode(substr(section1, 3, 3)) + lowest_cloud = LowestCloudBase$new() + result = lowest_cloud$decode(substr(section1, 3, 3)) if (!is.null(result)) { - data$lowest_cloud_base <- result + data$lowest_cloud_base = result } }, error = function(e) { warning(paste("Error decoding lowest cloud base:", e$message)) }) tryCatch({ - vis <- Visibility$new() - result <- vis$decode(substr(section1, 4, 5)) + vis = Visibility$new() + result = vis$decode(substr(section1, 4, 5)) if (!is.null(result)) { - data$visibility <- result + data$visibility = result } }, error = function(e) { warning(paste("Error decoding visibility:", e$message)) }) # Get cloud cover and wind (Nddff) - nddff <- next_group() + nddff = next_group() if (!is.null(nddff) && nchar(nddff) >= 5) { tryCatch({ - cloud <- CloudCover$new() - result <- cloud$decode(substr(nddff, 1, 1)) + cloud = CloudCover$new() + result = cloud$decode(substr(nddff, 1, 1)) if (!is.null(result)) { - data$cloud_cover <- result + data$cloud_cover = result } }, error = function(e) { warning(paste("Error decoding cloud cover from:", nddff, "-", e$message)) }) tryCatch({ - wind <- SurfaceWind$new() - wind_data <- wind$decode(substr(nddff, 2, 5)) + wind = SurfaceWind$new() + wind_data = wind$decode(substr(nddff, 2, 5)) if (!is.null(wind_data)) { if (!is.null(data$wind_indicator)) { if (!is.null(wind_data$speed)) { - wind_data$speed$unit <- data$wind_indicator$unit + wind_data$speed$unit = data$wind_indicator$unit } } - data$surface_wind <- wind_data + data$surface_wind = wind_data } }, error = function(e) { warning(paste("Error decoding surface wind from:", nddff, "-", e$message)) @@ -1093,7 +1095,7 @@ SYNOP <- R6Class("SYNOP", } # Parse section 1 groups (1sTTT, 2sTTT, 3P0P0P0, 4PPPP, etc.) - next_grp <- next_group() + next_grp = next_group() while (!is.null(next_grp)) { if (grepl("^333|^444|^555", next_grp)) { # Start of next section @@ -1101,20 +1103,20 @@ SYNOP <- R6Class("SYNOP", } # Try to get header, handle errors gracefully - header <- tryCatch({ + header = tryCatch({ as.integer(substr(next_grp, 1, 1)) }, error = function(e) { warning(paste("Unable to parse header from group:", next_grp)) - next_grp <<- next_group() + next_grp <= next_group() return(NULL) }, warning = function(w) { warning(paste("Warning parsing header from group:", next_grp)) - next_grp <<- next_group() + next_grp <= next_group() return(NULL) }) if (is.null(header) || is.na(header)) { - next_grp <- next_group() + next_grp = next_group() # Skip to next iteration if (is.null(next_grp)) break next @@ -1123,83 +1125,83 @@ SYNOP <- R6Class("SYNOP", tryCatch({ if (header == 1) { # Air temperature - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$air_temperature <- result + data$air_temperature = result } } else if (header == 2) { # Dewpoint temperature or relative humidity - sn <- substr(next_grp, 2, 2) + sn = substr(next_grp, 2, 2) if (sn == "9") { - rel_hum <- RelativeHumidity$new() - result <- rel_hum$decode(substr(next_grp, 3, 5)) + rel_hum = RelativeHumidity$new() + result = rel_hum$decode(substr(next_grp, 3, 5)) if (!is.null(result)) { - data$relative_humidity <- result + data$relative_humidity = result } } else { - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$dewpoint_temperature <- result + data$dewpoint_temperature = result } } } else if (header == 3) { # Station pressure - press <- Pressure$new() - result <- press$decode(substr(next_grp, 2, 5)) + press = Pressure$new() + result = press$decode(substr(next_grp, 2, 5)) if (!is.null(result)) { - data$station_pressure <- result + data$station_pressure = result } } else if (header == 4) { # Sea level pressure - press <- Pressure$new() - result <- press$decode(substr(next_grp, 2, 5)) + press = Pressure$new() + result = press$decode(substr(next_grp, 2, 5)) if (!is.null(result)) { - data$sea_level_pressure <- result + data$sea_level_pressure = result } } else if (header == 5) { # Pressure tendency - press_tend <- PressureTendency$new() - result <- press_tend$decode(next_grp) + press_tend = PressureTendency$new() + result = press_tend$decode(next_grp) if (!is.null(result)) { - data$pressure_tendency <- result + data$pressure_tendency = result } } else if (header == 6) { # Precipitation if (!is.null(data$precipitation_indicator) && data$precipitation_indicator$in_group_1) { - precip <- Precipitation$new() - result <- precip$decode(next_grp) + precip = Precipitation$new() + result = precip$decode(next_grp) if (!is.null(result)) { - data$precipitation_s1 <- result + data$precipitation_s1 = result } } } else if (header == 7) { # Present and past weather if (nchar(next_grp) >= 5) { - ww <- Weather$new() - result <- ww$decode(substr(next_grp, 2, 3), + ww = Weather$new() + result = ww$decode(substr(next_grp, 2, 3), time_before = list(value = 6, unit = "h"), type = "present", weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) if (!is.null(result)) { - data$present_weather <- result + data$present_weather = result } - result2 <- ww$decode(substr(next_grp, 4, 4), type = "past", + result2 = ww$decode(substr(next_grp, 4, 4), type = "past", weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) - result3 <- ww$decode(substr(next_grp, 5, 5), type = "past", + result3 = ww$decode(substr(next_grp, 5, 5), type = "past", weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) if (!is.null(result2) || !is.null(result3)) { - data$past_weather <- list(result2, result3) + data$past_weather = list(result2, result3) } } } else if (header == 8) { # Cloud types - cloud_types <- CloudType$new() - result <- cloud_types$decode(next_grp) + cloud_types = CloudType$new() + result = cloud_types$decode(next_grp) if (!is.null(result)) { - data$cloud_types <- result + data$cloud_types = result } } }, error = function(e) { @@ -1210,19 +1212,19 @@ SYNOP <- R6Class("SYNOP", # Continue to next group }) - next_grp <- next_group() + next_grp = next_group() } # SECTION 3: Additional observations if (!is.null(next_grp) && next_grp == "333") { - next_grp <- next_group() - cloud_layers <- list() - highest_gusts <- list() - group_9 <- list() # Collect group 9 codes + next_grp = next_group() + cloud_layers = list() + highest_gusts = list() + group_9 = list() # Collect group 9 codes while (!is.null(next_grp) && !grepl("^444|^555", next_grp)) { # Try to get header, handle errors gracefully - header <- tryCatch({ + header = tryCatch({ as.integer(substr(next_grp, 1, 1)) }, error = function(e) { warning(paste("Unable to parse header from group:", next_grp)) @@ -1233,7 +1235,7 @@ SYNOP <- R6Class("SYNOP", }) if (is.null(header) || is.na(header)) { - next_grp <- next_group() + next_grp = next_group() # Skip to next iteration if (is.null(next_grp)) break next @@ -1242,37 +1244,37 @@ SYNOP <- R6Class("SYNOP", tryCatch({ # Check if it's a group 9 code (9xxxx) if (header == 9) { - group_9[[length(group_9) + 1]] <- next_grp + group_9[[length(group_9) + 1]] = next_grp } else if (header == 8) { # Cloud layers - cloud_layer <- CloudLayer$new() - result <- cloud_layer$decode(next_grp) + cloud_layer = CloudLayer$new() + result = cloud_layer$decode(next_grp) if (!is.null(result)) { - cloud_layers[[length(cloud_layers) + 1]] <- result + cloud_layers[[length(cloud_layers) + 1]] = result } } else if (header == 1) { # Maximum temperature - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$maximum_temperature <- result + data$maximum_temperature = result } } else if (header == 2) { # Minimum temperature - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$minimum_temperature <- result + data$minimum_temperature = result } } else if (header == 5) { # Section 3 group 5: only 55SSS (daily sunshine in 1/10 h) is implemented. # Pressure-change subgroups (j1 in 1..4) and radiation (j1 in 6..9) are skipped. if (substr(next_grp, 2, 2) == "5" && nchar(next_grp) >= 5) { - sss <- substr(next_grp, 3, 5) + sss = substr(next_grp, 3, 5) if (sss != "///") { - sss_int <- suppressWarnings(as.integer(sss)) + sss_int = suppressWarnings(as.integer(sss)) if (!is.na(sss_int) && sss_int >= 0 && sss_int <= 240) { - data$sunshine <- list( + data$sunshine = list( value = sss_int / 10, unit = "h", time_before_obs = list(value = 24, unit = "h") @@ -1289,84 +1291,84 @@ SYNOP <- R6Class("SYNOP", # Continue to next group }) - next_grp <- next_group() + next_grp = next_group() } # Parse group 9 codes (including highest gusts) if (length(group_9) > 0) { - idx <- 1 + idx = 1 while (idx <= length(group_9)) { - g <- group_9[[idx]] + g = group_9[[idx]] tryCatch({ if (nchar(g) >= 3) { - j1 <- substr(g, 2, 2) # Second character - j2 <- substr(g, 3, 3) # Third character + j1 = substr(g, 2, 2) # Second character + j2 = substr(g, 3, 3) # Third character if (j1 == "1") { # Group 91xx - highest gusts if (j2 == "0") { # 910ff - gust with 10 min period if (is.null(data$highest_gust)) { - data$highest_gust <- list() + data$highest_gust = list() } - gust <- HighestGust$new() - gust_data <- gust$decode(g, + gust = HighestGust$new() + gust_data = gust$decode(g, unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, measure_period = list(value = 10, unit = "min") ) if (!is.null(gust_data)) { - data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + data$highest_gust[[length(data$highest_gust) + 1]] = gust_data } - idx <- idx + 1 + idx = idx + 1 } else if (j2 == "1") { # 911ff - gust with time before obs # Check if next group is direction (915dd) if (idx < length(group_9)) { - next_g <- group_9[[idx + 1]] + next_g = group_9[[idx + 1]] if (substr(next_g, 1, 3) == "915") { - gust_group <- paste(g, next_g, sep = " ") - idx <- idx + 2 # Skip next group + gust_group = paste(g, next_g, sep = " ") + idx = idx + 2 # Skip next group } else { - gust_group <- g - idx <- idx + 1 + gust_group = g + idx = idx + 1 } } else { - gust_group <- g - idx <- idx + 1 + gust_group = g + idx = idx + 1 } if (is.null(data$highest_gust)) { - data$highest_gust <- list() + data$highest_gust = list() } - gust <- HighestGust$new() - gust_data <- gust$decode(gust_group, + gust = HighestGust$new() + gust_data = gust$decode(gust_group, unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, time_before = list(value = 6, unit = "h") # Default time before ) if (!is.null(gust_data)) { - data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + data$highest_gust[[length(data$highest_gust) + 1]] = gust_data } } else { - idx <- idx + 1 + idx = idx + 1 } } else { - idx <- idx + 1 + idx = idx + 1 } } else { - idx <- idx + 1 + idx = idx + 1 } }, error = function(e) { warning(paste("Error decoding group 9 code:", g, "-", e$message)) - idx <<- idx + 1 + idx <= idx + 1 }, warning = function(w) { warning(paste("Warning decoding group 9 code:", g, "-", w$message)) - idx <<- idx + 1 + idx <= idx + 1 }) } } if (length(cloud_layers) > 0) { - data$cloud_layer <- cloud_layers + data$cloud_layer = cloud_layers } } @@ -1380,7 +1382,7 @@ SYNOP <- R6Class("SYNOP", ################################################################################ # ObservationTime -ObservationTime <- R6Class("ObservationTime", +ObservationTime = R6Class("ObservationTime", inherit = Observation, public = list( components = list( @@ -1390,23 +1392,23 @@ ObservationTime <- R6Class("ObservationTime", initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 } ) ) # WindIndicator -WindIndicator <- R6Class("WindIndicator", +WindIndicator = R6Class("WindIndicator", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$valid_range <- c(1, 7) + self$code_len = 1 + self$valid_range = c(1, 7) }, decode_internal = function(iw, ...) { - iw_int <- as.integer(iw) + iw_int = as.integer(iw) if (iw == "/") { list(value = NULL, unit = NULL, estimated = NULL) } else { @@ -1421,13 +1423,13 @@ WindIndicator <- R6Class("WindIndicator", ) # Region -Region <- R6Class("Region", +Region = R6Class("Region", inherit = Observation, public = list( decode_internal = function(raw, ...) { - raw_int <- as.integer(raw) + raw_int = as.integer(raw) - regions <- list( + regions = list( I = list(c(60000, 69998)), II = list(c(20000, 20099), c(20200, 21998), c(23001, 25998), c(28001, 32998), c(35001, 36998), c(38001, 39998), @@ -1455,18 +1457,18 @@ Region <- R6Class("Region", ) # PrecipitationIndicator -PrecipitationIndicator <- R6Class("PrecipitationIndicator", +PrecipitationIndicator = R6Class("PrecipitationIndicator", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 }, decode_internal = function(i, ...) { - kwargs <- list(...) - country <- kwargs$country - i_int <- as.integer(i) + kwargs = list(...) + country = kwargs$country + i_int = as.integer(i) list( value = i_int, @@ -1478,17 +1480,17 @@ PrecipitationIndicator <- R6Class("PrecipitationIndicator", ) # WeatherIndicator -WeatherIndicator <- R6Class("WeatherIndicator", +WeatherIndicator = R6Class("WeatherIndicator", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$valid_range <- c(1, 7) + self$code_len = 1 + self$valid_range = c(1, 7) }, decode_internal = function(ix, ...) { - ix_int <- ifelse(ix == "/", NULL, as.integer(ix)) + ix_int = ifelse(ix == "/", NULL, as.integer(ix)) list( value = ix_int, @@ -1499,20 +1501,20 @@ WeatherIndicator <- R6Class("WeatherIndicator", ) # LowestCloudBase -LowestCloudBase <- R6Class("LowestCloudBase", +LowestCloudBase = R6Class("LowestCloudBase", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable1600$new() - self$unit <- "m" + self$code_len = 1 + self$code_table = CodeTable1600$new() + self$unit = "m" } ) ) # CodeTable1600 -CodeTable1600 <- R6Class("CodeTable1600", +CodeTable1600 = R6Class("CodeTable1600", inherit = CodeTable, public = list( ranges = list( @@ -1521,13 +1523,13 @@ CodeTable1600 <- R6Class("CodeTable1600", ), initialize = function() { - self$table_name <- "1600" + self$table_name = "1600" }, decode_internal = function(h, ...) { - h_int <- as.integer(h) + h_int = as.integer(h) if (h_int >= 0 && h_int < length(self$ranges)) { - range <- self$ranges[[h_int + 1]] + range = self$ranges[[h_int + 1]] # ifelse(test, yes, NULL) raises a warning that gets caught upstream and # silently drops the result, so use plain if/else here. if (is.infinite(range[2])) { @@ -1543,29 +1545,29 @@ CodeTable1600 <- R6Class("CodeTable1600", ) # Precipitation -Precipitation <- R6Class("Precipitation", +Precipitation = R6Class("Precipitation", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - kwargs <- list(...) - tenths <- ifelse(is.null(kwargs$tenths), FALSE, kwargs$tenths) + kwargs = list(...) + tenths = ifelse(is.null(kwargs$tenths), FALSE, kwargs$tenths) if (tenths) { - rrrr <- substr(group, 2, 5) - amount <- Amount24$new() + rrrr = substr(group, 2, 5) + amount = Amount24$new() list( amount = amount$decode(rrrr), time_before_obs = list(value = 24, unit = "h") ) } else { - rrr <- substr(group, 2, 4) - t <- substr(group, 5, 5) - amount <- Amount$new() + rrr = substr(group, 2, 4) + t = substr(group, 5, 5) + amount = Amount$new() list( amount = amount$decode(rrr), time_before_obs = TimeBeforeObs$new()$decode(t) @@ -1576,41 +1578,41 @@ Precipitation <- R6Class("Precipitation", ) # Amount (simplified) -Amount <- R6Class("Amount", +Amount = R6Class("Amount", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 3 - self$code_table <- CodeTable3590$new() - self$unit <- "mm" + self$code_len = 3 + self$code_table = CodeTable3590$new() + self$unit = "mm" } ) ) # Amount24 -Amount24 <- R6Class("Amount24", +Amount24 = R6Class("Amount24", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 - self$code_table <- CodeTable3590A$new() - self$unit <- "mm" + self$code_len = 4 + self$code_table = CodeTable3590A$new() + self$unit = "mm" } ) ) # CodeTable3590 (simplified) -CodeTable3590 <- R6Class("CodeTable3590", +CodeTable3590 = R6Class("CodeTable3590", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "3590" + self$table_name = "3590" }, decode_internal = function(RRR, ...) { - rrr_int <- as.integer(RRR) + rrr_int = as.integer(RRR) if (rrr_int <= 988) { list(value = rrr_int, quantifier = NULL, trace = FALSE) } else if (rrr_int == 989) { @@ -1627,15 +1629,15 @@ CodeTable3590 <- R6Class("CodeTable3590", ) # CodeTable3590A (simplified) -CodeTable3590A <- R6Class("CodeTable3590A", +CodeTable3590A = R6Class("CodeTable3590A", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "3590A" + self$table_name = "3590A" }, decode_internal = function(RRRR, ...) { - rrrr_int <- as.integer(RRRR) + rrrr_int = as.integer(RRRR) if (rrrr_int <= 9998) { list(value = round(rrrr_int * 0.1, 1), quantifier = NULL, trace = FALSE) } else if (rrrr_int == 9999) { @@ -1648,32 +1650,32 @@ CodeTable3590A <- R6Class("CodeTable3590A", ) # TimeBeforeObs (simplified) -TimeBeforeObs <- R6Class("TimeBeforeObs", +TimeBeforeObs = R6Class("TimeBeforeObs", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable4019$new() - self$unit <- "h" + self$code_len = 1 + self$code_table = CodeTable4019$new() + self$unit = "h" } ) ) # CodeTable4019 -CodeTable4019 <- R6Class("CodeTable4019", +CodeTable4019 = R6Class("CodeTable4019", inherit = CodeTable, public = list( values = c(NULL, 6, 12, 18, 24, 1, 2, 3, 9, 15), initialize = function() { - self$table_name <- "4019" + self$table_name = "4019" }, decode_internal = function(t, ...) { - t_int <- as.integer(t) + 1 + t_int = as.integer(t) + 1 if (t_int >= 1 && t_int <= length(self$values)) { - val <- self$values[[t_int]] + val = self$values[[t_int]] if (!is.null(val)) { list(value = val, unit = "h") } else { @@ -1687,20 +1689,20 @@ CodeTable4019 <- R6Class("CodeTable4019", ) # PressureTendency -PressureTendency <- R6Class("PressureTendency", +PressureTendency = R6Class("PressureTendency", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - a <- substr(group, 2, 2) - ppp <- substr(group, 3, 5) + a = substr(group, 2, 2) + ppp = substr(group, 3, 5) - tendency <- Tendency$new() - change <- Change$new() + tendency = Tendency$new() + change = Change$new() list( tendency = tendency$decode(a), @@ -1711,34 +1713,34 @@ PressureTendency <- R6Class("PressureTendency", ) # Tendency (simplified) -Tendency <- R6Class("Tendency", +Tendency = R6Class("Tendency", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$valid_range <- c(0, 8) + self$code_len = 1 + self$valid_range = c(0, 8) } ) ) # Change (simplified) -Change <- R6Class("Change", +Change = R6Class("Change", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 3 - self$unit <- "hPa" + self$code_len = 3 + self$unit = "hPa" }, decode_convert = function(val, ...) { - kwargs <- list(...) - tendency <- kwargs$tendency + kwargs = list(...) + tendency = kwargs$tendency if (is.list(tendency) && "value" %in% names(tendency)) { - factor <- ifelse(tendency$value < 5, 10.0, -10.0) - val$value <- val$value / factor + factor = ifelse(tendency$value < 5, 10.0, -10.0) + val$value = val$value / factor } val } @@ -1746,35 +1748,35 @@ Change <- R6Class("Change", ) # Weather -Weather <- R6Class("Weather", +Weather = R6Class("Weather", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(group, ...) { - kwargs <- list(...) - w_type <- kwargs$type - ix <- kwargs$weather_indicator + kwargs = list(...) + w_type = kwargs$type + ix = kwargs$weather_indicator if (w_type == "present") { - table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4680", "4677") + table = ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4680", "4677") } else if (w_type == "past") { - table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4531", "4561") + table = ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4531", "4561") } else { stop(paste("Invalid weather type:", w_type)) } - group_int <- as.integer(group) + group_int = as.integer(group) if (is.na(group_int)) { return(NULL) } - result <- list(value = group_int, `_table` = table) + result = list(value = group_int, `_table` = table) if (!is.null(kwargs$time_before)) { - result$time_before_obs <- kwargs$time_before + result$time_before_obs = kwargs$time_before } result @@ -1783,43 +1785,43 @@ Weather <- R6Class("Weather", ) # CloudType -CloudType <- R6Class("CloudType", +CloudType = R6Class("CloudType", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - nh <- substr(group, 2, 2) - cl <- substr(group, 3, 3) - cm <- substr(group, 4, 4) - ch <- substr(group, 5, 5) + nh = substr(group, 2, 2) + cl = substr(group, 3, 3) + cm = substr(group, 4, 4) + ch = substr(group, 5, 5) - low_cloud <- LowCloud$new() - middle_cloud <- MiddleCloud$new() - high_cloud <- HighCloud$new() - cloud_cover <- CloudCover$new() + low_cloud = LowCloud$new() + middle_cloud = MiddleCloud$new() + high_cloud = HighCloud$new() + cloud_cover = CloudCover$new() - result <- list( + result = list( low_cloud_type = low_cloud$decode(cl), middle_cloud_type = middle_cloud$decode(cm), high_cloud_type = high_cloud$decode(ch) ) - cover <- cloud_cover$decode(nh) + cover = cloud_cover$decode(nh) if (nh != "/") { if (!is.null(result$low_cloud_type) && result$low_cloud_type$value >= 1 && result$low_cloud_type$value <= 9) { - result$low_cloud_amount <- cover + result$low_cloud_amount = cover } else if (!is.null(result$middle_cloud_type) && result$middle_cloud_type$value >= 0 && result$middle_cloud_type$value <= 9) { - result$middle_cloud_amount <- cover + result$middle_cloud_amount = cover } else { - result$cloud_amount <- cover + result$cloud_amount = cover } } @@ -1829,53 +1831,53 @@ CloudType <- R6Class("CloudType", ) # LowCloud, MiddleCloud, HighCloud (simplified) -LowCloud <- R6Class("LowCloud", +LowCloud = R6Class("LowCloud", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 } ) ) -MiddleCloud <- R6Class("MiddleCloud", +MiddleCloud = R6Class("MiddleCloud", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 } ) ) -HighCloud <- R6Class("HighCloud", +HighCloud = R6Class("HighCloud", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 } ) ) # CloudLayer -CloudLayer <- R6Class("CloudLayer", +CloudLayer = R6Class("CloudLayer", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - n <- substr(group, 2, 2) - c <- substr(group, 3, 3) - hh <- substr(group, 4, 5) + n = substr(group, 2, 2) + c = substr(group, 3, 3) + hh = substr(group, 4, 5) - cloud_cover <- CloudCover$new() - cloud_genus <- CloudGenus$new() - height <- Height$new() + cloud_cover = CloudCover$new() + cloud_genus = CloudGenus$new() + height = Height$new() list( cloud_cover = cloud_cover$decode(n), @@ -1887,29 +1889,29 @@ CloudLayer <- R6Class("CloudLayer", ) # Height (simplified) -Height <- R6Class("Height", +Height = R6Class("Height", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$code_table <- CodeTable1677$new() - self$unit <- "m" + self$code_len = 2 + self$code_table = CodeTable1677$new() + self$unit = "m" } ) ) # CodeTable1677 (simplified) -CodeTable1677 <- R6Class("CodeTable1677", +CodeTable1677 = R6Class("CodeTable1677", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "1677" + self$table_name = "1677" }, decode_internal = function(hh, ...) { - hh_int <- as.integer(hh) - quantifier <- NULL + hh_int = as.integer(hh) + quantifier = NULL if (hh_int == 0) { list(value = 30, quantifier = "isLess") @@ -1931,87 +1933,87 @@ CodeTable1677 <- R6Class("CodeTable1677", ) # RelativeHumidity -RelativeHumidity <- R6Class("RelativeHumidity", +RelativeHumidity = R6Class("RelativeHumidity", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 3 - self$valid_range <- c(0, 100) - self$unit <- "%" + self$code_len = 3 + self$valid_range = c(0, 100) + self$unit = "%" } ) ) # HighestGust - Highest wind gust -HighestGust <- R6Class("HighestGust", +HighestGust = R6Class("HighestGust", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(group, ...) { - kwargs <- list(...) + kwargs = list(...) # Split group into separate groups if needed - groups <- strsplit(group, " ")[[1]] + groups = strsplit(group, " ")[[1]] # Get type, speed and direction # Format: 910ff or 911ff, optionally followed by 915dd - t <- NULL - ff <- NULL - dd <- NULL + t = NULL + ff = NULL + dd = NULL if (length(groups) > 0) { # First group: 910ff or 911ff - first_group <- groups[1] + first_group = groups[1] if (nchar(first_group) >= 5) { - t <- substr(first_group, 3, 3) - ff <- substr(first_group, 4, 5) + t = substr(first_group, 3, 3) + ff = substr(first_group, 4, 5) } } # Second group: 915dd (direction) if (length(groups) > 1) { - second_group <- groups[2] + second_group = groups[2] if (nchar(second_group) >= 5 && substr(second_group, 1, 3) == "915") { - dd <- substr(second_group, 4, 5) + dd = substr(second_group, 4, 5) } } # Return values - time_before <- kwargs$time_before - measure_period <- kwargs$measure_period + time_before = kwargs$time_before + measure_period = kwargs$measure_period - gust_obs <- Gust$new() - dir_obs <- DirectionDegrees$new() + gust_obs = Gust$new() + dir_obs = DirectionDegrees$new() - data <- list( + data = list( speed = gust_obs$decode(ff, unit = kwargs$unit), direction = dir_obs$decode(dd) ) if (!is.null(time_before)) { - data$time_before_obs <- time_before + data$time_before_obs = time_before } if (!is.null(measure_period)) { - data$measure_period <- measure_period + data$measure_period = measure_period } data }, encode_internal = function(data, ...) { - kwargs <- list(...) - time_before <- kwargs$time_before - measure_period <- kwargs$measure_period - output <- character(0) + kwargs = list(...) + time_before = kwargs$time_before + measure_period = kwargs$measure_period + output = character(0) # Handle list of gusts or single gust if (is.list(data) && "speed" %in% names(data)) { - data <- list(data) # Convert single gust to list + data = list(data) # Convert single gust to list } for (d in data) { @@ -2019,33 +2021,33 @@ HighestGust <- R6Class("HighestGust", if ("time_before_obs" %in% names(d)) { if (is.null(time_before) || (!is.null(time_before) && !identical(d$time_before_obs, time_before))) { - time_before_obs <- TimeBeforeObs$new() - tt <- time_before_obs$encode(d$time_before_obs) + time_before_obs = TimeBeforeObs$new() + tt = time_before_obs$encode(d$time_before_obs) if (tt != "//") { - output <- c(output, paste0("907", tt)) + output = c(output, paste0("907", tt)) } } - prefix <- "911" + prefix = "911" } else if ("measure_period" %in% names(d)) { if (identical(d$measure_period, list(value = 10, unit = "min"))) { - prefix <- "910" + prefix = "910" } else { stop("Invalid value for measure_period") } } else { - prefix <- "910" # Default + prefix = "910" # Default } # Convert the gust - gust_obs <- Gust$new() - ff <- gust_obs$encode(if ("speed" %in% names(d)) d$speed else NULL) - output <- c(output, paste0(prefix, ff)) + gust_obs = Gust$new() + ff = gust_obs$encode(if ("speed" %in% names(d)) d$speed else NULL) + output = c(output, paste0(prefix, ff)) # Convert the direction if ("direction" %in% names(d) && !is.null(d$direction)) { - dir_obs <- DirectionDegrees$new() - dd <- dir_obs$encode(d$direction) - output <- c(output, paste0("915", dd)) + dir_obs = DirectionDegrees$new() + dd = dir_obs$encode(d$direction) + output = c(output, paste0("915", dd)) } } @@ -2055,12 +2057,12 @@ HighestGust <- R6Class("HighestGust", ) # Gust - Wind gust speed (internal class for HighestGust) -Gust <- R6Class("Gust", +Gust = R6Class("Gust", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(ff, ...) { @@ -2073,7 +2075,7 @@ Gust <- R6Class("Gust", if (is.null(data)) { return(paste(rep(self$null_char, self$code_len), collapse = "")) } - value <- if (is.list(data)) data$value else data + value = if (is.list(data)) data$value else data if (!is.null(value) && value > 99) { return(paste0("99 00", sprintf("%02d", value))) } @@ -2087,8 +2089,8 @@ Gust <- R6Class("Gust", ################################################################################ # Helper function to create observation instances -create_observation <- function(class_name, ...) { - class_map <- list( +create_observation = function(class_name, ...) { + class_map = list( "CloudCover" = CloudCover, "CloudGenus" = CloudGenus, "Day" = Day, @@ -2113,35 +2115,35 @@ create_observation <- function(class_name, ...) { } # Example usage function -example_usage <- function() { +example_usage = function() { # Example: Decode temperature # Format: 1sTTT where s=0 (positive) or s=1 (negative), TTT=temperature - temp <- Temperature$new() - result <- temp$decode("10094") # Sign=0 (positive), TTT=094 -> 9.4°C + temp = Temperature$new() + result = temp$decode("10094") # Sign=0 (positive), TTT=094 -> 9.4°C print(result) # Negative temperature - result2 <- temp$decode("11094") # Sign=1 (negative), TTT=094 -> -9.4°C + result2 = temp$decode("11094") # Sign=1 (negative), TTT=094 -> -9.4°C print(result2) # Example: Encode temperature - encoded <- temp$encode(list(value = 19.4)) + encoded = temp$encode(list(value = 19.4)) print(encoded) # Example: Decode cloud cover - cloud <- CloudCover$new() - result <- cloud$decode("6") + cloud = CloudCover$new() + result = cloud$decode("6") print(result) # Example: Decode surface wind - wind <- SurfaceWind$new() - result <- wind$decode("1506") + wind = SurfaceWind$new() + result = wind$decode("1506") print(result) # Example: Decode full SYNOP - synop <- SYNOP$new() - synop_msg <- "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 81656 86070" - output <- synop$decode(synop_msg) + synop = SYNOP$new() + synop_msg = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 81656 86070" + output = synop$decode(synop_msg) print(output) } diff --git a/R/zzz.R b/R/zzz.R index edeeeed..afe03ef 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -2,7 +2,7 @@ #' @return Empty env #' @keywords internal #' @noRd -env <- new.env(parent = emptyenv()) +env = new.env(parent = emptyenv()) globalVariables(c("DZ", "GG", "MC", "NSP", "POST.x", "ROK", "id", "..status_cols", "status_cols")) \ No newline at end of file diff --git a/data-raw/01_example.R b/data-raw/01_example.R index 829bdd5..a7fee6f 100644 --- a/data-raw/01_example.R +++ b/data-raw/01_example.R @@ -1,5 +1,5 @@ library(climate) -df <- meteo_ogimet(interval = "hourly", date = c("2018-01-01", "2018-12-31"), +df = meteo_ogimet(interval = "hourly", date = c("2018-01-01", "2018-12-31"), station = "01008") #> [1] "01008" #> |======================================================================| 100 % diff --git a/data-raw/02_example.R b/data-raw/02_example.R index 2a6513a..fcf247b 100644 --- a/data-raw/02_example.R +++ b/data-raw/02_example.R @@ -1,16 +1,16 @@ library(climate) # downloading data -df <- meteo_ogimet(interval = "hourly", date = c("2018-01-01", "2018-12-31"), +df = meteo_ogimet(interval = "hourly", date = c("2018-01-01", "2018-12-31"), station = c("01008")) library(openair) # external package for plotting wind roses # converting wind direction from character into degrees -wdir <- data.frame(ddd = c("CAL", "N", "NNE", "NE", "ENE", "E", "ESE", "SE", "SSE", +wdir = data.frame(ddd = c("CAL", "N", "NNE", "NE", "ENE", "E", "ESE", "SE", "SSE", "S", "SSW", "SW", "WSW", "W", "WNW", "NW", "NNW"), dir = c(NA, 0:15 * 22.5), stringsAsFactors = FALSE) # changing the date column to the format required by the openair package -df$date <- as.POSIXct(df$Date, tz = "UTC") -df <- merge(df, wdir, by = "ddd", all.x = TRUE) # joining two datasets -df$ws <- df$ffkmh / 3.6 # converting to m/s from km/h -df$gust <- df$Gustkmh / 3.6 # converting to m/s from km/h +df$date = as.POSIXct(df$Date, tz = "UTC") +df = merge(df, wdir, by = "ddd", all.x = TRUE) # joining two datasets +df$ws = df$ffkmh / 3.6 # converting to m/s from km/h +df$gust = df$Gustkmh / 3.6 # converting to m/s from km/h windRose(mydata = df, ws = "ws", wd = "dir", type = "season", paddle = FALSE, main = "Svalbard Lufthavn (2018)", ws.int = 3, dig.lab = 3, layout = c(4, 1)) diff --git a/data-raw/04_example.R b/data-raw/04_example.R index 39cb8fe..55ca706 100644 --- a/data-raw/04_example.R +++ b/data-raw/04_example.R @@ -1,6 +1,6 @@ library(climate) -profile <- sounding_wyoming(wmo_id = 12120,yy = 2019, mm = 4, dd = 4, hh = 0) -df <- profile[[1]] +profile = sounding_wyoming(wmo_id = 12120,yy = 2019, mm = 4, dd = 4, hh = 0) +df = profile[[1]] colnames(df)[c(1, 3:4)] = c("press", "temp", "dewpt") # changing column names RadioSonde::plotsonde(df, winds = FALSE, title = "2019-04-04 00UTC (LEBA, PL)", col = c("red", "blue"), lwd = 3) diff --git a/data-raw/05_example.R b/data-raw/05_example.R index 74e2920..2a2eb73 100644 --- a/data-raw/05_example.R +++ b/data-raw/05_example.R @@ -5,7 +5,7 @@ library(sf) library(tmap) library(rnaturalearth) library(climate) -ms <- meteo_imgw("monthly", "synop", year = 1978:2017, coords = TRUE) +ms = meteo_imgw("monthly", "synop", year = 1978:2017, coords = TRUE) # calculating annual values ms %>% filter(!(mm > 5 && mm < 9 && t2m_mean_mon == 0)) %>% @@ -16,15 +16,15 @@ ms %>% spread(yy, annual_mean_t2m) %>% na.omit() -> trend # extracting trends -regression <- function(x) { - df <- data.frame(yy = 1978:2017, temp = as.numeric(x)) +regression = function(x) { + df = data.frame(yy = 1978:2017, temp = as.numeric(x)) coef(lm(temp ~ yy, data = df))[2] } -trend$coef <- round(apply(trend[, -1:-4], 1, regression) * 100, 1) -trend <- st_as_sf(trend, coords = c("X", "Y"), crs = 4326) +trend$coef = round(apply(trend[, -1:-4], 1, regression) * 100, 1) +trend = st_as_sf(trend, coords = c("X", "Y"), crs = 4326) # mapping the results -world <- ne_countries(scale = "medium", returnclass = "sf") -tm <- tm_shape(world) + tm_borders() + +world = ne_countries(scale = "medium", returnclass = "sf") +tm = tm_shape(world) + tm_borders() + tm_shape(trend, is.master = TRUE) + tm_dots(col = "coef", size = 4) + tm_shape(trend) + tm_text(text = "coef") tm diff --git a/data-raw/parametry_przyklad_synop.R b/data-raw/parametry_przyklad_synop.R index 892c323..8f74ada 100644 --- a/data-raw/parametry_przyklad_synop.R +++ b/data-raw/parametry_przyklad_synop.R @@ -1,27 +1,27 @@ library(imgw) library(stringr) -synop <- meteo_daily("synop", year=2010) -daily <- synop +synop = meteo_daily("synop", year=2010) +daily = synop head(daily) -abbrev <- read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) +abbrev = read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) saveRDS(abbrev, file="data/abbrev.rda") -abbrev <- read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) +abbrev = read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) -orig_columns <- trimws(gsub("\\s+", " ", colnames(daily))) # remove double spaces +orig_columns = trimws(gsub("\\s+", " ", colnames(daily))) # remove double spaces # fullname polish, no changes required: abbrev$fullname[match(orig_columns, abbrev$fullname)] # abbrev english -colnames(synop) <- abbrev$abbr_ang[match(orig_columns, abbrev$fullname)] +colnames(synop) = abbrev$abbr_ang[match(orig_columns, abbrev$fullname)] head(synop) # fullname english -colnames(synop) <- abbrev$fullname_ang[match(orig_columns, abbrev$fullname)] +colnames(synop) = abbrev$fullname_ang[match(orig_columns, abbrev$fullname)] head(synop) # zastanowic sie nad usunieciem zduplikowanych kolumn (Np. nazwa stacji) -synop <- synop[,!duplicated(colnames(synop))] +synop = synop[,!duplicated(colnames(synop))] head(synop) diff --git a/data-raw/unique_meteo_parameters.R b/data-raw/unique_meteo_parameters.R index 0b6ce10..31feb7b 100644 --- a/data-raw/unique_meteo_parameters.R +++ b/data-raw/unique_meteo_parameters.R @@ -1,14 +1,14 @@ library(climate) library(stringr) -m_hs <- meteo_metadata_imgw("hourly", "synop") -m_hc <- meteo_metadata_imgw("hourly", "climate") -m_ds <- meteo_metadata_imgw("daily", "synop") -m_dc <- meteo_metadata_imgw("daily", "climate") -m_dp <- meteo_metadata_imgw("daily", "precip") -m_ms <- meteo_metadata_imgw("monthly", "synop") -m_mc <- meteo_metadata_imgw("monthly", "climate") -m_mp <- meteo_metadata_imgw("monthly", "precip") +m_hs = meteo_metadata_imgw("hourly", "synop") +m_hc = meteo_metadata_imgw("hourly", "climate") +m_ds = meteo_metadata_imgw("daily", "synop") +m_dc = meteo_metadata_imgw("daily", "climate") +m_dp = meteo_metadata_imgw("daily", "precip") +m_ms = meteo_metadata_imgw("monthly", "synop") +m_mc = meteo_metadata_imgw("monthly", "climate") +m_mp = meteo_metadata_imgw("monthly", "precip") all_meteo_metadata = dplyr::bind_rows( m_hs[[1]], @@ -32,7 +32,7 @@ unique_meteo_parameters = sort(unique_meteo_parameters) View(unique_meteo_parameters) # sprawdzenie czy stworzona recznie baza daje sie polaczyc left_joinem: -skroty <- read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) -wsio <- data.frame(fullname = unique_meteo_parameters) -laczenie <- dplyr::left_join(wsio,skroty) +skroty = read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) +wsio = data.frame(fullname = unique_meteo_parameters) +laczenie = dplyr::left_join(wsio,skroty) head(laczenie) diff --git a/inst/parser.R b/inst/parser.R index bbcfd99..808a963 100644 --- a/inst/parser.R +++ b/inst/parser.R @@ -19,7 +19,7 @@ #' parser(rep("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", 2), simplify = FALSE) #' @import R6 #' @export -parser <- function(message, country = NULL, simplify = TRUE) { +parser = function(message, country = NULL, simplify = TRUE) { if (missing(message) || length(message) == 0) { stop("`message` must contain at least one SYNOP string.") } @@ -32,14 +32,14 @@ parser <- function(message, country = NULL, simplify = TRUE) { stop("`country` must be NULL, a single string, or a character vector matching the length of `message`.") } - country_vec <- if (is.null(country)) rep(list(NULL), length(message)) else as.list(rep(country, length.out = length(message))) + country_vec = if (is.null(country)) rep(list(NULL), length(message)) else as.list(rep(country, length.out = length(message))) - results <- mapply( + results = mapply( function(msg, cntry) { - msg <- trimws(msg) + msg = trimws(msg) if (nzchar(msg)) { - synop <- SYNOP$new() - synop$country <- cntry + synop = SYNOP$new() + synop$country = cntry synop$decode(msg) } else { warning("Empty SYNOP message supplied; returning NULL.") @@ -72,7 +72,7 @@ parser <- function(message, country = NULL, simplify = TRUE) { ################################################################################ # Base Observation class -Observation <- R6Class("Observation", +Observation = R6Class("Observation", public = list( null_char = "/", code_len = NULL, @@ -81,21 +81,21 @@ Observation <- R6Class("Observation", valid_range = NULL, initialize = function(null_char = "/") { - self$null_char <- null_char + self$null_char = null_char }, # Check if value is available (not all null chars) is_available = function(value, char = NULL) { - if (is.null(char)) char <- self$null_char + if (is.null(char)) char = self$null_char if (is.null(value)) return(FALSE) - value_str <- as.character(value) + value_str = as.character(value) !all(strsplit(value_str, "")[[1]] == char) }, # Check if value is valid is_valid = function(value, raise_exception = TRUE, name = NULL, ...) { tryCatch({ - valid <- private$check_valid(value, ...) + valid = private$check_valid(value, ...) if (!valid && raise_exception) { stop(paste0(value, " is not a valid code for ", ifelse(is.null(name), class(self)[1], name))) } @@ -115,7 +115,7 @@ Observation <- R6Class("Observation", # Decode raw value decode = function(raw, ...) { - kwargs <- list(...) + kwargs = list(...) # Check if available if (!self$is_available(raw)) { @@ -138,8 +138,8 @@ Observation <- R6Class("Observation", # Encode observation encode = function(data, ...) { - kwargs <- list(...) - allow_none <- ifelse(is.null(kwargs$allow_none), FALSE, kwargs$allow_none) + kwargs = list(...) + allow_none = ifelse(is.null(kwargs$allow_none), FALSE, kwargs$allow_none) tryCatch({ if (is.null(data) || (is.list(data) && is.null(data$value))) { @@ -161,11 +161,11 @@ Observation <- R6Class("Observation", decode_internal = function(raw, ...) { if (!is.null(self$components) && length(self$components) > 0) { # Handle components - result <- list() + result = list() for (comp in self$components) { - comp_class <- comp[[4]] - comp_obj <- comp_class$new() - result[[comp[[1]]]] <- comp_obj$decode( + comp_class = comp[[4]] + comp_obj = comp_class$new() + result[[comp[[1]]]] = comp_obj$decode( substr(raw, comp[[2]] + 1, comp[[2]] + comp[[3]]) ) } @@ -179,11 +179,11 @@ Observation <- R6Class("Observation", encode_internal = function(data, ...) { if (!is.null(self$components)) { # Handle components - result <- character(0) + result = character(0) for (comp in self$components) { - comp_class <- comp[[4]] - comp_obj <- comp_class$new() - result <- c(result, comp_obj$encode( + comp_class = comp[[4]] + comp_obj = comp_class$new() + result = c(result, comp_obj$encode( if (comp[[1]] %in% names(data)) data[[comp[[1]]]] else NULL )) } @@ -195,7 +195,7 @@ Observation <- R6Class("Observation", # Decode value (uses code table if available) decode_value = function(val, ...) { - kwargs <- list(...) + kwargs = list(...) # Check if value is available if (!self$is_available(val)) { @@ -203,11 +203,11 @@ Observation <- R6Class("Observation", } # Get unit - unit <- if (is.null(kwargs$unit)) self$unit else kwargs$unit + unit = if (is.null(kwargs$unit)) self$unit else kwargs$unit # Get value from code table if (!is.null(self$code_table)) { - out_val <- tryCatch({ + out_val = tryCatch({ self$code_table$decode(val, ...) }, error = function(e) { warning(paste("Error decoding with code table:", val, "-", e$message)) @@ -218,18 +218,18 @@ Observation <- R6Class("Observation", }) if (!is.null(out_val) && !is.list(out_val)) { - out_val <- list(value = out_val) + out_val = list(value = out_val) } if (!is.null(out_val) && !("_code" %in% names(out_val))) { - code_val <- suppressWarnings(as.integer(val)) + code_val = suppressWarnings(as.integer(val)) if (!is.na(code_val)) { - out_val[["_code"]] <- code_val + out_val[["_code"]] = code_val } } } else { # No code table - just convert to integer - out_val <- tryCatch({ - code_val <- suppressWarnings(as.integer(val)) + out_val = tryCatch({ + code_val = suppressWarnings(as.integer(val)) if (is.na(code_val)) { return(NULL) } @@ -244,22 +244,22 @@ Observation <- R6Class("Observation", return(NULL) } - out_val <- list(value = out_val) + out_val = list(value = out_val) } if (is.null(out_val)) return(NULL) # Convert to int if not a list if (!is.list(out_val)) { - out_val <- list(value = as.integer(out_val)) + out_val = list(value = as.integer(out_val)) } # Perform post conversion - out_val <- self$decode_convert(out_val, ...) + out_val = self$decode_convert(out_val, ...) # Add unit if specified if (!is.null(unit)) { - out_val$unit <- unit + out_val$unit = unit } out_val @@ -269,13 +269,13 @@ Observation <- R6Class("Observation", encode_value = function(data, ...) { # Get value from code table or data if (!is.null(self$code_table)) { - out_val <- self$code_table$encode(data) + out_val = self$code_table$encode(data) } else { - out_val <- if ("value" %in% names(data)) data$value else data + out_val = if ("value" %in% names(data)) data$value else data } # Convert value - out_val <- self$encode_convert(out_val, ...) + out_val = self$encode_convert(out_val, ...) # Format code if (is.null(self$code_len)) { @@ -304,7 +304,7 @@ Observation <- R6Class("Observation", # Check valid range if (!is.null(self$valid_range)) { - val_num <- suppressWarnings(as.numeric(value)) + val_num = suppressWarnings(as.numeric(value)) if (is.na(val_num)) { return(FALSE) } @@ -329,97 +329,97 @@ Observation <- R6Class("Observation", # SHARED CLASSES ################################################################################ -CloudCover <- R6Class("CloudCover", +CloudCover = R6Class("CloudCover", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable2700$new() - self$unit <- "okta" + self$code_len = 1 + self$code_table = CodeTable2700$new() + self$unit = "okta" } ) ) -CloudGenus <- R6Class("CloudGenus", +CloudGenus = R6Class("CloudGenus", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable0500$new() + self$code_len = 1 + self$code_table = CodeTable0500$new() } ) ) -Day <- R6Class("Day", +Day = R6Class("Day", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$valid_range <- c(1, 31) + self$code_len = 2 + self$valid_range = c(1, 31) } ) ) -DirectionCardinal <- R6Class("DirectionCardinal", +DirectionCardinal = R6Class("DirectionCardinal", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable0700$new() + self$code_len = 1 + self$code_table = CodeTable0700$new() } ) ) -DirectionDegrees <- R6Class("DirectionDegrees", +DirectionDegrees = R6Class("DirectionDegrees", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$code_table <- CodeTable0877$new() - self$unit <- "deg" + self$code_len = 2 + self$code_table = CodeTable0877$new() + self$unit = "deg" } ) ) -Hour <- R6Class("Hour", +Hour = R6Class("Hour", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$valid_range <- c(0, 24) + self$code_len = 2 + self$valid_range = c(0, 24) } ) ) -Minute <- R6Class("Minute", +Minute = R6Class("Minute", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$valid_range <- c(0, 59) + self$code_len = 2 + self$valid_range = c(0, 59) } ) ) -SignedTemperature <- R6Class("SignedTemperature", +SignedTemperature = R6Class("SignedTemperature", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 - self$unit <- "Cel" + self$code_len = 4 + self$unit = "Cel" }, decode_internal = function(raw, ...) { - kwargs <- list(...) - sign <- kwargs$sign + kwargs = list(...) + sign = kwargs$sign if (is.null(sign) || sign == "/") { return(NULL) @@ -433,36 +433,36 @@ SignedTemperature <- R6Class("SignedTemperature", }, decode_convert = function(val, ...) { - kwargs <- list(...) - sign <- kwargs$sign + kwargs = list(...) + sign = kwargs$sign if (is.null(sign)) return(val) - factor <- ifelse(sign == "0", 10, -10) - val$value <- val$value / factor + factor = ifelse(sign == "0", 10, -10) + val$value = val$value / factor val }, encode_convert = function(val, ...) { - sign_char <- ifelse(val >= 0, "0", "1") - abs_val <- abs(val * 10) + sign_char = ifelse(val >= 0, "0", "1") + abs_val = abs(val * 10) paste0(sign_char, sprintf("%03d", as.integer(abs_val))) } ) ) -Visibility <- R6Class("Visibility", +Visibility = R6Class("Visibility", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$code_table <- CodeTable4377$new() - self$unit <- "m" + self$code_len = 2 + self$code_table = CodeTable4377$new() + self$unit = "m" }, encode_internal = function(data, ...) { - kwargs <- list(...) - use90 <- ifelse(is.null(kwargs$use90), + kwargs = list(...) + use90 = ifelse(is.null(kwargs$use90), ifelse("use90" %in% names(data), data$use90, FALSE), kwargs$use90) self$encode_value(data, use90 = use90) @@ -475,15 +475,15 @@ Visibility <- R6Class("Visibility", ################################################################################ # Base CodeTable class -CodeTable <- R6Class("CodeTable", +CodeTable = R6Class("CodeTable", public = list( table_name = NULL, decode = function(value, ...) { tryCatch({ - result <- self$decode_internal(value, ...) + result = self$decode_internal(value, ...) if (!is.null(result)) { - result$`_table` <- self$table_name + result$`_table` = self$table_name } result }, error = function(e) { @@ -511,15 +511,15 @@ CodeTable <- R6Class("CodeTable", ) # CodeTable2700 - Total cloud cover -CodeTable2700 <- R6Class("CodeTable2700", +CodeTable2700 = R6Class("CodeTable2700", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "2700" + self$table_name = "2700" }, decode_internal = function(N, ...) { - n <- as.integer(N) + n = as.integer(N) if (n == 9) { list(value = NULL, obscured = TRUE, unit = "okta") } else { @@ -538,17 +538,17 @@ CodeTable2700 <- R6Class("CodeTable2700", ) # CodeTable0500 - Genus of cloud -CodeTable0500 <- R6Class("CodeTable0500", +CodeTable0500 = R6Class("CodeTable0500", inherit = CodeTable, public = list( values = c("Ci", "Cc", "Cs", "Ac", "As", "Ns", "Sc", "St", "Cu", "Cb"), initialize = function() { - self$table_name <- "0500" + self$table_name = "0500" }, decode_internal = function(i, ...) { - idx <- as.integer(i) + 1 + idx = as.integer(i) + 1 if (idx >= 1 && idx <= length(self$values)) { list(value = self$values[idx]) } else { @@ -557,8 +557,8 @@ CodeTable0500 <- R6Class("CodeTable0500", }, encode_internal = function(data, ...) { - val <- if (is.list(data)) data$value else data - idx <- which(self$values == val) + val = if (is.list(data)) data$value else data + idx = which(self$values == val) if (length(idx) == 0) { stop(paste("Invalid cloud genus:", val)) } @@ -568,13 +568,13 @@ CodeTable0500 <- R6Class("CodeTable0500", ) # CodeTable0700 - Direction or bearing in one figure -CodeTable0700 <- R6Class("CodeTable0700", +CodeTable0700 = R6Class("CodeTable0700", inherit = CodeTable, public = list( directions = c(NULL, "NE", "E", "SE", "S", "SW", "W", "NW", "N", NULL), initialize = function() { - self$table_name <- "0700" + self$table_name = "0700" }, decode_internal = function(D, ...) { @@ -582,11 +582,11 @@ CodeTable0700 <- R6Class("CodeTable0700", return(list(value = NULL, isCalmOrStationary = NULL, allDirections = NULL)) } - d <- as.integer(D) - isCalmOrStationary <- (d == 0) - allDirections <- (d == 9) + d = as.integer(D) + isCalmOrStationary = (d == 0) + allDirections = (d == 9) - direction <- if (d >= 0 && d < length(self$directions)) { + direction = if (d >= 0 && d < length(self$directions)) { self$directions[d + 1] } else { NULL @@ -607,7 +607,7 @@ CodeTable0700 <- R6Class("CodeTable0700", return("9") } if ("value" %in% names(data) && !is.null(data$value)) { - idx <- which(self$directions == data$value) - 1 + idx = which(self$directions == data$value) - 1 if (length(idx) > 0) { return(as.character(idx)) } @@ -618,24 +618,24 @@ CodeTable0700 <- R6Class("CodeTable0700", ) # CodeTable0877 - True direction in tens of degrees -CodeTable0877 <- R6Class("CodeTable0877", +CodeTable0877 = R6Class("CodeTable0877", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "0877" + self$table_name = "0877" }, decode_internal = function(dd, ...) { - dd_int <- as.integer(dd) - calm <- (dd_int == 0) - varAllUnknown <- (dd_int == 99) + dd_int = as.integer(dd) + calm = (dd_int == 0) + varAllUnknown = (dd_int == 99) if (calm) { - direction <- NULL + direction = NULL } else if (varAllUnknown) { - direction <- NULL + direction = NULL } else if (dd_int >= 1 && dd_int <= 36) { - direction <- dd_int * 10 + direction = dd_int * 10 } else { stop(paste("Invalid direction code:", dd)) } @@ -648,22 +648,22 @@ CodeTable0877 <- R6Class("CodeTable0877", }, encode_internal = function(data, ...) { - val <- if (is.list(data)) data$value else data + val = if (is.list(data)) data$value else data if (is.null(val)) { if ("calm" %in% names(data) && data$calm) return("00") if ("varAllUnknown" %in% names(data) && data$varAllUnknown) return("99") return("//") } - code <- round(val / 10) - if (code < 1) code <- 0 - if (code > 36) code <- 36 + code = round(val / 10) + if (code < 1) code = 0 + if (code > 36) code = 36 sprintf("%02d", code) } ) ) # CodeTable4377 - Horizontal visibility at surface -CodeTable4377 <- R6Class("CodeTable4377", +CodeTable4377 = R6Class("CodeTable4377", inherit = CodeTable, public = list( range90 = list( @@ -673,58 +673,58 @@ CodeTable4377 <- R6Class("CodeTable4377", ), initialize = function() { - self$table_name <- "4377" + self$table_name = "4377" }, decode_internal = function(VV, ...) { - vv <- as.integer(VV) + vv = as.integer(VV) if (vv >= 51 && vv <= 55) { stop(paste("Invalid visibility code:", VV)) } - visibility <- NULL - quantifier <- NULL + visibility = NULL + quantifier = NULL if (vv == 0) { - visibility <- 100 - quantifier <- "isLess" + visibility = 100 + quantifier = "isLess" } else if (vv <= 50) { - visibility <- vv * 100 + visibility = vv * 100 } else if (vv <= 80) { - visibility <- (vv - 50) * 1000 + visibility = (vv - 50) * 1000 } else if (vv <= 88) { - visibility <- (vv - 74) * 5000 + visibility = (vv - 74) * 5000 } else if (vv == 89) { - visibility <- 70000 - quantifier <- "isGreater" + visibility = 70000 + quantifier = "isGreater" } else if (vv == 90) { - visibility <- 50 - quantifier <- "isLess" + visibility = 50 + quantifier = "isLess" } else if (vv == 91) { - visibility <- 50 + visibility = 50 } else if (vv == 92) { - visibility <- 200 + visibility = 200 } else if (vv == 93) { - visibility <- 500 + visibility = 500 } else if (vv == 94) { - visibility <- 1000 + visibility = 1000 } else if (vv == 95) { - visibility <- 2000 + visibility = 2000 } else if (vv == 96) { - visibility <- 4000 + visibility = 4000 } else if (vv == 97) { - visibility <- 10000 + visibility = 10000 } else if (vv == 98) { - visibility <- 20000 + visibility = 20000 } else if (vv == 99) { - visibility <- 50000 - quantifier <- "isGreaterOrEqual" + visibility = 50000 + quantifier = "isGreaterOrEqual" } else { stop(paste("Invalid visibility code:", VV)) } - use90 <- (vv >= 90) + use90 = (vv >= 90) list( value = visibility, quantifier = quantifier, @@ -733,27 +733,27 @@ CodeTable4377 <- R6Class("CodeTable4377", }, encode_internal = function(data, use90 = FALSE, ...) { - value <- if (is.list(data)) data$value else data - quantifier <- if (is.list(data) && "quantifier" %in% names(data)) data$quantifier else NULL + value = if (is.list(data)) data$value else data + quantifier = if (is.list(data) && "quantifier" %in% names(data)) data$quantifier else NULL if (use90) { for (idx in seq_along(self$range90)) { - r <- self$range90[[idx]] + r = self$range90[[idx]] if (value >= r[1] && value < r[2]) { return(sprintf("%02d", idx + 89)) } } } else { if (value < 100) { - code <- 0 + code = 0 } else if (value <= 5000) { - code <- floor(value / 100) + code = floor(value / 100) } else if (value <= 30000) { - code <- floor(value / 1000) + 50 + code = floor(value / 1000) + 50 } else if (value <= 70000 && is.null(quantifier)) { - code <- floor(value / 5000) + 74 + code = floor(value / 5000) + 74 } else { - code <- 89 + code = 89 } return(sprintf("%02d", code)) } @@ -768,21 +768,21 @@ CodeTable4377 <- R6Class("CodeTable4377", ################################################################################ # Temperature observation -Temperature <- R6Class("Temperature", +Temperature = R6Class("Temperature", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - sn <- substr(group, 2, 2) - TTT <- substr(group, 3, 5) + sn = substr(group, 2, 2) + TTT = substr(group, 3, 5) # Fix trailing "/" (issue #10) if (TTT != "///") { - TTT <- sub("/$", "0", TTT) + TTT = sub("/$", "0", TTT) } if (!sn %in% c("0", "1", "/")) { @@ -790,30 +790,30 @@ Temperature <- R6Class("Temperature", return(NULL) } - temp_obs <- SignedTemperature$new() + temp_obs = SignedTemperature$new() temp_obs$decode(TTT, sign = sn) }, encode_internal = function(data, ...) { - temp_obs <- SignedTemperature$new() + temp_obs = SignedTemperature$new() temp_obs$encode(data) } ) ) # Pressure observation -Pressure <- R6Class("Pressure", +Pressure = R6Class("Pressure", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 - self$unit <- "hPa" + self$code_len = 4 + self$unit = "hPa" }, decode_convert = function(val, ...) { - val_int <- as.integer(val$value) - val$value <- (val_int / 10) + ifelse(val_int > 5000, 0, 1000) + val_int = as.integer(val$value) + val$value = (val_int / 10) + ifelse(val_int > 5000, 0, 1000) val }, @@ -824,40 +824,40 @@ Pressure <- R6Class("Pressure", ) # Surface wind observation -SurfaceWind <- R6Class("SurfaceWind", +SurfaceWind = R6Class("SurfaceWind", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(ddff, ...) { - dd <- substr(ddff, 1, 2) - ff <- substr(ddff, 3, 4) + dd = substr(ddff, 1, 2) + ff = substr(ddff, 3, 4) - dir_obs <- DirectionDegrees$new() - direction <- dir_obs$decode(dd) + dir_obs = DirectionDegrees$new() + direction = dir_obs$decode(dd) - speed_obs <- WindSpeed$new() - speed <- speed_obs$decode(ff) + speed_obs = WindSpeed$new() + speed = speed_obs$decode(ff) # Sanity check: if wind is calm, it can't have a speed if (!is.null(direction) && !is.null(direction$calm) && direction$calm && !is.null(speed) && !is.null(speed$value) && speed$value > 0) { warning(paste("Wind is calm, yet has a speed (dd:", dd, ", ff:", ff, ")")) - speed <- NULL + speed = NULL } list(direction = direction, speed = speed) }, encode_internal = function(data, ...) { - dir_obs <- DirectionDegrees$new() - speed_obs <- WindSpeed$new() + dir_obs = DirectionDegrees$new() + speed_obs = WindSpeed$new() - dd <- dir_obs$encode(if ("direction" %in% names(data)) data$direction else NULL, allow_none = TRUE) - ff <- speed_obs$encode(if ("speed" %in% names(data)) data$speed else NULL) + dd = dir_obs$encode(if ("direction" %in% names(data)) data$direction else NULL, allow_none = TRUE) + ff = speed_obs$encode(if ("speed" %in% names(data)) data$speed else NULL) paste0(dd, ff) } @@ -865,12 +865,12 @@ SurfaceWind <- R6Class("SurfaceWind", ) # Wind speed (simplified) -WindSpeed <- R6Class("WindSpeed", +WindSpeed = R6Class("WindSpeed", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(ff, ...) { @@ -883,7 +883,7 @@ WindSpeed <- R6Class("WindSpeed", if (is.null(data)) { return(paste(rep(self$null_char, self$code_len), collapse = "")) } - value <- if (is.list(data)) data$value else data + value = if (is.list(data)) data$value else data if (!is.null(value) && value > 99) { return(paste0("99 00", sprintf("%02d", value))) } @@ -897,7 +897,7 @@ WindSpeed <- R6Class("WindSpeed", ################################################################################ # Base Report class -Report <- R6Class("Report", +Report = R6Class("Report", public = list( not_implemented = list(), @@ -916,104 +916,104 @@ Report <- R6Class("Report", ) # SYNOP class - main class for decoding SYNOP messages -SYNOP <- R6Class("SYNOP", +SYNOP = R6Class("SYNOP", inherit = Report, public = list( country = NULL, initialize = function() { - self$not_implemented <- list() - self$country <- NULL + self$not_implemented = list() + self$country = NULL }, decode_internal = function(message) { # Initialize data - data <- list() + data = list() # Split message into groups - groups <- strsplit(message, " ")[[1]] - group_idx <- 1 + groups = strsplit(message, " ")[[1]] + group_idx = 1 # Helper function to get next group - get_next_group <- function() { + get_next_group = function() { if (group_idx <= length(groups)) { - group <- groups[group_idx] - group_idx <<- group_idx + 1 + group = groups[group_idx] + group_idx <= group_idx + 1 return(group) } return(NULL) } # Alias for convenience - next_group <- get_next_group + next_group = get_next_group # SECTION 0: Station type, time, and identification - station_type <- next_group() + station_type = next_group() if (is.null(station_type)) { stop("Invalid SYNOP: missing station type") } # For simplicity, assume AAXX format - data$station_type <- list(value = station_type) + data$station_type = list(value = station_type) # Get observation time and wind indicator (YYGGi) - yygii <- next_group() + yygii = next_group() if (is.null(yygii) || nchar(yygii) < 5) { stop("Invalid SYNOP: missing YYGGi group") } # Decode observation time - obs_time <- ObservationTime$new() - data$obs_time <- obs_time$decode(substr(yygii, 1, 4)) + obs_time = ObservationTime$new() + data$obs_time = obs_time$decode(substr(yygii, 1, 4)) # Decode wind indicator - wind_ind <- WindIndicator$new() - data$wind_indicator <- wind_ind$decode(substr(yygii, 5, 5)) + wind_ind = WindIndicator$new() + data$wind_indicator = wind_ind$decode(substr(yygii, 5, 5)) # Get station ID - station_id_group <- next_group() + station_id_group = next_group() if (is.null(station_id_group)) { stop("Invalid SYNOP: missing station ID") } - data$station_id <- list(value = station_id_group) + data$station_id = list(value = station_id_group) # Decode region tryCatch({ - region <- Region$new() - result <- region$decode(station_id_group) + region = Region$new() + result = region$decode(station_id_group) if (!is.null(result)) { - data$region <- result + data$region = result } }, error = function(e) { warning(paste("Error decoding region:", e$message)) }) # Check if next group is NIL (station did not send data) - next_check <- next_group() + next_check = next_group() if (!is.null(next_check) && (next_check == "NIL" || grepl("^NIL", next_check))) { # Station did not send data - set remaining fields to NA - data$precipitation_indicator <- NA - data$weather_indicator <- NA - data$lowest_cloud_base <- NA - data$visibility <- NA - data$cloud_cover <- NA - data$surface_wind <- NA - data$air_temperature <- NA - data$dewpoint_temperature <- NA - data$relative_humidity <- NA - data$station_pressure <- NA - data$sea_level_pressure <- NA - data$pressure_tendency <- NA - data$precipitation_s1 <- NA - data$present_weather <- NA - data$past_weather <- NA - data$cloud_types <- NA + data$precipitation_indicator = NA + data$weather_indicator = NA + data$lowest_cloud_base = NA + data$visibility = NA + data$cloud_cover = NA + data$surface_wind = NA + data$air_temperature = NA + data$dewpoint_temperature = NA + data$relative_humidity = NA + data$station_pressure = NA + data$sea_level_pressure = NA + data$pressure_tendency = NA + data$precipitation_s1 = NA + data$present_weather = NA + data$past_weather = NA + data$cloud_types = NA return(data) } # SECTION 1: Main observations - section1 <- next_check # Use the group we already got + section1 = next_check # Use the group we already got if (is.null(section1) || nchar(section1) < 5) { # If section1 is invalid, try to continue anyway warning("Invalid or missing section 1") @@ -1022,68 +1022,68 @@ SYNOP <- R6Class("SYNOP", # Decode precipitation indicator, weather indicator, cloud base, visibility tryCatch({ - precip_ind <- PrecipitationIndicator$new() - result <- precip_ind$decode(substr(section1, 1, 1), country = self$country) + precip_ind = PrecipitationIndicator$new() + result = precip_ind$decode(substr(section1, 1, 1), country = self$country) if (!is.null(result)) { - data$precipitation_indicator <- result + data$precipitation_indicator = result } }, error = function(e) { warning(paste("Error decoding precipitation indicator:", e$message)) }) tryCatch({ - weather_ind <- WeatherIndicator$new() - result <- weather_ind$decode(substr(section1, 2, 2)) + weather_ind = WeatherIndicator$new() + result = weather_ind$decode(substr(section1, 2, 2)) if (!is.null(result)) { - data$weather_indicator <- result + data$weather_indicator = result } }, error = function(e) { warning(paste("Error decoding weather indicator:", e$message)) }) tryCatch({ - lowest_cloud <- LowestCloudBase$new() - result <- lowest_cloud$decode(substr(section1, 3, 3)) + lowest_cloud = LowestCloudBase$new() + result = lowest_cloud$decode(substr(section1, 3, 3)) if (!is.null(result)) { - data$lowest_cloud_base <- result + data$lowest_cloud_base = result } }, error = function(e) { warning(paste("Error decoding lowest cloud base:", e$message)) }) tryCatch({ - vis <- Visibility$new() - result <- vis$decode(substr(section1, 4, 5)) + vis = Visibility$new() + result = vis$decode(substr(section1, 4, 5)) if (!is.null(result)) { - data$visibility <- result + data$visibility = result } }, error = function(e) { warning(paste("Error decoding visibility:", e$message)) }) # Get cloud cover and wind (Nddff) - nddff <- next_group() + nddff = next_group() if (!is.null(nddff) && nchar(nddff) >= 5) { tryCatch({ - cloud <- CloudCover$new() - result <- cloud$decode(substr(nddff, 1, 1)) + cloud = CloudCover$new() + result = cloud$decode(substr(nddff, 1, 1)) if (!is.null(result)) { - data$cloud_cover <- result + data$cloud_cover = result } }, error = function(e) { warning(paste("Error decoding cloud cover from:", nddff, "-", e$message)) }) tryCatch({ - wind <- SurfaceWind$new() - wind_data <- wind$decode(substr(nddff, 2, 5)) + wind = SurfaceWind$new() + wind_data = wind$decode(substr(nddff, 2, 5)) if (!is.null(wind_data)) { if (!is.null(data$wind_indicator)) { if (!is.null(wind_data$speed)) { - wind_data$speed$unit <- data$wind_indicator$unit + wind_data$speed$unit = data$wind_indicator$unit } } - data$surface_wind <- wind_data + data$surface_wind = wind_data } }, error = function(e) { warning(paste("Error decoding surface wind from:", nddff, "-", e$message)) @@ -1091,7 +1091,7 @@ SYNOP <- R6Class("SYNOP", } # Parse section 1 groups (1sTTT, 2sTTT, 3P0P0P0, 4PPPP, etc.) - next_grp <- next_group() + next_grp = next_group() while (!is.null(next_grp)) { if (grepl("^333|^444|^555", next_grp)) { # Start of next section @@ -1099,20 +1099,20 @@ SYNOP <- R6Class("SYNOP", } # Try to get header, handle errors gracefully - header <- tryCatch({ + header = tryCatch({ as.integer(substr(next_grp, 1, 1)) }, error = function(e) { warning(paste("Unable to parse header from group:", next_grp)) - next_grp <<- next_group() + next_grp <= next_group() return(NULL) }, warning = function(w) { warning(paste("Warning parsing header from group:", next_grp)) - next_grp <<- next_group() + next_grp <= next_group() return(NULL) }) if (is.null(header) || is.na(header)) { - next_grp <- next_group() + next_grp = next_group() # Skip to next iteration if (is.null(next_grp)) break next @@ -1121,83 +1121,83 @@ SYNOP <- R6Class("SYNOP", tryCatch({ if (header == 1) { # Air temperature - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$air_temperature <- result + data$air_temperature = result } } else if (header == 2) { # Dewpoint temperature or relative humidity - sn <- substr(next_grp, 2, 2) + sn = substr(next_grp, 2, 2) if (sn == "9") { - rel_hum <- RelativeHumidity$new() - result <- rel_hum$decode(substr(next_grp, 3, 5)) + rel_hum = RelativeHumidity$new() + result = rel_hum$decode(substr(next_grp, 3, 5)) if (!is.null(result)) { - data$relative_humidity <- result + data$relative_humidity = result } } else { - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$dewpoint_temperature <- result + data$dewpoint_temperature = result } } } else if (header == 3) { # Station pressure - press <- Pressure$new() - result <- press$decode(substr(next_grp, 2, 5)) + press = Pressure$new() + result = press$decode(substr(next_grp, 2, 5)) if (!is.null(result)) { - data$station_pressure <- result + data$station_pressure = result } } else if (header == 4) { # Sea level pressure - press <- Pressure$new() - result <- press$decode(substr(next_grp, 2, 5)) + press = Pressure$new() + result = press$decode(substr(next_grp, 2, 5)) if (!is.null(result)) { - data$sea_level_pressure <- result + data$sea_level_pressure = result } } else if (header == 5) { # Pressure tendency - press_tend <- PressureTendency$new() - result <- press_tend$decode(next_grp) + press_tend = PressureTendency$new() + result = press_tend$decode(next_grp) if (!is.null(result)) { - data$pressure_tendency <- result + data$pressure_tendency = result } } else if (header == 6) { # Precipitation if (!is.null(data$precipitation_indicator) && data$precipitation_indicator$in_group_1) { - precip <- Precipitation$new() - result <- precip$decode(next_grp) + precip = Precipitation$new() + result = precip$decode(next_grp) if (!is.null(result)) { - data$precipitation_s1 <- result + data$precipitation_s1 = result } } } else if (header == 7) { # Present and past weather if (nchar(next_grp) >= 5) { - ww <- Weather$new() - result <- ww$decode(substr(next_grp, 2, 3), + ww = Weather$new() + result = ww$decode(substr(next_grp, 2, 3), time_before = list(value = 6, unit = "h"), type = "present", weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) if (!is.null(result)) { - data$present_weather <- result + data$present_weather = result } - result2 <- ww$decode(substr(next_grp, 4, 4), type = "past", + result2 = ww$decode(substr(next_grp, 4, 4), type = "past", weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) - result3 <- ww$decode(substr(next_grp, 5, 5), type = "past", + result3 = ww$decode(substr(next_grp, 5, 5), type = "past", weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) if (!is.null(result2) || !is.null(result3)) { - data$past_weather <- list(result2, result3) + data$past_weather = list(result2, result3) } } } else if (header == 8) { # Cloud types - cloud_types <- CloudType$new() - result <- cloud_types$decode(next_grp) + cloud_types = CloudType$new() + result = cloud_types$decode(next_grp) if (!is.null(result)) { - data$cloud_types <- result + data$cloud_types = result } } }, error = function(e) { @@ -1208,19 +1208,19 @@ SYNOP <- R6Class("SYNOP", # Continue to next group }) - next_grp <- next_group() + next_grp = next_group() } # SECTION 3: Additional observations if (!is.null(next_grp) && next_grp == "333") { - next_grp <- next_group() - cloud_layers <- list() - highest_gusts <- list() - group_9 <- list() # Collect group 9 codes + next_grp = next_group() + cloud_layers = list() + highest_gusts = list() + group_9 = list() # Collect group 9 codes while (!is.null(next_grp) && !grepl("^444|^555", next_grp)) { # Try to get header, handle errors gracefully - header <- tryCatch({ + header = tryCatch({ as.integer(substr(next_grp, 1, 1)) }, error = function(e) { warning(paste("Unable to parse header from group:", next_grp)) @@ -1231,7 +1231,7 @@ SYNOP <- R6Class("SYNOP", }) if (is.null(header) || is.na(header)) { - next_grp <- next_group() + next_grp = next_group() # Skip to next iteration if (is.null(next_grp)) break next @@ -1240,27 +1240,27 @@ SYNOP <- R6Class("SYNOP", tryCatch({ # Check if it's a group 9 code (9xxxx) if (header == 9) { - group_9[[length(group_9) + 1]] <- next_grp + group_9[[length(group_9) + 1]] = next_grp } else if (header == 8) { # Cloud layers - cloud_layer <- CloudLayer$new() - result <- cloud_layer$decode(next_grp) + cloud_layer = CloudLayer$new() + result = cloud_layer$decode(next_grp) if (!is.null(result)) { - cloud_layers[[length(cloud_layers) + 1]] <- result + cloud_layers[[length(cloud_layers) + 1]] = result } } else if (header == 1) { # Maximum temperature - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$maximum_temperature <- result + data$maximum_temperature = result } } else if (header == 2) { # Minimum temperature - temp <- Temperature$new() - result <- temp$decode(next_grp) + temp = Temperature$new() + result = temp$decode(next_grp) if (!is.null(result)) { - data$minimum_temperature <- result + data$minimum_temperature = result } } }, error = function(e) { @@ -1271,84 +1271,84 @@ SYNOP <- R6Class("SYNOP", # Continue to next group }) - next_grp <- next_group() + next_grp = next_group() } # Parse group 9 codes (including highest gusts) if (length(group_9) > 0) { - idx <- 1 + idx = 1 while (idx <= length(group_9)) { - g <- group_9[[idx]] + g = group_9[[idx]] tryCatch({ if (nchar(g) >= 3) { - j1 <- substr(g, 2, 2) # Second character - j2 <- substr(g, 3, 3) # Third character + j1 = substr(g, 2, 2) # Second character + j2 = substr(g, 3, 3) # Third character if (j1 == "1") { # Group 91xx - highest gusts if (j2 == "0") { # 910ff - gust with 10 min period if (is.null(data$highest_gust)) { - data$highest_gust <- list() + data$highest_gust = list() } - gust <- HighestGust$new() - gust_data <- gust$decode(g, + gust = HighestGust$new() + gust_data = gust$decode(g, unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, measure_period = list(value = 10, unit = "min") ) if (!is.null(gust_data)) { - data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + data$highest_gust[[length(data$highest_gust) + 1]] = gust_data } - idx <- idx + 1 + idx = idx + 1 } else if (j2 == "1") { # 911ff - gust with time before obs # Check if next group is direction (915dd) if (idx < length(group_9)) { - next_g <- group_9[[idx + 1]] + next_g = group_9[[idx + 1]] if (substr(next_g, 1, 3) == "915") { - gust_group <- paste(g, next_g, sep = " ") - idx <- idx + 2 # Skip next group + gust_group = paste(g, next_g, sep = " ") + idx = idx + 2 # Skip next group } else { - gust_group <- g - idx <- idx + 1 + gust_group = g + idx = idx + 1 } } else { - gust_group <- g - idx <- idx + 1 + gust_group = g + idx = idx + 1 } if (is.null(data$highest_gust)) { - data$highest_gust <- list() + data$highest_gust = list() } - gust <- HighestGust$new() - gust_data <- gust$decode(gust_group, + gust = HighestGust$new() + gust_data = gust$decode(gust_group, unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, time_before = list(value = 6, unit = "h") # Default time before ) if (!is.null(gust_data)) { - data$highest_gust[[length(data$highest_gust) + 1]] <- gust_data + data$highest_gust[[length(data$highest_gust) + 1]] = gust_data } } else { - idx <- idx + 1 + idx = idx + 1 } } else { - idx <- idx + 1 + idx = idx + 1 } } else { - idx <- idx + 1 + idx = idx + 1 } }, error = function(e) { warning(paste("Error decoding group 9 code:", g, "-", e$message)) - idx <<- idx + 1 + idx <= idx + 1 }, warning = function(w) { warning(paste("Warning decoding group 9 code:", g, "-", w$message)) - idx <<- idx + 1 + idx <= idx + 1 }) } } if (length(cloud_layers) > 0) { - data$cloud_layer <- cloud_layers + data$cloud_layer = cloud_layers } } @@ -1362,7 +1362,7 @@ SYNOP <- R6Class("SYNOP", ################################################################################ # ObservationTime -ObservationTime <- R6Class("ObservationTime", +ObservationTime = R6Class("ObservationTime", inherit = Observation, public = list( components = list( @@ -1372,23 +1372,23 @@ ObservationTime <- R6Class("ObservationTime", initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 } ) ) # WindIndicator -WindIndicator <- R6Class("WindIndicator", +WindIndicator = R6Class("WindIndicator", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$valid_range <- c(1, 7) + self$code_len = 1 + self$valid_range = c(1, 7) }, decode_internal = function(iw, ...) { - iw_int <- as.integer(iw) + iw_int = as.integer(iw) if (iw == "/") { list(value = NULL, unit = NULL, estimated = NULL) } else { @@ -1403,13 +1403,13 @@ WindIndicator <- R6Class("WindIndicator", ) # Region -Region <- R6Class("Region", +Region = R6Class("Region", inherit = Observation, public = list( decode_internal = function(raw, ...) { - raw_int <- as.integer(raw) + raw_int = as.integer(raw) - regions <- list( + regions = list( I = list(c(60000, 69998)), II = list(c(20000, 20099), c(20200, 21998), c(23001, 25998), c(28001, 32998), c(35001, 36998), c(38001, 39998), @@ -1437,18 +1437,18 @@ Region <- R6Class("Region", ) # PrecipitationIndicator -PrecipitationIndicator <- R6Class("PrecipitationIndicator", +PrecipitationIndicator = R6Class("PrecipitationIndicator", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 }, decode_internal = function(i, ...) { - kwargs <- list(...) - country <- kwargs$country - i_int <- as.integer(i) + kwargs = list(...) + country = kwargs$country + i_int = as.integer(i) list( value = i_int, @@ -1460,17 +1460,17 @@ PrecipitationIndicator <- R6Class("PrecipitationIndicator", ) # WeatherIndicator -WeatherIndicator <- R6Class("WeatherIndicator", +WeatherIndicator = R6Class("WeatherIndicator", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$valid_range <- c(1, 7) + self$code_len = 1 + self$valid_range = c(1, 7) }, decode_internal = function(ix, ...) { - ix_int <- ifelse(ix == "/", NULL, as.integer(ix)) + ix_int = ifelse(ix == "/", NULL, as.integer(ix)) list( value = ix_int, @@ -1481,20 +1481,20 @@ WeatherIndicator <- R6Class("WeatherIndicator", ) # LowestCloudBase -LowestCloudBase <- R6Class("LowestCloudBase", +LowestCloudBase = R6Class("LowestCloudBase", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable1600$new() - self$unit <- "m" + self$code_len = 1 + self$code_table = CodeTable1600$new() + self$unit = "m" } ) ) # CodeTable1600 -CodeTable1600 <- R6Class("CodeTable1600", +CodeTable1600 = R6Class("CodeTable1600", inherit = CodeTable, public = list( ranges = list( @@ -1503,14 +1503,14 @@ CodeTable1600 <- R6Class("CodeTable1600", ), initialize = function() { - self$table_name <- "1600" + self$table_name = "1600" }, decode_internal = function(h, ...) { - h_int <- as.integer(h) + h_int = as.integer(h) if (h_int >= 0 && h_int < length(self$ranges)) { - range <- self$ranges[[h_int + 1]] - quantifier <- ifelse(is.infinite(range[2]), "isGreaterOrEqual", NULL) + range = self$ranges[[h_int + 1]] + quantifier = ifelse(is.infinite(range[2]), "isGreaterOrEqual", NULL) list(min = range[1], max = ifelse(is.infinite(range[2]), NULL, range[2]), quantifier = quantifier) } else { @@ -1521,29 +1521,29 @@ CodeTable1600 <- R6Class("CodeTable1600", ) # Precipitation -Precipitation <- R6Class("Precipitation", +Precipitation = R6Class("Precipitation", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - kwargs <- list(...) - tenths <- ifelse(is.null(kwargs$tenths), FALSE, kwargs$tenths) + kwargs = list(...) + tenths = ifelse(is.null(kwargs$tenths), FALSE, kwargs$tenths) if (tenths) { - rrrr <- substr(group, 2, 5) - amount <- Amount24$new() + rrrr = substr(group, 2, 5) + amount = Amount24$new() list( amount = amount$decode(rrrr), time_before_obs = list(value = 24, unit = "h") ) } else { - rrr <- substr(group, 2, 4) - t <- substr(group, 5, 5) - amount <- Amount$new() + rrr = substr(group, 2, 4) + t = substr(group, 5, 5) + amount = Amount$new() list( amount = amount$decode(rrr), time_before_obs = TimeBeforeObs$new()$decode(t) @@ -1554,41 +1554,41 @@ Precipitation <- R6Class("Precipitation", ) # Amount (simplified) -Amount <- R6Class("Amount", +Amount = R6Class("Amount", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 3 - self$code_table <- CodeTable3590$new() - self$unit <- "mm" + self$code_len = 3 + self$code_table = CodeTable3590$new() + self$unit = "mm" } ) ) # Amount24 -Amount24 <- R6Class("Amount24", +Amount24 = R6Class("Amount24", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 - self$code_table <- CodeTable3590A$new() - self$unit <- "mm" + self$code_len = 4 + self$code_table = CodeTable3590A$new() + self$unit = "mm" } ) ) # CodeTable3590 (simplified) -CodeTable3590 <- R6Class("CodeTable3590", +CodeTable3590 = R6Class("CodeTable3590", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "3590" + self$table_name = "3590" }, decode_internal = function(RRR, ...) { - rrr_int <- as.integer(RRR) + rrr_int = as.integer(RRR) if (rrr_int <= 988) { list(value = rrr_int, quantifier = NULL, trace = FALSE) } else if (rrr_int == 989) { @@ -1605,15 +1605,15 @@ CodeTable3590 <- R6Class("CodeTable3590", ) # CodeTable3590A (simplified) -CodeTable3590A <- R6Class("CodeTable3590A", +CodeTable3590A = R6Class("CodeTable3590A", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "3590A" + self$table_name = "3590A" }, decode_internal = function(RRRR, ...) { - rrrr_int <- as.integer(RRRR) + rrrr_int = as.integer(RRRR) if (rrrr_int <= 9998) { list(value = round(rrrr_int * 0.1, 1), quantifier = NULL, trace = FALSE) } else if (rrrr_int == 9999) { @@ -1626,32 +1626,32 @@ CodeTable3590A <- R6Class("CodeTable3590A", ) # TimeBeforeObs (simplified) -TimeBeforeObs <- R6Class("TimeBeforeObs", +TimeBeforeObs = R6Class("TimeBeforeObs", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$code_table <- CodeTable4019$new() - self$unit <- "h" + self$code_len = 1 + self$code_table = CodeTable4019$new() + self$unit = "h" } ) ) # CodeTable4019 -CodeTable4019 <- R6Class("CodeTable4019", +CodeTable4019 = R6Class("CodeTable4019", inherit = CodeTable, public = list( values = c(NULL, 6, 12, 18, 24, 1, 2, 3, 9, 15), initialize = function() { - self$table_name <- "4019" + self$table_name = "4019" }, decode_internal = function(t, ...) { - t_int <- as.integer(t) + 1 + t_int = as.integer(t) + 1 if (t_int >= 1 && t_int <= length(self$values)) { - val <- self$values[[t_int]] + val = self$values[[t_int]] if (!is.null(val)) { list(value = val, unit = "h") } else { @@ -1665,20 +1665,20 @@ CodeTable4019 <- R6Class("CodeTable4019", ) # PressureTendency -PressureTendency <- R6Class("PressureTendency", +PressureTendency = R6Class("PressureTendency", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - a <- substr(group, 2, 2) - ppp <- substr(group, 3, 5) + a = substr(group, 2, 2) + ppp = substr(group, 3, 5) - tendency <- Tendency$new() - change <- Change$new() + tendency = Tendency$new() + change = Change$new() list( tendency = tendency$decode(a), @@ -1689,34 +1689,34 @@ PressureTendency <- R6Class("PressureTendency", ) # Tendency (simplified) -Tendency <- R6Class("Tendency", +Tendency = R6Class("Tendency", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 - self$valid_range <- c(0, 8) + self$code_len = 1 + self$valid_range = c(0, 8) } ) ) # Change (simplified) -Change <- R6Class("Change", +Change = R6Class("Change", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 3 - self$unit <- "hPa" + self$code_len = 3 + self$unit = "hPa" }, decode_convert = function(val, ...) { - kwargs <- list(...) - tendency <- kwargs$tendency + kwargs = list(...) + tendency = kwargs$tendency if (is.list(tendency) && "value" %in% names(tendency)) { - factor <- ifelse(tendency$value < 5, 10.0, -10.0) - val$value <- val$value / factor + factor = ifelse(tendency$value < 5, 10.0, -10.0) + val$value = val$value / factor } val } @@ -1724,35 +1724,35 @@ Change <- R6Class("Change", ) # Weather -Weather <- R6Class("Weather", +Weather = R6Class("Weather", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(group, ...) { - kwargs <- list(...) - w_type <- kwargs$type - ix <- kwargs$weather_indicator + kwargs = list(...) + w_type = kwargs$type + ix = kwargs$weather_indicator if (w_type == "present") { - table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4680", "4677") + table = ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4680", "4677") } else if (w_type == "past") { - table <- ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4531", "4561") + table = ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4531", "4561") } else { stop(paste("Invalid weather type:", w_type)) } - group_int <- as.integer(group) + group_int = as.integer(group) if (is.na(group_int)) { return(NULL) } - result <- list(value = group_int, `_table` = table) + result = list(value = group_int, `_table` = table) if (!is.null(kwargs$time_before)) { - result$time_before_obs <- kwargs$time_before + result$time_before_obs = kwargs$time_before } result @@ -1761,43 +1761,43 @@ Weather <- R6Class("Weather", ) # CloudType -CloudType <- R6Class("CloudType", +CloudType = R6Class("CloudType", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - nh <- substr(group, 2, 2) - cl <- substr(group, 3, 3) - cm <- substr(group, 4, 4) - ch <- substr(group, 5, 5) + nh = substr(group, 2, 2) + cl = substr(group, 3, 3) + cm = substr(group, 4, 4) + ch = substr(group, 5, 5) - low_cloud <- LowCloud$new() - middle_cloud <- MiddleCloud$new() - high_cloud <- HighCloud$new() - cloud_cover <- CloudCover$new() + low_cloud = LowCloud$new() + middle_cloud = MiddleCloud$new() + high_cloud = HighCloud$new() + cloud_cover = CloudCover$new() - result <- list( + result = list( low_cloud_type = low_cloud$decode(cl), middle_cloud_type = middle_cloud$decode(cm), high_cloud_type = high_cloud$decode(ch) ) - cover <- cloud_cover$decode(nh) + cover = cloud_cover$decode(nh) if (nh != "/") { if (!is.null(result$low_cloud_type) && result$low_cloud_type$value >= 1 && result$low_cloud_type$value <= 9) { - result$low_cloud_amount <- cover + result$low_cloud_amount = cover } else if (!is.null(result$middle_cloud_type) && result$middle_cloud_type$value >= 0 && result$middle_cloud_type$value <= 9) { - result$middle_cloud_amount <- cover + result$middle_cloud_amount = cover } else { - result$cloud_amount <- cover + result$cloud_amount = cover } } @@ -1807,53 +1807,53 @@ CloudType <- R6Class("CloudType", ) # LowCloud, MiddleCloud, HighCloud (simplified) -LowCloud <- R6Class("LowCloud", +LowCloud = R6Class("LowCloud", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 } ) ) -MiddleCloud <- R6Class("MiddleCloud", +MiddleCloud = R6Class("MiddleCloud", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 } ) ) -HighCloud <- R6Class("HighCloud", +HighCloud = R6Class("HighCloud", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 1 + self$code_len = 1 } ) ) # CloudLayer -CloudLayer <- R6Class("CloudLayer", +CloudLayer = R6Class("CloudLayer", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 4 + self$code_len = 4 }, decode_internal = function(group, ...) { - n <- substr(group, 2, 2) - c <- substr(group, 3, 3) - hh <- substr(group, 4, 5) + n = substr(group, 2, 2) + c = substr(group, 3, 3) + hh = substr(group, 4, 5) - cloud_cover <- CloudCover$new() - cloud_genus <- CloudGenus$new() - height <- Height$new() + cloud_cover = CloudCover$new() + cloud_genus = CloudGenus$new() + height = Height$new() list( cloud_cover = cloud_cover$decode(n), @@ -1865,29 +1865,29 @@ CloudLayer <- R6Class("CloudLayer", ) # Height (simplified) -Height <- R6Class("Height", +Height = R6Class("Height", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 - self$code_table <- CodeTable1677$new() - self$unit <- "m" + self$code_len = 2 + self$code_table = CodeTable1677$new() + self$unit = "m" } ) ) # CodeTable1677 (simplified) -CodeTable1677 <- R6Class("CodeTable1677", +CodeTable1677 = R6Class("CodeTable1677", inherit = CodeTable, public = list( initialize = function() { - self$table_name <- "1677" + self$table_name = "1677" }, decode_internal = function(hh, ...) { - hh_int <- as.integer(hh) - quantifier <- NULL + hh_int = as.integer(hh) + quantifier = NULL if (hh_int == 0) { list(value = 30, quantifier = "isLess") @@ -1909,87 +1909,87 @@ CodeTable1677 <- R6Class("CodeTable1677", ) # RelativeHumidity -RelativeHumidity <- R6Class("RelativeHumidity", +RelativeHumidity = R6Class("RelativeHumidity", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 3 - self$valid_range <- c(0, 100) - self$unit <- "%" + self$code_len = 3 + self$valid_range = c(0, 100) + self$unit = "%" } ) ) # HighestGust - Highest wind gust -HighestGust <- R6Class("HighestGust", +HighestGust = R6Class("HighestGust", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(group, ...) { - kwargs <- list(...) + kwargs = list(...) # Split group into separate groups if needed - groups <- strsplit(group, " ")[[1]] + groups = strsplit(group, " ")[[1]] # Get type, speed and direction # Format: 910ff or 911ff, optionally followed by 915dd - t <- NULL - ff <- NULL - dd <- NULL + t = NULL + ff = NULL + dd = NULL if (length(groups) > 0) { # First group: 910ff or 911ff - first_group <- groups[1] + first_group = groups[1] if (nchar(first_group) >= 5) { - t <- substr(first_group, 3, 3) - ff <- substr(first_group, 4, 5) + t = substr(first_group, 3, 3) + ff = substr(first_group, 4, 5) } } # Second group: 915dd (direction) if (length(groups) > 1) { - second_group <- groups[2] + second_group = groups[2] if (nchar(second_group) >= 5 && substr(second_group, 1, 3) == "915") { - dd <- substr(second_group, 4, 5) + dd = substr(second_group, 4, 5) } } # Return values - time_before <- kwargs$time_before - measure_period <- kwargs$measure_period + time_before = kwargs$time_before + measure_period = kwargs$measure_period - gust_obs <- Gust$new() - dir_obs <- DirectionDegrees$new() + gust_obs = Gust$new() + dir_obs = DirectionDegrees$new() - data <- list( + data = list( speed = gust_obs$decode(ff, unit = kwargs$unit), direction = dir_obs$decode(dd) ) if (!is.null(time_before)) { - data$time_before_obs <- time_before + data$time_before_obs = time_before } if (!is.null(measure_period)) { - data$measure_period <- measure_period + data$measure_period = measure_period } data }, encode_internal = function(data, ...) { - kwargs <- list(...) - time_before <- kwargs$time_before - measure_period <- kwargs$measure_period - output <- character(0) + kwargs = list(...) + time_before = kwargs$time_before + measure_period = kwargs$measure_period + output = character(0) # Handle list of gusts or single gust if (is.list(data) && "speed" %in% names(data)) { - data <- list(data) # Convert single gust to list + data = list(data) # Convert single gust to list } for (d in data) { @@ -1997,33 +1997,33 @@ HighestGust <- R6Class("HighestGust", if ("time_before_obs" %in% names(d)) { if (is.null(time_before) || (!is.null(time_before) && !identical(d$time_before_obs, time_before))) { - time_before_obs <- TimeBeforeObs$new() - tt <- time_before_obs$encode(d$time_before_obs) + time_before_obs = TimeBeforeObs$new() + tt = time_before_obs$encode(d$time_before_obs) if (tt != "//") { - output <- c(output, paste0("907", tt)) + output = c(output, paste0("907", tt)) } } - prefix <- "911" + prefix = "911" } else if ("measure_period" %in% names(d)) { if (identical(d$measure_period, list(value = 10, unit = "min"))) { - prefix <- "910" + prefix = "910" } else { stop("Invalid value for measure_period") } } else { - prefix <- "910" # Default + prefix = "910" # Default } # Convert the gust - gust_obs <- Gust$new() - ff <- gust_obs$encode(if ("speed" %in% names(d)) d$speed else NULL) - output <- c(output, paste0(prefix, ff)) + gust_obs = Gust$new() + ff = gust_obs$encode(if ("speed" %in% names(d)) d$speed else NULL) + output = c(output, paste0(prefix, ff)) # Convert the direction if ("direction" %in% names(d) && !is.null(d$direction)) { - dir_obs <- DirectionDegrees$new() - dd <- dir_obs$encode(d$direction) - output <- c(output, paste0("915", dd)) + dir_obs = DirectionDegrees$new() + dd = dir_obs$encode(d$direction) + output = c(output, paste0("915", dd)) } } @@ -2033,12 +2033,12 @@ HighestGust <- R6Class("HighestGust", ) # Gust - Wind gust speed (internal class for HighestGust) -Gust <- R6Class("Gust", +Gust = R6Class("Gust", inherit = Observation, public = list( initialize = function() { super$initialize() - self$code_len <- 2 + self$code_len = 2 }, decode_internal = function(ff, ...) { @@ -2051,7 +2051,7 @@ Gust <- R6Class("Gust", if (is.null(data)) { return(paste(rep(self$null_char, self$code_len), collapse = "")) } - value <- if (is.list(data)) data$value else data + value = if (is.list(data)) data$value else data if (!is.null(value) && value > 99) { return(paste0("99 00", sprintf("%02d", value))) } @@ -2065,8 +2065,8 @@ Gust <- R6Class("Gust", ################################################################################ # Helper function to create observation instances -create_observation <- function(class_name, ...) { - class_map <- list( +create_observation = function(class_name, ...) { + class_map = list( "CloudCover" = CloudCover, "CloudGenus" = CloudGenus, "Day" = Day, @@ -2091,35 +2091,35 @@ create_observation <- function(class_name, ...) { } # Example usage function -example_usage <- function() { +example_usage = function() { # Example: Decode temperature # Format: 1sTTT where s=0 (positive) or s=1 (negative), TTT=temperature - temp <- Temperature$new() - result <- temp$decode("10094") # Sign=0 (positive), TTT=094 -> 9.4°C + temp = Temperature$new() + result = temp$decode("10094") # Sign=0 (positive), TTT=094 -> 9.4°C print(result) # Negative temperature - result2 <- temp$decode("11094") # Sign=1 (negative), TTT=094 -> -9.4°C + result2 = temp$decode("11094") # Sign=1 (negative), TTT=094 -> -9.4°C print(result2) # Example: Encode temperature - encoded <- temp$encode(list(value = 19.4)) + encoded = temp$encode(list(value = 19.4)) print(encoded) # Example: Decode cloud cover - cloud <- CloudCover$new() - result <- cloud$decode("6") + cloud = CloudCover$new() + result = cloud$decode("6") print(result) # Example: Decode surface wind - wind <- SurfaceWind$new() - result <- wind$decode("1506") + wind = SurfaceWind$new() + result = wind$decode("1506") print(result) # Example: Decode full SYNOP - synop <- SYNOP$new() - synop_msg <- "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 81656 86070" - output <- synop$decode(synop_msg) + synop = SYNOP$new() + synop_msg = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 81656 86070" + output = synop$decode(synop_msg) print(output) } diff --git a/man/parser.Rd b/man/parser.Rd index 7c8e110..3312df4 100644 --- a/man/parser.Rd +++ b/man/parser.Rd @@ -27,6 +27,7 @@ returns their structured representation as generated by the \code{SYNOP} R6 decoder. } \examples{ -parser("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541") -parser(rep("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", 2), simplify = FALSE) +synop_code = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541" +parser(synop_code) +parser(rep(synop_code, 2), simplify = FALSE) } diff --git a/tests/testthat/test-hydro_imgw.R b/tests/testthat/test-hydro_imgw.R index 2892d46..429bef6 100644 --- a/tests/testthat/test-hydro_imgw.R +++ b/tests/testthat/test-hydro_imgw.R @@ -1,5 +1,5 @@ context("hydro_imgw") -y <- 2017 +y = 2017 test_that("hydro_imgw_not_available", { diff --git a/tests/testthat/test-hydro_metadata_imgw.R b/tests/testthat/test-hydro_metadata_imgw.R index 62982d4..ef2319e 100644 --- a/tests/testthat/test-hydro_metadata_imgw.R +++ b/tests/testthat/test-hydro_metadata_imgw.R @@ -1,7 +1,7 @@ context("hydro-metadata") -h_d <- suppressWarnings(hydro_metadata_imgw("daily")) -h_m <- suppressWarnings(hydro_metadata_imgw("monthly")) +h_d = suppressWarnings(hydro_metadata_imgw("daily")) +h_m = suppressWarnings(hydro_metadata_imgw("monthly")) test_that("hydro-metadata works!", { if (is.list(h_d)) { diff --git a/tests/testthat/test-meteo_imgw.R b/tests/testthat/test-meteo_imgw.R index ba1940a..1c13c94 100644 --- a/tests/testthat/test-meteo_imgw.R +++ b/tests/testthat/test-meteo_imgw.R @@ -1,5 +1,5 @@ context("meteo_imgw") -y <- 2018 +y = 2018 test_that("meteo_imgw works!", { @@ -7,20 +7,20 @@ test_that("meteo_imgw works!", { message("No internet connection! \n") return(invisible(NULL)) } else { - x <- meteo_imgw("hourly", "synop", year = y) - x <- meteo_imgw("hourly", "climate", year = y) - expect_message(x <- meteo_imgw("hourly", "precip", year = y)) - x <- meteo_imgw("daily", "synop", year = y) - x <- meteo_imgw("daily", "climate", year = y) - x <- meteo_imgw("daily", "precip", year = y) - x <- meteo_imgw("monthly", "synop", year = y) - x <- meteo_imgw("monthly", "climate", year = y) - x <- meteo_imgw("monthly", "precip", year = y) - x <- meteo_imgw("monthly", "synop", year = y, status = TRUE) - x <- meteo_imgw("monthly", "synop", year = y, coords = TRUE) - x <- meteo_imgw("monthly", "synop", year = y, col_names = "full") - x <- meteo_imgw("monthly", "synop", year = y, coords = TRUE, col_names = "polish") - testthat::expect_message(x <- suppressWarnings(meteo_imgw_daily(rank = "synop", year = 2001, station = "blabla"))) + x = meteo_imgw("hourly", "synop", year = y) + x = meteo_imgw("hourly", "climate", year = y) + expect_message(x = meteo_imgw("hourly", "precip", year = y)) + x = meteo_imgw("daily", "synop", year = y) + x = meteo_imgw("daily", "climate", year = y) + x = meteo_imgw("daily", "precip", year = y) + x = meteo_imgw("monthly", "synop", year = y) + x = meteo_imgw("monthly", "climate", year = y) + x = meteo_imgw("monthly", "precip", year = y) + x = meteo_imgw("monthly", "synop", year = y, status = TRUE) + x = meteo_imgw("monthly", "synop", year = y, coords = TRUE) + x = meteo_imgw("monthly", "synop", year = y, col_names = "full") + x = meteo_imgw("monthly", "synop", year = y, coords = TRUE, col_names = "polish") + testthat::expect_message(x = suppressWarnings(meteo_imgw_daily(rank = "synop", year = 2001, station = "blabla"))) leszno = meteo_imgw(interval = "monthly", rank = "synop", year = 2020:2021, station = "LESZNO") testthat::expect_equal(nrow(leszno), 24) } diff --git a/tests/testthat/test-nearest_stations_ogimet.R b/tests/testthat/test-nearest_stations_ogimet.R index 5da2dee..689599c 100644 --- a/tests/testthat/test-nearest_stations_ogimet.R +++ b/tests/testthat/test-nearest_stations_ogimet.R @@ -2,14 +2,14 @@ context("meteo_imgw") test_that("nearest_stations_ogimet works!", { - x <- nearest_stations_ogimet(country = "United Kingdom", point = c(-10, -50), add_map = TRUE, no_of_stations = 10) + x = nearest_stations_ogimet(country = "United Kingdom", point = c(-10, -50), add_map = TRUE, no_of_stations = 10) if (is.data.frame(x) && ncol(x) > 5) { testthat::expect_equal(nrow(x), 10) } Sys.sleep(21) - x <- nearest_stations_ogimet(country = "Poland", point = c(10, 50), add_map = TRUE, no_of_stations = 10) + x = nearest_stations_ogimet(country = "Poland", point = c(10, 50), add_map = TRUE, no_of_stations = 10) if (is.data.frame(x) && ncol(x) > 5) { testthat::expect_equal(nrow(x), 10) @@ -22,7 +22,7 @@ test_that("nearest_stations_ogimet works!", { # allow_failure = FALSE, # no_of_stations = 10)) - x <- nearest_stations_ogimet(country = c("United Kingdom", "Poland"), point = c(0, 0), add_map = TRUE, no_of_stations = 150) + x = nearest_stations_ogimet(country = c("United Kingdom", "Poland"), point = c(0, 0), add_map = TRUE, no_of_stations = 150) if (is.data.frame(x) && ncol(x) > 5) { expect_true(mean(x$distance) > 5000) } diff --git a/vignettes/articles/usecase_ogimet.Rmd b/vignettes/articles/usecase_ogimet.Rmd index 7d31e0b..3da4e5e 100644 --- a/vignettes/articles/usecase_ogimet.Rmd +++ b/vignettes/articles/usecase_ogimet.Rmd @@ -15,7 +15,7 @@ knitr::opts_chunk$set(echo = TRUE) ```{r,warning=FALSE} library(climate) # downloading data -df <- meteo_ogimet(interval = "hourly", +df = meteo_ogimet(interval = "hourly", date = c("2018-01-01", "2018-12-31"), station = "01008") @@ -24,16 +24,16 @@ library(dplyr) library(openair) # external package for plotting wind roses # converting wind direction from character into degress required by most -wdir <- data.frame(ddd = c("CAL","N","NNE","NE","ENE","E","ESE","SE","SSE", +wdir = data.frame(ddd = c("CAL","N","NNE","NE","ENE","E","ESE","SE","SSE", "S","SSW","SW","WSW","W","WNW","NW","NNW"), dir = c(NA, 0:15 * 22.5), stringsAsFactors = FALSE) # changing date column to the format required by openair package: -df$Date <- as.POSIXct(df$Date, tz = "UTC") -df$date <- df$Date -df <- left_join(df, wdir) +df$Date = as.POSIXct(df$Date, tz = "UTC") +df$date = df$Date +df = left_join(df, wdir) -df$ws <- df$ffkmh / 3.6 # conversion to m/s from km/h -df$gust <- as.numeric(df$Gustmax) / 3.6 # conversion to m/s from km/h +df$ws = df$ffkmh / 3.6 # conversion to m/s from km/h +df$gust = as.numeric(df$Gustmax) / 3.6 # conversion to m/s from km/h windRose(mydata = df, ws = "ws", wd = "dir", type = "season", paddle = FALSE, main = "Svalbard Lufthavn (2018)", ws.int = 3, dig.lab = 3, layout = c(4, 1)) diff --git a/vignettes/getstarted.Rmd b/vignettes/getstarted.Rmd index 721241e..880490d 100644 --- a/vignettes/getstarted.Rmd +++ b/vignettes/getstarted.Rmd @@ -14,7 +14,7 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) -old <- options(scipen = 999) +old = options(scipen = 999) ``` The goal of the **climate** R package is to automatize downloading of meteorological @@ -131,7 +131,7 @@ colnames(df2)[c(1, 3:4)] = c("PRESS", "TEMP", "DEWPT") # changing column names ``` ```{r sonda, eval=F, include=T} -profile_demo <- sounding_wyoming(wmo_id = 12120, +profile_demo = sounding_wyoming(wmo_id = 12120, yy = 2000, mm = 3, dd = 23, From 77f9a42a8b2ed837e9603531cd25dc53ac3fee65 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sat, 9 May 2026 16:36:39 +0200 Subject: [PATCH 10/16] fix vignette --- .Rbuildignore | 2 +- vignettes/articles/usecase_ogimet.Rmd | 17 +++++++++++------ 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 699112d..7c282fe 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -20,4 +20,4 @@ vignettes/articles/usecase.Rmd ^.covrignore$ ^\.positai$ ^\.claude$ -^\.CLAUDE.md$ +CLAUDE.md$ diff --git a/vignettes/articles/usecase_ogimet.Rmd b/vignettes/articles/usecase_ogimet.Rmd index 3da4e5e..16c39a1 100644 --- a/vignettes/articles/usecase_ogimet.Rmd +++ b/vignettes/articles/usecase_ogimet.Rmd @@ -16,26 +16,31 @@ knitr::opts_chunk$set(echo = TRUE) library(climate) # downloading data df = meteo_ogimet(interval = "hourly", - date = c("2018-01-01", "2018-12-31"), - station = "01008") + date = c("2018-01-01", "2018-12-31"), + station = "01008") # loading external packages: library(dplyr) library(openair) # external package for plotting wind roses +print(paste("dplyr version:", packageVersion("dplyr"))) +print(paste("openair version:", packageVersion("openair"))) # converting wind direction from character into degress required by most wdir = data.frame(ddd = c("CAL","N","NNE","NE","ENE","E","ESE","SE","SSE", - "S","SSW","SW","WSW","W","WNW","NW","NNW"), + "S","SSW","SW","WSW","W","WNW","NW","NNW"), dir = c(NA, 0:15 * 22.5), stringsAsFactors = FALSE) # changing date column to the format required by openair package: df$Date = as.POSIXct(df$Date, tz = "UTC") df$date = df$Date -df = left_join(df, wdir) +df = dplyr::left_join(df, wdir) df$ws = df$ffkmh / 3.6 # conversion to m/s from km/h df$gust = as.numeric(df$Gustmax) / 3.6 # conversion to m/s from km/h -windRose(mydata = df, ws = "ws", wd = "dir", type = "season", paddle = FALSE, - main = "Svalbard Lufthavn (2018)", ws.int = 3, dig.lab = 3, layout = c(4, 1)) +openair::windRose(mydata = df, ws = "ws", wd = "dir", + type = "season", paddle = FALSE, + main = "Svalbard Lufthavn (2018)", + ws.int = 3, dig.lab = 3, + layout = c(4, 1)) # do we miss any data? openair::summaryPlot(df[ ,c("date", "TC", "ws", "gust")]) From 71683de150a28da74b1294a72e97075ee0ad6576 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sat, 9 May 2026 16:50:47 +0200 Subject: [PATCH 11/16] fix vignette --- vignettes/articles/usecase_ogimet.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/articles/usecase_ogimet.Rmd b/vignettes/articles/usecase_ogimet.Rmd index 16c39a1..14ab77b 100644 --- a/vignettes/articles/usecase_ogimet.Rmd +++ b/vignettes/articles/usecase_ogimet.Rmd @@ -43,7 +43,7 @@ openair::windRose(mydata = df, ws = "ws", wd = "dir", layout = c(4, 1)) # do we miss any data? -openair::summaryPlot(df[ ,c("date", "TC", "ws", "gust")]) +openair::timePlot(df, pollutant = c("TC", "ws")) # which sectors are responsible for warm/cold air mass advection: openair::polarPlot(df, pollutant = "TC", x = "ws", wd = "dir", k = 50, force.positive = FALSE, From 6790e9f047d3304c31c6b5fb534c0c6de6692036 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sun, 10 May 2026 00:08:23 +0200 Subject: [PATCH 12/16] fix unit tests for meteo-imgw --- tests/testthat/test-meteo_imgw.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-meteo_imgw.R b/tests/testthat/test-meteo_imgw.R index 1c13c94..ffb0fb0 100644 --- a/tests/testthat/test-meteo_imgw.R +++ b/tests/testthat/test-meteo_imgw.R @@ -9,7 +9,7 @@ test_that("meteo_imgw works!", { } else { x = meteo_imgw("hourly", "synop", year = y) x = meteo_imgw("hourly", "climate", year = y) - expect_message(x = meteo_imgw("hourly", "precip", year = y)) + expect_message(meteo_imgw("hourly", "precip", year = y)) x = meteo_imgw("daily", "synop", year = y) x = meteo_imgw("daily", "climate", year = y) x = meteo_imgw("daily", "precip", year = y) @@ -20,7 +20,7 @@ test_that("meteo_imgw works!", { x = meteo_imgw("monthly", "synop", year = y, coords = TRUE) x = meteo_imgw("monthly", "synop", year = y, col_names = "full") x = meteo_imgw("monthly", "synop", year = y, coords = TRUE, col_names = "polish") - testthat::expect_message(x = suppressWarnings(meteo_imgw_daily(rank = "synop", year = 2001, station = "blabla"))) + expect_message(suppressWarnings(meteo_imgw_daily(rank = "synop", year = 2001, station = "blabla"))) leszno = meteo_imgw(interval = "monthly", rank = "synop", year = 2020:2021, station = "LESZNO") testthat::expect_equal(nrow(leszno), 24) } From ca8d294922feeab9e922245591bd7a7537f0bf44 Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sun, 10 May 2026 00:23:53 +0200 Subject: [PATCH 13/16] add parser unit-tests --- R/parser.R | 13 +- inst/parser.R | 2126 ---------------------------------- tests/testthat/test-parser.R | 183 +++ 3 files changed, 189 insertions(+), 2133 deletions(-) delete mode 100644 inst/parser.R create mode 100644 tests/testthat/test-parser.R diff --git a/R/parser.R b/R/parser.R index f16935c..8fc1148 100644 --- a/R/parser.R +++ b/R/parser.R @@ -20,7 +20,6 @@ #' parser(rep(synop_code, 2), simplify = FALSE) #' @import R6 #' @export - parser = function(message, country = NULL, simplify = TRUE) { if (missing(message) || length(message) == 0) { stop("`message` must contain at least one SYNOP string.") @@ -416,7 +415,7 @@ SignedTemperature = R6Class("SignedTemperature", initialize = function() { super$initialize() self$code_len = 4 - self$unit = "Cel" + self$unit = "Celsius" }, decode_internal = function(raw, ...) { @@ -942,7 +941,7 @@ SYNOP = R6Class("SYNOP", get_next_group = function() { if (group_idx <= length(groups)) { group = groups[group_idx] - group_idx <= group_idx + 1 + group_idx <<- group_idx + 1 return(group) } return(NULL) @@ -1107,11 +1106,11 @@ SYNOP = R6Class("SYNOP", as.integer(substr(next_grp, 1, 1)) }, error = function(e) { warning(paste("Unable to parse header from group:", next_grp)) - next_grp <= next_group() + next_grp <<- next_group() return(NULL) }, warning = function(w) { warning(paste("Warning parsing header from group:", next_grp)) - next_grp <= next_group() + next_grp <<- next_group() return(NULL) }) @@ -1359,10 +1358,10 @@ SYNOP = R6Class("SYNOP", } }, error = function(e) { warning(paste("Error decoding group 9 code:", g, "-", e$message)) - idx <= idx + 1 + idx <<- idx + 1 }, warning = function(w) { warning(paste("Warning decoding group 9 code:", g, "-", w$message)) - idx <= idx + 1 + idx <<- idx + 1 }) } } diff --git a/inst/parser.R b/inst/parser.R deleted file mode 100644 index 808a963..0000000 --- a/inst/parser.R +++ /dev/null @@ -1,2126 +0,0 @@ -#' Parse SYNOP messages into structured lists -#' -#' This function wraps the SYNOP decoding logic that was previously distributed -#' with the package in `inst/extdata`. It parses one or more SYNOP messages and -#' returns their structured representation as generated by the `SYNOP` R6 -#' decoder. -#' -#' @param message Character vector with SYNOP messages. -#' @param country Optional single character value passed to the precipitation -#' indicator decoder to adjust country-specific behaviour (e.g. `"RU"`). -#' @param simplify Logical. If `TRUE` (default) and a single message is -#' provided, the function returns the decoded list directly instead of a -#' length-one list. -#' -#' @return A list of decoded SYNOP messages. When `simplify = TRUE` and a single -#' message is supplied, the corresponding decoded list is returned directly. -#' @examples -#' parser("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541") -#' parser(rep("AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", 2), simplify = FALSE) -#' @import R6 -#' @export -parser = function(message, country = NULL, simplify = TRUE) { - if (missing(message) || length(message) == 0) { - stop("`message` must contain at least one SYNOP string.") - } - - if (!is.character(message)) { - stop("`message` must be a character vector.") - } - - if (!is.null(country) && !(is.character(country) && length(country) %in% c(1, length(message)))) { - stop("`country` must be NULL, a single string, or a character vector matching the length of `message`.") - } - - country_vec = if (is.null(country)) rep(list(NULL), length(message)) else as.list(rep(country, length.out = length(message))) - - results = mapply( - function(msg, cntry) { - msg = trimws(msg) - if (nzchar(msg)) { - synop = SYNOP$new() - synop$country = cntry - synop$decode(msg) - } else { - warning("Empty SYNOP message supplied; returning NULL.") - NULL - } - }, - message, - country_vec, - SIMPLIFY = FALSE - ) - - if (simplify && length(results) == 1) { - return(results[[1]]) - } - - results -} - -################################################################################ -# observations.R -# -# Observation classes from SYNOP - R version -# -# This is an R port of pymetdecoder/synop/observations.py -# Adapted from Python to R using R6 classes and functional approach -################################################################################ - -################################################################################ -# BASE CLASSES -################################################################################ - -# Base Observation class -Observation = R6Class("Observation", - public = list( - null_char = "/", - code_len = NULL, - code_table = NULL, - unit = NULL, - valid_range = NULL, - - initialize = function(null_char = "/") { - self$null_char = null_char - }, - - # Check if value is available (not all null chars) - is_available = function(value, char = NULL) { - if (is.null(char)) char = self$null_char - if (is.null(value)) return(FALSE) - value_str = as.character(value) - !all(strsplit(value_str, "")[[1]] == char) - }, - - # Check if value is valid - is_valid = function(value, raise_exception = TRUE, name = NULL, ...) { - tryCatch({ - valid = private$check_valid(value, ...) - if (!valid && raise_exception) { - stop(paste0(value, " is not a valid code for ", ifelse(is.null(name), class(self)[1], name))) - } - valid - }, error = function(e) { - if (raise_exception) { - stop(e) - } - FALSE - }, warning = function(w) { - if (raise_exception) { - stop(w) - } - FALSE - }) - }, - - # Decode raw value - decode = function(raw, ...) { - kwargs = list(...) - - # Check if available - if (!self$is_available(raw)) { - return(NULL) - } - - # Check if valid - if (!self$is_valid(raw, raise_exception = FALSE, ...)) { - return(NULL) - } - - # Decode - tryCatch({ - self$decode_internal(raw, ...) - }, error = function(e) { - warning(paste("Unable to decode:", raw)) - NULL - }) - }, - - # Encode observation - encode = function(data, ...) { - kwargs = list(...) - allow_none = ifelse(is.null(kwargs$allow_none), FALSE, kwargs$allow_none) - - tryCatch({ - if (is.null(data) || (is.list(data) && is.null(data$value))) { - if (allow_none || !is.null(self$code_table)) { - self$encode_internal(data, ...) - } else { - paste(rep(self$null_char, self$code_len), collapse = "") - } - } else { - self$encode_internal(data, ...) - } - }, error = function(e) { - warning(paste("Unable to encode:", toString(data))) - paste(rep(self$null_char, self$code_len), collapse = "") - }) - }, - - # Internal decode method (to be overridden) - decode_internal = function(raw, ...) { - if (!is.null(self$components) && length(self$components) > 0) { - # Handle components - result = list() - for (comp in self$components) { - comp_class = comp[[4]] - comp_obj = comp_class$new() - result[[comp[[1]]]] = comp_obj$decode( - substr(raw, comp[[2]] + 1, comp[[2]] + comp[[3]]) - ) - } - result - } else { - self$decode_value(raw, ...) - } - }, - - # Internal encode method (to be overridden) - encode_internal = function(data, ...) { - if (!is.null(self$components)) { - # Handle components - result = character(0) - for (comp in self$components) { - comp_class = comp[[4]] - comp_obj = comp_class$new() - result = c(result, comp_obj$encode( - if (comp[[1]] %in% names(data)) data[[comp[[1]]]] else NULL - )) - } - paste(result, collapse = "") - } else { - self$encode_value(data, ...) - } - }, - - # Decode value (uses code table if available) - decode_value = function(val, ...) { - kwargs = list(...) - - # Check if value is available - if (!self$is_available(val)) { - return(NULL) - } - - # Get unit - unit = if (is.null(kwargs$unit)) self$unit else kwargs$unit - - # Get value from code table - if (!is.null(self$code_table)) { - out_val = tryCatch({ - self$code_table$decode(val, ...) - }, error = function(e) { - warning(paste("Error decoding with code table:", val, "-", e$message)) - NULL - }, warning = function(w) { - warning(paste("Warning decoding with code table:", val, "-", w$message)) - NULL - }) - - if (!is.null(out_val) && !is.list(out_val)) { - out_val = list(value = out_val) - } - if (!is.null(out_val) && !("_code" %in% names(out_val))) { - code_val = suppressWarnings(as.integer(val)) - if (!is.na(code_val)) { - out_val[["_code"]] = code_val - } - } - } else { - # No code table - just convert to integer - out_val = tryCatch({ - code_val = suppressWarnings(as.integer(val)) - if (is.na(code_val)) { - return(NULL) - } - code_val - }, warning = function(w) { - NULL - }, error = function(e) { - NULL - }) - - if (is.null(out_val)) { - return(NULL) - } - - out_val = list(value = out_val) - } - - if (is.null(out_val)) return(NULL) - - # Convert to int if not a list - if (!is.list(out_val)) { - out_val = list(value = as.integer(out_val)) - } - - # Perform post conversion - out_val = self$decode_convert(out_val, ...) - - # Add unit if specified - if (!is.null(unit)) { - out_val$unit = unit - } - - out_val - }, - - # Encode value - encode_value = function(data, ...) { - # Get value from code table or data - if (!is.null(self$code_table)) { - out_val = self$code_table$encode(data) - } else { - out_val = if ("value" %in% names(data)) data$value else data - } - - # Convert value - out_val = self$encode_convert(out_val, ...) - - # Format code - if (is.null(self$code_len)) { - return(as.character(out_val)) - } - sprintf(paste0("%0", self$code_len, "d"), as.integer(out_val)) - }, - - # Conversion methods (to be overridden) - decode_convert = function(val, ...) { - val - }, - - encode_convert = function(val, ...) { - val - } - ), - - private = list( - check_valid = function(value, ...) { - tryCatch({ - # Check if value is available - if (!self$is_available(value)) { - return(TRUE) - } - - # Check valid range - if (!is.null(self$valid_range)) { - val_num = suppressWarnings(as.numeric(value)) - if (is.na(val_num)) { - return(FALSE) - } - if (val_num >= self$valid_range[1] && val_num <= self$valid_range[2]) { - return(TRUE) - } - return(FALSE) - } - - # If we reach here, assume valid - TRUE - }, error = function(e) { - FALSE - }, warning = function(w) { - FALSE - }) - } - ) -) - -################################################################################ -# SHARED CLASSES -################################################################################ - -CloudCover = R6Class("CloudCover", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$code_table = CodeTable2700$new() - self$unit = "okta" - } - ) -) - -CloudGenus = R6Class("CloudGenus", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$code_table = CodeTable0500$new() - } - ) -) - -Day = R6Class("Day", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - self$valid_range = c(1, 31) - } - ) -) - -DirectionCardinal = R6Class("DirectionCardinal", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$code_table = CodeTable0700$new() - } - ) -) - -DirectionDegrees = R6Class("DirectionDegrees", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - self$code_table = CodeTable0877$new() - self$unit = "deg" - } - ) -) - -Hour = R6Class("Hour", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - self$valid_range = c(0, 24) - } - ) -) - -Minute = R6Class("Minute", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - self$valid_range = c(0, 59) - } - ) -) - -SignedTemperature = R6Class("SignedTemperature", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - self$unit = "Cel" - }, - - decode_internal = function(raw, ...) { - kwargs = list(...) - sign = kwargs$sign - - if (is.null(sign) || sign == "/") { - return(NULL) - } - - if (!sign %in% c("0", "1")) { - stop(paste(sign, "is not a valid temperature sign")) - } - - self$decode_value(raw, sign = sign) - }, - - decode_convert = function(val, ...) { - kwargs = list(...) - sign = kwargs$sign - if (is.null(sign)) return(val) - - factor = ifelse(sign == "0", 10, -10) - val$value = val$value / factor - val - }, - - encode_convert = function(val, ...) { - sign_char = ifelse(val >= 0, "0", "1") - abs_val = abs(val * 10) - paste0(sign_char, sprintf("%03d", as.integer(abs_val))) - } - ) -) - -Visibility = R6Class("Visibility", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - self$code_table = CodeTable4377$new() - self$unit = "m" - }, - - encode_internal = function(data, ...) { - kwargs = list(...) - use90 = ifelse(is.null(kwargs$use90), - ifelse("use90" %in% names(data), data$use90, FALSE), - kwargs$use90) - self$encode_value(data, use90 = use90) - } - ) -) - -################################################################################ -# CODE TABLE CLASSES (simplified versions) -################################################################################ - -# Base CodeTable class -CodeTable = R6Class("CodeTable", - public = list( - table_name = NULL, - - decode = function(value, ...) { - tryCatch({ - result = self$decode_internal(value, ...) - if (!is.null(result)) { - result$`_table` = self$table_name - } - result - }, error = function(e) { - warning(paste("Unable to decode", value, "in", class(self)[1])) - NULL - }) - }, - - encode = function(value, ...) { - if (is.null(value)) return(NULL) - if (is.list(value) && "_code" %in% names(value)) { - return(value$`_code`) - } - self$encode_internal(value, ...) - }, - - decode_internal = function(value, ...) { - stop("decode_internal must be implemented in subclass") - }, - - encode_internal = function(value, ...) { - stop("encode_internal must be implemented in subclass") - } - ) -) - -# CodeTable2700 - Total cloud cover -CodeTable2700 = R6Class("CodeTable2700", - inherit = CodeTable, - public = list( - initialize = function() { - self$table_name = "2700" - }, - - decode_internal = function(N, ...) { - n = as.integer(N) - if (n == 9) { - list(value = NULL, obscured = TRUE, unit = "okta") - } else { - list(value = n, obscured = FALSE, unit = "okta") - } - }, - - encode_internal = function(data, ...) { - if (is.null(data$value)) { - if (data$obscured) return("9") - stop("Cannot encode cloud cover: value is NULL and obscured is FALSE") - } - as.character(data$value) - } - ) -) - -# CodeTable0500 - Genus of cloud -CodeTable0500 = R6Class("CodeTable0500", - inherit = CodeTable, - public = list( - values = c("Ci", "Cc", "Cs", "Ac", "As", "Ns", "Sc", "St", "Cu", "Cb"), - - initialize = function() { - self$table_name = "0500" - }, - - decode_internal = function(i, ...) { - idx = as.integer(i) + 1 - if (idx >= 1 && idx <= length(self$values)) { - list(value = self$values[idx]) - } else { - stop(paste("Invalid cloud genus code:", i)) - } - }, - - encode_internal = function(data, ...) { - val = if (is.list(data)) data$value else data - idx = which(self$values == val) - if (length(idx) == 0) { - stop(paste("Invalid cloud genus:", val)) - } - as.character(idx - 1) - } - ) -) - -# CodeTable0700 - Direction or bearing in one figure -CodeTable0700 = R6Class("CodeTable0700", - inherit = CodeTable, - public = list( - directions = c(NULL, "NE", "E", "SE", "S", "SW", "W", "NW", "N", NULL), - - initialize = function() { - self$table_name = "0700" - }, - - decode_internal = function(D, ...) { - if (D == "/") { - return(list(value = NULL, isCalmOrStationary = NULL, allDirections = NULL)) - } - - d = as.integer(D) - isCalmOrStationary = (d == 0) - allDirections = (d == 9) - - direction = if (d >= 0 && d < length(self$directions)) { - self$directions[d + 1] - } else { - NULL - } - - list( - value = direction, - isCalmOrStationary = isCalmOrStationary, - allDirections = allDirections - ) - }, - - encode_internal = function(data, ...) { - if ("isCalmOrStationary" %in% names(data) && data$isCalmOrStationary) { - return("0") - } - if ("allDirections" %in% names(data) && data$allDirections) { - return("9") - } - if ("value" %in% names(data) && !is.null(data$value)) { - idx = which(self$directions == data$value) - 1 - if (length(idx) > 0) { - return(as.character(idx)) - } - } - stop("Cannot encode direction") - } - ) -) - -# CodeTable0877 - True direction in tens of degrees -CodeTable0877 = R6Class("CodeTable0877", - inherit = CodeTable, - public = list( - initialize = function() { - self$table_name = "0877" - }, - - decode_internal = function(dd, ...) { - dd_int = as.integer(dd) - calm = (dd_int == 0) - varAllUnknown = (dd_int == 99) - - if (calm) { - direction = NULL - } else if (varAllUnknown) { - direction = NULL - } else if (dd_int >= 1 && dd_int <= 36) { - direction = dd_int * 10 - } else { - stop(paste("Invalid direction code:", dd)) - } - - list( - value = direction, - varAllUnknown = varAllUnknown, - calm = calm - ) - }, - - encode_internal = function(data, ...) { - val = if (is.list(data)) data$value else data - if (is.null(val)) { - if ("calm" %in% names(data) && data$calm) return("00") - if ("varAllUnknown" %in% names(data) && data$varAllUnknown) return("99") - return("//") - } - code = round(val / 10) - if (code < 1) code = 0 - if (code > 36) code = 36 - sprintf("%02d", code) - } - ) -) - -# CodeTable4377 - Horizontal visibility at surface -CodeTable4377 = R6Class("CodeTable4377", - inherit = CodeTable, - public = list( - range90 = list( - c(0, 50), c(50, 200), c(200, 500), c(500, 1000), c(1000, 2000), - c(2000, 4000), c(4000, 10000), c(10000, 20000), c(20000, 50000), - c(50000, Inf) - ), - - initialize = function() { - self$table_name = "4377" - }, - - decode_internal = function(VV, ...) { - vv = as.integer(VV) - - if (vv >= 51 && vv <= 55) { - stop(paste("Invalid visibility code:", VV)) - } - - visibility = NULL - quantifier = NULL - - if (vv == 0) { - visibility = 100 - quantifier = "isLess" - } else if (vv <= 50) { - visibility = vv * 100 - } else if (vv <= 80) { - visibility = (vv - 50) * 1000 - } else if (vv <= 88) { - visibility = (vv - 74) * 5000 - } else if (vv == 89) { - visibility = 70000 - quantifier = "isGreater" - } else if (vv == 90) { - visibility = 50 - quantifier = "isLess" - } else if (vv == 91) { - visibility = 50 - } else if (vv == 92) { - visibility = 200 - } else if (vv == 93) { - visibility = 500 - } else if (vv == 94) { - visibility = 1000 - } else if (vv == 95) { - visibility = 2000 - } else if (vv == 96) { - visibility = 4000 - } else if (vv == 97) { - visibility = 10000 - } else if (vv == 98) { - visibility = 20000 - } else if (vv == 99) { - visibility = 50000 - quantifier = "isGreaterOrEqual" - } else { - stop(paste("Invalid visibility code:", VV)) - } - - use90 = (vv >= 90) - list( - value = visibility, - quantifier = quantifier, - use90 = use90 - ) - }, - - encode_internal = function(data, use90 = FALSE, ...) { - value = if (is.list(data)) data$value else data - quantifier = if (is.list(data) && "quantifier" %in% names(data)) data$quantifier else NULL - - if (use90) { - for (idx in seq_along(self$range90)) { - r = self$range90[[idx]] - if (value >= r[1] && value < r[2]) { - return(sprintf("%02d", idx + 89)) - } - } - } else { - if (value < 100) { - code = 0 - } else if (value <= 5000) { - code = floor(value / 100) - } else if (value <= 30000) { - code = floor(value / 1000) + 50 - } else if (value <= 70000 && is.null(quantifier)) { - code = floor(value / 5000) + 74 - } else { - code = 89 - } - return(sprintf("%02d", code)) - } - - stop(paste("Cannot encode visibility:", value)) - } - ) -) - -################################################################################ -# MAIN OBSERVATION CLASSES -################################################################################ - -# Temperature observation -Temperature = R6Class("Temperature", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - }, - - decode_internal = function(group, ...) { - sn = substr(group, 2, 2) - TTT = substr(group, 3, 5) - - # Fix trailing "/" (issue #10) - if (TTT != "///") { - TTT = sub("/$", "0", TTT) - } - - if (!sn %in% c("0", "1", "/")) { - warning(paste(group, "is an invalid temperature group")) - return(NULL) - } - - temp_obs = SignedTemperature$new() - temp_obs$decode(TTT, sign = sn) - }, - - encode_internal = function(data, ...) { - temp_obs = SignedTemperature$new() - temp_obs$encode(data) - } - ) -) - -# Pressure observation -Pressure = R6Class("Pressure", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - self$unit = "hPa" - }, - - decode_convert = function(val, ...) { - val_int = as.integer(val$value) - val$value = (val_int / 10) + ifelse(val_int > 5000, 0, 1000) - val - }, - - encode_convert = function(val, ...) { - abs(val * 10) - ifelse(val >= 1000, 10000, 0) - } - ) -) - -# Surface wind observation -SurfaceWind = R6Class("SurfaceWind", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - }, - - decode_internal = function(ddff, ...) { - dd = substr(ddff, 1, 2) - ff = substr(ddff, 3, 4) - - dir_obs = DirectionDegrees$new() - direction = dir_obs$decode(dd) - - speed_obs = WindSpeed$new() - speed = speed_obs$decode(ff) - - # Sanity check: if wind is calm, it can't have a speed - if (!is.null(direction) && !is.null(direction$calm) && direction$calm && - !is.null(speed) && !is.null(speed$value) && speed$value > 0) { - warning(paste("Wind is calm, yet has a speed (dd:", dd, ", ff:", ff, ")")) - speed = NULL - } - - list(direction = direction, speed = speed) - }, - - encode_internal = function(data, ...) { - dir_obs = DirectionDegrees$new() - speed_obs = WindSpeed$new() - - dd = dir_obs$encode(if ("direction" %in% names(data)) data$direction else NULL, allow_none = TRUE) - ff = speed_obs$encode(if ("speed" %in% names(data)) data$speed else NULL) - - paste0(dd, ff) - } - ) -) - -# Wind speed (simplified) -WindSpeed = R6Class("WindSpeed", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - }, - - decode_internal = function(ff, ...) { - # Decode wind speed - ff is just a numeric value - # Use the base decode_value method which handles numeric conversion - self$decode_value(ff, ...) - }, - - encode_internal = function(data, ...) { - if (is.null(data)) { - return(paste(rep(self$null_char, self$code_len), collapse = "")) - } - value = if (is.list(data)) data$value else data - if (!is.null(value) && value > 99) { - return(paste0("99 00", sprintf("%02d", value))) - } - sprintf("%02d", as.integer(value)) - } - ) -) - -################################################################################ -# SYNOP REPORT CLASS -################################################################################ - -# Base Report class -Report = R6Class("Report", - public = list( - not_implemented = list(), - - decode = function(message) { - tryCatch({ - self$decode_internal(message) - }, error = function(e) { - stop(paste("Decode error:", e$message)) - }) - }, - - decode_internal = function(message) { - stop("decode_internal must be implemented in subclass") - } - ) -) - -# SYNOP class - main class for decoding SYNOP messages -SYNOP = R6Class("SYNOP", - inherit = Report, - public = list( - country = NULL, - - initialize = function() { - self$not_implemented = list() - self$country = NULL - }, - - decode_internal = function(message) { - # Initialize data - data = list() - - # Split message into groups - groups = strsplit(message, " ")[[1]] - group_idx = 1 - - # Helper function to get next group - get_next_group = function() { - if (group_idx <= length(groups)) { - group = groups[group_idx] - group_idx <= group_idx + 1 - return(group) - } - return(NULL) - } - - # Alias for convenience - next_group = get_next_group - - # SECTION 0: Station type, time, and identification - station_type = next_group() - if (is.null(station_type)) { - stop("Invalid SYNOP: missing station type") - } - - # For simplicity, assume AAXX format - data$station_type = list(value = station_type) - - # Get observation time and wind indicator (YYGGi) - yygii = next_group() - if (is.null(yygii) || nchar(yygii) < 5) { - stop("Invalid SYNOP: missing YYGGi group") - } - - # Decode observation time - obs_time = ObservationTime$new() - data$obs_time = obs_time$decode(substr(yygii, 1, 4)) - - # Decode wind indicator - wind_ind = WindIndicator$new() - data$wind_indicator = wind_ind$decode(substr(yygii, 5, 5)) - - # Get station ID - station_id_group = next_group() - if (is.null(station_id_group)) { - stop("Invalid SYNOP: missing station ID") - } - - data$station_id = list(value = station_id_group) - - # Decode region - tryCatch({ - region = Region$new() - result = region$decode(station_id_group) - if (!is.null(result)) { - data$region = result - } - }, error = function(e) { - warning(paste("Error decoding region:", e$message)) - }) - - # Check if next group is NIL (station did not send data) - next_check = next_group() - if (!is.null(next_check) && (next_check == "NIL" || grepl("^NIL", next_check))) { - # Station did not send data - set remaining fields to NA - data$precipitation_indicator = NA - data$weather_indicator = NA - data$lowest_cloud_base = NA - data$visibility = NA - data$cloud_cover = NA - data$surface_wind = NA - data$air_temperature = NA - data$dewpoint_temperature = NA - data$relative_humidity = NA - data$station_pressure = NA - data$sea_level_pressure = NA - data$pressure_tendency = NA - data$precipitation_s1 = NA - data$present_weather = NA - data$past_weather = NA - data$cloud_types = NA - return(data) - } - - # SECTION 1: Main observations - section1 = next_check # Use the group we already got - if (is.null(section1) || nchar(section1) < 5) { - # If section1 is invalid, try to continue anyway - warning("Invalid or missing section 1") - return(data) - } - - # Decode precipitation indicator, weather indicator, cloud base, visibility - tryCatch({ - precip_ind = PrecipitationIndicator$new() - result = precip_ind$decode(substr(section1, 1, 1), country = self$country) - if (!is.null(result)) { - data$precipitation_indicator = result - } - }, error = function(e) { - warning(paste("Error decoding precipitation indicator:", e$message)) - }) - - tryCatch({ - weather_ind = WeatherIndicator$new() - result = weather_ind$decode(substr(section1, 2, 2)) - if (!is.null(result)) { - data$weather_indicator = result - } - }, error = function(e) { - warning(paste("Error decoding weather indicator:", e$message)) - }) - - tryCatch({ - lowest_cloud = LowestCloudBase$new() - result = lowest_cloud$decode(substr(section1, 3, 3)) - if (!is.null(result)) { - data$lowest_cloud_base = result - } - }, error = function(e) { - warning(paste("Error decoding lowest cloud base:", e$message)) - }) - - tryCatch({ - vis = Visibility$new() - result = vis$decode(substr(section1, 4, 5)) - if (!is.null(result)) { - data$visibility = result - } - }, error = function(e) { - warning(paste("Error decoding visibility:", e$message)) - }) - - # Get cloud cover and wind (Nddff) - nddff = next_group() - if (!is.null(nddff) && nchar(nddff) >= 5) { - tryCatch({ - cloud = CloudCover$new() - result = cloud$decode(substr(nddff, 1, 1)) - if (!is.null(result)) { - data$cloud_cover = result - } - }, error = function(e) { - warning(paste("Error decoding cloud cover from:", nddff, "-", e$message)) - }) - - tryCatch({ - wind = SurfaceWind$new() - wind_data = wind$decode(substr(nddff, 2, 5)) - if (!is.null(wind_data)) { - if (!is.null(data$wind_indicator)) { - if (!is.null(wind_data$speed)) { - wind_data$speed$unit = data$wind_indicator$unit - } - } - data$surface_wind = wind_data - } - }, error = function(e) { - warning(paste("Error decoding surface wind from:", nddff, "-", e$message)) - }) - } - - # Parse section 1 groups (1sTTT, 2sTTT, 3P0P0P0, 4PPPP, etc.) - next_grp = next_group() - while (!is.null(next_grp)) { - if (grepl("^333|^444|^555", next_grp)) { - # Start of next section - break - } - - # Try to get header, handle errors gracefully - header = tryCatch({ - as.integer(substr(next_grp, 1, 1)) - }, error = function(e) { - warning(paste("Unable to parse header from group:", next_grp)) - next_grp <= next_group() - return(NULL) - }, warning = function(w) { - warning(paste("Warning parsing header from group:", next_grp)) - next_grp <= next_group() - return(NULL) - }) - - if (is.null(header) || is.na(header)) { - next_grp = next_group() - # Skip to next iteration - if (is.null(next_grp)) break - next - } - - tryCatch({ - if (header == 1) { - # Air temperature - temp = Temperature$new() - result = temp$decode(next_grp) - if (!is.null(result)) { - data$air_temperature = result - } - } else if (header == 2) { - # Dewpoint temperature or relative humidity - sn = substr(next_grp, 2, 2) - if (sn == "9") { - rel_hum = RelativeHumidity$new() - result = rel_hum$decode(substr(next_grp, 3, 5)) - if (!is.null(result)) { - data$relative_humidity = result - } - } else { - temp = Temperature$new() - result = temp$decode(next_grp) - if (!is.null(result)) { - data$dewpoint_temperature = result - } - } - } else if (header == 3) { - # Station pressure - press = Pressure$new() - result = press$decode(substr(next_grp, 2, 5)) - if (!is.null(result)) { - data$station_pressure = result - } - } else if (header == 4) { - # Sea level pressure - press = Pressure$new() - result = press$decode(substr(next_grp, 2, 5)) - if (!is.null(result)) { - data$sea_level_pressure = result - } - } else if (header == 5) { - # Pressure tendency - press_tend = PressureTendency$new() - result = press_tend$decode(next_grp) - if (!is.null(result)) { - data$pressure_tendency = result - } - } else if (header == 6) { - # Precipitation - if (!is.null(data$precipitation_indicator) && - data$precipitation_indicator$in_group_1) { - precip = Precipitation$new() - result = precip$decode(next_grp) - if (!is.null(result)) { - data$precipitation_s1 = result - } - } - } else if (header == 7) { - # Present and past weather - if (nchar(next_grp) >= 5) { - ww = Weather$new() - result = ww$decode(substr(next_grp, 2, 3), - time_before = list(value = 6, unit = "h"), - type = "present", - weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) - if (!is.null(result)) { - data$present_weather = result - } - result2 = ww$decode(substr(next_grp, 4, 4), type = "past", - weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) - result3 = ww$decode(substr(next_grp, 5, 5), type = "past", - weather_indicator = if (!is.null(data$weather_indicator)) data$weather_indicator$value else NULL) - if (!is.null(result2) || !is.null(result3)) { - data$past_weather = list(result2, result3) - } - } - } else if (header == 8) { - # Cloud types - cloud_types = CloudType$new() - result = cloud_types$decode(next_grp) - if (!is.null(result)) { - data$cloud_types = result - } - } - }, error = function(e) { - warning(paste("Error decoding group:", next_grp, "-", e$message)) - # Continue to next group - }, warning = function(w) { - warning(paste("Warning decoding group:", next_grp, "-", w$message)) - # Continue to next group - }) - - next_grp = next_group() - } - - # SECTION 3: Additional observations - if (!is.null(next_grp) && next_grp == "333") { - next_grp = next_group() - cloud_layers = list() - highest_gusts = list() - group_9 = list() # Collect group 9 codes - - while (!is.null(next_grp) && !grepl("^444|^555", next_grp)) { - # Try to get header, handle errors gracefully - header = tryCatch({ - as.integer(substr(next_grp, 1, 1)) - }, error = function(e) { - warning(paste("Unable to parse header from group:", next_grp)) - return(NULL) - }, warning = function(w) { - warning(paste("Warning parsing header from group:", next_grp)) - return(NULL) - }) - - if (is.null(header) || is.na(header)) { - next_grp = next_group() - # Skip to next iteration - if (is.null(next_grp)) break - next - } - - tryCatch({ - # Check if it's a group 9 code (9xxxx) - if (header == 9) { - group_9[[length(group_9) + 1]] = next_grp - } else if (header == 8) { - # Cloud layers - cloud_layer = CloudLayer$new() - result = cloud_layer$decode(next_grp) - if (!is.null(result)) { - cloud_layers[[length(cloud_layers) + 1]] = result - } - } else if (header == 1) { - # Maximum temperature - temp = Temperature$new() - result = temp$decode(next_grp) - if (!is.null(result)) { - data$maximum_temperature = result - } - } else if (header == 2) { - # Minimum temperature - temp = Temperature$new() - result = temp$decode(next_grp) - if (!is.null(result)) { - data$minimum_temperature = result - } - } - }, error = function(e) { - warning(paste("Error decoding group:", next_grp, "-", e$message)) - # Continue to next group - }, warning = function(w) { - warning(paste("Warning decoding group:", next_grp, "-", w$message)) - # Continue to next group - }) - - next_grp = next_group() - } - - # Parse group 9 codes (including highest gusts) - if (length(group_9) > 0) { - idx = 1 - while (idx <= length(group_9)) { - g = group_9[[idx]] - tryCatch({ - if (nchar(g) >= 3) { - j1 = substr(g, 2, 2) # Second character - j2 = substr(g, 3, 3) # Third character - - if (j1 == "1") { - # Group 91xx - highest gusts - if (j2 == "0") { - # 910ff - gust with 10 min period - if (is.null(data$highest_gust)) { - data$highest_gust = list() - } - gust = HighestGust$new() - gust_data = gust$decode(g, - unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, - measure_period = list(value = 10, unit = "min") - ) - if (!is.null(gust_data)) { - data$highest_gust[[length(data$highest_gust) + 1]] = gust_data - } - idx = idx + 1 - } else if (j2 == "1") { - # 911ff - gust with time before obs - # Check if next group is direction (915dd) - if (idx < length(group_9)) { - next_g = group_9[[idx + 1]] - if (substr(next_g, 1, 3) == "915") { - gust_group = paste(g, next_g, sep = " ") - idx = idx + 2 # Skip next group - } else { - gust_group = g - idx = idx + 1 - } - } else { - gust_group = g - idx = idx + 1 - } - - if (is.null(data$highest_gust)) { - data$highest_gust = list() - } - gust = HighestGust$new() - gust_data = gust$decode(gust_group, - unit = if (!is.null(data$wind_indicator)) data$wind_indicator$unit else NULL, - time_before = list(value = 6, unit = "h") # Default time before - ) - if (!is.null(gust_data)) { - data$highest_gust[[length(data$highest_gust) + 1]] = gust_data - } - } else { - idx = idx + 1 - } - } else { - idx = idx + 1 - } - } else { - idx = idx + 1 - } - }, error = function(e) { - warning(paste("Error decoding group 9 code:", g, "-", e$message)) - idx <= idx + 1 - }, warning = function(w) { - warning(paste("Warning decoding group 9 code:", g, "-", w$message)) - idx <= idx + 1 - }) - } - } - - if (length(cloud_layers) > 0) { - data$cloud_layer = cloud_layers - } - } - - return(data) - } - ) -) - -################################################################################ -# ADDITIONAL CLASSES NEEDED FOR SYNOP -################################################################################ - -# ObservationTime -ObservationTime = R6Class("ObservationTime", - inherit = Observation, - public = list( - components = list( - list("day", 0, 2, Day), - list("hour", 2, 2, Hour) - ), - - initialize = function() { - super$initialize() - self$code_len = 4 - } - ) -) - -# WindIndicator -WindIndicator = R6Class("WindIndicator", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$valid_range = c(1, 7) - }, - - decode_internal = function(iw, ...) { - iw_int = as.integer(iw) - if (iw == "/") { - list(value = NULL, unit = NULL, estimated = NULL) - } else { - list( - value = iw_int, - unit = ifelse(iw_int < 2, "m/s", "KT"), - estimated = (iw_int %in% c(0, 3)) - ) - } - } - ) -) - -# Region -Region = R6Class("Region", - inherit = Observation, - public = list( - decode_internal = function(raw, ...) { - raw_int = as.integer(raw) - - regions = list( - I = list(c(60000, 69998)), - II = list(c(20000, 20099), c(20200, 21998), c(23001, 25998), - c(28001, 32998), c(35001, 36998), c(38001, 39998), - c(40350, 48599), c(48800, 49998), c(50001, 59998)), - III = list(c(80001, 88998)), - IV = list(c(70001, 79998)), - V = list(c(48600, 48799), c(90001, 98998)), - VI = list(c(1, 19998), c(20100, 20199), c(22001, 22998), - c(26001, 27998), c(33001, 34998), c(37001, 37998), - c(40001, 40349)), - Antarctic = list(c(89001, 89998)) - ) - - for (reg_name in names(regions)) { - for (range in regions[[reg_name]]) { - if (raw_int >= range[1] && raw_int <= range[2]) { - return(list(value = reg_name)) - } - } - } - - stop(paste("Invalid region code:", raw)) - } - ) -) - -# PrecipitationIndicator -PrecipitationIndicator = R6Class("PrecipitationIndicator", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - }, - - decode_internal = function(i, ...) { - kwargs = list(...) - country = kwargs$country - i_int = as.integer(i) - - list( - value = i_int, - in_group_1 = (i %in% c("0", "1")) || (i == "6" && !is.null(country) && country == "RU"), - in_group_3 = (i %in% c("0", "2")) || (i == "7" && !is.null(country) && country == "RU") - ) - } - ) -) - -# WeatherIndicator -WeatherIndicator = R6Class("WeatherIndicator", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$valid_range = c(1, 7) - }, - - decode_internal = function(ix, ...) { - ix_int = ifelse(ix == "/", NULL, as.integer(ix)) - - list( - value = ix_int, - automatic = ifelse(is.null(ix_int) || ix_int < 3, FALSE, TRUE) - ) - } - ) -) - -# LowestCloudBase -LowestCloudBase = R6Class("LowestCloudBase", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$code_table = CodeTable1600$new() - self$unit = "m" - } - ) -) - -# CodeTable1600 -CodeTable1600 = R6Class("CodeTable1600", - inherit = CodeTable, - public = list( - ranges = list( - c(0, 50), c(50, 100), c(100, 200), c(200, 300), c(300, 600), - c(600, 1000), c(1000, 1500), c(1500, 2000), c(2000, 2500), c(2500, Inf) - ), - - initialize = function() { - self$table_name = "1600" - }, - - decode_internal = function(h, ...) { - h_int = as.integer(h) - if (h_int >= 0 && h_int < length(self$ranges)) { - range = self$ranges[[h_int + 1]] - quantifier = ifelse(is.infinite(range[2]), "isGreaterOrEqual", NULL) - list(min = range[1], max = ifelse(is.infinite(range[2]), NULL, range[2]), - quantifier = quantifier) - } else { - stop(paste("Invalid cloud base code:", h)) - } - } - ) -) - -# Precipitation -Precipitation = R6Class("Precipitation", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - }, - - decode_internal = function(group, ...) { - kwargs = list(...) - tenths = ifelse(is.null(kwargs$tenths), FALSE, kwargs$tenths) - - if (tenths) { - rrrr = substr(group, 2, 5) - amount = Amount24$new() - list( - amount = amount$decode(rrrr), - time_before_obs = list(value = 24, unit = "h") - ) - } else { - rrr = substr(group, 2, 4) - t = substr(group, 5, 5) - amount = Amount$new() - list( - amount = amount$decode(rrr), - time_before_obs = TimeBeforeObs$new()$decode(t) - ) - } - } - ) -) - -# Amount (simplified) -Amount = R6Class("Amount", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 3 - self$code_table = CodeTable3590$new() - self$unit = "mm" - } - ) -) - -# Amount24 -Amount24 = R6Class("Amount24", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - self$code_table = CodeTable3590A$new() - self$unit = "mm" - } - ) -) - -# CodeTable3590 (simplified) -CodeTable3590 = R6Class("CodeTable3590", - inherit = CodeTable, - public = list( - initialize = function() { - self$table_name = "3590" - }, - - decode_internal = function(RRR, ...) { - rrr_int = as.integer(RRR) - if (rrr_int <= 988) { - list(value = rrr_int, quantifier = NULL, trace = FALSE) - } else if (rrr_int == 989) { - list(value = rrr_int, quantifier = "isGreaterOrEqual", trace = FALSE) - } else if (rrr_int == 990) { - list(value = 0, quantifier = NULL, trace = TRUE) - } else if (rrr_int >= 991 && rrr_int <= 999) { - list(value = (rrr_int - 990) / 10.0, quantifier = NULL, trace = FALSE) - } else { - stop(paste("Invalid precipitation code:", RRR)) - } - } - ) -) - -# CodeTable3590A (simplified) -CodeTable3590A = R6Class("CodeTable3590A", - inherit = CodeTable, - public = list( - initialize = function() { - self$table_name = "3590A" - }, - - decode_internal = function(RRRR, ...) { - rrrr_int = as.integer(RRRR) - if (rrrr_int <= 9998) { - list(value = round(rrrr_int * 0.1, 1), quantifier = NULL, trace = FALSE) - } else if (rrrr_int == 9999) { - list(value = 0, quantifier = NULL, trace = TRUE) - } else { - stop(paste("Invalid precipitation code:", RRRR)) - } - } - ) -) - -# TimeBeforeObs (simplified) -TimeBeforeObs = R6Class("TimeBeforeObs", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$code_table = CodeTable4019$new() - self$unit = "h" - } - ) -) - -# CodeTable4019 -CodeTable4019 = R6Class("CodeTable4019", - inherit = CodeTable, - public = list( - values = c(NULL, 6, 12, 18, 24, 1, 2, 3, 9, 15), - - initialize = function() { - self$table_name = "4019" - }, - - decode_internal = function(t, ...) { - t_int = as.integer(t) + 1 - if (t_int >= 1 && t_int <= length(self$values)) { - val = self$values[[t_int]] - if (!is.null(val)) { - list(value = val, unit = "h") - } else { - NULL - } - } else { - NULL - } - } - ) -) - -# PressureTendency -PressureTendency = R6Class("PressureTendency", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - }, - - decode_internal = function(group, ...) { - a = substr(group, 2, 2) - ppp = substr(group, 3, 5) - - tendency = Tendency$new() - change = Change$new() - - list( - tendency = tendency$decode(a), - change = change$decode(ppp, tendency = tendency$decode(a)) - ) - } - ) -) - -# Tendency (simplified) -Tendency = R6Class("Tendency", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - self$valid_range = c(0, 8) - } - ) -) - -# Change (simplified) -Change = R6Class("Change", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 3 - self$unit = "hPa" - }, - - decode_convert = function(val, ...) { - kwargs = list(...) - tendency = kwargs$tendency - - if (is.list(tendency) && "value" %in% names(tendency)) { - factor = ifelse(tendency$value < 5, 10.0, -10.0) - val$value = val$value / factor - } - val - } - ) -) - -# Weather -Weather = R6Class("Weather", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - }, - - decode_internal = function(group, ...) { - kwargs = list(...) - w_type = kwargs$type - ix = kwargs$weather_indicator - - if (w_type == "present") { - table = ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4680", "4677") - } else if (w_type == "past") { - table = ifelse(!is.null(ix) && ix %in% c(5, 6, 7), "4531", "4561") - } else { - stop(paste("Invalid weather type:", w_type)) - } - - group_int = as.integer(group) - if (is.na(group_int)) { - return(NULL) - } - - result = list(value = group_int, `_table` = table) - if (!is.null(kwargs$time_before)) { - result$time_before_obs = kwargs$time_before - } - - result - } - ) -) - -# CloudType -CloudType = R6Class("CloudType", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - }, - - decode_internal = function(group, ...) { - nh = substr(group, 2, 2) - cl = substr(group, 3, 3) - cm = substr(group, 4, 4) - ch = substr(group, 5, 5) - - low_cloud = LowCloud$new() - middle_cloud = MiddleCloud$new() - high_cloud = HighCloud$new() - cloud_cover = CloudCover$new() - - result = list( - low_cloud_type = low_cloud$decode(cl), - middle_cloud_type = middle_cloud$decode(cm), - high_cloud_type = high_cloud$decode(ch) - ) - - cover = cloud_cover$decode(nh) - if (nh != "/") { - if (!is.null(result$low_cloud_type) && - result$low_cloud_type$value >= 1 && - result$low_cloud_type$value <= 9) { - result$low_cloud_amount = cover - } else if (!is.null(result$middle_cloud_type) && - result$middle_cloud_type$value >= 0 && - result$middle_cloud_type$value <= 9) { - result$middle_cloud_amount = cover - } else { - result$cloud_amount = cover - } - } - - result - } - ) -) - -# LowCloud, MiddleCloud, HighCloud (simplified) -LowCloud = R6Class("LowCloud", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - } - ) -) - -MiddleCloud = R6Class("MiddleCloud", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - } - ) -) - -HighCloud = R6Class("HighCloud", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 1 - } - ) -) - -# CloudLayer -CloudLayer = R6Class("CloudLayer", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 4 - }, - - decode_internal = function(group, ...) { - n = substr(group, 2, 2) - c = substr(group, 3, 3) - hh = substr(group, 4, 5) - - cloud_cover = CloudCover$new() - cloud_genus = CloudGenus$new() - height = Height$new() - - list( - cloud_cover = cloud_cover$decode(n), - cloud_genus = cloud_genus$decode(c), - cloud_height = height$decode(hh) - ) - } - ) -) - -# Height (simplified) -Height = R6Class("Height", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - self$code_table = CodeTable1677$new() - self$unit = "m" - } - ) -) - -# CodeTable1677 (simplified) -CodeTable1677 = R6Class("CodeTable1677", - inherit = CodeTable, - public = list( - initialize = function() { - self$table_name = "1677" - }, - - decode_internal = function(hh, ...) { - hh_int = as.integer(hh) - quantifier = NULL - - if (hh_int == 0) { - list(value = 30, quantifier = "isLess") - } else if (hh_int >= 1 && hh_int <= 50) { - list(value = hh_int * 30, quantifier = NULL) - } else if (hh_int >= 56 && hh_int <= 80) { - list(value = (hh_int - 50) * 300, quantifier = NULL) - } else if (hh_int >= 81 && hh_int <= 88) { - list(value = ((hh_int - 80) * 1500) + 9000, quantifier = NULL) - } else if (hh_int == 89) { - list(value = 21000, quantifier = "isGreater") - } else if (hh_int == 99) { - list(value = 21000, quantifier = "isGreater") - } else { - stop(paste("Invalid height code:", hh)) - } - } - ) -) - -# RelativeHumidity -RelativeHumidity = R6Class("RelativeHumidity", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 3 - self$valid_range = c(0, 100) - self$unit = "%" - } - ) -) - -# HighestGust - Highest wind gust -HighestGust = R6Class("HighestGust", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - }, - - decode_internal = function(group, ...) { - kwargs = list(...) - - # Split group into separate groups if needed - groups = strsplit(group, " ")[[1]] - - # Get type, speed and direction - # Format: 910ff or 911ff, optionally followed by 915dd - t = NULL - ff = NULL - dd = NULL - - if (length(groups) > 0) { - # First group: 910ff or 911ff - first_group = groups[1] - if (nchar(first_group) >= 5) { - t = substr(first_group, 3, 3) - ff = substr(first_group, 4, 5) - } - } - - # Second group: 915dd (direction) - if (length(groups) > 1) { - second_group = groups[2] - if (nchar(second_group) >= 5 && substr(second_group, 1, 3) == "915") { - dd = substr(second_group, 4, 5) - } - } - - # Return values - time_before = kwargs$time_before - measure_period = kwargs$measure_period - - gust_obs = Gust$new() - dir_obs = DirectionDegrees$new() - - data = list( - speed = gust_obs$decode(ff, unit = kwargs$unit), - direction = dir_obs$decode(dd) - ) - - if (!is.null(time_before)) { - data$time_before_obs = time_before - } - if (!is.null(measure_period)) { - data$measure_period = measure_period - } - - data - }, - - encode_internal = function(data, ...) { - kwargs = list(...) - time_before = kwargs$time_before - measure_period = kwargs$measure_period - output = character(0) - - # Handle list of gusts or single gust - if (is.list(data) && "speed" %in% names(data)) { - data = list(data) # Convert single gust to list - } - - for (d in data) { - # Convert time before obs, if required - if ("time_before_obs" %in% names(d)) { - if (is.null(time_before) || - (!is.null(time_before) && !identical(d$time_before_obs, time_before))) { - time_before_obs = TimeBeforeObs$new() - tt = time_before_obs$encode(d$time_before_obs) - if (tt != "//") { - output = c(output, paste0("907", tt)) - } - } - prefix = "911" - } else if ("measure_period" %in% names(d)) { - if (identical(d$measure_period, list(value = 10, unit = "min"))) { - prefix = "910" - } else { - stop("Invalid value for measure_period") - } - } else { - prefix = "910" # Default - } - - # Convert the gust - gust_obs = Gust$new() - ff = gust_obs$encode(if ("speed" %in% names(d)) d$speed else NULL) - output = c(output, paste0(prefix, ff)) - - # Convert the direction - if ("direction" %in% names(d) && !is.null(d$direction)) { - dir_obs = DirectionDegrees$new() - dd = dir_obs$encode(d$direction) - output = c(output, paste0("915", dd)) - } - } - - paste(output, collapse = " ") - } - ) -) - -# Gust - Wind gust speed (internal class for HighestGust) -Gust = R6Class("Gust", - inherit = Observation, - public = list( - initialize = function() { - super$initialize() - self$code_len = 2 - }, - - decode_internal = function(ff, ...) { - # Decode wind gust speed - same as WindSpeed - self$decode_value(ff, ...) - }, - - encode_internal = function(data, ...) { - # Encode wind gust speed - same as WindSpeed - if (is.null(data)) { - return(paste(rep(self$null_char, self$code_len), collapse = "")) - } - value = if (is.list(data)) data$value else data - if (!is.null(value) && value > 99) { - return(paste0("99 00", sprintf("%02d", value))) - } - sprintf("%02d", as.integer(value)) - } - ) -) - -################################################################################ -# EXPORT FUNCTIONS -################################################################################ - -# Helper function to create observation instances -create_observation = function(class_name, ...) { - class_map = list( - "CloudCover" = CloudCover, - "CloudGenus" = CloudGenus, - "Day" = Day, - "DirectionCardinal" = DirectionCardinal, - "DirectionDegrees" = DirectionDegrees, - "Hour" = Hour, - "Minute" = Minute, - "SignedTemperature" = SignedTemperature, - "Visibility" = Visibility, - "Temperature" = Temperature, - "Pressure" = Pressure, - "SurfaceWind" = SurfaceWind, - "WindSpeed" = WindSpeed, - "SYNOP" = SYNOP - ) - - if (!class_name %in% names(class_map)) { - stop(paste("Unknown observation class:", class_name)) - } - - class_map[[class_name]]$new(...) -} - -# Example usage function -example_usage = function() { - # Example: Decode temperature - # Format: 1sTTT where s=0 (positive) or s=1 (negative), TTT=temperature - temp = Temperature$new() - result = temp$decode("10094") # Sign=0 (positive), TTT=094 -> 9.4°C - print(result) - - # Negative temperature - result2 = temp$decode("11094") # Sign=1 (negative), TTT=094 -> -9.4°C - print(result2) - - # Example: Encode temperature - encoded = temp$encode(list(value = 19.4)) - print(encoded) - - # Example: Decode cloud cover - cloud = CloudCover$new() - result = cloud$decode("6") - print(result) - - # Example: Decode surface wind - wind = SurfaceWind$new() - result = wind$decode("1506") - print(result) - - # Example: Decode full SYNOP - synop = SYNOP$new() - synop_msg = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 81656 86070" - output = synop$decode(synop_msg) - print(output) -} - - diff --git a/tests/testthat/test-parser.R b/tests/testthat/test-parser.R new file mode 100644 index 0000000..fec337e --- /dev/null +++ b/tests/testthat/test-parser.R @@ -0,0 +1,183 @@ +## Reference SYNOP message used across multiple tests: +## AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 +## Decoded (reference values verified interactively): +## station_type = "AAXX" +## obs_time = day 1, hour 0 +## wind_indicator= 4 (KT, anemometer) +## station_id = "88889" (region III) +## cloud_cover = 6 okta +## visibility = 40000 m +## wind dir = 150 deg, speed = 6 kt +## air_temp = 9.4 Celsius, dewpoint = 4.7 Celsius +## station_pres = 1011.1 hPa +## sea_lvl_pres = 1019.7 hPa +## precip_s1 = 0 mm + +SYNOP_MSG = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541" + +# ── input validation ────────────────────────────────────────────────────────── + +test_that("parser stops on missing message", { + expect_error(parser(), "`message` must contain at least one SYNOP string.") +}) + +test_that("parser stops on zero-length character vector", { + expect_error(parser(character(0)), "`message` must contain at least one SYNOP string.") +}) + +test_that("parser stops on non-character input", { + expect_error(parser(12345), "`message` must be a character vector.") +}) + +test_that("parser warns and returns NULL for empty string", { + expect_warning(parser(""), "Empty SYNOP message supplied") +}) + +test_that("parser stops when country length mismatches message length", { + expect_error( + parser(SYNOP_MSG, country = c("RU", "PL")), + "`country` must be NULL" + ) +}) + +# ── return-type behaviour ───────────────────────────────────────────────────── + +test_that("parser returns a list for a single message (simplify = TRUE)", { + result = parser(SYNOP_MSG) + expect_type(result, "list") +}) + +test_that("parser with simplify = FALSE wraps single message in a list of length 1", { + result = parser(SYNOP_MSG, simplify = FALSE) + expect_type(result, "list") + expect_length(result, 1) + expect_type(result[[1]], "list") +}) + +test_that("parser returns a list of n elements for n messages", { + result = parser(rep(SYNOP_MSG, 3), simplify = FALSE) + expect_type(result, "list") + expect_length(result, 3) +}) + +test_that("parser simplify = FALSE and TRUE are consistent for single message", { + r_simplified = parser(SYNOP_MSG, simplify = TRUE) + r_wrapped = parser(SYNOP_MSG, simplify = FALSE) + expect_identical(r_simplified, r_wrapped[[1]]) +}) + +# ── top-level field presence ────────────────────────────────────────────────── + +test_that("parsed result contains expected top-level fields", { + result = parser(SYNOP_MSG) + expected_fields = c( + "station_type", "obs_time", "wind_indicator", "station_id", + "precipitation_indicator", "weather_indicator", + "visibility", "cloud_cover", "surface_wind", + "air_temperature", "dewpoint_temperature", + "station_pressure", "sea_level_pressure" + ) + for (field in expected_fields) { + expect_true(field %in% names(result), info = paste("missing field:", field)) + } +}) + +# ── decoded values ──────────────────────────────────────────────────────────── + +test_that("parser decodes station type correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$station_type$value, "AAXX") +}) + +test_that("parser decodes station ID correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$station_id$value, "88889") +}) + +test_that("parser decodes observation time correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$obs_time$day$value, 1) + expect_equal(result$obs_time$hour$value, 0) +}) + +test_that("parser decodes wind indicator correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$wind_indicator$unit, "KT") + expect_false(result$wind_indicator$estimated) +}) + +test_that("parser decodes cloud cover correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$cloud_cover$value, 6) + expect_equal(result$cloud_cover$unit, "okta") +}) + +test_that("parser decodes visibility correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$visibility$value, 40000) + expect_equal(result$visibility$unit, "m") +}) + +test_that("parser decodes surface wind correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$surface_wind$direction$value, 150) + expect_equal(result$surface_wind$speed$value, 6) +}) + +test_that("parser decodes air temperature correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$air_temperature$value, 9.4, tolerance = 1e-6) + expect_equal(result$air_temperature$unit, "Celsius") +}) + +test_that("parser decodes dewpoint temperature correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$dewpoint_temperature$value, 4.7, tolerance = 1e-6) +}) + +test_that("parser decodes station pressure correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$station_pressure$value, 1011.1, tolerance = 0.05) + expect_equal(result$station_pressure$unit, "hPa") +}) + +test_that("parser decodes sea-level pressure correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$sea_level_pressure$value, 1019.7, tolerance = 0.05) + expect_equal(result$sea_level_pressure$unit, "hPa") +}) + +test_that("parser decodes section-1 precipitation amount correctly", { + result = parser(SYNOP_MSG) + expect_equal(result$precipitation_s1$amount$value, 0) +}) + +# ── country parameter ───────────────────────────────────────────────────────── + +test_that("parser accepts a valid single-value country argument", { + result = parser(SYNOP_MSG, country = "RU") + expect_type(result, "list") + expect_true("station_type" %in% names(result)) +}) + +test_that("parser accepts country vector matching message length", { + result = parser(rep(SYNOP_MSG, 2), country = c("RU", "PL"), simplify = FALSE) + expect_length(result, 2) +}) + +# ── whitespace handling ─────────────────────────────────────────────────────── + +test_that("parser trims leading/trailing whitespace from messages", { + padded = paste0(" ", SYNOP_MSG, " ") + result = parser(padded) + expect_equal(result$station_id$value, "88889") +}) + +# ── multiple messages consistency ───────────────────────────────────────────── + +test_that("each element of a multi-message result matches the single-message result", { + single = parser(SYNOP_MSG) + multi = parser(rep(SYNOP_MSG, 2), simplify = FALSE) + expect_identical(multi[[1]], single) + expect_identical(multi[[2]], single) +}) From 65b2c7b5febc0d270794ce34703098edbf7e2e0d Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sun, 10 May 2026 01:43:05 +0200 Subject: [PATCH 14/16] cleaning parser for SYNOP messages --- NEWS.md | 11 +- R/parser.R | 80 +++- README.md | 51 +++ man/parser.Rd | 30 +- tests/testthat/test-parser.R | 752 +++++++++++++++++++++++++++++++++++ 5 files changed, 906 insertions(+), 18 deletions(-) diff --git a/NEWS.md b/NEWS.md index 984e727..a2f0436 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,11 +1,10 @@ # climate 1.4.0 -## TODO/in progress: -* adding parser for SYNOP messages from OGIMET webportal to speed up downloading and avoid server overload; -the new parser allows to download data for multiple stations in a single query -* adding label description to `hydro_imgw()` datasets to easen understanding of the data and avoid confusion with units (e.g. "Q [m3/s]" instead of "Q") -* minor fixes in R code syntax and documentation - +* adding the `parser()` function for SYNOP messages +* minor fixes + * adding label description to `hydro_imgw()` datasets to easen understanding of the data and avoid confusion with units (e.g. "Q [m3/s]" instead of "Q") + * updated documentation + * unified R code syntax for assignement # climate 1.3.0 diff --git a/R/parser.R b/R/parser.R index 8fc1148..8dcd58e 100644 --- a/R/parser.R +++ b/R/parser.R @@ -1,4 +1,4 @@ -#' Parse SYNOP messages into structured lists +#' Parse SYNOP messages into structured lists or a data frame #' #' This function wraps the SYNOP decoding logic that was previously distributed #' with the package in `inst/extdata`. It parses one or more SYNOP messages and @@ -6,21 +6,38 @@ #' decoder. #' #' @param message Character vector with SYNOP messages. -#' @param country Optional single character value passed to the precipitation +#' @param country Optional; A single character value passed to the precipitation #' indicator decoder to adjust country-specific behaviour (e.g. `"RU"`). #' @param simplify Logical. If `TRUE` (default) and a single message is #' provided, the function returns the decoded list directly instead of a -#' length-one list. +#' length-one list. Ignored when `as_data_frame = TRUE`. +#' @param as_data_frame Logical. If `TRUE`, return a `data.frame` with one row +#' per message and commonly-used decoded fields as columns. Missing or +#' unparsed fields are filled with `NA`. Default is `FALSE`. #' -#' @return A list of decoded SYNOP messages. When `simplify = TRUE` and a single -#' message is supplied, the corresponding decoded list is returned directly. +#' @return When `as_data_frame = FALSE` (default): a list of decoded SYNOP +#' messages, or the decoded list directly when `simplify = TRUE` and a single +#' message is supplied. When `as_data_frame = TRUE`: a `data.frame` with one +#' row per message and the following columns (all numeric/character as +#' appropriate, `NA` when not present in the message): +#' `station_type`, `station_id`, `region`, `obs_day`, `obs_hour`, +#' `wind_unit`, `wind_estimated`, `visibility`, `cloud_cover`, +#' `wind_direction`, `wind_speed`, `air_temperature`, `dewpoint_temperature`, +#' `station_pressure`, `sea_level_pressure`, `pressure_tendency`, +#' `pressure_change`, `precipitation_amount`, `precipitation_time`, +#' `cloud_base_min`, `cloud_base_max`, `low_cloud_type`, +#' `middle_cloud_type`, `high_cloud_type`, `low_cloud_amount`, +#' `source` (the original SYNOP message string). +#' Row names are sequential integers. #' @examples #' synop_code = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541" #' parser(synop_code) #' parser(rep(synop_code, 2), simplify = FALSE) +#' parser(synop_code, as_data_frame = TRUE) +#' parser(rep(synop_code, 2), as_data_frame = TRUE) #' @import R6 #' @export -parser = function(message, country = NULL, simplify = TRUE) { +parser = function(message, country = NULL, simplify = TRUE, as_data_frame = FALSE) { if (missing(message) || length(message) == 0) { stop("`message` must contain at least one SYNOP string.") } @@ -52,6 +69,13 @@ parser = function(message, country = NULL, simplify = TRUE) { SIMPLIFY = FALSE ) + if (as_data_frame) { + rows = Map(.synop_to_row, results, message) + df = do.call(rbind, rows) + rownames(df) = NULL + return(df) + } + if (simplify && length(results) == 1) { return(results[[1]]) } @@ -59,6 +83,50 @@ parser = function(message, country = NULL, simplify = TRUE) { results } +# Internal helper: extract a deeply-nested value safely, returning NA on failure. +.sg = function(lst, ...) { + keys = c(...) + for (k in keys) { + if (is.null(lst) || !is.list(lst) || is.null(lst[[k]])) return(NA) + lst = lst[[k]] + } + lst +} + +# Internal helper: flatten one decoded SYNOP list into a single-row data.frame. +# `source` is the original SYNOP message string, added as the last column. +.synop_to_row = function(x, source = NA_character_) { + data.frame( + station_type = .sg(x, "station_type", "value"), + station_id = .sg(x, "station_id", "value"), + region = .sg(x, "region", "value"), + obs_day = .sg(x, "obs_time", "day", "value"), + obs_hour = .sg(x, "obs_time", "hour", "value"), + wind_unit = .sg(x, "wind_indicator", "unit"), + wind_estimated = .sg(x, "wind_indicator", "estimated"), + visibility = .sg(x, "visibility", "value"), + cloud_cover = .sg(x, "cloud_cover", "value"), + wind_direction = .sg(x, "surface_wind", "direction", "value"), + wind_speed = .sg(x, "surface_wind", "speed", "value"), + air_temperature = .sg(x, "air_temperature", "value"), + dewpoint_temperature = .sg(x, "dewpoint_temperature", "value"), + station_pressure = .sg(x, "station_pressure", "value"), + sea_level_pressure = .sg(x, "sea_level_pressure", "value"), + pressure_tendency = .sg(x, "pressure_tendency", "tendency", "value"), + pressure_change = .sg(x, "pressure_tendency", "change", "value"), + precipitation_amount = .sg(x, "precipitation_s1", "amount", "value"), + precipitation_time = .sg(x, "precipitation_s1", "time_before_obs", "value"), + cloud_base_min = .sg(x, "lowest_cloud_base", "min"), + cloud_base_max = .sg(x, "lowest_cloud_base", "max"), + low_cloud_type = .sg(x, "cloud_types", "low_cloud_type", "value"), + middle_cloud_type = .sg(x, "cloud_types", "middle_cloud_type", "value"), + high_cloud_type = .sg(x, "cloud_types", "high_cloud_type", "value"), + low_cloud_amount = .sg(x, "cloud_types", "low_cloud_amount", "value"), + source = source, + stringsAsFactors = FALSE + ) +} + ################################################################################ # observations.R # diff --git a/README.md b/README.md index 61329e7..c51f4f0 100644 --- a/README.md +++ b/README.md @@ -72,6 +72,7 @@ country in the Ogimet repository - **imgw_hydro_stations** - Built-in metadata from the IMGW-PIB repository for hydrological stations, their geographical coordinates, and ID numbers - **stations_meteo_imgw_telemetry** - Downloading complete and up-to-date information about coordinates for IMGW-PIB telemetry meteorological stations - **stations_hydro_imgw_telemetry** - Downloading complete and up-to-date information about coordinates for IMGW-PIB telemetry hydrological stations +- **parser()** - Decoding raw SYNOP meteorological messages into structured R lists or data frames ## Example 1 #### Download hourly dataset from NCEI/NOAA ISH meteorological repository: @@ -265,6 +266,56 @@ res.head ``` +## Example 8 +#### Decode raw SYNOP messages with `parser()` + +The `parser()` function decodes FM-12 SYNOP meteorological messages into structured R objects. + +```r +library(climate) + +synop_code = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541" + +# Decode a single message — returns a named list +result = parser(synop_code) +result$station_id$value #> "88889" +result$air_temperature$value #> 9.4 +result$wind_speed$value #> 6 +result$visibility$value #> 40000 +result$sea_level_pressure$value #> 1019.7 +``` + +```r +# Return a tidy data frame with one row per message +df = parser(synop_code, as_data_frame = TRUE) +df +#> station_type station_id region obs_day obs_hour wind_unit wind_estimated +#> 1 AAXX 88889 III 1 0 KT FALSE +#> visibility cloud_cover wind_direction wind_speed air_temperature +#> 1 40000 6 150 6 9.4 +#> dewpoint_temperature station_pressure sea_level_pressure pressure_tendency +#> 1 4.7 1011.1 1019.7 0 +#> pressure_change precipitation_amount precipitation_time cloud_base_min +#> 1 7 0 6 1500 +#> cloud_base_max low_cloud_type middle_cloud_type high_cloud_type +#> 1 2000 5 4 1 +#> low_cloud_amount source +#> 1 1 AAXX 01004 88889 12782 61506 10094 20047 30111 40197 ... +``` + +```r +# Decode multiple SYNOP messages at once +msgs = c( + "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541", + "AAXX 10124 26477 32560 83102 10156 20106 38528 40128 52003 60001 333 56017" +) +df2 = parser(msgs, as_data_frame = TRUE) +nrow(df2) #> 2 +df2$station_id #> c("88889", "26477") +df2$source # original SYNOP strings preserved in last column +... +``` + ## Acknowledgment Ogimet.com, University of Wyoming, and Institute of Meteorology and Water Management - National Research Institute (IMGW-PIB), National Oceanic & Atmospheric Administration (NOAA) - Earth System Research Laboratory, Global Monitoring Division and Integrated Surface Hourly (NOAA ISH) are the sources of the data. diff --git a/man/parser.Rd b/man/parser.Rd index 3312df4..7b00541 100644 --- a/man/parser.Rd +++ b/man/parser.Rd @@ -2,23 +2,39 @@ % Please edit documentation in R/parser.R \name{parser} \alias{parser} -\title{Parse SYNOP messages into structured lists} +\title{Parse SYNOP messages into structured lists or a data frame} \usage{ -parser(message, country = NULL, simplify = TRUE) +parser(message, country = NULL, simplify = TRUE, as_data_frame = FALSE) } \arguments{ \item{message}{Character vector with SYNOP messages.} -\item{country}{Optional single character value passed to the precipitation +\item{country}{Optional; A single character value passed to the precipitation indicator decoder to adjust country-specific behaviour (e.g. \code{"RU"}).} \item{simplify}{Logical. If \code{TRUE} (default) and a single message is provided, the function returns the decoded list directly instead of a -length-one list.} +length-one list. Ignored when \code{as_data_frame = TRUE}.} + +\item{as_data_frame}{Logical. If \code{TRUE}, return a \code{data.frame} with one row +per message and commonly-used decoded fields as columns. Missing or +unparsed fields are filled with \code{NA}. Default is \code{FALSE}.} } \value{ -A list of decoded SYNOP messages. When \code{simplify = TRUE} and a single -message is supplied, the corresponding decoded list is returned directly. +When \code{as_data_frame = FALSE} (default): a list of decoded SYNOP +messages, or the decoded list directly when \code{simplify = TRUE} and a single +message is supplied. When \code{as_data_frame = TRUE}: a \code{data.frame} with one +row per message and the following columns (all numeric/character as +appropriate, \code{NA} when not present in the message): +\code{station_type}, \code{station_id}, \code{region}, \code{obs_day}, \code{obs_hour}, +\code{wind_unit}, \code{wind_estimated}, \code{visibility}, \code{cloud_cover}, +\code{wind_direction}, \code{wind_speed}, \code{air_temperature}, \code{dewpoint_temperature}, +\code{station_pressure}, \code{sea_level_pressure}, \code{pressure_tendency}, +\code{pressure_change}, \code{precipitation_amount}, \code{precipitation_time}, +\code{cloud_base_min}, \code{cloud_base_max}, \code{low_cloud_type}, +\code{middle_cloud_type}, \code{high_cloud_type}, \code{low_cloud_amount}, +\code{source} (the original SYNOP message string). +Row names are sequential integers. } \description{ This function wraps the SYNOP decoding logic that was previously distributed @@ -30,4 +46,6 @@ decoder. synop_code = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541" parser(synop_code) parser(rep(synop_code, 2), simplify = FALSE) +parser(synop_code, as_data_frame = TRUE) +parser(rep(synop_code, 2), as_data_frame = TRUE) } diff --git a/tests/testthat/test-parser.R b/tests/testthat/test-parser.R index fec337e..5baabda 100644 --- a/tests/testthat/test-parser.R +++ b/tests/testthat/test-parser.R @@ -181,3 +181,755 @@ test_that("each element of a multi-message result matches the single-message res expect_identical(multi[[1]], single) expect_identical(multi[[2]], single) }) + +# ── as_data_frame ───────────────────────────────────────────────────────────── + +test_that("as_data_frame = TRUE returns a data.frame for a single message", { + df = parser(SYNOP_MSG, as_data_frame = TRUE) + expect_s3_class(df, "data.frame") + expect_equal(nrow(df), 1L) +}) + +test_that("as_data_frame = TRUE returns n rows for n messages", { + df = parser(rep(SYNOP_MSG, 3), as_data_frame = TRUE) + expect_s3_class(df, "data.frame") + expect_equal(nrow(df), 3L) +}) + +test_that("as_data_frame result has expected column names", { + expected_cols = c( + "station_type", "station_id", "region", "obs_day", "obs_hour", + "wind_unit", "wind_estimated", "visibility", "cloud_cover", + "wind_direction", "wind_speed", "air_temperature", "dewpoint_temperature", + "station_pressure", "sea_level_pressure", "pressure_tendency", + "pressure_change", "precipitation_amount", "precipitation_time", + "cloud_base_min", "cloud_base_max", "low_cloud_type", + "middle_cloud_type", "high_cloud_type", "low_cloud_amount", "source" + ) + df = parser(SYNOP_MSG, as_data_frame = TRUE) + expect_true(all(expected_cols %in% names(df))) + expect_equal(tail(names(df), 1), "source") +}) + +test_that("as_data_frame result contains correct decoded values", { + df = parser(SYNOP_MSG, as_data_frame = TRUE) + expect_equal(df$station_type, "AAXX") + expect_equal(df$station_id, "88889") + expect_equal(df$region, "III") + expect_equal(df$obs_day, 1L) + expect_equal(df$obs_hour, 0L) + expect_equal(df$wind_unit, "KT") + expect_equal(df$wind_direction, 150) + expect_equal(df$wind_speed, 6L) + expect_equal(df$air_temperature, 9.4) + expect_equal(df$dewpoint_temperature, 4.7) + expect_equal(df$station_pressure, 1011.1, tolerance = 0.01) + expect_equal(df$sea_level_pressure, 1019.7, tolerance = 0.01) + expect_equal(df$cloud_cover, 6L) + expect_equal(df$visibility, 40000) + expect_equal(df$precipitation_amount, 0L) + expect_equal(df$source, SYNOP_MSG) +}) + +test_that("multi-row as_data_frame result is consistent across rows", { + df = parser(rep(SYNOP_MSG, 2), as_data_frame = TRUE) + expect_equal(rownames(df), c("1", "2")) + row1 = df[1, ] + row2 = df[2, ] + rownames(row1) = NULL + rownames(row2) = NULL + expect_identical(row1, row2) +}) + +test_that("as_data_frame row for NULL result contains all-NA numeric columns", { + df = suppressWarnings(parser("", as_data_frame = TRUE)) + numeric_cols = c("obs_day", "obs_hour", "visibility", "cloud_cover", + "wind_direction", "wind_speed", "air_temperature", + "station_pressure", "sea_level_pressure") + for (col in numeric_cols) { + expect_true(is.na(df[[col]]), label = paste("column", col, "is NA")) + } +}) + +test_that("as_data_frame has integer rownames (not SYNOP strings)", { + msgs = c(SYNOP_MSG, SYNOP_MSG) + df = parser(msgs, as_data_frame = TRUE) + expect_equal(rownames(df), c("1", "2")) +}) + +test_that("as_data_frame source column contains the original message strings", { + msgs = c(SYNOP_MSG, SYNOP_MSG) + df = parser(msgs, as_data_frame = TRUE) + expect_equal(df$source, msgs) +}) + +test_that("simplify is ignored when as_data_frame = TRUE", { + df_default = parser(SYNOP_MSG, as_data_frame = TRUE) + df_nosimply = parser(SYNOP_MSG, as_data_frame = TRUE, simplify = FALSE) + expect_s3_class(df_default, "data.frame") + expect_s3_class(df_nosimply, "data.frame") + expect_equal(nrow(df_default), 1L) + expect_equal(nrow(df_nosimply), 1L) +}) + +# ── SYNOP message variants ───────────────────────────────────────────────────── + +test_that("NIL station returns NA for all observation fields", { + result = parser("AAXX 01004 88889 NIL") + expect_true(is.na(result$visibility)) + expect_true(is.na(result$cloud_cover)) + expect_true(is.na(result$air_temperature)) + expect_true(is.na(result$precipitation_s1)) + expect_true(is.na(result$present_weather)) +}) + +test_that("relative humidity group (sn=9) is decoded", { + result = parser("AAXX 01004 88889 12782 61506 10094 29067") + expect_false(is.null(result$relative_humidity)) + expect_equal(result$relative_humidity$value, 67L) + expect_equal(result$relative_humidity$unit, "%") +}) + +test_that("weather group 7 (present and past weather) is decoded", { + # 71023: ww=10, W1=2, W2=3 + result = parser("AAXX 01004 88889 12782 61506 10094 71023") + expect_false(is.null(result$present_weather)) + expect_equal(result$present_weather$value, 10L) + expect_false(is.null(result$past_weather)) + expect_equal(length(result$past_weather), 2L) +}) + +test_that("section 3 maximum and minimum temperature are decoded", { + msg = paste(SYNOP_MSG, "333 10025 20012") + result = parser(msg) + expect_false(is.null(result$maximum_temperature)) + expect_equal(result$maximum_temperature$value, 2.5) + expect_false(is.null(result$minimum_temperature)) + expect_equal(result$minimum_temperature$value, 1.2) +}) + +test_that("section 3 sunshine (55SSS) is decoded", { + msg = paste(SYNOP_MSG, "333 55060") + result = parser(msg) + expect_false(is.null(result$sunshine)) + expect_equal(result$sunshine$value, 6.0) + expect_equal(result$sunshine$unit, "h") +}) + +test_that("section 3 cloud layer (8NChh) is decoded", { + msg = paste(SYNOP_MSG, "333 81656") + result = parser(msg) + expect_false(is.null(result$cloud_layer)) + expect_equal(length(result$cloud_layer), 1L) + expect_equal(result$cloud_layer[[1]]$cloud_genus$value, "Sc") +}) + +test_that("section 3 highest gust 910ff with 10-min period is decoded", { + msg = paste(SYNOP_MSG, "333 91020") + result = parser(msg) + expect_false(is.null(result$highest_gust)) + expect_equal(result$highest_gust[[1]]$speed$value, 20L) + expect_equal(result$highest_gust[[1]]$measure_period$value, 10) +}) + +test_that("section 3 highest gust 911ff followed by 915dd is decoded", { + msg = paste(SYNOP_MSG, "333 91120 91518") + result = parser(msg) + expect_false(is.null(result$highest_gust)) + gust = result$highest_gust[[1]] + expect_equal(gust$speed$value, 20L) + expect_equal(gust$direction$value, 180) +}) + +test_that("section 3 highest gust 911ff without direction group is decoded", { + msg = paste(SYNOP_MSG, "333 91120") + result = parser(msg) + expect_false(is.null(result$highest_gust)) + expect_equal(result$highest_gust[[1]]$speed$value, 20L) +}) + +test_that("section 3 unrecognised j2 in group 9 is skipped gracefully", { + # 91220 has j2=2, which is neither 0 nor 1 + msg = paste(SYNOP_MSG, "333 91220") + result = parser(msg) + # No crash; highest_gust should be absent or empty + expect_true(is.null(result$highest_gust) || length(result$highest_gust) == 0) +}) + +test_that("visibility VV=00 gives isLess 100m", { + result = parser("AAXX 01004 88889 12700 61506 10094") + expect_equal(result$visibility$value, 100) + expect_equal(result$visibility$quantifier, "isLess") +}) + +test_that("visibility VV=25 gives 2500m", { + result = parser("AAXX 01004 88889 12725 61506 10094") + expect_equal(result$visibility$value, 2500) +}) + +test_that("visibility VV=60 gives 10000m", { + result = parser("AAXX 01004 88889 12760 61506 10094") + expect_equal(result$visibility$value, 10000) +}) + +test_that("visibility VV=89 gives isGreater 70000m", { + result = parser("AAXX 01004 88889 12789 61506 10094") + expect_equal(result$visibility$value, 70000) + expect_equal(result$visibility$quantifier, "isGreater") +}) + +test_that("visibility VV=90 gives isLess 50m and use90=TRUE", { + result = parser("AAXX 01004 88889 12790 61506 10094") + expect_equal(result$visibility$value, 50) + expect_equal(result$visibility$quantifier, "isLess") + expect_true(result$visibility$use90) +}) + +test_that("visibility VV=91 gives 50m with use90=TRUE", { + result = parser("AAXX 01004 88889 12791 61506 10094") + expect_equal(result$visibility$value, 50) + expect_true(result$visibility$use90) +}) + +test_that("visibility VV=99 gives isGreaterOrEqual 50000m", { + result = parser("AAXX 01004 88889 12799 61506 10094") + expect_equal(result$visibility$value, 50000) + expect_equal(result$visibility$quantifier, "isGreaterOrEqual") +}) + +test_that("invalid visibility code 51-55 emits a warning", { + expect_warning(result <- parser("AAXX 01004 88889 12753 61506 10094")) + expect_null(result$visibility) +}) + +test_that("precipitation code 989 gives isGreaterOrEqual", { + result = parser("AAXX 01004 88889 12782 61506 10094 20047 69891") + expect_false(is.null(result$precipitation_s1)) + expect_equal(result$precipitation_s1$amount$quantifier, "isGreaterOrEqual") +}) + +test_that("precipitation code 990 gives trace", { + result = parser("AAXX 01004 88889 12782 61506 10094 20047 69901") + expect_false(is.null(result$precipitation_s1)) + expect_true(result$precipitation_s1$amount$trace) +}) + +test_that("precipitation code 993 gives 0.3 mm", { + result = parser("AAXX 01004 88889 12782 61506 10094 20047 69931") + expect_false(is.null(result$precipitation_s1)) + expect_equal(result$precipitation_s1$amount$value, 0.3) +}) + +test_that("calm wind with nonzero speed triggers a warning", { + expect_warning(parser("AAXX 01004 88889 12782 60015 10094")) +}) + +test_that("wind direction dd=99 (variable, all directions) is decoded", { + result = parser("AAXX 01004 88889 12782 69906 10094") + expect_true(result$surface_wind$direction$varAllUnknown) +}) + +# ── check_valid / is_valid paths ─────────────────────────────────────────────── + +test_that("is_valid returns TRUE for unavailable (slash) value", { + expect_true(Hour$new()$is_valid("//")) +}) + +test_that("is_valid returns FALSE for out-of-range value without raising", { + expect_false(Hour$new()$is_valid("99", raise_exception = FALSE)) +}) + +test_that("is_valid returns FALSE for non-numeric value when range set", { + expect_false(Hour$new()$is_valid("XY", raise_exception = FALSE)) +}) + +# ── decode error path ────────────────────────────────────────────────────────── + +test_that("decode warns and returns NULL on internal error", { + expect_warning(result <- SignedTemperature$new()$decode("094", sign = "X")) + expect_null(result) +}) + +# ── Observation.encode paths ─────────────────────────────────────────────────── + +test_that("encode returns null chars for NULL data when no code_table", { + # SurfaceWind has no code_table; NULL data → "////" (code_len=4) + result = SurfaceWind$new()$encode(NULL) + expect_equal(result, "////") +}) + +test_that("encode calls encode_internal for NULL data when code_table present", { + # CloudCover has code_table; NULL with obscured=TRUE → "9" via CodeTable2700 + result = CloudCover$new()$encode(list(value = NULL, obscured = TRUE)) + expect_equal(result, "9") +}) + +test_that("encode warns and returns null char when encode_internal errors", { + # CodeTable2700 stops when value=NULL and obscured=FALSE + expect_warning(result <- CloudCover$new()$encode(list(value = NULL, obscured = FALSE))) + expect_equal(result, "/") +}) + +# ── Observation.encode_internal component path ───────────────────────────────── + +test_that("encode_internal handles component-based classes (ObservationTime)", { + ot = ObservationTime$new() + # Must call encode_internal directly: data has no $value key so encode() treats it as null + result = ot$encode_internal(list(day = list(value = 15L), hour = list(value = 12L))) + expect_equal(result, "1512") +}) + +test_that("encode_internal uses null chars for missing component keys", { + ot = ObservationTime$new() + result = ot$encode_internal(list()) # neither day nor hour present + expect_equal(result, "////") +}) + +# ── decode_value paths ───────────────────────────────────────────────────────── + +test_that("decode_value returns NULL for unavailable value '/'", { + result = Hour$new()$decode_value("/") + expect_null(result) +}) + +test_that("decode_value warns and returns NULL when code_table decode fails", { + # Code "10" exceeds CodeTable0500's index range → stop → warning chain + expect_warning(result <- CloudGenus$new()$decode("10")) + expect_null(result) +}) + +test_that("decode_value returns NULL for non-numeric string without code_table", { + result = Hour$new()$decode_value("XY") + expect_null(result) +}) + +# ── Temperature encode ───────────────────────────────────────────────────────── + +test_that("Temperature encodes a positive value correctly", { + temp = Temperature$new() + result = temp$encode(list(value = 9.4)) + expect_equal(result, "0094") +}) + +test_that("Temperature encodes a negative value correctly", { + temp = Temperature$new() + result = temp$encode(list(value = -9.4)) + expect_equal(result, "1094") +}) + +# ── Pressure encode ──────────────────────────────────────────────────────────── + +test_that("Pressure encodes a value >= 1000 hPa correctly", { + press = Pressure$new() + result = press$encode(list(value = 1019.7)) + expect_equal(result, "0197") +}) + +test_that("Pressure encodes a value < 1000 hPa correctly", { + press = Pressure$new() + result = press$encode(list(value = 978.5)) + expect_equal(result, "9785") +}) + +# ── Visibility encode via CodeTable4377 ──────────────────────────────────────── + +test_that("Visibility encodes < 100m to code 00", { + result = Visibility$new()$encode(list(value = 50, use90 = FALSE)) + expect_equal(result, "00") +}) + +test_that("Visibility encodes 5000m (<=5000) to correct code", { + result = Visibility$new()$encode(list(value = 5000, use90 = FALSE)) + expect_equal(result, "50") +}) + +test_that("Visibility encodes 10000m (5001-30000) to correct code", { + result = Visibility$new()$encode(list(value = 10000, use90 = FALSE)) + expect_equal(result, "60") +}) + +test_that("Visibility encodes > 70000m (isGreater quantifier) to 89", { + result = Visibility$new()$encode(list(value = 100000, quantifier = "isGreater", use90 = FALSE)) + expect_equal(result, "89") +}) + +test_that("CodeTable4377 encode_internal with use90=TRUE maps 50m to code 91", { + vt = CodeTable4377$new() + result = vt$encode_internal(list(value = 50), use90 = TRUE) + expect_equal(result, "91") +}) + +test_that("CodeTable4377 encode_internal with use90=TRUE maps 200m to code 92", { + vt = CodeTable4377$new() + result = vt$encode_internal(list(value = 200), use90 = TRUE) + expect_equal(result, "92") +}) + +test_that("CodeTable4377 encode_internal stops on unmatched use90=TRUE value", { + vt = CodeTable4377$new() + expect_error(vt$encode_internal(list(value = -1), use90 = TRUE), "Cannot encode visibility") +}) + +# ── SurfaceWind encode ───────────────────────────────────────────────────────── + +test_that("SurfaceWind encodes direction and speed correctly", { + sw = SurfaceWind$new() + # Must call encode_internal directly: complex data has no $value key + result = sw$encode_internal(list(direction = list(value = 150), speed = list(value = 6L))) + expect_equal(result, "1506") +}) + +# ── WindSpeed encode ─────────────────────────────────────────────────────────── + +test_that("WindSpeed encodes NULL with allow_none=TRUE to '//'", { + result = WindSpeed$new()$encode(NULL, allow_none = TRUE) + expect_equal(result, "//") +}) + +test_that("WindSpeed encodes speed > 99 using 99 prefix", { + result = WindSpeed$new()$encode(list(value = 120)) + expect_match(result, "^99 00120$") +}) + +test_that("WindSpeed encodes a normal speed", { + result = WindSpeed$new()$encode(list(value = 35)) + expect_equal(result, "35") +}) + +# ── CloudCover encode ────────────────────────────────────────────────────────── + +test_that("CloudCover encodes a numeric value", { + result = CloudCover$new()$encode(list(value = 6, obscured = FALSE)) + expect_equal(result, "6") +}) + +# ── CloudGenus decode and encode ─────────────────────────────────────────────── + +test_that("CloudGenus decodes code 6 to Sc", { + result = CloudGenus$new()$decode("6") + expect_equal(result$value, "Sc") +}) + +test_that("CloudGenus encodes Sc to code 6", { + result = CloudGenus$new()$encode(list(value = "Sc")) + expect_equal(result, "6") +}) + +test_that("CloudGenus warns on invalid genus name", { + expect_warning(result <- CloudGenus$new()$encode(list(value = "XX"))) + expect_equal(result, "/") +}) + +# ── DirectionCardinal decode and encode ──────────────────────────────────────── + +test_that("DirectionCardinal decodes 0 as calm", { + result = DirectionCardinal$new()$decode("0") + expect_true(result$isCalmOrStationary) + expect_null(result$value) +}) + +test_that("DirectionCardinal decodes 9 as all-directions", { + result = DirectionCardinal$new()$decode("9") + expect_true(result$allDirections) +}) + +test_that("DirectionCardinal decodes 1 as NE", { + result = DirectionCardinal$new()$decode("1") + expect_equal(result$value, "NE") +}) + +test_that("DirectionCardinal encodes calm flag to '0'", { + result = DirectionCardinal$new()$encode(list(isCalmOrStationary = TRUE)) + expect_equal(result, "0") +}) + +test_that("DirectionCardinal encodes all-directions flag to '9'", { + result = DirectionCardinal$new()$encode(list(isCalmOrStationary = FALSE, allDirections = TRUE)) + expect_equal(result, "9") +}) + +test_that("DirectionCardinal encodes NE to '1'", { + result = DirectionCardinal$new()$encode(list(isCalmOrStationary = FALSE, allDirections = FALSE, value = "NE")) + expect_equal(result, "1") +}) + +test_that("DirectionCardinal warns on unresolvable direction", { + expect_warning(result <- DirectionCardinal$new()$encode( + list(isCalmOrStationary = FALSE, allDirections = FALSE, value = NULL) + )) + expect_equal(result, "/") +}) + +# ── DirectionDegrees encode ──────────────────────────────────────────────────── + +test_that("DirectionDegrees encodes calm to '00'", { + result = DirectionDegrees$new()$encode(list(value = NULL, calm = TRUE)) + expect_equal(result, "00") +}) + +test_that("DirectionDegrees encodes varAllUnknown to '99'", { + result = DirectionDegrees$new()$encode(list(value = NULL, varAllUnknown = TRUE)) + expect_equal(result, "99") +}) + +test_that("DirectionDegrees encodes NULL with no flags to '//'", { + # CodeTable0877.encode_internal returns "//" for null-value with no flags; + # test via code table directly since encode_value mangles "/" strings + result = CodeTable0877$new()$encode_internal(list(value = NULL, calm = FALSE, varAllUnknown = FALSE)) + expect_equal(result, "//") +}) + +test_that("DirectionDegrees encodes a degree value", { + result = DirectionDegrees$new()$encode(list(value = 150)) + expect_equal(result, "15") +}) + +test_that("DirectionDegrees warns on invalid direction code", { + expect_warning(DirectionDegrees$new()$decode("37")) +}) + +# ── CodeTable4377 decode edge cases ─────────────────────────────────────────── + +test_that("CodeTable4377 decodes VV=00 to isLess 100m", { + result = CodeTable4377$new()$decode("00") + expect_equal(result$value, 100) + expect_equal(result$quantifier, "isLess") +}) + +test_that("CodeTable4377 decodes VV=25 to 2500m", { + result = CodeTable4377$new()$decode("25") + expect_equal(result$value, 2500) + expect_null(result$quantifier) +}) + +test_that("CodeTable4377 decodes VV=60 to 10000m", { + result = CodeTable4377$new()$decode("60") + expect_equal(result$value, 10000) +}) + +test_that("CodeTable4377 decodes VV=89 to isGreater 70000m", { + result = CodeTable4377$new()$decode("89") + expect_equal(result$value, 70000) + expect_equal(result$quantifier, "isGreater") +}) + +test_that("CodeTable4377 decodes VV=90 to isLess 50m with use90", { + result = CodeTable4377$new()$decode("90") + expect_equal(result$value, 50) + expect_equal(result$quantifier, "isLess") + expect_true(result$use90) +}) + +test_that("CodeTable4377 decodes VV=92 to 200m with use90", { + result = CodeTable4377$new()$decode("92") + expect_equal(result$value, 200) + expect_true(result$use90) +}) + +test_that("CodeTable4377 decodes VV=98 to 20000m with use90", { + result = CodeTable4377$new()$decode("98") + expect_equal(result$value, 20000) + expect_true(result$use90) +}) + +test_that("CodeTable4377 decodes VV=99 to isGreaterOrEqual 50000m", { + result = CodeTable4377$new()$decode("99") + expect_equal(result$value, 50000) + expect_equal(result$quantifier, "isGreaterOrEqual") +}) + +test_that("CodeTable4377 warns on invalid code 53", { + expect_warning(result <- CodeTable4377$new()$decode("53")) + expect_null(result) +}) + +# ── CodeTable1677 decode (Height) edge cases ─────────────────────────────────── + +test_that("Height decodes hh=00 to isLess 30m", { + result = Height$new()$decode("00") + expect_equal(result$value, 30) + expect_equal(result$quantifier, "isLess") +}) + +test_that("Height decodes hh=25 to 750m", { + result = Height$new()$decode("25") + expect_equal(result$value, 750) +}) + +test_that("Height decodes hh=56 to 1800m", { + result = Height$new()$decode("56") + expect_equal(result$value, 1800) +}) + +test_that("Height decodes hh=82 to 12000m", { + result = Height$new()$decode("82") + expect_equal(result$value, 12000) +}) + +test_that("Height decodes hh=89 to isGreater 21000m", { + result = Height$new()$decode("89") + expect_equal(result$value, 21000) + expect_equal(result$quantifier, "isGreater") +}) + +test_that("Height decodes hh=99 to isGreater 21000m", { + result = Height$new()$decode("99") + expect_equal(result$value, 21000) + expect_equal(result$quantifier, "isGreater") +}) + +test_that("Height warns on invalid code 55 (gap between ranges)", { + expect_warning(result <- Height$new()$decode("55")) + expect_null(result) +}) + +# ── Amount24 / CodeTable3590A decode ────────────────────────────────────────── + +test_that("Amount24 decodes normal value to tenths of mm", { + result = Amount24$new()$decode("0500") + expect_equal(result$value, 50.0) + expect_false(result$trace) +}) + +test_that("Amount24 decodes 9999 as trace", { + result = Amount24$new()$decode("9999") + expect_equal(result$value, 0) + expect_true(result$trace) +}) + +# ── Precipitation.decode_internal with tenths=TRUE ───────────────────────────── + +test_that("Precipitation decodes with tenths=TRUE using Amount24", { + precip = Precipitation$new() + result = precip$decode("60010", tenths = TRUE) + expect_false(is.null(result$amount)) + expect_equal(result$time_before_obs$value, 24) +}) + +# ── LowestCloudBase decode with invalid code ─────────────────────────────────── + +test_that("LowestCloudBase warns on out-of-range code", { + # CodeTable1600 only has 10 entries (codes 0-9); code 10 is out of range + # LowestCloudBase.decode("9") returns the last valid entry without warning + # so use two-digit code which as.integer truncates to the first character anyway; + # instead test via CodeTable1600 directly with an out-of-range integer string + expect_warning(result <- LowestCloudBase$new()$decode_value("a")) + expect_null(result) # non-numeric string → NA integer → NULL via decode_value path +}) + +test_that("Region warns on station ID outside all defined ranges", { + expect_warning(result <- Region$new()$decode("99999")) + expect_null(result) +}) + +# ── Gust encode ──────────────────────────────────────────────────────────────── + +test_that("Gust encodes NULL with allow_none=TRUE to '//'", { + result = Gust$new()$encode(NULL, allow_none = TRUE) + expect_equal(result, "//") +}) + +test_that("Gust encodes speed > 99 using 99 prefix", { + result = Gust$new()$encode(list(value = 120)) + expect_match(result, "^99 00120$") +}) + +test_that("Gust encodes normal speed", { + result = Gust$new()$encode(list(value = 35)) + expect_equal(result, "35") +}) + +# ── HighestGust encode ──────────────────────────────────────────────────────── + +test_that("HighestGust encodes gust with 10-min measure_period", { + hg = HighestGust$new() + # Must call encode_internal directly: complex data has no $value key + result = hg$encode_internal(list(speed = list(value = 20), measure_period = list(value = 10, unit = "min"))) + expect_equal(result, "91020") +}) + +test_that("HighestGust encodes gust with time_before_obs using 911 prefix", { + hg = HighestGust$new() + result = hg$encode_internal(list( + speed = list(value = 20), + time_before_obs = list("_code" = "5") + )) + expect_match(result, "91120") +}) + +test_that("HighestGust encodes gust with direction appended as 915dd", { + hg = HighestGust$new() + result = hg$encode_internal(list( + speed = list(value = 25), + measure_period = list(value = 10, unit = "min"), + direction = list(value = 180) + )) + expect_match(result, "91025") + expect_match(result, "91518") +}) + +test_that("HighestGust encode_internal stops on invalid measure_period", { + hg = HighestGust$new() + expect_error(hg$encode_internal(list( + speed = list(value = 20), + measure_period = list(value = 5, unit = "min") # only 10 min is valid + )), "Invalid value for measure_period") +}) + +# ── create_observation ──────────────────────────────────────────────────────── + +test_that("create_observation returns the correct R6 class instance", { + obj = create_observation("Temperature") + expect_true(inherits(obj, "Temperature")) +}) + +test_that("create_observation stops on unknown class name", { + expect_error(create_observation("UnknownClass"), "Unknown observation class") +}) + +# ── example_usage ───────────────────────────────────────────────────────────── + +test_that("example_usage runs without error", { + expect_no_error(capture.output(example_usage())) +}) + +# ── Minute class ────────────────────────────────────────────────────────────── + +test_that("Minute decodes a valid minute value", { + result = Minute$new()$decode("30") + expect_equal(result$value, 30L) +}) + +test_that("Minute returns NULL for out-of-range value", { + result = Minute$new()$decode("60") + expect_null(result) +}) + +# ── is_available ────────────────────────────────────────────────────────────── + +test_that("is_available returns FALSE for NULL", { + expect_false(Hour$new()$is_available(NULL)) +}) + +test_that("is_available returns FALSE for all-slash string", { + expect_false(Hour$new()$is_available("//")) +}) + +test_that("is_available returns TRUE for a valid string", { + expect_true(Hour$new()$is_available("12")) +}) + +# ── WindIndicator decode ────────────────────────────────────────────────────── + +test_that("WindIndicator decodes iw=3 as KT estimated", { + result = WindIndicator$new()$decode("3") + expect_equal(result$unit, "KT") + expect_true(result$estimated) +}) + +# ── Hour encode ─────────────────────────────────────────────────────────────── + +test_that("Hour encode_convert passes through via encode", { + result = Hour$new()$encode(list(value = 12L)) + expect_equal(result, "12") +}) From bb6bd8c35feeb1260d2a3e1e0d2d9b78df038c8f Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sun, 10 May 2026 02:05:40 +0200 Subject: [PATCH 15/16] update README --- README.md | 160 ++++++++++++++++++++++++++---------------------------- 1 file changed, 77 insertions(+), 83 deletions(-) diff --git a/README.md b/README.md index c51f4f0..7073d4e 100644 --- a/README.md +++ b/README.md @@ -77,23 +77,23 @@ country in the Ogimet repository ## Example 1 #### Download hourly dataset from NCEI/NOAA ISH meteorological repository: -``` r0 +``` r library(climate) -noaa <- meteo_noaa_hourly(station = "123300-99999", year = 2018:2019) # station ID: Poznan, Poland +noaa = meteo_noaa_hourly(station = "123300-99999", year = 2018:2019) # station ID: Poznan, Poland head(noaa) - -# year month day hour lon lat alt t2m dpt2m ws wd slp visibility -# 2019 1 1 0 16.85 52.417 84 3.3 2.3 5 220 1025.0 6000 -# 2019 1 1 1 16.85 52.417 84 3.7 3.0 4 220 1024.2 1500 -# 2019 1 1 2 16.85 52.417 84 4.2 3.6 4 220 1022.5 1300 -# 2019 1 1 3 16.85 52.417 84 5.2 4.6 5 240 1021.2 1900 ``` +| year | month | day | hour | lon | lat | alt | t2m | dpt2m | ws | wd | slp | visibility | +|------|-------|-----|------|-------|--------|-----|-----|-------|----|-----|--------|------------| +| 2019 | 1 | 1 | 0 | 16.85 | 52.417 | 84 | 3.3 | 2.3 | 5 | 220 | 1025.0 | 6000 | +| 2019 | 1 | 1 | 1 | 16.85 | 52.417 | 84 | 3.7 | 3.0 | 4 | 220 | 1024.2 | 1500 | +| 2019 | 1 | 1 | 2 | 16.85 | 52.417 | 84 | 4.2 | 3.6 | 4 | 220 | 1022.5 | 1300 | +| 2019 | 1 | 1 | 3 | 16.85 | 52.417 | 84 | 5.2 | 4.6 | 5 | 240 | 1021.2 | 1900 | + ## Example 2 -#### Finding a nearest meteorological stations in a given country using NCEI/NOAA ISH data source: +#### Finding a nearest meteorological stations in a given country using NCEI/NOAA ISH data source (used in Ex. 1): -``` r1 -library(climate) +``` r # find 100 nearest UK stations to longitude 1W and latitude 53N : nearest_stations_ogimet(country = "United+Kingdom", @@ -102,80 +102,74 @@ nearest_stations_ogimet(country = "United+Kingdom", point = c(-1, 53), no_of_stations = 100 ) - -# wmo_id station_names lon lat alt distance [km] -# 03354 Nottingham Weather Centre -1.250005 53.00000 117 28.04973 -# 03379 Cranwell -0.500010 53.03333 67 56.22175 -# 03377 Waddington -0.516677 53.16667 68 57.36093 -# 03373 Scampton -0.550011 53.30001 57 60.67897 -# 03462 Wittering -0.466676 52.61668 84 73.68934 -# 03544 Church Lawford -1.333340 52.36667 107 80.29844 -# ... ``` +| wmo_id | station_names | lon | lat | alt | distance [km] | +|--------|---------------------------|-----------|----------|-----|---------------| +| 03354 | Nottingham Weather Centre | -1.250005 | 53.00000 | 117 | 28.04973 | +| 03379 | Cranwell | -0.500010 | 53.03333 | 67 | 56.22175 | +| 03377 | Waddington | -0.516677 | 53.16667 | 68 | 57.36093 | +| 03373 | Scampton | -0.550011 | 53.30001 | 57 | 60.67897 | +| 03462 | Wittering | -0.466676 | 52.61668 | 84 | 73.68934 | +| 03544 | Church Lawford | -1.333340 | 52.36667 | 107 | 80.29844 | +| ... | ... | ... | ... | ... | ... | + ![100 nearest stations to given coordinates in UK](http://iqdata.eu/kolokwium/uk.png) ## Example 3 #### Downloading daily (or hourly) data from a global (OGIMET) repository knowing its ID (see also `nearest_stations_ogimet()`): ``` r -library(climate) o = meteo_ogimet(date = c(Sys.Date() - 5, Sys.Date() - 1), interval = "daily", coords = FALSE, station = 12330) head(o) - -#> station_ID Date TemperatureCAvg TemperatureCMax TemperatureCMin TdAvgC HrAvg WindkmhDir -#> 3 12330 2019-12-21 8.8 13.2 4.9 5.3 79.3 SSE -#> 4 12330 2019-12-20 5.4 8.5 -1.2 4.5 92.4 ESE -#> 5 12330 2019-12-19 3.8 10.3 -3.0 1.9 89.6 SW -#> 6 12330 2019-12-18 6.3 9.0 2.2 4.1 84.8 S -#> 7 12330 2019-12-17 4.9 7.6 0.3 2.9 87.2 SSE -#> WindkmhInt WindkmhGust PresslevHp Precmm TotClOct lowClOct SunD1h VisKm SnowDepcm PreselevHp -#> 3 11.4 39.6 995.9 1.8 3.6 2.0 6.7 21.4 NA -#> 4 15.0 NA 1015.0 0.0 6.4 0.6 1.0 8.0 NA -#> 5 7.1 NA 1020.4 0.0 5.2 5.9 2.5 14.1 NA -#> 6 9.2 NA 1009.2 0.0 5.7 2.7 1.4 12.2 NA -#> 7 7.2 NA 1010.8 0.1 6.2 4.6 13.0 NA ``` +| station_ID | Date | TempCAvg | TempCMax | TempCMin | TdAvgC | HrAvg | WindDir | WindInt | WindGust | PressHp | Precmm | TotClOct | lowClOct | SunD1h | VisKm | +|------------|------------|----------|----------|----------|--------|-------|---------|---------|----------|---------|--------|----------|----------|--------|-------| +| 12330 | 2019-12-21 | 8.8 | 13.2 | 4.9 | 5.3 | 79.3 | SSE | 11.4 | 39.6 | 995.9 | 1.8 | 3.6 | 2.0 | 6.7 | 21.4 | +| 12330 | 2019-12-20 | 5.4 | 8.5 | -1.2 | 4.5 | 92.4 | ESE | 15.0 | NA | 1015.0 | 0.0 | 6.4 | 0.6 | 1.0 | 8.0 | +| 12330 | 2019-12-19 | 3.8 | 10.3 | -3.0 | 1.9 | 89.6 | SW | 7.1 | NA | 1020.4 | 0.0 | 5.2 | 5.9 | 2.5 | 14.1 | +| 12330 | 2019-12-18 | 6.3 | 9.0 | 2.2 | 4.1 | 84.8 | S | 9.2 | NA | 1009.2 | 0.0 | 5.7 | 2.7 | 1.4 | 12.2 | +| 12330 | 2019-12-17 | 4.9 | 7.6 | 0.3 | 2.9 | 87.2 | SSE | 7.2 | NA | 1010.8 | 0.1 | 6.2 | 4.6 | NA | 13.0 | + ## Example 4 #### Downloading monthly/daily/hourly meteorological/hydrological data from the Polish (IMGW-PIB) repository: -``` r3 +``` r m = meteo_imgw(interval = "monthly", rank = "synop", year = 2000, coords = TRUE) head(m) -#> rank id X Y station yy mm tmax_abs -#> 575 SYNOPTYCZNA 353230295 23.16228 53.10726 BIAŁYSTOK 2000 1 5.3 -#> 577 SYNOPTYCZNA 353230295 23.16228 53.10726 BIAŁYSTOK 2000 2 10.6 -#> 578 SYNOPTYCZNA 353230295 23.16228 53.10726 BIAŁYSTOK 2000 3 14.8 -#> 579 SYNOPTYCZNA 353230295 23.16228 53.10726 BIAŁYSTOK 2000 4 27.8 -#> 580 SYNOPTYCZNA 353230295 23.16228 53.10726 BIAŁYSTOK 2000 5 29.3 -#> 581 SYNOPTYCZNA 353230295 23.16228 53.10726 BIAŁYSTOK 2000 6 32.6 -#> tmax_mean tmin_abs tmin_mean t2m_mean_mon t5cm_min rr_monthly -#> 575 0.4 -16.5 -4.5 -2.1 -23.5 34.2 -#> 577 4.1 -10.4 -1.4 1.3 -12.9 25.4 -#> 578 6.2 -6.4 -1.0 2.4 -9.4 45.5 -#> 579 17.9 -4.6 4.7 11.5 -8.1 31.6 -#> 580 21.3 -4.3 5.7 13.8 -8.3 9.4 -#> 581 23.1 1.0 9.6 16.6 -1.8 36.4 +``` +| rank | id | X | Y | station | yy | mm | tmax_abs | tmax_mean | tmin_abs | tmin_mean | t2m_mean_mon | t5cm_min | rr_monthly | +|-------|-----------|----------|----------|-----------|------|----|----------|-----------|----------|-----------|--------------|----------|------------| +| SYNOP | 353230295 | 23.16228 | 53.10726 | BIAŁYSTOK | 2000 | 1 | 5.3 | 0.4 | -16.5 | -4.5 | -2.1 | -23.5 | 34.2 | +| SYNOP | 353230295 | 23.16228 | 53.10726 | BIAŁYSTOK | 2000 | 2 | 10.6 | 4.1 | -10.4 | -1.4 | 1.3 | -12.9 | 25.4 | +| SYNOP | 353230295 | 23.16228 | 53.10726 | BIAŁYSTOK | 2000 | 3 | 14.8 | 6.2 | -6.4 | -1.0 | 2.4 | -9.4 | 45.5 | +| SYNOP | 353230295 | 23.16228 | 53.10726 | BIAŁYSTOK | 2000 | 4 | 27.8 | 17.9 | -4.6 | 4.7 | 11.5 | -8.1 | 31.6 | +| SYNOP | 353230295 | 23.16228 | 53.10726 | BIAŁYSTOK | 2000 | 5 | 29.3 | 21.3 | -4.3 | 5.7 | 13.8 | -8.3 | 9.4 | +| SYNOP | 353230295 | 23.16228 | 53.10726 | BIAŁYSTOK | 2000 | 6 | 32.6 | 23.1 | 1.0 | 9.6 | 16.6 | -1.8 | 36.4 | + +``` r h = hydro_imgw(interval = "daily", year = 2010:2011) head(h) - id station riv_or_lake date hyy idhyy dd H Q T mm thick -1 150210180 ANNOPOL Wisła (2) 2009-11-01 2010 1 1 287 436 NA 11 NA -2 150210180 ANNOPOL Wisła (2) 2009-11-02 2010 1 2 282 412 NA 11 NA -3 150210180 ANNOPOL Wisła (2) 2009-11-03 2010 1 3 272 368 NA 11 NA -4 150210180 ANNOPOL Wisła (2) 2009-11-04 2010 1 4 268 352 NA 11 NA -5 150210180 ANNOPOL Wisła (2) 2009-11-05 2010 1 5 264 336 NA 11 NA -6 150210180 ANNOPOL Wisła (2) 2009-11-06 2010 1 6 260 320 NA 11 NA ``` +| id | station | riv_or_lake | date | hyy | idhyy | dd | H | Q | T | mm | thick | +|-----------|---------|-------------|------------|------|-------|----|-----|-----|----|----|-------| +| 150210180 | ANNOPOL | Wisła (2) | 2009-11-01 | 2010 | 1 | 1 | 287 | 436 | NA | 11 | NA | +| 150210180 | ANNOPOL | Wisła (2) | 2009-11-02 | 2010 | 1 | 2 | 282 | 412 | NA | 11 | NA | +| 150210180 | ANNOPOL | Wisła (2) | 2009-11-03 | 2010 | 1 | 3 | 272 | 368 | NA | 11 | NA | +| 150210180 | ANNOPOL | Wisła (2) | 2009-11-04 | 2010 | 1 | 4 | 268 | 352 | NA | 11 | NA | +| 150210180 | ANNOPOL | Wisła (2) | 2009-11-05 | 2010 | 1 | 5 | 264 | 336 | NA | 11 | NA | +| 150210180 | ANNOPOL | Wisła (2) | 2009-11-06 | 2010 | 1 | 6 | 260 | 320 | NA | 11 | NA | + ## Example 5 #### Create Walter & Lieth climatic diagram based on downloaded data -``` r4 +``` r library(climate) library(dplyr) @@ -193,13 +187,16 @@ monthly_summary = as.data.frame(t(monthly_summary[, c(5,2,3,4)])) monthly_summary = round(monthly_summary, 1) colnames(monthly_summary) = month.abb print(monthly_summary) +``` -# Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec -# prec 37.1 31.3 38.5 31.3 53.9 60.8 94.8 59.6 40.5 39.7 35.7 38.6 -# tmax 8.7 11.2 17.2 23.8 28.3 31.6 32.3 31.8 26.9 21.3 14.3 9.8 -# tmin -15.0 -11.9 -7.6 -3.3 1.0 5.8 8.9 7.5 2.7 -2.4 -5.2 -10.4 -# tavg -1.0 0.5 3.7 9.4 14.4 17.4 19.4 19.0 14.3 9.1 4.5 0.8 +| | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec | +|------|-------|-------|------|------|------|------|------|------|------|------|------|-------| +| prec | 37.1 | 31.3 | 38.5 | 31.3 | 53.9 | 60.8 | 94.8 | 59.6 | 40.5 | 39.7 | 35.7 | 38.6 | +| tmax | 8.7 | 11.2 | 17.2 | 23.8 | 28.3 | 31.6 | 32.3 | 31.8 | 26.9 | 21.3 | 14.3 | 9.8 | +| tmin | -15.0 | -11.9 | -7.6 | -3.3 | 1.0 | 5.8 | 8.9 | 7.5 | 2.7 | -2.4 | -5.2 | -10.4 | +| tavg | -1.0 | 0.5 | 3.7 | 9.4 | 14.4 | 17.4 | 19.4 | 19.0 | 14.3 | 9.1 | 4.5 | 0.8 | +``` r # create plot with use of the "climatol" package: climatol::diagwl(monthly_summary, mlab = "en", est = "POZNAŃ", alt = NA, @@ -211,7 +208,7 @@ climatol::diagwl(monthly_summary, mlab = "en", ## Example 6 #### Download monthly CO2 dataset from Mauna Loa observatory -``` r5 +``` r library(climate) library(ggplot2) library(ggthemes) @@ -257,15 +254,16 @@ res["Date"] = pd.TimedeltaIndex(res["Date"], unit="d") + dt.datetime(1970,1,1) res.head >>> res[res.columns[0:7]].head() -# station_ID Date TemperatureCAvg ... TemperatureCMin TdAvgC HrAvg -#0 72503.0 2022-06-15 23.5 ... 19.4 10.9 45.2 -#1 72503.0 2022-06-14 25.0 ... 20.6 16.1 59.0 -#2 72503.0 2022-06-13 20.4 ... 17.8 16.0 74.8 -#3 72503.0 2022-06-12 21.3 ... 18.3 12.0 57.1 -#4 72503.0 2022-06-11 22.6 ... 17.8 8.1 40.1 - ``` +| station_ID | Date | TemperatureCAvg | TemperatureCMin | TdAvgC | HrAvg | +|------------|------------|-----------------|-----------------|--------|-------| +| 72503.0 | 2022-06-15 | 23.5 | 19.4 | 10.9 | 45.2 | +| 72503.0 | 2022-06-14 | 25.0 | 20.6 | 16.1 | 59.0 | +| 72503.0 | 2022-06-13 | 20.4 | 17.8 | 16.0 | 74.8 | +| 72503.0 | 2022-06-12 | 21.3 | 18.3 | 12.0 | 57.1 | +| 72503.0 | 2022-06-11 | 22.6 | 17.8 | 8.1 | 40.1 | + ## Example 8 #### Decode raw SYNOP messages with `parser()` @@ -289,20 +287,16 @@ result$sea_level_pressure$value #> 1019.7 # Return a tidy data frame with one row per message df = parser(synop_code, as_data_frame = TRUE) df -#> station_type station_id region obs_day obs_hour wind_unit wind_estimated -#> 1 AAXX 88889 III 1 0 KT FALSE -#> visibility cloud_cover wind_direction wind_speed air_temperature -#> 1 40000 6 150 6 9.4 -#> dewpoint_temperature station_pressure sea_level_pressure pressure_tendency -#> 1 4.7 1011.1 1019.7 0 -#> pressure_change precipitation_amount precipitation_time cloud_base_min -#> 1 7 0 6 1500 -#> cloud_base_max low_cloud_type middle_cloud_type high_cloud_type -#> 1 2000 5 4 1 -#> low_cloud_amount source -#> 1 1 AAXX 01004 88889 12782 61506 10094 20047 30111 40197 ... ``` +| station_type | station_id | region | obs_day | obs_hour | wind_unit | wind_estimated | visibility | cloud_cover | wind_direction | wind_speed | air_temperature | dewpoint_temperature | +|--------------|------------|--------|---------|----------|-----------|----------------|------------|-------------|----------------|------------|-----------------|----------------------| +| AAXX | 88889 | III | 1 | 0 | KT | FALSE | 40000 | 6 | 150 | 6 | 9.4 | 4.7 | + +| station_pressure | sea_level_pressure | pressure_tendency | pressure_change | precipitation_amount | precipitation_time | cloud_base_min | cloud_base_max | low_cloud_type | middle_cloud_type | high_cloud_type | low_cloud_amount | source | +|------------------|--------------------|-------------------|-----------------|----------------------|--------------------|----------------|----------------|----------------|-------------------|-----------------|------------------|-------------------------| +| 1011.1 | 1019.7 | 0 | 7 | 0 | 6 | 1500 | 2000 | 5 | 4 | 1 | 1 | AAXX 01004 88889 12782… | + ```r # Decode multiple SYNOP messages at once msgs = c( @@ -313,7 +307,7 @@ df2 = parser(msgs, as_data_frame = TRUE) nrow(df2) #> 2 df2$station_id #> c("88889", "26477") df2$source # original SYNOP strings preserved in last column -... + ``` ## Acknowledgment From 45ab132b3e63a1ad8f10323d2b84acf47b09259c Mon Sep 17 00:00:00 2001 From: bczernecki Date: Sun, 10 May 2026 14:49:44 +0200 Subject: [PATCH 16/16] SYNOP parser --- NAMESPACE | 2 + R/compute_relative_humidity.R | 45 +++ R/meteo_ogimet_synop.R | 368 ++++++++++++++++++ R/parser.R | 148 +++++-- data-raw/parametry_przyklad_synop.R | 27 -- man/compute_relative_humidity.Rd | 44 +++ man/meteo_ogimet_synop.Rd | 129 ++++++ man/parser.Rd | 9 + .../testthat/test-compute_relative_humidity.R | 36 ++ tests/testthat/test-meteo_ogimet_synop.R | 175 +++++++++ tests/testthat/test-nearest_stations_ogimet.R | 4 +- tests/testthat/test-parser.R | 107 +++-- 12 files changed, 1011 insertions(+), 83 deletions(-) create mode 100644 R/compute_relative_humidity.R create mode 100644 R/meteo_ogimet_synop.R delete mode 100644 data-raw/parametry_przyklad_synop.R create mode 100644 man/compute_relative_humidity.Rd create mode 100644 man/meteo_ogimet_synop.Rd create mode 100644 tests/testthat/test-compute_relative_humidity.R create mode 100644 tests/testthat/test-meteo_ogimet_synop.R diff --git a/NAMESPACE b/NAMESPACE index 4832175..f8c3046 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand export(.onAttach) +export(compute_relative_humidity) export(find_all_station_names) export(hydro_imgw) export(hydro_imgw_daily) @@ -15,6 +16,7 @@ export(meteo_imgw_monthly) export(meteo_noaa_co2) export(meteo_noaa_hourly) export(meteo_ogimet) +export(meteo_ogimet_synop) export(meteo_shortening_imgw) export(nearest_stations_imgw) export(nearest_stations_noaa) diff --git a/R/compute_relative_humidity.R b/R/compute_relative_humidity.R new file mode 100644 index 0000000..d0cc414 --- /dev/null +++ b/R/compute_relative_humidity.R @@ -0,0 +1,45 @@ +#' Compute relative humidity from air temperature and dew-point temperature +#' +#' Uses the August-Roche-Magnus approximation to derive relative humidity from +#' the 2-metre air temperature and dew-point temperature. +#' +#' @param t2m Numeric vector. Air temperature (2 m) in degrees Celsius. +#' @param dpt2m Numeric vector. Dew-point temperature (2 m) in degrees Celsius. +#' Must be the same length as `t2m`. +#' +#' @return Numeric vector of relative humidity values in percent (0–100). +#' Returns `NA` where either input is `NA`. Values are not clamped, so +#' rounding errors may produce results marginally outside 0–100. +#' +#' @details +#' The August-Roche-Magnus approximation is: +#' +#' \deqn{RH = 100 \times +#' \frac{\exp\!\bigl(\tfrac{17.625\,T_d}{243.04 + T_d}\bigr)} +#' {\exp\!\bigl(\tfrac{17.625\,T}{243.04 + T}\bigr)}} +#' +#' where \eqn{T} is the air temperature and \eqn{T_d} is the dew-point +#' temperature, both in degrees Celsius. The coefficients (17.625 and 243.04) +#' follow Alduchov & Eskridge (1996). +#' +#' @references +#' Alduchov, O. A., & Eskridge, R. E. (1996). Improved Magnus form approximation +#' of saturation vapor pressure. *Journal of Applied Meteorology*, 35(4), 601–609. +#' +#' @examples +#' compute_relative_humidity(t2m = 20, dpt2m = 10) # ~52 % +#' compute_relative_humidity(t2m = 0, dpt2m = 0) # 100 % +#' compute_relative_humidity(t2m = c(20, 15, NA), dpt2m = c(10, 12, 8)) +#' +#' @export +compute_relative_humidity = function(t2m, dpt2m) { + if (!is.numeric(t2m) || !is.numeric(dpt2m)) { + stop("`t2m` and `dpt2m` must be numeric vectors") + } + if (length(t2m) != length(dpt2m)) { + stop("`t2m` and `dpt2m` must have the same length") + } + a = 17.625 + b = 243.04 + 100 * exp((a * dpt2m) / (b + dpt2m)) / exp((a * t2m) / (b + t2m)) +} diff --git a/R/meteo_ogimet_synop.R b/R/meteo_ogimet_synop.R new file mode 100644 index 0000000..f9314c7 --- /dev/null +++ b/R/meteo_ogimet_synop.R @@ -0,0 +1,368 @@ +#' Download and decode raw SYNOP messages from the Ogimet getsynop service +#' +#' Downloads raw SYNOP messages from the Ogimet `getsynop` endpoint and decodes +#' them into a tidy `data.frame` using the [parser()] function. Two retrieval +#' modes are supported: +#' +#' - **Station mode** (`station` provided): fetches messages for one or more +#' WMO station IDs. +#' URL form: `http://www.ogimet.com/cgi-bin/getsynop?block=&begin=&end=` +#' +#' - **Country mode** (`country_name` provided): fetches messages for all +#' Ogimet stations in a country in a single request. +#' URL form: `http://www.ogimet.com/cgi-bin/getsynop?begin=&end=&state=` +#' +#' When both `station` and `country_name` are supplied, `country_name` takes +#' precedence and a warning is issued. +#' +#' Each line of the response is a comma-separated record: +#' `station_id,year,month,day,hour,minute,`. +#' The SYNOP message is decoded via [parser()] with `as_data_frame = TRUE`. +#' +#' @param station Numeric or character vector of WMO station IDs. Optional when +#' `country_name` is provided; required otherwise. +#' @param date Character or Date vector of length 2 giving the start and end of +#' the requested period, e.g. `c("2009-12-01", "2009-12-04")`. Defaults to +#' the last 30 days. +#' @param country Optional; passed to [parser()] for country-specific +#' precipitation indicator decoding (e.g. `"RU"`). Single string or `NULL` +#' (default). This is distinct from `country_name`. +#' @param country_name Optional character string naming the country whose +#' stations should be downloaded, as recognised by Ogimet (e.g. +#' `"Poland"`, `"Germany"`, `"France"`). When provided, the `state=` Ogimet +#' parameter is used and `station` is ignored. The full date range is +#' fetched in a single request. +#' @param simplified Logical. When `TRUE` (default) returns a compact `data.frame` with +#' 20 standardised columns (see **Value** below). When `FALSE` the +#' full parser output is returned. +#' @param allow_failure Logical. When `TRUE` (default) network errors are caught +#' and a message is emitted; when `FALSE` errors propagate to the caller. +#' +#' @return By default (`simplified = TRUE`), a compact `data.frame` with one +#' row per decoded SYNOP observation. Columns: +#' +#' * `date` — Observation date-time (`POSIXct`, UTC). +#' * `station` — WMO station identifier (character). +#' * `t2m` — Air temperature at 2 m (°C). +#' * `dpt2m` — Dew-point temperature at 2 m (°C). +#' * `rel_hum` — Relative humidity (%), derived via [compute_relative_humidity()]. +#' * `tmax` — Daily maximum temperature from Section 3 (°C). +#' * `tmin` — Daily minimum temperature from Section 3 (°C). +#' * `wd` — Wind direction (degrees). +#' * `ws` — Wind speed (m/s or knots, per `wind_unit`). +#' * `gust` — Highest gust speed from Section 3, same unit as `ws`. +#' * `press` — Station-level pressure (hPa). +#' * `slp` — Sea-level pressure (hPa). +#' * `press_tend` — 3-hour pressure change (hPa). +#' * `precip` — Precipitation amount (mm). +#' * `Nt` — Total cloud cover (oktas, 0–8) from the `Nddff` group. +#' * `Nh` — Cover of low clouds (genera Sc, St, Cu, Cb) in oktas (0–8), +#' from Section 1 group `8NhCLCMCH`; `NA` when not reported. +#' * `N_base` — Height of base of lowest observed cloud (m). +#' * `insol` — Daily sunshine duration (hours). +#' * `visibility` — Horizontal visibility (m). +#' * `snow` — Total snow depth (cm); 0 for trace amounts. +#' +#' When `simplified = FALSE`, a `data.frame` with the first two columns +#' `station_id` (WMO identifier, character) and `Date` (`POSIXct`, UTC), +#' followed by all columns produced by [parser()] with `as_data_frame = TRUE`: +#' `station_type`, `region`, `obs_day`, `obs_hour`, `wind_unit`, +#' `wind_estimated`, `visibility`, `cloud_cover`, `wind_direction`, +#' `wind_speed`, `air_temperature`, `dewpoint_temperature`, +#' `station_pressure`, `sea_level_pressure`, `pressure_tendency`, +#' `pressure_change`, `precipitation_amount`, `precipitation_time`, +#' `cloud_base_min`, `cloud_base_max`, `low_cloud_type`, `middle_cloud_type`, +#' `high_cloud_type`, `low_cloud_amount`, `maximum_temperature`, +#' `minimum_temperature`, `gust`, `sunshine_duration`, +#' `snow_depth`, `snow_depth_state`, `source`. +#' +#' Returns `NULL` invisibly when the download fails and `allow_failure = TRUE`. +#' +#' @export +#' +#' @examples +#' \donttest{ +#' # Station mode: Poznan-Lawica (Poland) +#' poznan = meteo_ogimet_synop(station = 12330, +#' date = c("2009-12-01", "2009-12-04")) +#' head(poznan) +#' +#' # Station mode: multiple stations +#' two_stations = meteo_ogimet_synop(station = c(12330, 12375), +#' date = c("2019-06-01", "2019-06-03")) +#' head(two_stations) +#' +#' # Country mode: all Polish stations for one day +#' poland = meteo_ogimet_synop(country_name = "Poland", +#' date = c("2009-12-15", "2009-12-15")) +#' head(poland) +#' +#' # Simplified view +#' poznan_simple = meteo_ogimet_synop(station = 12330, +#' date = c("2009-12-01", "2009-12-04"), +#' simplified = TRUE) +#' head(poznan_simple) +#' } +#' +meteo_ogimet_synop = function(station = NULL, + date = c(Sys.Date() - 30, Sys.Date()), + country = NULL, + country_name = NULL, + simplified = TRUE, + allow_failure = TRUE) { + if (allow_failure) { + tryCatch( + meteo_ogimet_synop_bp(station = station, date = date, + country = country, country_name = country_name, + simplified = simplified), + error = function(e) { + message(paste("Problems with downloading data.", + "Run function with argument allow_failure = FALSE", + "to see more details")) + invisible(NULL) + } + ) + } else { + meteo_ogimet_synop_bp(station = station, date = date, + country = country, country_name = country_name, + simplified = simplified) + } +} + +#' @keywords internal +#' @noRd +meteo_ogimet_synop_bp = function(station, date, country, country_name, simplified) { + + if (is.null(station) && is.null(country_name)) { + stop("Provide at least one of `station` or `country_name`.") + } + + if (!is.null(station) && !is.null(country_name)) { + warning("`station` is ignored when `country_name` is provided.", call. = FALSE) + station = NULL + } + + if (!curl::has_internet()) { + message("No internet connection!") + return(invisible(NULL)) + } + + all_results = list() + + begin_date = as.Date(min(date)) + end_date = as.Date(max(date)) + + if (!is.null(country_name)) { + # ── Country mode ───────────────────────────────────────────────────────── + # Single request (auto-split if response exceeds 200 000 rows). + message(paste("Downloading country:", country_name)) + url_tmpl = paste0( + "http://www.ogimet.com/cgi-bin/getsynop?begin=%s", + "&end=%s", + "&state=", utils::URLencode(country_name, reserved = TRUE) + ) + chunk = .ogimet_synop_fetch_decode(url_tmpl, begin_date, end_date, + label = country_name, country = country, + use_csv_station_id = TRUE) + if (!is.null(chunk)) all_results[[length(all_results) + 1L]] = chunk + + } else { + # ── Station mode ────────────────────────────────────────────────────────── + for (station_nr in station) { + message(paste("station:", station_nr)) + url_tmpl = paste0( + "http://www.ogimet.com/cgi-bin/getsynop?block=", station_nr, + "&begin=%s&end=%s" + ) + chunk = .ogimet_synop_fetch_decode(url_tmpl, begin_date, end_date, + label = station_nr, country = country, + use_csv_station_id = FALSE, + station_id_override = as.character(station_nr)) + if (!is.null(chunk)) all_results[[length(all_results) + 1L]] = chunk + + if (!identical(station_nr, station[length(station)])) Sys.sleep(20) + } + } + + if (length(all_results) == 0) return(invisible(NULL)) + + out = do.call(rbind, all_results) + rownames(out) = NULL + + out = out[which(!is.na(out$Date) & + as.Date(out$Date) >= as.Date(min(date)) & + as.Date(out$Date) <= as.Date(max(date))), ] + out = unique(out) + rownames(out) = NULL + + if (simplified) { + out = data.frame( + date = out$Date, + station = out$station_id, + t2m = out$air_temperature, + dpt2m = out$dewpoint_temperature, + rel_hum = round(compute_relative_humidity(out$air_temperature, + out$dewpoint_temperature), 1), + tmax = out$maximum_temperature, + tmin = out$minimum_temperature, + wd = out$wind_direction, + ws = out$wind_speed, + gust = out$gust, + press = out$station_pressure, + slp = out$sea_level_pressure, + press_tend = out$pressure_change, + precip = out$precipitation_amount, + Nt = out$cloud_cover, + Nh = out$low_cloud_amount, + N_base = out$cloud_base_min, + insol = out$sunshine_duration, + visibility = out$visibility, + snow = out$snow_depth, + stringsAsFactors = FALSE + ) + } + + out +} + +# Recursive raw-line fetcher. +# +# Builds the URL from `url_tmpl` (a sprintf template with two %s slots for +# begin and end timestamps), GETs it, and returns the non-empty trimmed lines. +# Ogimet caps responses at 200 000 rows server-side; receiving exactly that many +# lines signals truncation, so the date range is halved and each half is fetched +# recursively. When the range can no longer be bisected (begin_date == end_date) +# a warning is issued and the truncated chunk is returned as-is. +.ogimet_synop_raw_lines = function(url_tmpl, begin_date, end_date, label) { + begin_str = paste0(format(begin_date, "%Y%m%d"), "0000") + end_str = paste0(format(end_date, "%Y%m%d"), "2359") + url = sprintf(url_tmpl, begin_str, end_str) + message(url) + + resp = tryCatch( + httr::GET( + url, + httr::add_headers( + `User-Agent` = "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:143.0) Gecko/20100101 Firefox/143.0", + `Accept` = "text/plain,text/html,*/*", + `Accept-Language` = "en-US,en;q=0.5", + `Referer` = "http://www.ogimet.com/getsynop.phtml" + ) + ), + error = function(e) NULL + ) + + if (is.null(resp) || httr::http_error(resp)) { + message(paste("Could not retrieve data for:", label)) + return(NULL) + } + + body = httr::content(resp, as = "text", encoding = "UTF-8") + if (is.na(body) || !nzchar(trimws(body))) { + message(paste("Empty response for:", label)) + return(NULL) + } + + lines = strsplit(body, "\n")[[1]] + lines = trimws(lines[nzchar(trimws(lines))]) + + # 200 000 rows is the Ogimet server cap: receiving that many means the + # response was truncated, so split the date range and retry each half. + if (length(lines) >= 200000L) { + if (begin_date >= end_date) { + warning( + paste0("Response for ", label, " hit the 200 000-row server limit but", + " the date range cannot be split further. Returning partial results."), + call. = FALSE + ) + return(lines) + } + mid_date = begin_date + as.integer((end_date - begin_date) / 2L) + message(paste0( + "Server limit reached (200 000 rows); splitting date range: [", + begin_date, ", ", mid_date, "] and [", mid_date + 1L, ", ", end_date, "]" + )) + lo = .ogimet_synop_raw_lines(url_tmpl, begin_date, mid_date, label) + hi = .ogimet_synop_raw_lines(url_tmpl, mid_date + 1L, end_date, label) + return(c(lo, hi)) + } + + lines +} + +# Internal: fetch, (recursively) split if server limit is hit, parse lines, decode SYNOP. +# `url_tmpl` - sprintf template; two %s slots for begin/end timestamps +# `begin_date`/`end_date` - Date objects defining the requested range +# `label` - used in user-facing messages (station ID or country name) +# `use_csv_station_id` - TRUE -> station_id taken from field 1 of each CSV line +# FALSE -> station_id_override is used for every row +.ogimet_synop_fetch_decode = function(url_tmpl, begin_date, end_date, label, country, + use_csv_station_id, station_id_override = NULL) { + lines = .ogimet_synop_raw_lines(url_tmpl, begin_date, end_date, label) + + if (is.null(lines) || length(lines) == 0) { + message(paste("No SYNOP data returned for:", label)) + return(NULL) + } + + # Each line: station_id,year,month,day,hour,minute, + # Older records may omit the minute field (6 fields instead of 7). + parsed_lines = lapply(lines, function(line) { + parts = strsplit(line, ",", fixed = TRUE)[[1]] + n = length(parts) + if (n < 6) return(NULL) + + sid = if (use_csv_station_id) trimws(parts[1]) else station_id_override + yr = as.integer(parts[2]) + mo = as.integer(parts[3]) + dy = as.integer(parts[4]) + hr = as.integer(parts[5]) + + if (n >= 7) { + mn = as.integer(parts[6]) + synop_msg = paste(parts[7:n], collapse = ",") + } else { + mn = 0L + synop_msg = parts[6] + } + + dt = tryCatch( + as.POSIXct( + sprintf("%04d-%02d-%02d %02d:%02d", yr, mo, dy, hr, mn), + format = "%Y-%m-%d %H:%M", + tz = "UTC" + ), + error = function(e) NA + ) + + list(station_id = sid, Date = dt, synop = trimws(synop_msg)) + }) + + parsed_lines = Filter(Negate(is.null), parsed_lines) + if (length(parsed_lines) == 0) { + message(paste("Could not parse any lines for:", label)) + return(NULL) + } + + synop_msgs = vapply(parsed_lines, `[[`, character(1), "synop") + dates = do.call(c, lapply(parsed_lines, `[[`, "Date")) + station_ids = vapply(parsed_lines, `[[`, character(1), "station_id") + + decoded = tryCatch( + parser(synop_msgs, country = country, as_data_frame = TRUE), + error = function(e) { + message(paste("SYNOP decoding failed for", label, ":", conditionMessage(e))) + NULL + } + ) + if (is.null(decoded)) return(NULL) + + decoded$station_id = station_ids + + data.frame( + station_id = station_ids, + Date = dates, + decoded[, setdiff(names(decoded), "station_id")], + stringsAsFactors = FALSE + ) +} diff --git a/R/parser.R b/R/parser.R index 8dcd58e..d985c99 100644 --- a/R/parser.R +++ b/R/parser.R @@ -27,6 +27,15 @@ #' `pressure_change`, `precipitation_amount`, `precipitation_time`, #' `cloud_base_min`, `cloud_base_max`, `low_cloud_type`, #' `middle_cloud_type`, `high_cloud_type`, `low_cloud_amount`, +#' `maximum_temperature` (Section 3 daily maximum, °C), +#' `minimum_temperature` (Section 3 daily minimum, °C), +#' `gust` (highest gust speed from Section 3 group 910ff/911ff, in the wind unit of the message), +#' `cloudiness_height` (cloud cover in oktas of the highest cloud layer reported in Section 3, +#' i.e. cirrus/cirrocumulus/cirrostratus; `NA` when absent), +#' `sunshine_duration` (daily sunshine in hours, from Section 3 group 55SSS), +#' `snow_depth` (total snow depth in cm; 0 for trace amounts, `NA` for non-continuous cover or +#' unmeasurable depth), `snow_depth_state` (descriptive state of ground with snow/ice per WMO +#' code table 0975, e.g. `"Even layer of loose dry snow covering ground completely"`), #' `source` (the original SYNOP message string). #' Row names are sequential integers. #' @examples @@ -60,7 +69,7 @@ parser = function(message, country = NULL, simplify = TRUE, as_data_frame = FALS synop$country = cntry synop$decode(msg) } else { - warning("Empty SYNOP message supplied; returning NULL.") + message("Empty SYNOP message supplied; returning NULL.") NULL } }, @@ -122,6 +131,27 @@ parser = function(message, country = NULL, simplify = TRUE, as_data_frame = FALS middle_cloud_type = .sg(x, "cloud_types", "middle_cloud_type", "value"), high_cloud_type = .sg(x, "cloud_types", "high_cloud_type", "value"), low_cloud_amount = .sg(x, "cloud_types", "low_cloud_amount", "value"), + maximum_temperature = .sg(x, "maximum_temperature", "value"), + minimum_temperature = .sg(x, "minimum_temperature", "value"), + gust = { + gusts = x[["highest_gust"]] + if (!is.null(gusts) && length(gusts) > 0) .sg(gusts[[1]], "speed", "value") else NA_real_ + }, + cloudiness_height = { + layers = x[["cloud_layer"]] + high_genera = c("Ci", "Cc", "Cs") + if (!is.null(layers) && length(layers) > 0) { + high_idx = which(vapply(layers, function(l) { + isTRUE(l[["cloud_genus"]][["value"]] %in% high_genera) + }, logical(1))) + if (length(high_idx) > 0) { + as.numeric(layers[[high_idx[1L]]][["cloud_cover"]][["value"]]) + } else NA_real_ + } else NA_real_ + }, + sunshine_duration = .sg(x, "sunshine", "value"), + snow_depth = .sg(x, "snow_depth", "depth", "value"), + snow_depth_state = .sg(x, "snow_depth", "state_of_ground"), source = source, stringsAsFactors = FALSE ) @@ -200,7 +230,7 @@ Observation = R6Class("Observation", tryCatch({ self$decode_internal(raw, ...) }, error = function(e) { - warning(paste("Unable to decode:", raw)) + message(paste("Unable to decode:", raw)) NULL }) }, @@ -221,7 +251,7 @@ Observation = R6Class("Observation", self$encode_internal(data, ...) } }, error = function(e) { - warning(paste("Unable to encode:", toString(data))) + message(paste("Unable to encode:", toString(data))) paste(rep(self$null_char, self$code_len), collapse = "") }) }, @@ -279,10 +309,13 @@ Observation = R6Class("Observation", out_val = tryCatch({ self$code_table$decode(val, ...) }, error = function(e) { - warning(paste("Error decoding with code table:", val, "-", e$message)) + message(paste("Error decoding with code table:", val, "-", e$message)) NULL }, warning = function(w) { - warning(paste("Warning decoding with code table:", val, "-", w$message)) + message(paste("Warning decoding with code table:", val, "-", w$message)) + NULL + }, message = function(m) { + message(paste("Warning decoding with code table:", val, "-", trimws(conditionMessage(m)))) NULL }) @@ -556,7 +589,7 @@ CodeTable = R6Class("CodeTable", } result }, error = function(e) { - warning(paste("Unable to decode", value, "in", class(self)[1])) + message(paste("Unable to decode", value, "in", class(self)[1])) NULL }) }, @@ -857,7 +890,7 @@ Temperature = R6Class("Temperature", } if (!sn %in% c("0", "1", "/")) { - warning(paste(group, "is an invalid temperature group")) + message(paste(group, "is an invalid temperature group")) return(NULL) } @@ -916,7 +949,7 @@ SurfaceWind = R6Class("SurfaceWind", # Sanity check: if wind is calm, it can't have a speed if (!is.null(direction) && !is.null(direction$calm) && direction$calm && !is.null(speed) && !is.null(speed$value) && speed$value > 0) { - warning(paste("Wind is calm, yet has a speed (dd:", dd, ", ff:", ff, ")")) + message(paste("Wind is calm, yet has a speed (dd:", dd, ", ff:", ff, ")")) speed = NULL } @@ -1057,7 +1090,7 @@ SYNOP = R6Class("SYNOP", data$region = result } }, error = function(e) { - warning(paste("Error decoding region:", e$message)) + message(paste("Error decoding region:", e$message)) }) # Check if next group is NIL (station did not send data) @@ -1087,7 +1120,7 @@ SYNOP = R6Class("SYNOP", section1 = next_check # Use the group we already got if (is.null(section1) || nchar(section1) < 5) { # If section1 is invalid, try to continue anyway - warning("Invalid or missing section 1") + message("Invalid or missing section 1") return(data) } @@ -1099,7 +1132,7 @@ SYNOP = R6Class("SYNOP", data$precipitation_indicator = result } }, error = function(e) { - warning(paste("Error decoding precipitation indicator:", e$message)) + message(paste("Error decoding precipitation indicator:", e$message)) }) tryCatch({ @@ -1109,7 +1142,7 @@ SYNOP = R6Class("SYNOP", data$weather_indicator = result } }, error = function(e) { - warning(paste("Error decoding weather indicator:", e$message)) + message(paste("Error decoding weather indicator:", e$message)) }) tryCatch({ @@ -1119,7 +1152,7 @@ SYNOP = R6Class("SYNOP", data$lowest_cloud_base = result } }, error = function(e) { - warning(paste("Error decoding lowest cloud base:", e$message)) + message(paste("Error decoding lowest cloud base:", e$message)) }) tryCatch({ @@ -1129,7 +1162,7 @@ SYNOP = R6Class("SYNOP", data$visibility = result } }, error = function(e) { - warning(paste("Error decoding visibility:", e$message)) + message(paste("Error decoding visibility:", e$message)) }) # Get cloud cover and wind (Nddff) @@ -1142,7 +1175,9 @@ SYNOP = R6Class("SYNOP", data$cloud_cover = result } }, error = function(e) { - warning(paste("Error decoding cloud cover from:", nddff, "-", e$message)) + message(paste("Error decoding cloud cover from:", nddff, "-", e$message)) + }, message = function(m) { + message(paste("Warning decoding group:", nddff, "-", trimws(conditionMessage(m)))) }) tryCatch({ @@ -1157,7 +1192,9 @@ SYNOP = R6Class("SYNOP", data$surface_wind = wind_data } }, error = function(e) { - warning(paste("Error decoding surface wind from:", nddff, "-", e$message)) + message(paste("Error decoding surface wind from:", nddff, "-", e$message)) + }, message = function(m) { + message(paste("Warning decoding group:", nddff, "-", trimws(conditionMessage(m)))) }) } @@ -1173,11 +1210,11 @@ SYNOP = R6Class("SYNOP", header = tryCatch({ as.integer(substr(next_grp, 1, 1)) }, error = function(e) { - warning(paste("Unable to parse header from group:", next_grp)) + message(paste("Unable to parse header from group:", next_grp)) next_grp <<- next_group() return(NULL) }, warning = function(w) { - warning(paste("Warning parsing header from group:", next_grp)) + message(paste("Warning parsing header from group:", next_grp)) next_grp <<- next_group() return(NULL) }) @@ -1272,10 +1309,13 @@ SYNOP = R6Class("SYNOP", } } }, error = function(e) { - warning(paste("Error decoding group:", next_grp, "-", e$message)) + message(paste("Error decoding group:", next_grp, "-", e$message)) # Continue to next group }, warning = function(w) { - warning(paste("Warning decoding group:", next_grp, "-", w$message)) + message(paste("Warning decoding group:", next_grp, "-", w$message)) + # Continue to next group + }, message = function(m) { + message(paste("Warning decoding group:", next_grp, "-", trimws(conditionMessage(m)))) # Continue to next group }) @@ -1294,10 +1334,10 @@ SYNOP = R6Class("SYNOP", header = tryCatch({ as.integer(substr(next_grp, 1, 1)) }, error = function(e) { - warning(paste("Unable to parse header from group:", next_grp)) + message(paste("Unable to parse header from group:", next_grp)) return(NULL) }, warning = function(w) { - warning(paste("Warning parsing header from group:", next_grp)) + message(paste("Warning parsing header from group:", next_grp)) return(NULL) }) @@ -1333,6 +1373,56 @@ SYNOP = R6Class("SYNOP", if (!is.null(result)) { data$minimum_temperature = result } + } else if (header == 4) { + # Snow depth: 4E'sss (WMO No. 306, Section 3) + # E' = state of ground with snow/ice (code table 0975) + # sss = total snow depth in whole cm, or special values: + # 000 / 997 -> trace (< 0.5 cm) + # 998 -> snow cover not continuous + # 999 -> depth cannot be measured (drifts) + .snow_ground_states = c( + "0" = "Ground predominantly covered by ice", + "1" = "Compact or wet snow covering less than one-half of the ground", + "2" = "Compact or wet snow covering at least one-half of the ground but not completely", + "3" = "Even layer of compact or wet snow covering ground completely", + "4" = "Uneven layer of compact or wet snow covering ground completely", + "5" = "Loose dry snow covering less than one-half of the ground", + "6" = "Loose dry snow covering at least one-half of the ground but not completely", + "7" = "Even layer of loose dry snow covering ground completely", + "8" = "Uneven layer of loose dry snow covering ground completely", + "9" = "Snow covering ground completely; deep drifts within or nearby" + ) + if (nchar(next_grp) >= 5) { + e_prime = substr(next_grp, 2, 2) + sss_raw = substr(next_grp, 3, 5) + if (sss_raw != "///") { + sss_int = suppressWarnings(as.integer(sss_raw)) + if (!is.na(sss_int)) { + depth_val = if (sss_int %in% c(0L, 997L)) { + 0 + } else if (sss_int %in% c(998L, 999L)) { + NA_real_ + } else { + as.numeric(sss_int) + } + special_val = switch(as.character(sss_int), + "0" = , "997" = "trace", + "998" = "not_continuous", + "999" = "unmeasurable", + NULL + ) + state_desc = unname(.snow_ground_states[e_prime]) + data$snow_depth = list( + state_of_ground = if (!is.na(state_desc)) state_desc else NA_character_, + depth = list( + value = depth_val, + unit = "cm", + special = special_val + ) + ) + } + } + } } else if (header == 5) { # Section 3 group 5: only 55SSS (daily sunshine in 1/10 h) is implemented. # Pressure-change subgroups (j1 in 1..4) and radiation (j1 in 6..9) are skipped. @@ -1351,10 +1441,13 @@ SYNOP = R6Class("SYNOP", } } }, error = function(e) { - warning(paste("Error decoding group:", next_grp, "-", e$message)) + message(paste("Error decoding group:", next_grp, "-", e$message)) # Continue to next group }, warning = function(w) { - warning(paste("Warning decoding group:", next_grp, "-", w$message)) + message(paste("Warning decoding group:", next_grp, "-", w$message)) + # Continue to next group + }, message = function(m) { + message(paste("Warning decoding group:", next_grp, "-", trimws(conditionMessage(m)))) # Continue to next group }) @@ -1425,10 +1518,13 @@ SYNOP = R6Class("SYNOP", idx = idx + 1 } }, error = function(e) { - warning(paste("Error decoding group 9 code:", g, "-", e$message)) + message(paste("Error decoding group 9 code:", g, "-", e$message)) idx <<- idx + 1 }, warning = function(w) { - warning(paste("Warning decoding group 9 code:", g, "-", w$message)) + message(paste("Warning decoding group 9 code:", g, "-", w$message)) + idx <<- idx + 1 + }, message = function(m) { + message(paste("Warning decoding group 9 code:", g, "-", trimws(conditionMessage(m)))) idx <<- idx + 1 }) } diff --git a/data-raw/parametry_przyklad_synop.R b/data-raw/parametry_przyklad_synop.R deleted file mode 100644 index 8f74ada..0000000 --- a/data-raw/parametry_przyklad_synop.R +++ /dev/null @@ -1,27 +0,0 @@ -library(imgw) -library(stringr) -synop = meteo_daily("synop", year=2010) -daily = synop -head(daily) - -abbrev = read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) -saveRDS(abbrev, file="data/abbrev.rda") -abbrev = read.csv("data-raw/parametry_skrot.csv", stringsAsFactors = F) - -orig_columns = trimws(gsub("\\s+", " ", colnames(daily))) # remove double spaces - -# fullname polish, no changes required: -abbrev$fullname[match(orig_columns, abbrev$fullname)] - -# abbrev english -colnames(synop) = abbrev$abbr_ang[match(orig_columns, abbrev$fullname)] -head(synop) - -# fullname english -colnames(synop) = abbrev$fullname_ang[match(orig_columns, abbrev$fullname)] -head(synop) - - -# zastanowic sie nad usunieciem zduplikowanych kolumn (Np. nazwa stacji) -synop = synop[,!duplicated(colnames(synop))] -head(synop) diff --git a/man/compute_relative_humidity.Rd b/man/compute_relative_humidity.Rd new file mode 100644 index 0000000..1882581 --- /dev/null +++ b/man/compute_relative_humidity.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/compute_relative_humidity.R +\name{compute_relative_humidity} +\alias{compute_relative_humidity} +\title{Compute relative humidity from air temperature and dew-point temperature} +\usage{ +compute_relative_humidity(t2m, dpt2m) +} +\arguments{ +\item{t2m}{Numeric vector. Air temperature (2 m) in degrees Celsius.} + +\item{dpt2m}{Numeric vector. Dew-point temperature (2 m) in degrees Celsius. +Must be the same length as \code{t2m}.} +} +\value{ +Numeric vector of relative humidity values in percent (0–100). +Returns \code{NA} where either input is \code{NA}. Values are not clamped, so +rounding errors may produce results marginally outside 0–100. +} +\description{ +Uses the August-Roche-Magnus approximation to derive relative humidity from +the 2-metre air temperature and dew-point temperature. +} +\details{ +The August-Roche-Magnus approximation is: + +\deqn{RH = 100 \times + \frac{\exp\!\bigl(\tfrac{17.625\,T_d}{243.04 + T_d}\bigr)} + {\exp\!\bigl(\tfrac{17.625\,T}{243.04 + T}\bigr)}} + +where \eqn{T} is the air temperature and \eqn{T_d} is the dew-point +temperature, both in degrees Celsius. The coefficients (17.625 and 243.04) +follow Alduchov & Eskridge (1996). +} +\examples{ +compute_relative_humidity(t2m = 20, dpt2m = 10) # ~52 \% +compute_relative_humidity(t2m = 0, dpt2m = 0) # 100 \% +compute_relative_humidity(t2m = c(20, 15, NA), dpt2m = c(10, 12, 8)) + +} +\references{ +Alduchov, O. A., & Eskridge, R. E. (1996). Improved Magnus form approximation +of saturation vapor pressure. \emph{Journal of Applied Meteorology}, 35(4), 601–609. +} diff --git a/man/meteo_ogimet_synop.Rd b/man/meteo_ogimet_synop.Rd new file mode 100644 index 0000000..5fb1c22 --- /dev/null +++ b/man/meteo_ogimet_synop.Rd @@ -0,0 +1,129 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/meteo_ogimet_synop.R +\name{meteo_ogimet_synop} +\alias{meteo_ogimet_synop} +\title{Download and decode raw SYNOP messages from the Ogimet getsynop service} +\usage{ +meteo_ogimet_synop( + station = NULL, + date = c(Sys.Date() - 30, Sys.Date()), + country = NULL, + country_name = NULL, + simplified = TRUE, + allow_failure = TRUE +) +} +\arguments{ +\item{station}{Numeric or character vector of WMO station IDs. Optional when +\code{country_name} is provided; required otherwise.} + +\item{date}{Character or Date vector of length 2 giving the start and end of +the requested period, e.g. \code{c("2009-12-01", "2009-12-04")}. Defaults to +the last 30 days.} + +\item{country}{Optional; passed to \code{\link[=parser]{parser()}} for country-specific +precipitation indicator decoding (e.g. \code{"RU"}). Single string or \code{NULL} +(default). This is distinct from \code{country_name}.} + +\item{country_name}{Optional character string naming the country whose +stations should be downloaded, as recognised by Ogimet (e.g. +\code{"Poland"}, \code{"Germany"}, \code{"France"}). When provided, the \verb{state=} Ogimet +parameter is used and \code{station} is ignored. The full date range is +fetched in a single request.} + +\item{simplified}{Logical. When \code{TRUE} (default) returns a compact \code{data.frame} with +20 standardised columns (see \strong{Value} below). When \code{FALSE} the +full parser output is returned.} + +\item{allow_failure}{Logical. When \code{TRUE} (default) network errors are caught +and a message is emitted; when \code{FALSE} errors propagate to the caller.} +} +\value{ +By default (\code{simplified = TRUE}), a compact \code{data.frame} with one +row per decoded SYNOP observation. Columns: +\itemize{ +\item \code{date} — Observation date-time (\code{POSIXct}, UTC). +\item \code{station} — WMO station identifier (character). +\item \code{t2m} — Air temperature at 2 m (°C). +\item \code{dpt2m} — Dew-point temperature at 2 m (°C). +\item \code{rel_hum} — Relative humidity (\%), derived via \code{\link[=compute_relative_humidity]{compute_relative_humidity()}}. +\item \code{tmax} — Daily maximum temperature from Section 3 (°C). +\item \code{tmin} — Daily minimum temperature from Section 3 (°C). +\item \code{wd} — Wind direction (degrees). +\item \code{ws} — Wind speed (m/s or knots, per \code{wind_unit}). +\item \code{gust} — Highest gust speed from Section 3, same unit as \code{ws}. +\item \code{press} — Station-level pressure (hPa). +\item \code{slp} — Sea-level pressure (hPa). +\item \code{press_tend} — 3-hour pressure change (hPa). +\item \code{precip} — Precipitation amount (mm). +\item \code{Nt} — Total cloud cover (oktas, 0–8) from the \code{Nddff} group. +\item \code{Nh} — Cover of low clouds (genera Sc, St, Cu, Cb) in oktas (0–8), +from Section 1 group \verb{8NhCLCMCH}; \code{NA} when not reported. +\item \code{N_base} — Height of base of lowest observed cloud (m). +\item \code{insol} — Daily sunshine duration (hours). +\item \code{visibility} — Horizontal visibility (m). +\item \code{snow} — Total snow depth (cm); 0 for trace amounts. +} + +When \code{simplified = FALSE}, a \code{data.frame} with the first two columns +\code{station_id} (WMO identifier, character) and \code{Date} (\code{POSIXct}, UTC), +followed by all columns produced by \code{\link[=parser]{parser()}} with \code{as_data_frame = TRUE}: +\code{station_type}, \code{region}, \code{obs_day}, \code{obs_hour}, \code{wind_unit}, +\code{wind_estimated}, \code{visibility}, \code{cloud_cover}, \code{wind_direction}, +\code{wind_speed}, \code{air_temperature}, \code{dewpoint_temperature}, +\code{station_pressure}, \code{sea_level_pressure}, \code{pressure_tendency}, +\code{pressure_change}, \code{precipitation_amount}, \code{precipitation_time}, +\code{cloud_base_min}, \code{cloud_base_max}, \code{low_cloud_type}, \code{middle_cloud_type}, +\code{high_cloud_type}, \code{low_cloud_amount}, \code{maximum_temperature}, +\code{minimum_temperature}, \code{gust}, \code{sunshine_duration}, +\code{snow_depth}, \code{snow_depth_state}, \code{source}. + +Returns \code{NULL} invisibly when the download fails and \code{allow_failure = TRUE}. +} +\description{ +Downloads raw SYNOP messages from the Ogimet \code{getsynop} endpoint and decodes +them into a tidy \code{data.frame} using the \code{\link[=parser]{parser()}} function. Two retrieval +modes are supported: +} +\details{ +\itemize{ +\item \strong{Station mode} (\code{station} provided): fetches messages for one or more +WMO station IDs. +URL form: \verb{http://www.ogimet.com/cgi-bin/getsynop?block=&begin=&end=} +\item \strong{Country mode} (\code{country_name} provided): fetches messages for all +Ogimet stations in a country in a single request. +URL form: \verb{http://www.ogimet.com/cgi-bin/getsynop?begin=&end=&state=} +} + +When both \code{station} and \code{country_name} are supplied, \code{country_name} takes +precedence and a warning is issued. + +Each line of the response is a comma-separated record: +\verb{station_id,year,month,day,hour,minute,}. +The SYNOP message is decoded via \code{\link[=parser]{parser()}} with \code{as_data_frame = TRUE}. +} +\examples{ +\donttest{ + # Station mode: Poznan-Lawica (Poland) + poznan = meteo_ogimet_synop(station = 12330, + date = c("2009-12-01", "2009-12-04")) + head(poznan) + + # Station mode: multiple stations + two_stations = meteo_ogimet_synop(station = c(12330, 12375), + date = c("2019-06-01", "2019-06-03")) + head(two_stations) + + # Country mode: all Polish stations for one day + poland = meteo_ogimet_synop(country_name = "Poland", + date = c("2009-12-15", "2009-12-15")) + head(poland) + + # Simplified view + poznan_simple = meteo_ogimet_synop(station = 12330, + date = c("2009-12-01", "2009-12-04"), + simplified = TRUE) + head(poznan_simple) +} + +} diff --git a/man/parser.Rd b/man/parser.Rd index 7b00541..511d7ff 100644 --- a/man/parser.Rd +++ b/man/parser.Rd @@ -33,6 +33,15 @@ appropriate, \code{NA} when not present in the message): \code{pressure_change}, \code{precipitation_amount}, \code{precipitation_time}, \code{cloud_base_min}, \code{cloud_base_max}, \code{low_cloud_type}, \code{middle_cloud_type}, \code{high_cloud_type}, \code{low_cloud_amount}, +\code{maximum_temperature} (Section 3 daily maximum, °C), +\code{minimum_temperature} (Section 3 daily minimum, °C), +\code{gust} (highest gust speed from Section 3 group 910ff/911ff, in the wind unit of the message), +\code{cloudiness_height} (cloud cover in oktas of the highest cloud layer reported in Section 3, +i.e. cirrus/cirrocumulus/cirrostratus; \code{NA} when absent), +\code{sunshine_duration} (daily sunshine in hours, from Section 3 group 55SSS), +\code{snow_depth} (total snow depth in cm; 0 for trace amounts, \code{NA} for non-continuous cover or +unmeasurable depth), \code{snow_depth_state} (descriptive state of ground with snow/ice per WMO +code table 0975, e.g. \code{"Even layer of loose dry snow covering ground completely"}), \code{source} (the original SYNOP message string). Row names are sequential integers. } diff --git a/tests/testthat/test-compute_relative_humidity.R b/tests/testthat/test-compute_relative_humidity.R new file mode 100644 index 0000000..47990b7 --- /dev/null +++ b/tests/testthat/test-compute_relative_humidity.R @@ -0,0 +1,36 @@ +test_that("compute_relative_humidity returns 100% when t2m equals dpt2m", { + expect_equal(compute_relative_humidity(0, 0), 100) + expect_equal(compute_relative_humidity(20, 20), 100) + expect_equal(compute_relative_humidity(-10, -10), 100) +}) + +test_that("compute_relative_humidity returns plausible value for known inputs", { + rh = compute_relative_humidity(t2m = 20, dpt2m = 10) + expect_gt(rh, 50) + expect_lt(rh, 55) +}) + +test_that("compute_relative_humidity is vectorised", { + rh = compute_relative_humidity(t2m = c(20, 0), dpt2m = c(20, 0)) + expect_equal(rh, c(100, 100)) +}) + +test_that("compute_relative_humidity propagates NA", { + expect_true(is.na(compute_relative_humidity(NA_real_, 10))) + expect_true(is.na(compute_relative_humidity(20, NA_real_))) +}) + +test_that("compute_relative_humidity stops on non-numeric input", { + expect_error(compute_relative_humidity("20", 10)) + expect_error(compute_relative_humidity(20, "10")) +}) + +test_that("compute_relative_humidity stops on mismatched lengths", { + expect_error(compute_relative_humidity(c(20, 15), 10)) +}) + +test_that("compute_relative_humidity decreases as dpt2m decreases from t2m", { + rh_high = compute_relative_humidity(20, 18) + rh_low = compute_relative_humidity(20, 5) + expect_gt(rh_high, rh_low) +}) diff --git a/tests/testthat/test-meteo_ogimet_synop.R b/tests/testthat/test-meteo_ogimet_synop.R new file mode 100644 index 0000000..4143597 --- /dev/null +++ b/tests/testthat/test-meteo_ogimet_synop.R @@ -0,0 +1,175 @@ +test_that("meteo_ogimet_synop stops when neither station nor country_name is given", { + expect_error( + meteo_ogimet_synop(allow_failure = FALSE), + "station.*country_name" + ) +}) + +test_that(".ogimet_synop_raw_lines splits and recurses when server limit is reached", { + # Stub the HTTP layer so no network call is made. + # First call returns exactly 200 000 fake lines (server cap hit -> split). + # Recursive halves each return 5 lines (within limit). + call_count = 0L + line_tmpl = "12330,2009,12,01,00,00,AAXX 01004 12330 ///// /////" + fake_full = paste(rep(line_tmpl, 200000L), collapse = "\n") + fake_half = paste(rep(line_tmpl, 5L), collapse = "\n") + + with_mocked_bindings( + GET = function(url, ...) { + call_count <<- call_count + 1L + structure( + list(status_code = 200L, + content = if (call_count == 1L) fake_full else fake_half), + class = "response" + ) + }, + http_error = function(resp, ...) FALSE, + content = function(resp, ...) resp$content, + .package = "httr", + { + result = climate:::.ogimet_synop_raw_lines( + url_tmpl = "http://example.com/getsynop?begin=%s&end=%s", + begin_date = as.Date("2009-12-01"), + end_date = as.Date("2009-12-04"), + label = "test" + ) + # First call hit the limit -> two recursive calls -> 5 + 5 = 10 lines + expect_equal(length(result), 10L) + expect_equal(call_count, 3L) + } + ) +}) + +test_that("meteo_ogimet_synop warns when both station and country_name are given", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + # only check the warning; the download itself may or may not succeed + expect_warning( + meteo_ogimet_synop(station = 12330, + country_name = "Poland", + date = c("2009-12-15", "2009-12-15"), + allow_failure = TRUE), + "`station` is ignored" + ) +}) + +test_that("meteo_ogimet_synop station mode returns a data.frame with expected columns", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + result = meteo_ogimet_synop(station = 12330, + date = c("2009-12-01", "2009-12-04")) + + if (is.null(result)) return(invisible(NULL)) + + expect_s3_class(result, "data.frame") + expect_true("station_id" %in% names(result)) + expect_true("Date" %in% names(result)) + expect_true("air_temperature" %in% names(result)) + expect_true("wind_speed" %in% names(result)) + expect_true(nrow(result) > 0) +}) + +test_that("meteo_ogimet_synop station mode Date column is POSIXct UTC", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + result = meteo_ogimet_synop(station = 12330, + date = c("2009-12-01", "2009-12-04")) + + if (is.null(result) || nrow(result) == 0) return(invisible(NULL)) + + expect_s3_class(result$Date, "POSIXct") + expect_equal(attr(result$Date, "tzone"), "UTC") +}) + +test_that("meteo_ogimet_synop station mode clips to requested date range", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + result = meteo_ogimet_synop(station = 12330, + date = c("2009-12-01", "2009-12-04")) + + if (is.null(result) || nrow(result) == 0) return(invisible(NULL)) + + expect_true(all(as.Date(result$Date) >= as.Date("2009-12-01"))) + expect_true(all(as.Date(result$Date) <= as.Date("2009-12-04"))) +}) + +test_that("meteo_ogimet_synop station mode handles allow_failure gracefully", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + expect_no_error( + meteo_ogimet_synop(station = 9999999, date = c("2009-12-01", "2009-12-02"), + allow_failure = TRUE) + ) +}) + +test_that("meteo_ogimet_synop station mode source column contains SYNOP strings", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + result = meteo_ogimet_synop(station = 12330, + date = c("2009-12-01", "2009-12-04")) + + if (is.null(result) || nrow(result) == 0) return(invisible(NULL)) + + expect_true("source" %in% names(result)) + expect_true(all(nzchar(result$source[!is.na(result$source)]))) +}) + +test_that("meteo_ogimet_synop country mode returns a data.frame for one day", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + result = meteo_ogimet_synop(country_name = "Poland", + date = c("2009-12-15", "2009-12-15")) + + if (is.null(result)) return(invisible(NULL)) + + expect_s3_class(result, "data.frame") + expect_true("station_id" %in% names(result)) + expect_true("Date" %in% names(result)) + expect_true("air_temperature" %in% names(result)) + # Poland has many SYNOP stations; expect multiple rows + expect_true(nrow(result) > 1) +}) + +test_that("meteo_ogimet_synop country mode Date column is POSIXct UTC", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + result = meteo_ogimet_synop(country_name = "Poland", + date = c("2009-12-15", "2009-12-15")) + + if (is.null(result) || nrow(result) == 0) return(invisible(NULL)) + + expect_s3_class(result$Date, "POSIXct") + expect_equal(attr(result$Date, "tzone"), "UTC") +}) + +test_that("meteo_ogimet_synop country mode clips to the requested date", { + if (!curl::has_internet()) return(invisible(NULL)) + skip_on_cran() + + result = meteo_ogimet_synop(country_name = "Poland", + date = c("2009-12-15", "2009-12-15")) + + if (is.null(result) || nrow(result) == 0) return(invisible(NULL)) + + expect_true(all(as.Date(result$Date) == as.Date("2009-12-15"))) +}) + + +# ── Nt / Nh column mapping ──────────────────────────────────────────────────── + +test_that("parser Nt=cloud_cover and Nh=low_cloud_amount are decoded correctly", { + # 71703 -> Nddff: N=7 (total cloud cover 7 oktas) + # 85232 -> 8NhCLCMCH: Nh=5 (low cloud cover 5 oktas), CL=2 (Sc), CM=3, CH=2 + msg = "AAXX 15151 12120 42461 71703 11013 21016 30184 40192 58006 85232=" + row = parser(msg, as_data_frame = TRUE) + expect_equal(row$cloud_cover, 7) # Nt source + expect_equal(row$low_cloud_amount, 5) # Nh source +}) diff --git a/tests/testthat/test-nearest_stations_ogimet.R b/tests/testthat/test-nearest_stations_ogimet.R index 689599c..557eceb 100644 --- a/tests/testthat/test-nearest_stations_ogimet.R +++ b/tests/testthat/test-nearest_stations_ogimet.R @@ -1,4 +1,4 @@ -context("meteo_imgw") +context("nearest_station_ogimet") test_that("nearest_stations_ogimet works!", { @@ -24,7 +24,7 @@ test_that("nearest_stations_ogimet works!", { x = nearest_stations_ogimet(country = c("United Kingdom", "Poland"), point = c(0, 0), add_map = TRUE, no_of_stations = 150) if (is.data.frame(x) && ncol(x) > 5) { - expect_true(mean(x$distance) > 5000) + expect_true(mean(x$distance) > 5000) } }) diff --git a/tests/testthat/test-parser.R b/tests/testthat/test-parser.R index 5baabda..8691d4b 100644 --- a/tests/testthat/test-parser.R +++ b/tests/testthat/test-parser.R @@ -29,8 +29,8 @@ test_that("parser stops on non-character input", { expect_error(parser(12345), "`message` must be a character vector.") }) -test_that("parser warns and returns NULL for empty string", { - expect_warning(parser(""), "Empty SYNOP message supplied") +test_that("parser emits message and returns NULL for empty string", { + expect_message(parser(""), "Empty SYNOP message supplied") }) test_that("parser stops when country length mismatches message length", { @@ -397,8 +397,8 @@ test_that("visibility VV=99 gives isGreaterOrEqual 50000m", { expect_equal(result$visibility$quantifier, "isGreaterOrEqual") }) -test_that("invalid visibility code 51-55 emits a warning", { - expect_warning(result <- parser("AAXX 01004 88889 12753 61506 10094")) +test_that("invalid visibility code 51-55 emits a message", { + expect_message(result <- parser("AAXX 01004 88889 12753 61506 10094")) expect_null(result$visibility) }) @@ -420,8 +420,8 @@ test_that("precipitation code 993 gives 0.3 mm", { expect_equal(result$precipitation_s1$amount$value, 0.3) }) -test_that("calm wind with nonzero speed triggers a warning", { - expect_warning(parser("AAXX 01004 88889 12782 60015 10094")) +test_that("calm wind with nonzero speed triggers a message", { + expect_message(parser("AAXX 01004 88889 12782 60015 10094")) }) test_that("wind direction dd=99 (variable, all directions) is decoded", { @@ -445,8 +445,8 @@ test_that("is_valid returns FALSE for non-numeric value when range set", { # ── decode error path ────────────────────────────────────────────────────────── -test_that("decode warns and returns NULL on internal error", { - expect_warning(result <- SignedTemperature$new()$decode("094", sign = "X")) +test_that("decode emits message and returns NULL on internal error", { + expect_message(result <- SignedTemperature$new()$decode("094", sign = "X")) expect_null(result) }) @@ -464,9 +464,9 @@ test_that("encode calls encode_internal for NULL data when code_table present", expect_equal(result, "9") }) -test_that("encode warns and returns null char when encode_internal errors", { +test_that("encode emits message and returns null char when encode_internal errors", { # CodeTable2700 stops when value=NULL and obscured=FALSE - expect_warning(result <- CloudCover$new()$encode(list(value = NULL, obscured = FALSE))) + expect_message(result <- CloudCover$new()$encode(list(value = NULL, obscured = FALSE))) expect_equal(result, "/") }) @@ -492,9 +492,9 @@ test_that("decode_value returns NULL for unavailable value '/'", { expect_null(result) }) -test_that("decode_value warns and returns NULL when code_table decode fails", { - # Code "10" exceeds CodeTable0500's index range → stop → warning chain - expect_warning(result <- CloudGenus$new()$decode("10")) +test_that("decode_value emits message and returns NULL when code_table decode fails", { + # Code "10" exceeds CodeTable0500's index range → stop → message chain + expect_message(result <- CloudGenus$new()$decode("10")) expect_null(result) }) @@ -615,8 +615,8 @@ test_that("CloudGenus encodes Sc to code 6", { expect_equal(result, "6") }) -test_that("CloudGenus warns on invalid genus name", { - expect_warning(result <- CloudGenus$new()$encode(list(value = "XX"))) +test_that("CloudGenus emits message on invalid genus name", { + expect_message(result <- CloudGenus$new()$encode(list(value = "XX"))) expect_equal(result, "/") }) @@ -653,8 +653,8 @@ test_that("DirectionCardinal encodes NE to '1'", { expect_equal(result, "1") }) -test_that("DirectionCardinal warns on unresolvable direction", { - expect_warning(result <- DirectionCardinal$new()$encode( +test_that("DirectionCardinal emits message on unresolvable direction", { + expect_message(result <- DirectionCardinal$new()$encode( list(isCalmOrStationary = FALSE, allDirections = FALSE, value = NULL) )) expect_equal(result, "/") @@ -684,8 +684,8 @@ test_that("DirectionDegrees encodes a degree value", { expect_equal(result, "15") }) -test_that("DirectionDegrees warns on invalid direction code", { - expect_warning(DirectionDegrees$new()$decode("37")) +test_that("DirectionDegrees emits message on invalid direction code", { + expect_message(DirectionDegrees$new()$decode("37")) }) # ── CodeTable4377 decode edge cases ─────────────────────────────────────────── @@ -738,8 +738,8 @@ test_that("CodeTable4377 decodes VV=99 to isGreaterOrEqual 50000m", { expect_equal(result$quantifier, "isGreaterOrEqual") }) -test_that("CodeTable4377 warns on invalid code 53", { - expect_warning(result <- CodeTable4377$new()$decode("53")) +test_that("CodeTable4377 emits message on invalid code 53", { + expect_message(result <- CodeTable4377$new()$decode("53")) expect_null(result) }) @@ -778,8 +778,8 @@ test_that("Height decodes hh=99 to isGreater 21000m", { expect_equal(result$quantifier, "isGreater") }) -test_that("Height warns on invalid code 55 (gap between ranges)", { - expect_warning(result <- Height$new()$decode("55")) +test_that("Height emits message on invalid code 55 (gap between ranges)", { + expect_message(result <- Height$new()$decode("55")) expect_null(result) }) @@ -808,17 +808,17 @@ test_that("Precipitation decodes with tenths=TRUE using Amount24", { # ── LowestCloudBase decode with invalid code ─────────────────────────────────── -test_that("LowestCloudBase warns on out-of-range code", { +test_that("LowestCloudBase emits message on out-of-range code", { # CodeTable1600 only has 10 entries (codes 0-9); code 10 is out of range - # LowestCloudBase.decode("9") returns the last valid entry without warning + # LowestCloudBase.decode("9") returns the last valid entry without message # so use two-digit code which as.integer truncates to the first character anyway; # instead test via CodeTable1600 directly with an out-of-range integer string - expect_warning(result <- LowestCloudBase$new()$decode_value("a")) + expect_message(result <- LowestCloudBase$new()$decode_value("a")) expect_null(result) # non-numeric string → NA integer → NULL via decode_value path }) -test_that("Region warns on station ID outside all defined ranges", { - expect_warning(result <- Region$new()$decode("99999")) +test_that("Region emits message on station ID outside all defined ranges", { + expect_message(result <- Region$new()$decode("99999")) expect_null(result) }) @@ -933,3 +933,54 @@ test_that("Hour encode_convert passes through via encode", { result = Hour$new()$encode(list(value = 12L)) expect_equal(result, "12") }) + +# ── Snow depth (Section 3, group 4E'sss) ───────────────────────────────────── + +test_that("snow depth: trace (sss=997) is decoded to 0 with correct state", { + msg = "AAXX 15061 12530 11225 80000 11012 21012 39997 40204 56006 69902 72022 885// 333 11011 21017 3/102 47997 79999 93097=" + row = parser(msg, as_data_frame = TRUE) + expect_equal(row$snow_depth, 0) + expect_equal(row$snow_depth_state, "Even layer of loose dry snow covering ground completely") +}) + +test_that("snow depth: actual depth is decoded correctly", { + msg = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 40055=" + row = parser(msg, as_data_frame = TRUE) + expect_equal(row$snow_depth, 55) + expect_equal(row$snow_depth_state, "Ground predominantly covered by ice") +}) + +test_that("snow depth: non-continuous (sss=998) returns NA", { + msg = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 42998=" + row = parser(msg, as_data_frame = TRUE) + expect_true(is.na(row$snow_depth)) + expect_equal(row$snow_depth_state, "Compact or wet snow covering at least one-half of the ground but not completely") +}) + +test_that("snow depth: unmeasurable (sss=999) returns NA", { + msg = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541 333 43999=" + row = parser(msg, as_data_frame = TRUE) + expect_true(is.na(row$snow_depth)) +}) + +test_that("snow depth: absent in message gives NA columns", { + msg = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541" + row = parser(msg, as_data_frame = TRUE) + expect_true(is.na(row$snow_depth)) + expect_true(is.na(row$snow_depth_state)) +}) + +# ── Nddff message chain ──────────────────────────────────────────────────────── + +test_that("invalid wind direction in Nddff emits full context message chain", { + # Group 88695: N=8 (cloud cover), dd=86 (invalid direction), ff=95 (wind speed) + # Expected chain: "Warning decoding group: 88695 - Warning decoding with code table: 86 - ..." + expect_message( + parser("AAXX 10061 11035 11234 88695 11020 21015="), + "Warning decoding group: 88695" + ) + expect_message( + parser("AAXX 10061 11035 11234 88695 11020 21015="), + "Warning decoding with code table: 86" + ) +})