R/synop_parser.R

Defines functions create_observation .synop_to_row .sg synop_parser

Documented in synop_parser

#' 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(...)
}

Try the climate package in your browser

Any scripts or data that you put into this service are public.

climate documentation built on Sept. 18, 2026, 5:06 p.m.