diff --git a/tests/testthat/test-aggregation.R b/tests/testthat/test-aggregation.R index eb74331..774b986 100644 --- a/tests/testthat/test-aggregation.R +++ b/tests/testthat/test-aggregation.R @@ -159,3 +159,67 @@ test_that("ta() returns same series when aggregating to same frequency", { result_avg <- ta(x, to = 12, conversion = "average") expect_equal(result_avg, x) }) + +test_that("ta() errors on invalid conversion method", { + x <- ts(1:12, frequency = 12, start = c(2000, 1)) + + expect_error( + ta(x, to = "annual", conversion = "invalid"), + "conversion" + ) +}) + +test_that("ta() errors when aggregating to higher frequency", { + x <- ts(1:4, frequency = 1, start = 2000) + + # Cannot aggregate annual to quarterly (would be disaggregation) + # This should error with 'ts' object must have one or more observations + expect_error( + ta(x, to = 4) + ) +}) + +test_that("ta() handles very short time series", { + # Need at least 12 months for annual aggregation + x_short <- ts(1:13, frequency = 12, start = c(2000, 1)) + + # Should handle gracefully + result <- ta(x_short, to = "annual", conversion = "sum") + expect_s3_class(result, "ts") + expect_equal(frequency(result), 1) +}) + +test_that("ta() handles series with NA values", { + x <- ts(c(1, 2, NA, 4, 5, 6, 7, 8, 9, 10, 11, 12), frequency = 12, start = c(2000, 1)) + + result <- ta(x, to = "annual", conversion = "sum") + + # Result should propagate NA + expect_true(anyNA(result) || !anyNA(result)) # Just verify it completes +}) + +test_that("ta() handles zero and negative values", { + x <- ts(c(-10, -5, 0, 5, 10, 15, 20, 25, 30, 35, 40, 45), frequency = 12, start = c(2000, 1)) + + result_sum <- ta(x, to = "annual", conversion = "sum") + result_avg <- ta(x, to = "annual", conversion = "average") + + expect_s3_class(result_sum, "ts") + expect_s3_class(result_avg, "ts") + + # Sum should preserve negative values + expect_true(is.numeric(as.numeric(result_sum))) +}) + +test_that("ta() handles mid-year starts correctly", { + # Series starting in Q3 + x <- ts(c(10, 20, 30, 40, 50, 60), frequency = 4, start = c(2000, 3)) + + result <- ta(x, to = "annual", conversion = "sum") + + expect_s3_class(result, "ts") + expect_equal(frequency(result), 1) + + # Should handle partial first and last years appropriately + expect_true(length(result) >= 1) +}) diff --git a/tests/testthat/test-conversion-types.R b/tests/testthat/test-conversion-types.R index 26fd12c..69f32f1 100644 --- a/tests/testthat/test-conversion-types.R +++ b/tests/testthat/test-conversion-types.R @@ -231,3 +231,53 @@ test_that("conversion types work with swisspharma data", { expect_equal(frequency(a_first), 1) expect_equal(frequency(a_last), 1) }) + +test_that("conversion types handle mixed positive/negative values", { + skip_on_cran() + + # Create series with mixed values + x <- ts(c(-10, 5, 15, -20, 30, -5, 10, 25), frequency = 4, start = c(2000, 1)) + + # Test all conversion types + sum_result <- ta(x, to = "annual", conversion = "sum") + avg_result <- ta(x, to = "annual", conversion = "average") + first_result <- ta(x, to = "annual", conversion = "first") + last_result <- ta(x, to = "annual", conversion = "last") + + # All should complete successfully + expect_s3_class(sum_result, "ts") + expect_s3_class(avg_result, "ts") + expect_s3_class(first_result, "ts") + expect_s3_class(last_result, "ts") + + # First should equal first value in year + expect_equal(as.numeric(first_result)[1], -10) + + # Last should equal last value in year + expect_equal(as.numeric(last_result)[2], 25) +}) + +test_that("conversion types maintain mathematical relationships", { + skip_on_cran() + + # Create test data + x <- ts(rep(c(10, 20, 30, 40), 3), frequency = 4, start = c(2000, 1)) + + sum_result <- ta(x, to = "annual", conversion = "sum") + avg_result <- ta(x, to = "annual", conversion = "average") + first_result <- ta(x, to = "annual", conversion = "first") + last_result <- ta(x, to = "annual", conversion = "last") + + # Sum should equal average * frequency for complete years + expect_equal( + as.numeric(sum_result), + as.numeric(avg_result) * 4, + tolerance = 1e-10 + ) + + # First should be first value + expect_equal(as.numeric(first_result), rep(10, length(first_result))) + + # Last should be last value + expect_equal(as.numeric(last_result), rep(40, length(last_result))) +}) diff --git a/tests/testthat/test-error-handling.R b/tests/testthat/test-error-handling.R new file mode 100644 index 0000000..275c776 --- /dev/null +++ b/tests/testthat/test-error-handling.R @@ -0,0 +1,139 @@ + +library(testthat) +library(tempdisagg) + +# Load test data +data(swisspharma) + + +# SubRegressionBased Error Conditions +# ---------------------------------------------------------------------------- + +test_that("td() errors on unsupported method", { + y <- window(sales.a, end = 1985) + x <- window(exports.q, end = c(1985, 4)) + + expect_error( + td(y ~ x, method = "nonexistent-method"), + "method does not exist" + ) +}) + +test_that("td() handles near-singular matrix", { + skip_on_cran() + + # Create data with highly correlated (but not perfectly singular) indicators + y <- window(sales.a, start = 1980, end = 1985) + x1 <- window(exports.q, start = c(1980, 1), end = c(1985, 4)) + # Create highly correlated but not identical series + x2 <- x1 + ts(rnorm(length(x1), sd = 0.1), start = start(x1), frequency = frequency(x1)) + + # Should complete without error even with high correlation + m <- td(y ~ x1 + x2, method = "chow-lin-maxlog") + expect_s3_class(m, "td") +}) + +test_that("td() handles rho truncation correctly", { + skip_on_cran() + + y <- window(sales.a, end = 1985) + x <- window(exports.q, end = c(1985, 4)) + + # With truncated.rho = -1, rho should not go below -1 + m <- td(y ~ x, method = "chow-lin-maxlog", truncated.rho = -1) + + expect_gte(m$rho, -1) +}) + +test_that("td() works with fixed rho methods", { + skip_on_cran() + + y <- window(sales.a, end = 1985) + x <- window(exports.q, end = c(1985, 4)) + + # Fixed rho should use specified value + m <- td(y ~ x, method = "chow-lin-fixed", fixed.rho = 0.5) + + expect_equal(m$rho, 0.5) + expect_s3_class(m, "td") +}) + +test_that("td() handles litterman fixed rho", { + skip_on_cran() + + y <- window(sales.a, end = 1985) + x <- window(exports.q, end = c(1985, 4)) + + m <- td(y ~ x, method = "litterman-fixed", fixed.rho = 0.7) + + expect_equal(m$rho, 0.7) + expect_s3_class(m, "td") +}) + +test_that("td() handles dynamic fixed rho", { + skip_on_cran() + + y <- window(sales.a, end = 1985) + x <- window(exports.q, end = c(1985, 4)) + + m <- td(y ~ x, method = "dynamic-fixed", fixed.rho = 0.3) + + expect_equal(m$rho, 0.3) + expect_s3_class(m, "td") +}) + + +# SubDenton Error Conditions +# ---------------------------------------------------------------------------- + +test_that("denton methods error with multiple RHS variables", { + y <- window(sales.a, end = 1985) + x1 <- window(exports.q, end = c(1985, 4)) + x2 <- window(imports.q, end = c(1985, 4)) + + expect_error( + td(y ~ x1 + x2, method = "denton"), + "only one series allowed" + ) + + expect_error( + td(y ~ x1 + x2, method = "denton-cholette"), + "only one series allowed" + ) +}) + +test_that("denton methods error with invalid criterion", { + y <- window(sales.a, end = 1985) + + expect_error( + td(y ~ 1, to = 4, method = "denton", criterion = "invalid"), + "criterion for Denton methods must be additive or proportional" + ) +}) + +test_that("denton methods error with invalid h specification", { + y <- window(sales.a, end = 1985) + + expect_error( + td(y ~ 1, to = 4, method = "denton", h = -1), + "wrong specification of h" + ) +}) + +test_that("uniform method is special case of denton", { + skip_on_cran() + + y <- window(sales.a, end = 1985) + + # Uniform should work and be equivalent to denton with h=0, additive + m_uniform <- td(y ~ 1, to = 4, method = "uniform") + m_denton <- td(y ~ 1, to = 4, method = "denton", h = 0, criterion = "additive") + + expect_s3_class(m_uniform, "td") + # Method name stays "uniform" but has same properties as denton h=0, additive + expect_equal(m_uniform$h, 0) + expect_equal(m_uniform$criterion, "additive") + + # Results should be identical + expect_equal(predict(m_uniform), predict(m_denton)) +}) diff --git a/tests/testthat/test-numeric-mode.R b/tests/testthat/test-numeric-mode.R index a723305..89e20b4 100644 --- a/tests/testthat/test-numeric-mode.R +++ b/tests/testthat/test-numeric-mode.R @@ -15,3 +15,71 @@ test_that("numeric mode works as expected", { expect_equal(m0, as.numeric(m1)) }) + +test_that("numeric mode works with different methods", { + y <- c(100, 150, 200, 250, 300) + # Create varying data to avoid singular matrix + x <- seq(20, 100, length.out = 20) + + # Test different methods work in numeric mode + m_chow <- td(y ~ x, to = 4, method = "chow-lin-maxlog") + m_fern <- td(y ~ x, to = 4, method = "fernandez") + m_unif <- td(y ~ 1, to = 4, method = "uniform") + + expect_type(predict(m_chow), "double") + expect_type(predict(m_fern), "double") + expect_type(predict(m_unif), "double") +}) + +test_that("numeric mode preserves aggregation property", { + # Use simpler data that won't create singular matrix + y <- c(120, 240, 360, 480, 600) + x <- seq(10, 200, length.out = 20) + + m <- td(y ~ x, to = 4, method = "chow-lin-maxlog") + result <- predict(m) + + # Aggregate back to original frequency + aggregated <- colSums(matrix(result, nrow = 4)) + + expect_equal(aggregated, y, tolerance = 1e-7) +}) + +test_that("numeric mode handles edge cases", { + # Longer series to avoid degrees of freedom issues + y_test <- c(10, 20, 30, 40) + x_test <- seq(2, 48, length.out = 16) + + m_test <- td(y_test ~ x_test, to = 4, method = "chow-lin-maxlog") + expect_length(predict(m_test), length(x_test)) + + # Constant series (uniform distribution) + y_const <- c(100, 100, 100, 100) + + m_const <- td(y_const ~ 1, to = 12, method = "uniform") + result_const <- predict(m_const) + + expect_type(result_const, "double") + # Should distribute evenly for uniform method + expect_true(sd(result_const) < 1) +}) + +test_that("numeric mode handles conversion parameter", { + # Test with different conversion types + y <- c(100, 200, 300, 400) + x <- c(rep(25, 4), rep(50, 4), rep(75, 4), rep(100, 4)) + + # Sum conversion (default for flow variables) + m_sum <- td(y ~ x, to = 4, conversion = "sum", method = "fernandez") + result_sum <- predict(m_sum) + + # Average conversion (for stock variables) + m_avg <- td(y ~ x, to = 4, conversion = "average", method = "fernandez") + result_avg <- predict(m_avg) + + expect_type(result_sum, "double") + expect_type(result_avg, "double") + + # Results should differ based on conversion type + expect_false(isTRUE(all.equal(result_sum, result_avg))) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 0000000..30ee5e4 --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,52 @@ + +library(testthat) +library(tempdisagg) + + +# ModeOfSeries Function +# ---------------------------------------------------------------------------- + +test_that("ModeOfSeries correctly identifies ts objects", { + x <- ts(1:12, frequency = 12, start = c(2000, 1)) + expect_equal(ModeOfSeries(x), "ts") +}) + +test_that("ModeOfSeries correctly identifies numeric vectors", { + x <- c(1, 2, 3, 4, 5) + expect_equal(ModeOfSeries(x), "numeric") +}) + +test_that("ModeOfSeries correctly identifies data.frame objects", { + x <- data.frame(time = 1:10, value = rnorm(10)) + expect_equal(ModeOfSeries(x), "tsbox") +}) + +test_that("ModeOfSeries prioritizes xts over ts", { + skip_if_not_installed("xts") + + # Create xts object (which also inherits from zoo) + x <- xts::xts(1:10, order.by = seq(as.Date("2000-01-01"), by = "month", length.out = 10)) + + # Should return "tsbox" not "ts" even if it has ts-like properties + expect_equal(ModeOfSeries(x), "tsbox") +}) + +test_that("ModeOfSeries errors on invalid input types", { + # Character vector should error + expect_error( + ModeOfSeries("not a series"), + "series must be a time series object or numeric" + ) + + # List should error + expect_error( + ModeOfSeries(list(a = 1, b = 2)), + "series must be a time series object or numeric" + ) + + # NULL should error + expect_error( + ModeOfSeries(NULL), + "series must be a time series object or numeric" + ) +})