R/data_nivo.R

In vadmbertr/bonski.data: Data To Tell Where Ski Is Good

#' Parse a character representing a date to a character understandable by
#' lubridate
#'
#' @param d character
#'
#' @return character
parse_date <- function(d) {
  paste0(substr(d, 1, 4), "-", substr(d, 5, 6), "-", substr(d, 7, 8), " ",
         substr(d, 9, 10), "-", substr(d, 11, 12), "-", substr(d, 13, 14), "-")
}

#' Parse the date field to an actual datetime object
#'
#' @param d character
#'
#' @return datetime
to_date <- function(d) {
  as.character(d) %>%
    parse_date() %>%
    lubridate::as_datetime()
}

#' Send and process a request for nivological observations
#'
#' @param nivo_url character. URL to request
#'
#' @return tibble
request_nivo_observations_once <- function(nivo_url) {
  nivo_observations <- suppressMessages(readr::read_delim(nivo_url, ";", show_col_types = FALSE))
  nivo_observations[, c("numer_sta", "date", "dd", "ff", "t", "tn24", "tx24", "td", "u", "n", "rr24",  "ht_neige",
                        "ssfrai", "t_neige", "grain_predom")] %>%
    tidy_nivo_observations()
}

#' Tidy nivological observations
#'
#' @param nivo_observations data.frame
#'
#' @return tibble
tidy_nivo_observations <- function(nivo_observations) {
  nivo_observations %>%
    dplyr::rename(station = numer_sta) %>%
    dplyr::mutate(station = as.integer(station)) %>%
    dplyr::mutate_all(~ replace(., . == "mq", NA)) %>%
    dplyr::rename(dir_vent = dd,
                  force_vent = ff,
                  temperature = t,
                  temp_min = tn24,
                  temp_max = tx24,
                  point_rose = td,
                  humidite = u,
                  nebulosite = n,
                  precipitation = rr24,
                  neige_totale = ht_neige,
                  neige_fraiche = ssfrai,
                  temp_neige = t_neige,
                  grain_neige = grain_predom) %>%
    dplyr::mutate(date = to_date(date),
                  dir_vent = as.integer(dir_vent),
                  force_vent = as.double(force_vent),
                  temperature = as.double(temperature),
                  temp_min = as.double(temp_min),
                  temp_max = as.double(temp_max),
                  point_rose = as.double(point_rose),
                  humidite = as.integer(humidite),
                  nebulosite = as.integer(nebulosite),
                  precipitation = as.double(precipitation),
                  neige_totale = as.double(neige_totale),
                  neige_fraiche = as.double(neige_fraiche),
                  temp_neige = as.double(temp_neige),
                  grain_neige = as.integer(grain_neige)) %>%
    dplyr::right_join(dplyr::select(bonski.data::nivo_stations, station), by = "station") %>%
    tidyr::fill(date)
}

#' Request, merge and parse nivo observations from a vector of urls
#'
#' @param urls vector. URLs to request
#'
#' @return data.frame
#'
#' @export
request_nivo_observations <- function(urls) {
  n_cores <- future::availableCores()
  future::plan(future::multisession, workers = n_cores)

  furrr::future_map(urls, request_nivo_observations_once) %>%
      data.table::rbindlist()
}

#' Group nivo observations by station and date
#'
#' If several observations exist for the same station and day
#'   1. infer NA data when possible for temp_min and temp_max variables
#'   2. get the mean for all
#'
#' @param nivo_observations data.frame
#'
#' @return data.frame
#'
#' @export
group_nivo_observations <- function(nivo_observations) {
  warn <- getOption("warn")
  options(warn = -1)

  daily_nivo_observations <- nivo_observations %>%
    dplyr::mutate(date = lubridate::date(date)) %>%
    tidyr::drop_na(date)

  daily_nivo_observations <- daily_nivo_observations %>%
    dplyr::group_by(station, date) %>%
    dplyr::mutate(temp_min = min(tidyr::replace_na(temp_min, min(temperature, na.rm = TRUE)), na.rm = TRUE),
                  temp_max = max(tidyr::replace_na(temp_max, max(temperature, na.rm = TRUE)), na.rm = TRUE)) %>%
    dplyr::mutate_at(dplyr::vars(temp_min, temp_max), list(~dplyr::na_if(abs(.), Inf))) %>%
    dplyr::summarise_all(mean, na.rm=TRUE)

  options(warn = warn)
  daily_nivo_observations
}