tests/testthat/test_download_contract.R

In wid: Download Data from the World Inequality Database

context("download_wid API contract")

mock_variables_response <- function() {
    data.frame(
        percentile = "p99p100",
        age = "992",
        pop = "j",
        variable = "sptinc",
        country = "FR",
        stringsAsFactors = FALSE
    )
}

mock_data_response <- function() {
    data.frame(
        indicator = c("sptinc_p99p100_992_j", "sptinc_p99p100_992_j"),
        country = c("FR", "FR"),
        year = c("2000", "2001"),
        value = c(1, 2),
        row_score = c(3, 4),
        stringsAsFactors = FALSE
    )
}

mock_decimal_data_response <- function() {
    data.frame(
        indicator = rep("sptinc_p99p100_992_j", 4),
        country = rep("FR", 4),
        year = c("2000", "2001", "2002", "2003"),
        value = c(1, 2, 3, 4),
        row_score = c(2.5, 3.25, 4.75, 5),
        stringsAsFactors = FALSE
    )
}

test_that("download_wid rejects empty full-database requests", {
    expect_error(
        download_wid(),
        regexp = "you must select at least some specific indicators, areas, or both",
        fixed = TRUE
    )
})

test_that("download_wid validates arguments before requesting data", {
    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            stop("request should not be made")
        },
        .package = "wid"
    )

    expect_error(
        download_wid(areas = "FR", indicators = "bad"),
        regexp = "indicators must be 6-letter codes",
        fixed = TRUE
    )
})

test_that("download_wid warns and returns null for empty variable matches", {
    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            data.frame(
                percentile = character(),
                age = character(),
                pop = character(),
                variable = character(),
                country = character(),
                stringsAsFactors = FALSE
            )
        },
        .package = "wid"
    )

    expect_warning(
        out <- download_wid(areas = "FR", indicators = "sptinc"),
        regexp = "no data matching selection",
        fixed = TRUE
    )
    expect_null(out)
})

test_that("metadata mode accepts partial metadata values", {
    partial_metadata <- data.frame(
        variable = "sptinc_p99p100_992_j",
        unit = NA_character_,
        unitname = NA_character_,
        shortname = "Top 1% share",
        shortdes = "share",
        technicaldes = "technical",
        shorttype = "share",
        longtype = "share",
        shortpop = "equal-split adults",
        pop = "equal-split adults",
        shortage = "adult",
        age = "20+",
        country = "FR",
        countryname = "France",
        method = NA_character_,
        source = NA_character_,
        series_score = NA_character_,
        stringsAsFactors = FALSE
    )

    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            mock_variables_response()
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            mock_data_response()
        },
        get_metadata_variables = function(areas, variables, report_missing = TRUE, collected_metadata = NULL) {
            list(response_table = partial_metadata, collected_metadata = list())
        },
        .package = "wid"
    )

    out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        metadata = TRUE
    )

    expect_equal(nrow(out), 2)
    expect_true(all(out$countryname == "France"))
    expect_true(all(is.na(out$series_score)))
    expect_equal(out$row_score, c(3, 4))
    expect_false("imputation" %in% names(out))
    expect_false("quality" %in% names(out))
})

test_that("plain data output omits row-level data quality", {
    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            mock_variables_response()
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            mock_data_response()
        },
        .package = "wid"
    )

    out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j"
    )

    expect_named(out, c("country", "variable", "percentile", "year", "value"))
    expect_false("row_score" %in% names(out))
    expect_false("series_score" %in% names(out))
})

test_that("metadata mode fills missing metadata schema columns", {
    broken_metadata <- data.frame(
        variable = "sptinc_p99p100_992_j",
        country = "FR",
        stringsAsFactors = FALSE
    )

    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            mock_variables_response()
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            mock_data_response()
        },
        get_metadata_variables = function(areas, variables, report_missing = TRUE, collected_metadata = NULL) {
            list(response_table = broken_metadata, collected_metadata = list())
        },
        .package = "wid"
    )

    out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        metadata = TRUE
    )

    expect_equal(nrow(out), 2)
    expect_named(out, c(
        "country", "countryname", "variable", "percentile", "year", "value",
        "shortname", "shortdes", "pop", "age", "source", "row_score",
        "series_score", "method"
    ))
    expect_true(all(is.na(out$countryname)))
    expect_true(all(is.na(out$series_score)))
    expect_equal(out$row_score, c(3, 4))
})

test_that("metadata requests keep age and population groups without percentile fanout", {
    observed_metadata_codes <- character()

    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            data.frame(
                percentile = c("p0p1", "p99p100", "p0p1", "p0p1"),
                age = c("992", "992", "999", "992"),
                pop = c("j", "j", "j", "i"),
                variable = "sptinc",
                country = "FR",
                stringsAsFactors = FALSE
            )
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            data.frame(
                indicator = variables,
                country = "FR",
                year = "2000",
                value = seq_along(variables),
                row_score = NA_real_,
                stringsAsFactors = FALSE
            )
        },
        get_metadata_variables = function(areas, variables, report_missing = TRUE, collected_metadata = NULL) {
            observed_metadata_codes <<- c(observed_metadata_codes, variables)
            metadata_rows <- lapply(variables, function(variable) {
                parts <- strsplit(variable, "_", fixed = TRUE)[[1]]
                data.frame(
                    variable = variable,
                    country = "FR",
                    countryname = "France",
                    shortname = paste0("short-", parts[1], parts[3], parts[4]),
                    shortdes = "description",
                    pop = paste0("pop-", parts[4]),
                    age = paste0("age-", parts[3]),
                    source = "source",
                    series_score = "4",
                    method = "method",
                    stringsAsFactors = FALSE
                )
            })
            list(response_table = do.call(rbind, metadata_rows), collected_metadata = list())
        },
        .package = "wid"
    )

    out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = c("p0p1", "p99p100"),
        ages = c("992", "999"),
        pop = c("j", "i"),
        metadata = TRUE
    )

    observed_groups <- vapply(strsplit(observed_metadata_codes, "_", fixed = TRUE), function(parts) {
        paste(parts[c(1, 3, 4)], collapse = "_")
    }, character(1))

    expect_equal(length(observed_metadata_codes), 3)
    expect_equal(sort(observed_groups), sort(c("sptinc_992_i", "sptinc_992_j", "sptinc_999_j")))
    expect_equal(sum(observed_groups == "sptinc_992_j"), 1)
    expect_equal(nrow(out), 4)
    expect_equal(sort(unique(out$variable)), sort(c("sptinc992i", "sptinc992j", "sptinc999j")))
    expect_false(any(is.na(out$countryname)))
    expect_equal(unique(out$age[out$variable == "sptinc999j"]), "age-999")
    expect_equal(unique(out$pop[out$variable == "sptinc992i"]), "pop-i")
})

test_that("score_filter filters row scores and returns filtering column", {
    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            mock_variables_response()
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            mock_data_response()
        },
        .package = "wid"
    )

    out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = 4
    )

    expect_named(out, c("country", "variable", "percentile", "year", "value", "row_score"))
    expect_equal(out$year, "2001")
    expect_equal(out$row_score, 4)

    range_out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(row_score = c(3, 3))
    )

    expect_equal(range_out$year, "2000")
    expect_equal(range_out$row_score, 3)

    explicit_out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(row_score = list(min = 3.5, max = 4))
    )

    expect_equal(explicit_out$year, "2001")
    expect_equal(explicit_out$row_score, 4)
})

test_that("score_filter handles decimal row score filters", {
    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            mock_variables_response()
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            mock_decimal_data_response()
        },
        .package = "wid"
    )

    shorthand_out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = 3.25
    )

    expect_equal(shorthand_out$year, c("2001", "2002", "2003"))
    expect_equal(shorthand_out$row_score, c(3.25, 4.75, 5))

    range_out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(row_score = c(2.5, 4.75))
    )

    expect_equal(range_out$year, c("2000", "2001", "2002"))
    expect_equal(range_out$row_score, c(2.5, 3.25, 4.75))

    explicit_out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(row_score = list(min = 3.5, max = 4.75))
    )

    expect_equal(explicit_out$year, "2002")
    expect_equal(explicit_out$row_score, 4.75)

    empty_out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(row_score = c(4.8, 4.9))
    )

    expect_named(empty_out, c("country", "variable", "percentile", "year", "value", "row_score"))
    expect_equal(nrow(empty_out), 0)
})

test_that("score_filter can fetch and return series score without full metadata", {
    observed_metadata_codes <- character()

    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            mock_variables_response()
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            mock_data_response()
        },
        get_metadata_variables = function(areas, variables, report_missing = TRUE, collected_metadata = NULL) {
            observed_metadata_codes <<- c(observed_metadata_codes, variables)
            list(
                response_table = data.frame(
                    variable = "sptinc_p99p100_992_j",
                    country = "FR",
                    series_score = "4",
                    stringsAsFactors = FALSE
                ),
                collected_metadata = list()
            )
        },
        .package = "wid"
    )

    out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(series_score = 4)
    )

    expect_equal(observed_metadata_codes, "sptinc_p99p100_992_j")
    expect_named(out, c("country", "variable", "percentile", "year", "value", "series_score"))
    expect_false("row_score" %in% names(out))
    expect_false("countryname" %in% names(out))
    expect_equal(nrow(out), 2)
    expect_equal(unique(out$series_score), "4")

    combined_out <- download_wid(
        areas = "FR",
        indicators = "sptinc",
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(row_score = 4, series_score = 4)
    )

    expect_named(combined_out, c(
        "country", "variable", "percentile", "year", "value",
        "row_score", "series_score"
    ))
    expect_equal(combined_out$year, "2001")
    expect_equal(combined_out$row_score, 4)
    expect_equal(combined_out$series_score, "4")
})

test_that("score_filter handles decimal series scores and combined filters", {
    testthat::local_mocked_bindings(
        get_variables_areas = function(areas, sixlet = "all") {
            data.frame(
                percentile = "p99p100",
                age = "992",
                pop = "j",
                variable = sixlet,
                country = "FR",
                stringsAsFactors = FALSE
            )
        },
        get_data_variables = function(areas, variables, no_extrapolation = FALSE) {
            parts <- strsplit(variables, "_", fixed = TRUE)
            data.frame(
                indicator = variables,
                country = "FR",
                year = "2000",
                value = seq_along(variables),
                row_score = vapply(parts, function(x) {
                    if (identical(x[[1]], "aptinc")) 3.75 else 2.5
                }, numeric(1)),
                stringsAsFactors = FALSE
            )
        },
        get_metadata_variables = function(areas, variables, report_missing = TRUE, collected_metadata = NULL) {
            metadata_rows <- lapply(variables, function(variable) {
                parts <- strsplit(variable, "_", fixed = TRUE)[[1]]
                data.frame(
                    variable = variable,
                    country = "FR",
                    series_score = if (identical(parts[[1]], "aptinc")) "4.75" else "3.25",
                    stringsAsFactors = FALSE
                )
            })
            list(response_table = do.call(rbind, metadata_rows), collected_metadata = list())
        },
        .package = "wid"
    )

    boundary_out <- download_wid(
        areas = "FR",
        indicators = c("sptinc", "aptinc"),
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(series_score = c(3.25, 4.75))
    )

    expect_equal(sort(boundary_out$variable), sort(c("aptinc992j", "sptinc992j")))
    expect_equal(sort(unique(boundary_out$series_score)), c("3.25", "4.75"))

    decimal_out <- download_wid(
        areas = "FR",
        indicators = c("sptinc", "aptinc"),
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(series_score = list(min = 3.5, max = 4.75))
    )

    expect_equal(decimal_out$variable, "aptinc992j")
    expect_equal(decimal_out$series_score, "4.75")

    combined_out <- download_wid(
        areas = "FR",
        indicators = c("sptinc", "aptinc"),
        perc = "p99p100",
        ages = "992",
        pop = "j",
        score_filter = list(row_score = 3.5, series_score = 4.5)
    )

    expect_named(combined_out, c(
        "country", "variable", "percentile", "year", "value",
        "row_score", "series_score"
    ))
    expect_equal(combined_out$variable, "aptinc992j")
    expect_equal(combined_out$row_score, 3.75)
    expect_equal(combined_out$series_score, "4.75")
})

test_that("score_filter rejects invalid filters before requesting data", {
    expect_error(
        download_wid(areas = "FR", indicators = "sptinc", score_filter = list(foo = 3)),
        regexp = "score_filter",
        fixed = TRUE
    )
    expect_error(
        download_wid(areas = "FR", indicators = "sptinc", score_filter = list(row_score = 6)),
        regexp = "score_filter",
        fixed = TRUE
    )
    expect_error(
        download_wid(areas = "FR", indicators = "sptinc", score_filter = list(row_score = 5.1)),
        regexp = "score_filter",
        fixed = TRUE
    )
    expect_error(
        download_wid(areas = "FR", indicators = "sptinc", score_filter = list(series_score = -0.1)),
        regexp = "score_filter",
        fixed = TRUE
    )
    expect_error(
        download_wid(areas = "FR", indicators = "sptinc", score_filter = list(row_score = c(4, 3))),
        regexp = "score_filter",
        fixed = TRUE
    )
    expect_error(
        download_wid(areas = "FR", indicators = "sptinc", score_filter = list(row_score = list(gt = 3))),
        regexp = "score_filter",
        fixed = TRUE
    )
})

test_that("exclude extrapolations path does not require meta in data payload", {
    fake_response <- list(
        sptinc_p99p100_992_j = list(
            list(FR = list(values = list(
                list("2000", 1),
                list("2001", 2)
            )))
        )
    )

    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) fake_response,
        .package = "wid"
    )

    out <- get_data_variables("FR", "sptinc_p99p100_992_j", no_extrapolation = TRUE)
    expect_equal(nrow(out), 2)
    expect_true(all(out$indicator == "sptinc_p99p100_992_j"))
    expect_true(all(out$country == "FR"))
    expect_true(all(is.na(out$row_score)))
})

test_that("data request reads named API value tuples", {
    fake_response <- list(
        sptinc_p99p100_992_j = list(
            list(FR = list(values = list(
                list(y = "2000", v = 1, dq = 3),
                list(y = "2001", v = 2, dq = NULL)
            )))
        )
    )

    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) fake_response,
        .package = "wid"
    )

    out <- get_data_variables("FR", "sptinc_p99p100_992_j")
    expect_named(out, c("indicator", "country", "year", "value", "row_score"))
    expect_equal(out$year, c("2000", "2001"))
    expect_equal(out$value, c(1, 2))
    expect_equal(out$row_score, c(3, NA))
})

test_that("data request reads decimal row scores from API tuples", {
    fake_response <- list(
        sptinc_p99p100_992_j = list(
            list(FR = list(values = list(
                list("2000", 1, 3.25),
                list(y = "2001", v = 2, dq = 4.75)
            )))
        )
    )

    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) fake_response,
        .package = "wid"
    )

    out <- get_data_variables("FR", "sptinc_p99p100_992_j")
    expect_equal(out$year, c("2000", "2001"))
    expect_equal(out$row_score, c(3.25, 4.75))
})

test_that("data request uses large payload download URL", {
    fake_response <- list(
        sptinc_p99p100_992_j = list(
            list(FR = list(values = list(
                list("2000", 1, 4)
            )))
        )
    )
    parsed_responses <- list(
        list(status = "payload_too_large", download_url = "https://example.test/payload.json"),
        fake_response
    )
    parse_call <- 0
    requested_urls <- character()

    testthat::local_mocked_bindings(
        GET = function(url, ...) {
            requested_urls <<- c(requested_urls, url)
            NULL
        },
        content = function(...) "ignored",
        fromJSON = function(...) {
            parse_call <<- parse_call + 1
            parsed_responses[[parse_call]]
        },
        .package = "wid"
    )

    expect_message(
        out <- get_data_variables("FR", "sptinc_p99p100_992_j"),
        regexp = "Downloading large data from alternative route",
        fixed = TRUE
    )

    expect_equal(nrow(out), 1)
    expect_true(grepl("countries-variables", requested_urls[[1]], fixed = TRUE))
    expect_equal(requested_urls[[2]], "https://example.test/payload.json")
})

test_that("data request rejects broken server response shapes", {
    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) list(status = "payload_too_large"),
        .package = "wid"
    )

    expect_error(
        get_data_variables("FR", "sptinc_p99p100_992_j"),
        regexp = "missing download URL",
        fixed = TRUE
    )

    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) list(status = "error", message = "bad request"),
        .package = "wid"
    )

    expect_error(
        get_data_variables("FR", "sptinc_p99p100_992_j"),
        regexp = "bad request",
        fixed = TRUE
    )

    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) "invalid",
        .package = "wid"
    )

    expect_error(
        get_data_variables("FR", "sptinc_p99p100_992_j"),
        regexp = "server response invalid",
        fixed = TRUE
    )
})

metadata_item <- function(variable, unit_metadata, data_quality = NULL) {
    item <- list(
        list(name = list(
            shortname = "Pre-tax national income",
            simpledes = "Pre-tax national income description",
            technicaldes = "technical"
        )),
        list(type = list(
            shortdes = "Share",
            longdes = "Income or wealth shares",
            onlinedes = "online",
            rank = 5
        )),
        list(pop = list(
            shortdes = "equal-split adults",
            longdes = "The base unit is the individual.",
            rank = 3
        )),
        list(age = list(
            agecode = "992",
            shortname = "Adults",
            fullname = "The population is comprised of individuals over age 20.",
            rank = 2
        )),
        list(units = list(list(
            country_name = "France",
            country = "FR",
            metadata = unit_metadata
        ))),
        list(notes = list(list(ptinc = list(list(
            alpha2 = "FR",
            method = "method",
            source = "source",
            extrapolation = NULL,
            data_points = NULL,
            data_quality = data_quality
        ))))),
        list(intuitivedes = "intuitive")
    )
    out <- list(item)
    names(out) <- variable
    out
}

test_that("metadata request accepts mixed optional metadata fields", {
    fake_response <- list(list(metadata_func = list(
        metadata_item(
            "sptinc_p99p100_992_j",
            list(unit = "share"),
            data_quality = NULL
        ),
        metadata_item(
            "aptinc_p0p100_992_j",
            list(unit = "EUR", unit_name = "Euro", unit_symbol = "EUR"),
            data_quality = "4.75"
        )
    )))

    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) fake_response,
        .package = "wid"
    )

    out <- get_metadata_variables(
        "FR",
        c("sptinc_p99p100_992_j", "aptinc_p0p100_992_j")
    )$response_table

    expect_equal(nrow(out), 2)
    expect_named(out, names(empty_metadata_table()))
    expect_equal(out$unitname, c(NA, "Euro"))
    expect_equal(out$unitsymbol, c(NA, "EUR"))
    expect_equal(out$series_score, c(NA, "4.75"))
    expect_false("imputation" %in% names(out))
})

test_that("metadata request treats API error shape as no metadata", {
    testthat::local_mocked_bindings(
        GET = function(...) NULL,
        content = function(...) "ignored",
        fromJSON = function(...) list(error = "Internal server error"),
        .package = "wid"
    )

    res <- get_metadata_variables("FR", "xxxxxx_p99p100_992_t")

    expect_equal(nrow(res$response_table), 0)
    expect_named(res$response_table, names(empty_metadata_table()))
    expect_equal(res$collected_metadata, list())
})