R/r6_daily.R

In folkehelseinstituttet/dashboards_normomo: Depreciated - to be removed

#' quasipoission
#' @import R6
#' @export daily
daily <- R6::R6Class(
  "daily",
  portable = FALSE,
  cloneable = FALSE,
  list(
    results_x = NULL,
    initialize = function() {
      fd::drop_table("normomo_daily_data")

      results_x <<- fd::schema$new(
        db_config = fd::config$db_config,
        db_table = glue::glue("normomo_daily_data"),
        db_field_types = daily_results_field_types,
        db_load_folder = "/xtmp/",
        keys = daily_results_keys,
        check_fields_match = TRUE
      )

      results_x$db_connect()
    },
    run_all = function(masterData) {
      fd::msg("normomo daily starting", slack = T)

      weekly <- fd::tbl("normomo_standard_results") %>%
        dplyr::collect() %>%
        fd::latin1_to_utf8()
      weekly <- weekly[, c("location_code", "age", "yrwk", "nb", "nbc")]
      setnames(weekly, c("nb", "nbc"), c("weekly_nb", "weekly_nbc"))

      max_date <- fhidata::days[yrwk == max(weekly$yrwk)]$sun
      locations <- c("norge", unique(fd::norway_locations()$county_code))

      d <- masterData[, .(nb = .N), keyby = .(ageCat, DoD, location_code)]
      dt <- d[, .(nb = sum(nb)), keyby = .(DoD, location_code)]
      dt[, ageCat := "Total"]
      d <- rbind(d, dt)
      d[, age := ageCat]
      d[, ageCat := NULL]
      dt <- d[, .(nb = sum(nb)), keyby = .(DoD, age)]
      dt[, location_code := "norge"]
      d <- rbind(d, dt)
      d <- d[location_code != "countyNA"]

      skeleton <- expand.grid(
        location_code = unique(d$location_code),
        age = unique(d$age),
        DoD = seq.Date(min(d$DoD), max_date, 1),
        stringsAsFactors = F
      )
      setDT(skeleton)
      skeleton[d, on = c("location_code", "age", "DoD"), nb := nb]
      skeleton[is.na(nb), nb := 0]
      skeleton[, yrwk := fhi::isoyearweek(DoD)]
      skeleton[weekly, on = c("yrwk", "age"), weekly_nb := weekly_nb]
      skeleton[weekly, on = c("yrwk", "age"), weekly_nbc := weekly_nbc]
      skeleton[, day_of_week := lubridate::wday(DoD)]
      skeleton[, needs_correction := abs(weekly_nb - weekly_nbc) > 10]
      proportions <- skeleton[needs_correction == F, .(prop = mean(nb / weekly_nbc, na.rm = T)), keyby = .(age, day_of_week, location_code)]
      skeleton[proportions, on = c("day_of_week", "age", "location_code"), prop := prop]
      skeleton[, nbc := nb]
      skeleton[needs_correction == T, nbc := round(prop * weekly_nbc)]
      skeleton <- skeleton[, c("location_code", "DoD", "age", "nb", "nbc")]
      setnames(skeleton, "DoD", "date")

      setorder(skeleton, location_code, age, date)
      results_x$db_upsert_load_data_infile(skeleton)
    }
  )
)

daily_results_field_types <- c(
  "location_code" = "TEXT",
  "age" = "TEXT",
  "date" = "DATE",
  "nb" = "DOUBLE",
  "nbc" = "DOUBLE"
)

daily_results_keys <- c(
  "location_code",
  "age",
  "date"
)