diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..9882260 --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,61 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: test-coverage.yaml + +permissions: read-all + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr, any::xml2 + needs: coverage + + - name: Test coverage + run: | + cov <- covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + covr::to_cobertura(cov) + shell: Rscript {0} + + - uses: codecov/codecov-action@v4 + with: + fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} + file: ./cobertura.xml + plugin: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v4 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/README.Rmd b/README.Rmd index 8579cc9..2676225 100644 --- a/README.Rmd +++ b/README.Rmd @@ -24,6 +24,7 @@ knitr::opts_chunk$set( [![](http://cranlogs.r-pkg.org/badges/grand-total/bayesRecon)](https://cran.r-project.org/package=bayesRecon) [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) [![License: LGPL (>= 3)](https://img.shields.io/badge/license-LGPL (>= 3)-yellow.svg)](https://www.gnu.org/licences/lgpl-3.0) +[![Codecov test coverage](https://codecov.io/gh/IDSIA/bayesRecon/graph/badge.svg)](https://app.codecov.io/gh/IDSIA/bayesRecon) The package `bayesRecon` implements several methods for probabilistic reconciliation of hierarchical time series forecasts. diff --git a/README.md b/README.md index 46c4813..b432987 100644 --- a/README.md +++ b/README.md @@ -16,6 +16,8 @@ status](https://www.r-pkg.org/badges/version/bayesRecon)](https://CRAN.R-project experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) [![License: LGPL (\>= 3)](https://img.shields.io/badge/license-LGPL%20(%3E=%203)-yellow.svg)](https://www.gnu.org/licences/lgpl-3.0) +[![Codecov test +coverage](https://codecov.io/gh/IDSIA/bayesRecon/graph/badge.svg)](https://app.codecov.io/gh/IDSIA/bayesRecon) The package `bayesRecon` implements several methods for probabilistic diff --git a/tests/testthat/dataForTests/Monthly-Count_ts.csv b/tests/testthat/dataForTests/Monthly-Count_ts.csv new file mode 100644 index 0000000..63494cc --- /dev/null +++ b/tests/testthat/dataForTests/Monthly-Count_ts.csv @@ -0,0 +1,120 @@ +4 +4 +1 +3 +2 +2 +3 +0 +2 +3 +2 +3 +4 +1 +2 +4 +5 +0 +2 +2 +4 +1 +6 +4 +0 +2 +1 +4 +2 +3 +3 +3 +1 +3 +0 +3 +0 +1 +4 +2 +1 +2 +0 +5 +2 +5 +4 +2 +5 +2 +1 +1 +1 +3 +0 +3 +3 +1 +1 +2 +2 +5 +3 +2 +3 +1 +1 +3 +3 +1 +0 +1 +1 +2 +1 +3 +0 +1 +2 +0 +2 +1 +1 +2 +3 +2 +1 +0 +0 +1 +2 +0 +1 +4 +4 +3 +1 +2 +3 +2 +2 +1 +1 +1 +4 +5 +3 +3 +2 +0 +2 +3 +3 +2 +2 +2 +0 +1 +2 +3 diff --git a/tests/testthat/dataForTests/generate_monthlyCountData.R b/tests/testthat/dataForTests/generate_monthlyCountData.R new file mode 100644 index 0000000..4644b03 --- /dev/null +++ b/tests/testthat/dataForTests/generate_monthlyCountData.R @@ -0,0 +1,12 @@ +# Generate the monthly count time series for the mixCond and TDcond tests +# CHANGE THE WORKING DIRECTORY BEFORE RUNNING +rm(list=ls()) +library(bayesRecon) + +set.seed(42) +vals <- stats::rpois(12*10,lambda = 2) + + +write.table(vals,file="./Monthly-Count_ts.csv",row.names = FALSE,sep=',', + col.names = FALSE,quote = FALSE) + diff --git a/tests/testthat/test-reconc_BUIS_gaussian.R b/tests/testthat/test-reconc_BUIS_gaussian.R index a517b0e..3ce0d69 100644 --- a/tests/testthat/test-reconc_BUIS_gaussian.R +++ b/tests/testthat/test-reconc_BUIS_gaussian.R @@ -106,4 +106,48 @@ test_that("Monthly, in_type=='samples', distr='discrete'",{ expect_equal(abs(m) < 1.5e-2, TRUE) }) +test_that("Monthly simple, in_type=='params', distr='nbinom'",{ + + # Read samples from dataForTests (reproducibility) + vals <- read.csv(file = "dataForTests/Monthly-Count_ts.csv", header = FALSE) + + # Create a count time series with monthly observations for 10 years + y <- ts(data=vals,frequency = 12) + + # Create the aggregated yearly time series + y_agg <- temporal_aggregation(y,agg_levels = c(1,12)) + + # We use a marginal forecast that computes for each month + # the empirical mean and variance + # the forecast is a negative binomial with those params + fc_bottom <- list() + for(i in seq(12)){ + mm <- mean(y_agg$`f=12`[seq(i,120,12)]) + vv <- max(var(y_agg$`f=12`[seq(i,120,12)]), mm+0.5) + #cat("i: ",i, "mean: ",mm, "var: ",vv, "size: ",mm^2/(vv-mm), "prob: ",mm/vv, "\n") + + fc_bottom[[i]] <- list(size=mm^2/(vv-mm),mu=mm) + } + + # We compute the empirical mean and variance of the yearly ts + # we forecast with a negative binomial with those parameters + mm <- mean(y_agg$`f=1`) + vv <- var(y_agg$`f=1`) + fc_upper <- list(size=mm^2/(vv-mm), prob= mm/vv) + + # Obtain the aggregation matrix for this hierarchy + rec_mat <- get_reconc_matrices(c(1,12),12) + + base_forecasts = append(list(fc_upper),fc_bottom) + res.buis_params = reconc_BUIS(rec_mat$A, base_forecasts, in_type = "params", distr = "nbinom", seed=42) + + + fc_upper_gauss <- list(mu=mm, Sigma = matrix(vv)) + res.mixCond <- reconc_MixCond(rec_mat$A, fc_bottom, fc_upper_gauss, bottom_in_type = "params", distr = 'nbinom') + upp_pmf <- PMF.from_samples(as.integer(res.buis_params$upper_reconciled_samples)) + + expect_equal(res.mixCond$upper_reconciled$pmf[[1]],upp_pmf,tolerance = 0.1) + +}) + ############################################################################## diff --git a/tests/testthat/test-reconc_MixCond.R b/tests/testthat/test-reconc_MixCond.R index 6a501e2..712a28e 100644 --- a/tests/testthat/test-reconc_MixCond.R +++ b/tests/testthat/test-reconc_MixCond.R @@ -23,7 +23,7 @@ test_that("reconc_MixCond simple example", { ## upper fc_upper <- list(mu = means[1:10], Sigma = diag(vars[1:10])) - + ## bottom fc_bottom <- list() for(i in seq(ncol(A))){ @@ -50,7 +50,65 @@ test_that("reconc_MixCond simple example", { bott_rec_means_pmf <- unlist(lapply(res.MixCond_pmf$bottom_reconciled$pmf,PMF.get_mean)) bott_rec_vars_pmf <- unlist(lapply(res.MixCond_pmf$bottom_reconciled$pmf,PMF.get_var)) - expect_equal(bott_rec_means,bott_rec_means_pmf, tolerance = 0.1) + expect_equal(bott_rec_means,bott_rec_means_pmf, tolerance = 0.01) expect_equal(bott_rec_vars,bott_rec_vars_pmf, tolerance = 0.1) + +}) + +test_that("reconc_MixCond and reconc_TDcond with temporal hier and params", { + + + # Read samples from dataForTests (reproducibility) + vals <- read.csv(file = "dataForTests/Monthly-Count_ts.csv", header = FALSE) + + # Create a count time series with monthly observations for 10 years + y <- ts(data=vals,frequency = 12) + + # Create the aggregated yearly time series + y_agg <- temporal_aggregation(y,agg_levels = c(1,12)) + + # We use a marginal forecast that computes for each month + # the empirical mean and forecasts a Poisson with that value + fc_bottom <- list() + for(i in seq(12)){ + fc_bottom[[i]] <- list(lambda=mean(y_agg$`f=12`[seq(i,120,12)])) + } + + # We compute the empirical mean and variance of the yearly ts + # we forecast with a Gaussian with those parameters + fc_upper <- list(mu=mean(y_agg$`f=1`), Sigma=matrix(var(y_agg$`f=1`))) + + # Obtain the aggregation matrix for this hierarchy + rec_mat <- get_reconc_matrices(c(1,12),12) + + # Do a couple of checks on S and A + expect_no_error(.check_S(rec_mat$S)) + expect_error(.check_S(rec_mat$A)) + expect_true(.check_BU_matr(rec_mat$A)) + expect_false(.check_BU_matr(rec_mat$S)) + + # We can reconcile with reconc_MixCond + res.mixCond <- reconc_MixCond(rec_mat$A, fc_bottom, fc_upper, bottom_in_type = "params", distr = 'poisson') + + # We can reconcile with reconc_TDcond + res.TDcond <- reconc_TDcond(rec_mat$A, fc_bottom, fc_upper, bottom_in_type = "params", distr = 'poisson') + + # Summary of the upper reconciled with TDcond + pmfSum <- PMF.summary(res.TDcond$upper_reconciled$pmf[[1]]) + # We expect that the reconciled mean is very similar to the initial mean (should be equal) + expect_equal(pmfSum$Mean,fc_upper$mu,tolerance = 0.01) + + # Check that all bottom and upper reconciled PMF sum to 1 + check_pmf_bott_mixCond <- sum(unlist(lapply(res.mixCond$bottom_reconciled$pmf, function(x){sum(x)}))) + check_pmf_upp_mixCond <- sum(unlist(lapply(res.mixCond$upper_reconciled$pmf, function(x){sum(x)}))) + expect_equal(check_pmf_bott_mixCond,12) + expect_equal(check_pmf_upp_mixCond,1) + + # Check that all bottom and upper reconciled PMF sum to 1 + check_pmf_bott_TDcond <- sum(unlist(lapply(res.TDcond$bottom_reconciled$pmf, function(x){sum(x)}))) + check_pmf_upp_TDcond <- sum(unlist(lapply(res.TDcond$upper_reconciled$pmf, function(x){sum(x)}))) + expect_equal(check_pmf_bott_TDcond,12) + expect_equal(check_pmf_upp_TDcond,1) + }) diff --git a/tests/testthat/test-sample_funs.R b/tests/testthat/test-sample_funs.R index 553cc71..2dfab51 100644 --- a/tests/testthat/test-sample_funs.R +++ b/tests/testthat/test-sample_funs.R @@ -114,11 +114,11 @@ test_that("MVN density works", { 2,3,4, 0.5,0.5,0.5, 0,1,-1), ncol=3,byrow=TRUE) - + res <- .MVN_density(x=xx,mu=mu,Sigma=Sigma) true_val <- c(8.742644e-04, 1.375497e-11, 3.739985e-03, 1.306453e-01) - expect_equal(res,true_val,tolerance = 0.1) + expect_equal(res,true_val, tolerance = 1e-6) # Check if block-evaluation works xx <- matrix(runif(3*1e4),ncol=3,byrow=TRUE)