Nothing
#' Parse SYNOP messages into structured lists or a data frame
#'
#' This function decodes SYNOP FM-12 meteorological messages which are commonly
#' used for reporting weather observations under the regulations of the World Meteorological Organization (WMO).
#' It parses one or more SYNOP messages and
#' returns their structured representation as generated by the `SYNOP` R6
#' decoder.
#'
#' Currently, the decoder contains most of the core logic for parsing the main
#' sections of SYNOP messages that are commonly used in atmospheric sciences.
#' However, it does not yet cover all possible SYNOP groups and fields,
#' and some fields may be missing or incomplete.
#'
#' @param message Character vector with SYNOP messages.
#' @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. 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 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`,
#' `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
#' synop_code = "AAXX 01004 88889 12782 61506 10094 20047 30111 40197 53007 60001 81541"
#' synop_parser(synop_code)
#' synop_parser(rep(synop_code, 2), simplify = FALSE)
#' synop_parser(synop_code, as_data_frame = TRUE)
#' synop_parser(rep(synop_code, 2), as_data_frame = TRUE)
#' @import R6
#' @export
synop_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.")
}
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 {
message("Empty SYNOP message supplied; returning NULL.")
NULL
}
},
message,
country_vec,
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]])
}
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"),
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
)
}
################################################################################
# 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) {
message(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) {
message(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) {
message(paste("Error decoding with code table:", val, "-", e$message))
NULL
}, warning = function(w) {
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
})
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 = "Celsius"
},
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) {
message(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(
# 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)) {
v = self$directions[d + 1]
if (is.na(v)) NULL else v
} 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", "/")) {
message(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) {
message(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) {
message(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
message("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) {
message(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) {
message(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) {
message(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) {
message(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) {
message(paste("Error decoding cloud cover from:", nddff, "-", e$message))
}, message = function(m) {
message(paste("Warning decoding group:", nddff, "-", trimws(conditionMessage(m))))
})
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) {
message(paste("Error decoding surface wind from:", nddff, "-", e$message))
}, message = function(m) {
message(paste("Warning decoding group:", nddff, "-", trimws(conditionMessage(m))))
})
}
# 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) {
message(paste("Unable to parse header from group:", next_grp))
next_grp <<- next_group()
return(NULL)
}, warning = function(w) {
message(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) {
message(paste("Error decoding group:", next_grp, "-", e$message))
# Continue to next group
}, warning = function(w) {
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
})
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) {
message(paste("Unable to parse header from group:", next_grp))
return(NULL)
}, warning = function(w) {
message(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
}
} 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.
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) {
message(paste("Error decoding group:", next_grp, "-", e$message))
# Continue to next group
}, warning = function(w) {
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
})
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) {
message(paste("Error decoding group 9 code:", g, "-", e$message))
idx <<- idx + 1
}, warning = function(w) {
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
})
}
}
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]]
# 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))
}
}
)
)
# 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(...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.