R/r6_quasipoisson.R

In folkehelseinstituttet/dashboards_normomo: Depreciated - to be removed

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

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

      results_x$db_connect()
    },
    run_all = function(masterData, info) {
      fd::msg("normomo standard generating stack", slack = T)

      stack <- GenerateStack(
        f = info[["f"]],
        dateDataMinusOneWeek = info[["dateDataMinusOneWeek"]],
        dateData = info[["dateData"]]
      )

      # run historical data to make sure we have all the years in there
      fd::msg("normomo standard running historical analysis", slack = T)
      std_run_analysis(masterData = masterData, stack = stack[["plan_historic"]])

      # run the daily stuff
      fd::msg("normomo standard running current analysis", slack = T)
      std_run_analysis(masterData = masterData, stack = stack[["plan_operational"]])

      # tech email
      fd::msg("normomo technical email", slack = T)
      std_email()

      fd::msg("normomo standard done", slack = T)
    }
  )
)

std_results_field_types <- c(
  "location_code" = "TEXT",
  "age" = "TEXT",
  "date" = "DATE",
  "wk" = "INTEGER",
  "yrwk" = "TEXT",
  "YoDi" = "INTEGER",
  "WoDi" = "INTEGER",
  "Pnb" = "DOUBLE",
  "nb" = "DOUBLE",
  "nbc" = "DOUBLE",
  "UPIb2" = "DOUBLE",
  "UPIb4" = "DOUBLE",
  "UPIc" = "DOUBLE",
  "LPIc" = "DOUBLE",
  "UCIc" = "DOUBLE",
  "LCIc" = "DOUBLE",
  "zscore" = "DOUBLE",
  "excess" = "DOUBLE",
  "thresholdp_0" = "DOUBLE",
  "thresholdp_1" = "DOUBLE",
  "thresholdp_2" = "DOUBLE",
  "excessp" = "DOUBLE",
  "status" = "TEXT"
)

std_results_keys <- c(
  "location_code",
  "age",
  "yrwk"
)

hfile <- function() {
  hfile <- fhidata::norway_dates_holidays[is_holiday == TRUE]
  hfile[, closed := 1]
  hfile[, is_holiday := NULL]
  return(as.data.frame(hfile))
}

std_run_analysis <- function(masterData, stack) {
  fd::msg("Running analysis")

  pb <- RAWmisc::ProgressBarCreate(min = 0, max = nrow(stack), flush = TRUE)
  for (i in 1:nrow(stack)) {
    RAWmisc::ProgressBarSet(pb, i)

    s <- stack[i, ]

    if (s[["location_code"]] == "norway") {
      dataAnalysis <- as.data.frame(masterData[!is.na(age) & DoR < s[["dateData"]],
        c("DoD", "DoR", "age"),
        with = F
      ])
    } else {
      dataAnalysis <- as.data.frame(masterData[!is.na(age) & DoR < s[["dateData"]] & location_code == s[["location_code"]],
        c("DoD", "DoR", "age"),
        with = F
      ])
    }

    MOMO::SetOpts(
      DoA = s[["dateData"]],
      DoPR = as.Date("2012-1-1"),
      WStart = 1,
      WEnd = 52,
      country = s[["location_code"]],
      source = "FHI",
      MDATA = dataAnalysis,
      HDATA = hfile(),
      INPUTDIR = s[["MOMOFolderInput"]],
      WDIR = s[["MOMOFolderResults"]],
      back = 7,
      WWW = 290,
      Ysum = s[["MOMOYsum"]],
      Wsum = 40,
      plotGraphs = s[["plotGraphs"]],
      delayVersion = "richard",
      delayFunction = NULL,
      MOMOgroups = s[["MOMOgroups"]][[1]],
      MOMOmodels = s[["MOMOmodels"]][[1]],
      verbose = FALSE
    )

    MOMO::RunMoMo()

    dataToSave <- rbindlist(MOMO::dataExport$toSave, fill = TRUE)

    res <- clean_exported_momo_data(
      data = dataToSave,
      s = s
    )

    results_x$db_upsert_load_data_infile(res[, names(results_x$db_field_types), with = F])
  }
  fd::msg("Finished analysis", slack = T)
}

std_email <- function() {
  html <- glue::glue(
    "New NorMOMO results available to download from:<br><br>
    <a href='file:///F:/Prosjekter/Dashboards/results/normomo/'>F:/Prosjekter/Dashboards/results/normomo/</a>
    "
  )

  fd::mailgun(
    subject = "TEKNISK: New NorMOMO results available",
    html = html,
    to = fd::e_emails("normomo_tech")
  )
}