#' @importFrom httr2 request req_url_query req_headers req_timeout req_retry
#'   req_perform resp_body_string resp_check_status
#' @importFrom base64enc base64encode
#' @importFrom jsonlite fromJSON
#' @importFrom digest digest
#' @importFrom tools R_user_dir
#' @importFrom utils head modifyList
#' @importFrom stats setNames
#' @importFrom ggplot2 ggplot aes geom_line geom_col geom_point geom_abline
#'   scale_color_manual scale_fill_manual scale_x_continuous scale_y_continuous
#'   facet_wrap labs theme element_rect element_text element_line element_blank
#' @importFrom scales percent_format
#' @docType package
#' @name widr-package
#' @aliases widr
"_PACKAGE"

utils::globalVariables(c("hi", "cum_share", "country", "year", "value"))

.wid_env <- new.env(parent = emptyenv())
`%||%`   <- function(a, b) if (!is.null(a)) a else b

.wid_df <- function() structure(
  data.frame(country = character(), variable = character(), percentile = character(),
             year = character(), value = numeric(), age = character(), pop = character(),
             stringsAsFactors = FALSE),
  class = c("wid_df", "data.frame"))

# ---- API --------------------------------------------------------------------

.API <- "https://rfap9nitz6.execute-api.eu-west-1.amazonaws.com/prod"

#' Set WID API key
#' @param key character API key
#' @return Invisibly, the key string.
#' @export
wid_set_key <- function(key) { assign("key", key, envir = .wid_env); invisible(key) }

#' @noRd
.get_key <- function() {
  k <- tryCatch(get("key", envir = .wid_env), error = function(e) NULL) %||%
    Sys.getenv("WID_API_KEY", unset = NA_character_)
  if (is.na(k))
    stop("No WID API key. Use wid_set_key() or set WID_API_KEY env var.", call. = FALSE)
  base64encode(charToRaw(k))
}

#' @noRd
.wid_get <- function(endpoint, params = list()) {
  resp <- request(paste0(.API, endpoint)) |>
    req_url_query(!!!params) |>
    req_headers(`x-api-key` = .get_key(), `User-Agent` = "widr/1.0") |>
    req_timeout(60L) |>
    req_retry(max_tries = 3L) |>
    req_perform()
  resp_check_status(resp)
  fromJSON(resp_body_string(resp, "UTF-8"), simplifyVector = FALSE)
}

# ---- Cache ------------------------------------------------------------------

.CACHE_DIR  <- tools::R_user_dir("widr", "cache")
#' @noRd
.cache_key  <- function(...) digest::digest(list(...), algo = "xxhash64")
#' @noRd
.cache_path <- function(key) file.path(.CACHE_DIR, paste0(key, ".rds"))

#' @noRd
.cache <- function(action, key = NULL, value = NULL) {
  switch(action,
         get   = { p <- .cache_path(key); if (file.exists(p)) readRDS(p) else NULL },
         set   = { dir.create(.CACHE_DIR, recursive = TRUE, showWarnings = FALSE)
           saveRDS(value, .cache_path(key)); invisible(value) },
         clear = { f <- list.files(.CACHE_DIR, "\\.rds$", full.names = TRUE)
         file.remove(f); invisible(length(f)) },
         list  = list.files(.CACHE_DIR, "\\.rds$"),
         stop("Unknown action: ", action, call. = FALSE)
  )
}

#' Interact with the WID response cache
#'
#' Low-level access to get, set, list, or clear cached API responses.
#' @param action One of \code{"get"}, \code{"set"}, \code{"list"}, \code{"clear"}.
#' @param key    Cache key string (required for \code{"get"} and \code{"set"}).
#' @param value  Value to store (\code{"set"} only).
#' @return For \code{"get"}: the cached object or \code{NULL}. For
#'   \code{"list"}: character vector of cache keys. For \code{"set"} and
#'   \code{"clear"}: invisibly, the stored value or file count removed.
#' @examples
#' wid_cache("list")
#' @export
wid_cache <- function(action, key = NULL, value = NULL)
  .cache(action, key = key, value = value)

#' List cached WID API responses
#' @return Character vector of cache file names.
#' @examples
#' wid_cache_list()
#' @export
wid_cache_list <- function() .cache("list")

#' Clear all cached WID API responses
#' @return Invisibly, the number of files removed.
#' @examples
#' wid_cache_clear()
#' @export
wid_cache_clear <- function() .cache("clear")

# ---- Internal helpers -------------------------------------------------------

.CODE_TYPES <- c(
  a = "average",           b = "inverted Pareto-Lorenz coefficient",
  e = "total emissions",   f = "female population",
  g = "Gini coefficient",  i = "index",
  k = "per-capita emissions", l = "avg per-capita group emissions",
  m = "total",             n = "population",
  p = "proportion women",  r = "top-10/bottom-50 ratio",
  s = "share",             t = "threshold",
  w = "wealth/income ratio", x = "exchange rate",
  y = "wealth/GDP ratio"
)

#' @noRd
.recode <- function(x, lookup) { m <- match(x, names(lookup)); ifelse(is.na(m), x, lookup[m]) }

#' @noRd
.check <- function(data, series_type = NULL) {
  if (!inherits(data, "wid_df"))
    stop("'data' must be a wid_df returned by download().", call. = FALSE)
  if (nrow(data) == 0L)
    stop("'data' is empty.", call. = FALSE)
  if (!is.null(series_type)) {
    found <- unique(substr(data$variable, 1L, 1L))
    if (!series_type %in% found)
      stop(sprintf("Expected series type '%s' (%s); data has type(s): %s",
                   series_type,
                   switch(series_type, s = "share", t = "threshold", series_type),
                   paste(found, collapse = ", ")), call. = FALSE)
  }
  invisible(data)
}

#' @noRd
.resolve_var <- function(data, variable) {
  if (!is.null(variable)) {
    if (!variable %in% data$variable)
      stop("Variable '", variable, "' not found in data.", call. = FALSE)
    return(variable)
  }
  vars <- unique(data$variable)
  if (length(vars) > 1L)
    stop("Multiple variables in data; pass variable= to select one.", call. = FALSE)
  vars[1L]
}

#' @noRd
.empty <- function(...) {
  nms <- unlist(list(...))
  as.data.frame(setNames(replicate(length(nms), character(0L), simplify = FALSE), nms),
                stringsAsFactors = FALSE)
}

#' @noRd
.recode_imp <- function(x) {
  if (is.null(x) || is.na(x)) return(NA_character_)
  switch(x, region = "regional imputation", survey = "adjusted surveys",
         tax = "surveys and tax data", full = "surveys and tax microdata",
         rescaling = "rescaled fiscal income", x)
}

#' @noRd
.strip_extrap <- function(df, meta) {
  b <- meta$extrapolation
  if (is.null(b) || is.na(b) || !nzchar(b)) return(df)
  b  <- fromJSON(b)
  dp <- meta$data_points
  dp <- if (!is.null(dp) && !is.na(dp) && nzchar(dp)) fromJSON(dp) else character(0L)
  ex <- unlist(lapply(seq_len(nrow(b)), function(i)
    as.character(seq(as.integer(b[i, 1L]) + 1L, as.integer(b[i, 2L])))))
  df[!(df$year %in% setdiff(ex, dp)), ]
}

#' @noRd
.filter_vars <- function(v, perc, ages, pop) {
  if (!identical(perc, "all")) v <- v[v$percentile %in% perc, ]
  if (!identical(ages, "all")) v <- v[v$age        %in% ages, ]
  if (!identical(pop,  "all")) v <- v[v$pop        %in% pop,  ]
  v
}

#' @noRd
.parse_indicator <- function(df) {
  parts <- strsplit(df$indicator, "_", fixed = TRUE)
  if (any(lengths(parts) < 4L))
    stop("Unexpected indicator format; expected '<code>_<perc>_<age>_<pop>'.", call. = FALSE)
  df$variable   <- vapply(parts, function(p) paste0(p[1L], p[3L], p[4L]), character(1L))
  df$percentile <- vapply(parts, `[`, character(1L), 2L)
  df$indicator  <- NULL
  df
}

# ---- Low-level API fetchers -------------------------------------------------

#' @noRd
.get_variables_areas <- function(indicators, areas) {
  json <- .wid_get("/countries-available-variables",
                   list(countries = paste(areas,      collapse = ","),
                        variables = paste(indicators, collapse = ",")))
  if (length(json) == 1L && is.null(names(json))) json <- json[[1L]]
  rows <- do.call(rbind, lapply(names(json), function(variable)
    do.call(rbind, lapply(names(json[[variable]]), function(country)
      do.call(rbind, lapply(json[[variable]][[country]], function(item)
        data.frame(variable = variable, country = country,
                   percentile = item[[1L]], age = item[[2L]], pop = item[[3L]],
                   stringsAsFactors = FALSE)))))))
  if (is.null(rows)) .empty("variable", "country", "percentile", "age", "pop") else rows
}

#' @noRd
.get_data_variables <- function(areas, variables, no_extrapolation = FALSE) {
  json <- .wid_get("/countries-variables",
                   list(countries = paste(areas,     collapse = ","),
                        variables = paste(variables, collapse = ","),
                        years     = "all"))
  rows <- do.call(rbind, lapply(names(json), function(variable)
    do.call(rbind, lapply(json[[variable]], function(json_country) {
      country <- names(json_country)[1L]
      cd      <- json_country[[1L]]
      df <- data.frame(
        indicator = variable, country = country,
        year  = vapply(cd$values, function(v) as.character(v[[1L]]), character(1L)),
        value = vapply(cd$values, function(v) as.numeric(v[[2L]]),   numeric(1L)),
        stringsAsFactors = FALSE)
      if (no_extrapolation) .strip_extrap(df, cd$meta) else df
    }))))
  if (is.null(rows)) .empty("indicator", "country", "year", "value") else rows
}

#' @noRd
.get_metadata_variables <- function(areas, variables) {
  json  <- .wid_get("/countries-variables-metadata",
                    list(countries = paste(areas,     collapse = ","),
                         variables = paste(variables, collapse = ",")))
  jmeta <- json[[1L]]$metadata_func
  rows <- do.call(rbind, lapply(jmeta, function(jvar) {
    vname <- names(jvar); jv <- jvar[[vname]]
    jname  <- jv[[1L]][[1L]]; jpop <- jv[[3L]][[1L]]
    jage   <- jv[[4L]][[1L]]; junits <- jv[[5L]][[1L]]
    notes  <- setNames(jv[[6L]][[1L]][[1L]],
                       vapply(jv[[6L]][[1L]][[1L]], `[[`, character(1L), "alpha2"))
    do.call(rbind, lapply(junits, function(mc) {
      n   <- notes[[mc$country]]
      chr <- function(x) if (is.null(x)) NA_character_ else as.character(x)[[1L]]
      data.frame(
        variable    = vname,
        country     = mc$country,
        countryname = mc$country_name,
        shortname   = jname$shortname,
        shortdes    = jname$simpledes,
        pop         = jpop$longdes,
        age         = if (is.list(jage)) jage$fullname else jage[["fullname"]],
        source      = chr(if (is.null(n)) NULL else n$source),
        method      = chr(if (is.null(n)) NULL else n$method),
        quality     = chr(if (is.null(n)) NULL else n$data_quality),
        imputation  = if (is.null(n)) NA_character_ else .recode_imp(n$imputation),
        stringsAsFactors = FALSE)
    }))
  }))
  if (is.null(rows))
    .empty("variable","country","countryname","shortname","shortdes",
           "pop","age","source","method","quality","imputation")
  else rows
}

#' @noRd
.chunk_fetch <- function(variables, size, fetch_fn) {
  variables$chunk <- floor((as.integer(factor(
    do.call(paste, c(variables[, c("variable","percentile","age","pop")],
                     list(sep = "_"))))) - 1L) / size)
  do.call(rbind, lapply(split(variables, variables$chunk), function(ch)
    fetch_fn(unique(ch$country), unique(ch$api_code))))
}

#' @noRd
.auto_title <- function(v, countries) {
  lbl <- tryCatch({
    d   <- wid_decode(v, strict = FALSE)
    con <- if (!is.null(d)) wid_concepts$description[wid_concepts$code == d$concept] else character(0L)
    if (length(con)) tools::toTitleCase(sub("^\\(.*?\\)\\s*", "", con[1L])) else v
  }, error = function(e) v, warning = function(w) v)
  paste0(lbl, if (length(countries) <= 3L) paste0(" -- ", paste(countries, collapse = ", ")))
}

#' @noRd
.common_year <- function(d) {
  common <- Reduce(intersect, split(d$year, d$country))
  if (!length(common)) stop("No common year across countries.", call. = FALSE)
  max(common)
}