R/r6_flumodl.R

In folkehelseinstituttet/dashboards_brain: Depreciated - to be removed

#' flumodl
#' @import R6
#' @export flumodl
flumodl <- R6::R6Class(
  "flumodl",
  portable = FALSE,
  cloneable = FALSE,
  list(
    #' @description
    #' Say hi.
    run_all = function() {
      # check to see if it can run
      if (!fd::exists_rundate("normomo")) {
        return()
      }
      if (!fd::exists_rundate("sykdomspuls")) {
        return()
      }
      if (!fd::exists_rundate("weather")) {
        return()
      }

      rundate <- fd::get_rundate()

      # determine if it should run
      run <- TRUE
      if (fd::exists_rundate("brain_flumodl")) {
        if (rundate[package == "brain_flumodl"]$date_extraction >= rundate[package == "normomo"]$date_extraction) run <- FALSE
        if (rundate[package == "brain_flumodl"]$date_extraction >= rundate[package == "sykdomspuls"]$date_extraction) run <- FALSE
      }
      if (rundate[package == "normomo"]$date_results != rundate[package == "sykdomspuls"]$date_results) run <- FALSE

      if (!run & fd::config$is_production) {
        return()
      }

      date_extraction <- max(
        rundate[package == "normomo"]$date_extraction,
        rundate[package == "sykdomspuls"]$date_extraction
      )

      date_results <- max(
        rundate[package == "normomo"]$date_results,
        rundate[package == "sykdomspuls"]$date_results
      )

      # update rundate
      fd::update_rundate(
        package = "brain_flumodl",
        date_extraction = date_extraction,
        date_results = date_results,
        date_run = lubridate::today()
      )
    }
  )
)

run_flumodl <- function(
                        year_max = fhi::isoyear_n(),
                        year_min = year_max - 4) {
  weather <- fd::get_weather(impute_missing = TRUE)
  weather <- weather[location_code == "norge"]

  daily_deaths <- fd::tbl("normomo_daily_results") %>%
    dplyr::filter(location_code == "norge") %>%
    dplyr::filter(age == "Total") %>%
    dplyr::collect() %>%
    fd::latin1_to_utf8()

  dates <- intersect(weather$date, daily_deaths$date)
  dates <- as.Date(dates, origin = "1970-01-01")
  dates <- dates[fhi::isoyear_n(dates) %in% year_min:year_max]

  mem <- fd::tbl("spuls_mem_results") %>%
    dplyr::filter(tag == "influensa") %>%
    dplyr::filter(location_code == "norge") %>%
    dplyr::collect() %>%
    fd::latin1_to_utf8()

  virology <- readxl::read_excel(system.file("extdata", "influenza.xlsx", package = "brain"))
  setDT(virology)
  mem[virology, on = "season", B := B_yamagata + B_victoria]
  mem[virology, on = "season", A_H1N1 := A_H1N1]
  mem[virology, on = "season", A_H3N2 := A_H3N2]

  mem <- mem[yrwk %in% fhi::isoyearweek(dates)]
  mem <- mem[!is.na(B)]

  dates <- dates[fhi::isoyearweek(dates) %in% mem$yrwk]
  weather <- weather[date %in% dates]
  daily_deaths <- daily_deaths[date %in% dates]

  m <- FluMoDL::fitFluMoDL(
    deaths = daily_deaths$nbc,
    temp = weather$tg,
    dates = dates,
    proxyH1 = mem$rate * mem$A_H1N1 * 1000,
    proxyH3 = mem$rate * mem$A_H3N2 * 1000,
    proxyB = mem$rate * mem$B * 1000,
    yearweek = as.numeric(stringr::str_remove(mem$yrwk, "-"))
  )

  FluMoDL::attrMort(m, sel = "season")
}