R/r6_flumomo.R

In folkehelseinstituttet/dashboards_brain: Depreciated - to be removed

#' flumomo
#' @import R6
#' @export flumomo
flumomo <- R6::R6Class(
  "flumomo",
  portable = FALSE,
  cloneable = FALSE,
  list(
    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()

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

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

      # determine if it should run
      run <- TRUE
      if (fd::exists_rundate("brain_flumomo")) {
        if (rundate[package == "brain_flumomo"]$date_extraction >= date_extraction) run <- FALSE
      }
      # norsyss must not have less information than normomo
      if (fhi::isoweek_n(rundate[package == "normomo"]$date_results) > fhi::isoweek_n(rundate[package == "sykdomspuls"]$date_results)) run <- FALSE

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

      run_flumomo(date_results)

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

      fd::msg("Brain flumomo - done", slack = T)
    }
  )
)

run_flumomo <- function(date_results) {
  last_year <- fhi::isoyear_n(date_results)
  last_week <- fhi::isoweek_n(date_results)

  plan <- expand.grid(
    season = c("summer", "winter"),
    end_year = 2012:(last_year + 1)
  )
  setDT(plan)
  plan <- plan[!(end_year == max(end_year) & season == "summer")]

  if (last_week <= 20) {
    plan <- plan[end_year != max(end_year)]
  } else if (last_week < 40) {
    plan <- plan[-.N]
  }

  plan[, end_week := 39]
  plan[season == "winter", end_week := 20]

  data_deaths <- fd::tbl("normomo_standard_results") %>%
    dplyr::filter(location_code == "norge") %>%
    dplyr::select(age, YoDi, WoDi, nb, nbc) %>%
    dplyr::collect() %>%
    fd::latin1_to_utf8()
  setnames(data_deaths, "age", "group")
  data_deaths

  data_population <- fd::norway_population()[location_code == "norge"]
  data_population[, group := fancycut::fancycut(
    age,
    "0to4" = "[0,4]",
    "5to14" = "[5,14]",
    "15to64" = "[15,64]",
    "65P" = "[65,200]",
    out.as.factor = F
  )]
  data_population_2 <- copy(data_population)
  data_population_2[, group := "Total"]
  data_population <- rbind(data_population, data_population_2)
  data_population <- data_population[, .(
    N = sum(pop)
  ), keyby = .(
    group,
    year
  )]

  data_ia1 <- fd::tbl("spuls_mem_results") %>%
    dplyr::filter(location_code == "norge") %>%
    dplyr::filter(tag == "influensa") %>%
    dplyr::filter(age == "Totalt") %>%
    dplyr::select(age, year, week, IA = rate) %>%
    dplyr::collect() %>%
    fd::latin1_to_utf8()
  data_ia2 <- fd::tbl("spuls_mem_results") %>%
    dplyr::filter(location_code == "norge") %>%
    dplyr::filter(tag == "influensa_all") %>%
    dplyr::filter(age != "Totalt") %>%
    dplyr::select(age, year, week, IA = rate) %>%
    dplyr::collect() %>%
    fd::latin1_to_utf8()
  data_ia <- rbind(data_ia1, data_ia2)
  data_ia[, group := dplyr::recode(
    age,
    "0-4" = "0to4",
    "5-14" = "5to14",
    "15-64" = "15to64",
    "65+" = "65P",
    "Totalt" = "Total"
  )]
  data_ia[, age := NULL]

  data_weather <- fd::get_weather(impute_missing = T)
  data_weather <- data_weather[stringr::str_detect(location_code, "^municip")]
  data_weather[, year := fhi::isoyear_n(date)]
  p <- fd::norway_population()
  p <- p[, .(
    pop = sum(pop)
  ), keyby = .(
    year, location_code
  )]
  data_weather[p, on = c("location_code", "year"), pop := pop]
  data_weather <- data_weather[, .(
    date,
    pop3 = pop, NUTS3 = location_code, temp = tg
  )]

  # do database stuff here
  fd::drop_table("brain_flumomo_cumulative_running")
  brain_flumomo_cumulative_running_field_types <- c(
    "tag_outcome" = "TEXT",
    "tag_exposure" = "TEXT",
    "location_code" = "TEXT",
    "season" = "TEXT",
    "yrwk" = "TEXT",
    "week" = "INTEGER",
    "x" = "INTEGER",
    "age" = "TEXT",
    "excess_est" = "DOUBLE",
    "excess_lower" = "DOUBLE",
    "excess_upper" = "DOUBLE"
  )

  brain_flumomo_cumulative_running_keys <- c(
    "tag_outcome",
    "tag_exposure",
    "location_code",
    "season",
    "yrwk",
    "week",
    "x",
    "age"
  )

  schema <- fd::schema$new(
    db_config = fd::config$db_config,
    db_table = glue::glue("brain_flumomo_cumulative_running"),
    db_field_types = brain_flumomo_cumulative_running_field_types,
    db_load_folder = "/xtmp/",
    keys = brain_flumomo_cumulative_running_keys,
    check_fields_match = TRUE
  )
  schema$db_connect()

  for (i in 1:nrow(plan)) {
    p <- plan[i]
    fd::msg(glue::glue("Brain flumomo - {i}"))
    run_flumomo_year(
      end_year = p$end_year,
      end_week = p$end_week,
      season = p$season,
      data_deaths = data_deaths,
      data_ia = data_ia,
      data_weather = data_weather,
      schema = schema
    )
  }
}

run_flumomo_year <- function(
                             end_year,
                             end_week,
                             season,
                             data_deaths,
                             data_ia,
                             data_weather,
                             schema) {
  res <- flumomo::run(
    country = "norge",
    country_code = "NO",
    start_year = end_year - 4,
    start_week = 40,
    end_year = end_year,
    end_week = end_week,
    data_deaths = data_deaths,
    data_ia = data_ia,
    data_weather = data_weather,
    IArest = TRUE,
    IAlags = 2,
    ETlags = 2
  )
  setDT(res)

  res[, season_type := "winter"]
  res[!is.na(summer), season_type := "summer"]

  varIA_est <- glue::glue("cEdIA_{season}")
  varIA_lower <- glue::glue("cEdIA_{season}_95L")
  varIA_upper <- glue::glue("cEdIA_{season}_95U")

  varET_est <- glue::glue("cEdET_{season}")
  varET_lower <- glue::glue("cEdET_{season}_95L")
  varET_upper <- glue::glue("cEdET_{season}_95U")

  resx <- res[
    season_type == season,
    c(
      "country",
      "year",
      "week",
      "agegrp",
      ..varIA_est,
      ..varIA_lower,
      ..varIA_upper,
      ..varET_est,
      ..varET_lower,
      ..varET_upper
    ),
    with = F
  ]

  setnames(
    resx,
    c(
      "country",
      varIA_est,
      varIA_lower,
      varIA_upper,
      varET_est,
      varET_lower,
      varET_upper
    ),
    c(
      "location_code",
      "varIA_est",
      "varIA_lower",
      "varIA_upper",
      "varET_est",
      "varET_lower",
      "varET_upper"
    )
  )

  resx <- melt.data.table(
    resx,
    id.vars = c("location_code", "year", "week", "agegrp"),
    measure = patterns("_est$", "_lower$", "_upper$"),
    value.name = c("est", "lower", "upper")
  )

  levels(resx$variable) <- c("ili", "tg")
  resx[, variable := as.character(variable)]

  resx[, yrwk := paste0(year, "-", formatC(week, flag = "0", width = 2))]
  if (season == "summer") {
    resx[, season := paste0(year, "/", year)]
  } else {
    resx[, season := fhi::season(yrwk, start_week = 40)]
  }
  resx[, x := fhi::x(week)]

  resx[, age := dplyr::recode(
    agegrp,
    `0` = "0to4",
    `1` = "5to14",
    `2` = "15to64",
    `3` = "65P",
    `4` = "Total"
  )]
  resx[, year := NULL]
  resx[, agegrp := NULL]

  setnames(
    resx,
    c(
      "variable",
      "est",
      "lower",
      "upper"
    ),
    c(
      "tag_exposure",
      "excess_est",
      "excess_lower",
      "excess_upper"
    )
  )
  resx[, tag_outcome := "attributable_mortality"]

  resx <- resx[season == max(season)]
  schema$db_upsert_load_data_infile(resx)
}