diff --git a/.Rbuildignore b/.Rbuildignore index 91114bf..c1a0590 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,2 +1,14 @@ ^.*\.Rproj$ ^\.Rproj\.user$ +^AlertTools$ +^AlertTools\.Rcheck$ +^AlertTools_[0-9.]+\.tar\.gz$ +^INSTRUCOES_AGENTE_REFATORACAO\.md$ +^plano_refatoracao_alerttools\.(qmd|html)$ +^docs/refactoring$ +^\.github$ +^_pkgdown\.yml$ +^\.lintr$ +^tools$ +^pkgdown-site$ +^data/(bairro2APS|locs|sinan)\.rda$ diff --git a/.github/PULL_REQUEST_TEMPLATE/consumer-migration.md b/.github/PULL_REQUEST_TEMPLATE/consumer-migration.md new file mode 100644 index 0000000..84e01c2 --- /dev/null +++ b/.github/PULL_REQUEST_TEMPLATE/consumer-migration.md @@ -0,0 +1,23 @@ +## Consumidor migrado + +- ID no registro: +- Repositório e arquivo: +- Responsável: +- API legada: +- API nova: + +## Evidências + +- [ ] testes unitários do consumidor passaram; +- [ ] execução com dados descartáveis passou; +- [ ] schemas e cardinalidades foram comparados; +- [ ] resultados epidemiológicos foram comparados e aprovados; +- [ ] execução com `lifecycle_verbosity = "warning"` não registrou depreciações; +- [ ] `consumer-registry.csv` foi atualizado com evidência e data. + +## Rollback + +- versão anterior do consumidor: +- versão do AlertTools a fixar: +- artefatos que precisam ser restaurados: +- critério para acionar rollback: diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..ca4f815 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,156 @@ +name: R-CMD-check + +on: + push: + branches: [master, main] + pull_request: + +permissions: + contents: read + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + name: ${{ matrix.config.os }} (R ${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macos-latest, r: release} + - {os: windows-latest, r: release} + - {os: ubuntu-latest, r: release} + - {os: ubuntu-latest, r: devel} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + use-public-rspm: true + extra-repositories: https://inla.r-inla-download.org/R/stable + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + + postgres-integration: + runs-on: ubuntu-latest + name: PostgreSQL integration (R release) + + services: + postgres: + image: postgres:16 + env: + POSTGRES_USER: postgres + POSTGRES_PASSWORD: postgres + POSTGRES_DB: alerttools_test + ports: + - 5432:5432 + options: >- + --health-cmd "pg_isready -U postgres -d alerttools_test" + --health-interval 10s + --health-timeout 5s + --health-retries 5 + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + ALERTTOOLS_TEST_POSTGRES: "true" + PGDATABASE: alerttools_test + PGHOST: 127.0.0.1 + PGPORT: 5432 + PGUSER: postgres + PGPASSWORD: postgres + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: release + use-public-rspm: true + extra-repositories: https://inla.r-inla-download.org/R/stable + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::devtools + needs: check + + - name: Run the complete suite against ephemeral PostgreSQL + run: Rscript -e 'devtools::test(stop_on_failure = TRUE)' + + coverage: + runs-on: ubuntu-latest + name: Coverage indicator (R release) + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: release + use-public-rspm: true + extra-repositories: https://inla.r-inla-download.org/R/stable + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr + needs: check + + - name: Measure package coverage + run: Rscript -e 'coverage <- covr::package_coverage(); print(coverage); saveRDS(coverage, "coverage.rds")' + + - uses: actions/upload-artifact@v4 + with: + name: coverage-rds + path: coverage.rds + + lint: + runs-on: ubuntu-latest + name: Static lint checks + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: release + use-public-rspm: true + extra-repositories: https://inla.r-inla-download.org/R/stable + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::lintr + needs: check + + - name: Lint package sources + run: Rscript -e 'lintr::lint_package()' + + migration-inventory: + runs-on: ubuntu-latest + name: Consumer migration inventory + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: release + + - name: Validate migration registry and removal gate inputs + run: Rscript tools/check-migration-readiness.R diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 0000000..24fa476 --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,43 @@ +name: pkgdown + +on: + workflow_dispatch: + inputs: + confirmation: + description: Type publish after maintainer validation + required: true + type: string + +permissions: + contents: write + +jobs: + build-and-publish: + if: github.event.inputs.confirmation == 'publish' + runs-on: ubuntu-latest + environment: pkgdown-production + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: release + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::pkgdown + needs: website + + - name: Build the site + run: Rscript -e 'pkgdown::build_site_github_pages(new_process = FALSE, install = TRUE)' + + - name: Publish the validated site + uses: JamesIves/github-pages-deploy-action@v4 + with: + branch: gh-pages + folder: pkgdown-site + clean: true diff --git a/.gitignore b/.gitignore index b349f2b..98dee0d 100644 --- a/.gitignore +++ b/.gitignore @@ -31,5 +31,7 @@ vignettes/*.pdf # Temporary files created by R markdown *.utf8.md *.knit.md +pkgdown-site/ +.DS_Store .Rproj.user .aider* diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..2cc494f --- /dev/null +++ b/.lintr @@ -0,0 +1,8 @@ +linters: list( + absolute_path_linter = absolute_path_linter(), + trailing_whitespace_linter = trailing_whitespace_linter(), + undesirable_function_linter = undesirable_function_linter( + fun = c("setwd" = "Do not change the caller's working directory.") + ) + ) +encoding: "UTF-8" diff --git a/AlertTools/.Rbuildignore b/AlertTools/.Rbuildignore deleted file mode 100755 index 91114bf..0000000 --- a/AlertTools/.Rbuildignore +++ /dev/null @@ -1,2 +0,0 @@ -^.*\.Rproj$ -^\.Rproj\.user$ diff --git a/AlertTools/.Rproj.user/B3A5F568/pcs/files-pane.pper b/AlertTools/.Rproj.user/B3A5F568/pcs/files-pane.pper deleted file mode 100755 index 9cfcda1..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/pcs/files-pane.pper +++ /dev/null @@ -1,13 +0,0 @@ -{ - "path" : "~/Documentos/AlertaDengueAnalise/AlertTools/tests/testthat", - "sortOrder" : [ - { - "ascending" : true, - "columnIndex" : 1 - }, - { - "ascending" : true, - "columnIndex" : 2 - } - ] -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/pcs/source-pane.pper b/AlertTools/.Rproj.user/B3A5F568/pcs/source-pane.pper deleted file mode 100755 index 84cf223..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/pcs/source-pane.pper +++ /dev/null @@ -1,3 +0,0 @@ -{ - "activeTab" : 5 -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/pcs/windowlayoutstate.pper b/AlertTools/.Rproj.user/B3A5F568/pcs/windowlayoutstate.pper deleted file mode 100755 index ea76316..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/pcs/windowlayoutstate.pper +++ /dev/null @@ -1,14 +0,0 @@ -{ - "left" : { - "panelheight" : 700, - "splitterpos" : 294, - "topwindowstate" : "NORMAL", - "windowheight" : 737 - }, - "right" : { - "panelheight" : 700, - "splitterpos" : 442, - "topwindowstate" : "NORMAL", - "windowheight" : 737 - } -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/pcs/workbench-pane.pper b/AlertTools/.Rproj.user/B3A5F568/pcs/workbench-pane.pper deleted file mode 100755 index bc9a124..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/pcs/workbench-pane.pper +++ /dev/null @@ -1,4 +0,0 @@ -{ - "TabSet1" : 2, - "TabSet2" : 1 -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/1D92B9DC b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/1D92B9DC deleted file mode 100755 index 32390ac..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/1D92B9DC +++ /dev/null @@ -1,3 +0,0 @@ -{ - "tempName" : "Untitled1" -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/1EB905B4 b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/1EB905B4 deleted file mode 100755 index 7a73a41..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/1EB905B4 +++ /dev/null @@ -1,2 +0,0 @@ -{ -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/5F431FF3 b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/5F431FF3 deleted file mode 100755 index 7a73a41..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/5F431FF3 +++ /dev/null @@ -1,2 +0,0 @@ -{ -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/7AC895AD b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/7AC895AD deleted file mode 100755 index 32390ac..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/7AC895AD +++ /dev/null @@ -1,3 +0,0 @@ -{ - "tempName" : "Untitled1" -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/7BC11AF9 b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/7BC11AF9 deleted file mode 100755 index 7a73a41..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/7BC11AF9 +++ /dev/null @@ -1,2 +0,0 @@ -{ -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/A5A32FB1 b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/A5A32FB1 deleted file mode 100755 index 7a73a41..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/A5A32FB1 +++ /dev/null @@ -1,2 +0,0 @@ -{ -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/ABF7713 b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/ABF7713 deleted file mode 100755 index 7a73a41..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/ABF7713 +++ /dev/null @@ -1,2 +0,0 @@ -{ -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/E027423A b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/E027423A deleted file mode 100755 index 7a73a41..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/E027423A +++ /dev/null @@ -1,2 +0,0 @@ -{ -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/F8B1DF b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/F8B1DF deleted file mode 100755 index 7a73a41..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/F8B1DF +++ /dev/null @@ -1,2 +0,0 @@ -{ -} \ No newline at end of file diff --git a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/INDEX b/AlertTools/.Rproj.user/B3A5F568/sdb/prop/INDEX deleted file mode 100755 index bd9b175..0000000 --- a/AlertTools/.Rproj.user/B3A5F568/sdb/prop/INDEX +++ /dev/null @@ -1,38 +0,0 @@ -%2Fmedia%2Fclaudia%2FKINGSTON%2FRtreino%2Fjurujuba%2Fscriptnovo.r="5F431FF3" -~%2FCopy%2FAlerta_Dengue%2Fanalises%2FRt%2FRt_varios.r="2B20E012" -~%2FCopy%2FAlerta_Dengue%2Fanalises%2FTG%2Fmodelagem_TG.rmd="52A76F64" -~%2FCopy%2FAlerta_Dengue%2Fanalises%2FforTrevor.r="40D0CFAA" -~%2FCopy%2FAlerta_Dengue%2Fdados%2Fdengue2013_09_01_2014%2FforTrevor.r="CE3DC6AF" -~%2FCopy%2FAlerta_Dengue%2Fdados%2Fdengue2013_09_01_2014%2Forganizadadosporbairro.r="9C283A77" -~%2FDocs_completo%2FR_Packages%2FAlertTools%2FR%2FgeraSeriesTemporais.r="7BC11AF9" -~%2FDocs_completo%2FR_Packages%2FAlertTools%2FR%2Fget_timeseries.R="1EB905B4" -~%2FDocs_completo%2FR_Packages%2FAlertTools%2FR%2Flog.txt="1D92B9DC" -~%2FDocs_completo%2FR_Packages%2FAlertTools%2FR%2Futility_tools.R="7AC895AD" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2FRt_functions.R="DEEDEBF7" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2Fadjust_incidence_functions.R="5F8FD898" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2Falert_functions.R="D7E1FC0C" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2Fget_timeseries.R="72A086EA" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2Flog.txt="FCED7A40" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2Freport.R="DC04F69" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2Freporttemplate.rmd="265F4E6C" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2FR%2Futility_tools.R="9E44C005" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Fdicas="9937C743" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Fmain.R="83674835" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Fmy-test.R="626124B9" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Ftests%2Ftestthat%2Ftest_alertfunctions.R="D2C1A922" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Ftests%2Ftestthat%2Ftest_getCases.R="7C69ADAD" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Ftests%2Ftestthat%2Ftest_timeseriespipeline.R="90F12290" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Ftests%2Ftestthat.R="AFD23ECF" -~%2FDocumentos%2FAlertaDengueAnalise%2FAlertTools%2Fvignettes%2Fmy-vignette.Rmd="E9784B15" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2Fatualiza_alerta.r="E027423A" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2Ffun%2FRt.r="906A4CF3" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2Ffun%2Fcorrigecasos.r="5F0BAA77" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2FgeraAlerta%2FgeraAlerta.r="F8B1DF" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2FgeraAlerta%2Frelatorio.rmd="AC0246C4" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2ForganizaDados%2FjuntaTudo.r="94D94490" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2ForganizaDados%2ForganizaTemperatura.r="ABF7713" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2ForganizaDados%2Forganizasinan.r="A5A32FB1" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2ForganizaDados%2Forganizatweets.r="CA306C12" -~%2FDocumentos%2FAlertaDengueAnalise%2FGeraAlerta%2Frelatorio.md="4C790A2B" -~%2FDropbox%2Ftempo%20gera%C3%A7%C3%A3o%20dengue%2Fmodelagem_TG.rmd="CB073DB4" -~%2FDropbox%2Ftempo%20gera%C3%A7%C3%A3o%20dengue%2Fmodelagem_TG_clean.rmd="6F8844FD" diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..b9d9f99 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,114 @@ +# Contribuindo com o AlertTools + +Obrigado por contribuir. Mudanças devem ser pequenas, reproduzíveis e preservar +os contratos epidemiológicos protegidos pelos testes. + +## Preparação do ambiente + +Com R e Git instalados, clone o repositório e execute na raiz do pacote: + +```r +install.packages("pak") +pak::pak() +devtools::load_all() +``` + +Dependências opcionais têm responsabilidades específicas: + +- `RSQLite`: integração local descartável; +- `RPostgres`: integração PostgreSQL e uso operacional; +- `INLA`: nowcasting bayesiano; +- `mem`: limiares MEM; +- `knitr`, `rmarkdown` e `pkgdown`: documentação e site; +- `covr`, `lintr` e `styler`: cobertura e qualidade estática. + +INLA usa o repositório adicional declarado no `DESCRIPTION`. Não torne INLA ou +MEM obrigatórios para quem usa somente o núcleo básico. + +## Fluxo de desenvolvimento + +1. Abra ou referencie uma issue com o comportamento esperado. +2. Crie um branch focado. +3. Adicione um teste de caracterização antes de mudar regra epidemiológica. +4. Implemente a menor alteração que satisfaça o contrato. +5. Atualize roxygen e `NEWS.md` quando houver efeito para usuários. +6. Execute testes, lint e check. +7. Abra um pull request descrevendo validação, riscos e impacto de migração. + +## Comandos locais + +```r +devtools::document() +devtools::test(stop_on_failure = TRUE) +lintr::lint_package() +devtools::check(error_on = "warning") +covr::package_coverage() +``` + +Para verificar as vignettes e o site: + +```r +devtools::build(vignettes = TRUE) +pkgdown::build_site(preview = FALSE, new_process = TRUE) +``` + +Os exemplos publicados também são executados por +`tests/testthat/test-documentation-examples.R`. + +Para uma mudança de migração ou depreciação: + +```sh +Rscript tools/check-migration-readiness.R +``` + +Atualize `docs/refactoring/consumer-registry.csv` no mesmo PR, incluindo +responsável, evidência, incompatibilidades e rollback. Use o template específico +de migração em `.github/PULL_REQUEST_TEMPLATE/consumer-migration.md`. + +## Estilo + +Execute `Rscript tools/style.R` somente em um branch ou commit dedicado a +formatação. Revise o diff e não misture alterações puramente de estilo com +mudanças funcionais. Arquivos legados fora do escopo do script serão formatados +gradualmente, para evitar diffs extensos sem ganho funcional. + +As regras automatizadas ficam em `.lintr`. Não desabilite uma regra apenas para +silenciar um caso; documente a exceção ou ajuste o código. + +## Bancos e dados sensíveis + +Testes não podem acessar produção, depender de `con` global ou gravar no +diretório de trabalho. Nunca registre credenciais ou dados de saúde +identificáveis. + +A suíte regular cria SQLite em memória. A integração PostgreSQL exige um banco +descartável chamado exatamente `alerttools_test`, com +`ALERTTOOLS_TEST_POSTGRES=true`. O helper recusa outro nome de banco e recria +somente os schemas dedicados ao teste. + +## Compatibilidade e ciência + +- Não remova wrappers depreciados sem a janela de suporte aprovada. +- Migre consumidores um por PR e mantenha a versão anterior implantável. +- Nos testes do consumidor, use `options(lifecycle_verbosity = "warning")` e + trate warnings remanescentes como evidência de migração incompleta. +- Atualize `vignettes/migrating-to-snake-case.Rmd` e a tabela de migração ao + alterar a API. +- Mudanças em calendário, nowcasting, Rt, MEM ou classificação exigem revisão + dos mantenedores de domínio. +- Mudanças de licença exigem decisão explícita dos mantenedores. + +## Pull request + +O PR deve informar: + +- problema e solução; +- testes adicionados ou atualizados; +- resultado de `R CMD check`; +- mudança de API ou schema; +- risco epidemiológico e necessidade de validação humana; +- plano de migração e rollback, quando aplicável. + +Consulte [docs/RELEASE.md](docs/RELEASE.md) para releases e +[docs/BRANCH_PROTECTION.md](docs/BRANCH_PROTECTION.md) para os controles que +dependem de autorização administrativa. diff --git a/DESCRIPTION b/DESCRIPTION index 46c669b..dd0744e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,29 +1,54 @@ Package: AlertTools Type: Package -Title: utility functions for the Infodengue Alert System -Version: 1.1.0 -Date: 2015-10-05 +Title: Utilities for the InfoDengue Alert System +Version: 1.2.0 Authors@R: person("Claudia", "Codeco", email="claudia.codeco@gmail.com", role = c("aut", "cre")) Maintainer: Claudia Codeco -Description: Set of functions to get data from the Infodengue Alert server, - organize into time series, correct the notification data, calculate alert - indices. Also includes utility functions to create reports and maps. -License: CCO +Description: Tools to retrieve and organize epidemiological and climate data, + adjust notification series, estimate epidemiological indicators, and + calculate alert levels used by the InfoDengue alert system. +License: file LICENSE Encoding: UTF-8 Imports: - foreign, - RPostgreSQL, - zoo, - knitr, + assertthat, + DBI, + dplyr, forecast, - tidyverse, + lifecycle, lubridate, - assertthat, + parallel, + plyr, + purrr, + stats, + stringr, + tibble, + tidyr, + utils, + zoo +Suggests: brpop, - parallel -VignetteBuilder: knitr + covr, + data.table, + INLA, + knitr, + lintr, + mem, + pkgdown, + RPostgres, + RSQLite, + rmarkdown, + styler, + testthat (>= 3.0.0), + withr +Additional_repositories: https://inla.r-inla-download.org/R/stable +Config/testthat/edition: 3 +Config/Needs/website: pkgdown +URL: https://github.com/AlertaDengue/AlertTools, + https://alertadengue.github.io/AlertTools/ +BugReports: https://github.com/AlertaDengue/AlertTools/issues RoxygenNote: 7.3.3 LazyData: true -Depends: +Depends: R (>= 3.5) +VignetteBuilder: knitr diff --git a/INSTRUCOES_AGENTE_REFATORACAO.md b/INSTRUCOES_AGENTE_REFATORACAO.md new file mode 100644 index 0000000..115951c --- /dev/null +++ b/INSTRUCOES_AGENTE_REFATORACAO.md @@ -0,0 +1,359 @@ +# Instruções para implementar o plano de refatoração do AlertTools + +Este documento orienta um agente de desenvolvimento a executar, seção por seção, o plano definido em [`plano_refatoracao_alerttools.qmd`](plano_refatoracao_alerttools.qmd). O plano original é a fonte de verdade para objetivos, arquitetura, nova API, compatibilidade, prioridades e definição de pronto. Estas instruções convertem esse conteúdo em um fluxo operacional verificável. + +## Missão do agente + +Refatorar o AlertTools incrementalmente no mesmo repositório, preservando o comportamento epidemiológico validado e mantendo a API legada por meio de wrappers até a versão principal prevista. O agente deve separar acesso a dados, cálculo, orquestração e persistência sem fazer uma reescrita integral. + +O trabalho deve avançar na ordem das fases 0 a 7. Não iniciar uma fase enquanto o critério de saída da fase anterior não estiver atendido ou enquanto um bloqueio não estiver explicitamente registrado e aceito pelos mantenedores. + +## Regras obrigatórias de execução + +1. Antes de editar, ler integralmente: + - `plano_refatoracao_alerttools.qmd`; + - `DESCRIPTION`, `NAMESPACE`, `.Rbuildignore` e `README.md`; + - os arquivos relevantes em `R/`, `tests/testthat/` e `man/`; + - instruções locais como `AGENTS.md`, caso existam. +2. Inspecionar `git status --short` antes de cada seção e preservar alterações preexistentes do usuário. +3. Tratar cada subseção deste documento como uma unidade de trabalho. Fazer alterações pequenas, coesas e revisáveis. +4. Antes de mudar comportamento, criar ou atualizar testes de caracterização que registrem o comportamento atual relevante. +5. Não corrigir silenciosamente uma divergência epidemiológica. Classificá-la como comportamento esperado, legado ou bug conhecido e solicitar validação de domínio quando necessário. +6. Não acessar o banco de produção em testes. Usar fixtures anonimizadas, banco temporário e, quando necessário, PostgreSQL efêmero em integração contínua. +7. Não criar conexão implícita nem depender de `con`, do diretório corrente, de variáveis globais ou do estado de uma sessão interativa. +8. Não remover, renomear ou alterar de modo incompatível uma função pública legada sem a etapa de wrapper e depreciação prevista na Fase 5. +9. Não editar `NAMESPACE` ou arquivos `.Rd` manualmente quando eles forem gerados por roxygen2. Alterar a documentação no código e regenerar os artefatos. +10. Usar chamadas qualificadas, como `DBI::dbGetQuery()`, ou imports seletivos. Não usar `library()` ou `require()` em `R/`. +11. Toda leitura deve ser livre de escrita. Todo cálculo deve operar em memória. Toda persistência deve ser explícita e transacional. +12. Execução paralela deve ser opcional, portável e sequencial por padrão, com `workers = 1`. +13. Não incluir segredos, credenciais, dados identificáveis ou dumps de produção no repositório, em fixtures ou logs. +14. Não criar commits, branches, releases ou publicar artefatos sem autorização expressa. + +## Ciclo obrigatório para cada seção + +Para cada seção de implementação: + +1. **Diagnosticar:** localizar código, testes, exports, documentação, dependências e consumidores internos afetados. +2. **Delimitar:** declarar quais arquivos e contratos serão alterados e quais ficarão fora do escopo. +3. **Proteger:** adicionar testes de caracterização ou regressão antes da mudança sempre que houver comportamento existente. +4. **Implementar:** realizar a menor alteração que cumpra a seção, mantendo compatibilidade. +5. **Documentar:** atualizar roxygen, README, vignettes, NEWS ou guia de migração conforme aplicável. +6. **Verificar:** executar primeiro testes focados, depois a suíte completa e os checks proporcionais ao impacto. +7. **Relatar:** registrar arquivos alterados, decisões, resultados dos comandos, riscos residuais e próximo passo. + +Se uma verificação falhar por causa preexistente, registrar evidência que diferencie a falha anterior de uma regressão introduzida. Não declarar a seção concluída enquanto houver regressão causada pelas alterações. + +## Comandos mínimos de verificação + +Adaptar os comandos ao ambiente, mas preservar esta progressão: + +```sh +Rscript -e 'testthat::test_file("tests/testthat/ARQUIVO_RELEVANTE.R")' +Rscript -e 'devtools::test()' +Rscript -e 'roxygen2::roxygenise()' +R CMD build . +R CMD check --no-manual AlertTools_*.tar.gz +``` + +Usar `devtools::document()` no lugar de `roxygen2::roxygenise()` se esse for o fluxo acordado pelo projeto. Antes de aceitar arquivos gerados, revisar o diff de `NAMESPACE` e `man/`. Não versionar diretórios `*.Rcheck`, tarballs ou outros artefatos locais de build. + +## Fase 0 — Descoberta e baseline + +### 0.1 Inventariar a API e os consumidores + +- Listar todos os símbolos exportados pelo `NAMESPACE` e associá-los aos respectivos arquivos, assinaturas e valores de retorno. +- Procurar no repositório chamadas internas às funções públicas e referências a `AlertTools::`, `library(AlertTools)` e `require(AlertTools)`. +- Com acesso autorizado, inventariar repositórios e scripts consumidores da organização. +- Criar uma tabela versionada contendo consumidor, função usada, argumentos relevantes, colunas consumidas, criticidade e responsável. +- Não presumir que a ausência de uso no repositório significa ausência de consumidor externo. + +**Entregável:** inventário da API e dos consumidores conhecidos. + +### 0.2 Criar fixtures representativas + +- Selecionar, com os responsáveis de domínio, municípios, doenças e períodos que cubram casos normais e limites relevantes. +- Criar fixtures anonimizadas de casos, clima, população, parâmetros e resultados. +- Incluir casos de borda: mudança de ano epidemiológico, semanas 52/53, dados ausentes, geocódigo de sete dígitos, séries curtas, duplicatas e valores extremos válidos. +- Manter fixtures pequenas, determinísticas e sem informações sensíveis. + +**Entregável:** fixtures autocontidas em `tests/testthat/fixtures/` ou estrutura equivalente documentada. + +### 0.3 Registrar o baseline + +- Executar os fluxos atuais com as fixtures e registrar resultados de referência. +- Preferir expectativas explícitas para schemas, classes, chaves e valores críticos; usar snapshots ou golden files apenas quando forem estáveis e revisáveis. +- Registrar tolerâncias numéricas justificadas para Rt, nowcasting e MEM. +- Classificar cada resultado como esperado, legado ou bug conhecido. +- Registrar também o baseline de `R CMD check`, incluindo errors, warnings e notes. + +**Gate da Fase 0:** comportamentos relevantes reproduzíveis sem banco de produção e consumidores conhecidos catalogados. Se faltarem validação de domínio, licença ou acesso a consumidores, registrar o bloqueio e solicitar decisão aos mantenedores. + +## Fase 1 — Saneamento do pacote + +### 1.1 Corrigir metadados e higiene do repositório + +- Atualizar título, descrição, autores, URLs e `BugReports` em `DESCRIPTION` com dados confirmados. +- Não decidir a licença tecnicamente. Solicitar confirmação dos mantenedores antes de alinhar `DESCRIPTION`, `LICENSE` e documentação. +- Remover `.Rproj.user` do versionamento e garantir sua exclusão futura. +- Excluir do versionamento apenas artefatos gerados confirmados, como `*.Rcheck` e tarballs, preservando arquivos do usuário que não pertençam à tarefa. +- Adicionar `Config/testthat/edition: 3`. +- Criar `NEWS.md`, `CONTRIBUTING.md` e, se aprovado, código de conduta. + +### 1.2 Corrigir dependências e namespace + +- Mapear cada chamada externa para `Imports`, `Suggests` ou remoção. +- Substituir o metapacote `tidyverse` por dependências específicas quando aplicável. +- Mover dependências opcionais e não-CRAN para `Suggests`, protegendo seu uso com verificação explícita. +- Remover `library()` e `require()` de `R/`. +- Qualificar chamadas ou adicionar `@importFrom` seletivo. +- Investigar e corrigir referências inválidas, incluindo `forecast::fitted`, sem mudar o resultado validado sem teste. + +### 1.3 Reparar documentação e dados + +- Corrigir tags roxygen para que argumentos documentados coincidam com as assinaturas. +- Tornar exemplos executáveis, autocontidos e independentes de `con`. +- Documentar datasets públicos ou internalizá-los quando não fizerem parte da API. +- Remover texto de template da documentação do pacote. +- Regenerar `NAMESPACE` e `man/` e revisar o diff. + +### 1.4 Configurar integração contínua + +- Adicionar workflow de `R CMD check` para os sistemas operacionais e versões R acordados. +- Separar dependências opcionais quando necessário para que a matriz permaneça confiável. +- Não mascarar warnings ou notes apenas para deixar a CI verde; corrigir a causa ou documentar uma exceção aceita. + +**Gate da Fase 1:** `R CMD check` termina com 0 errors, 0 warnings e 0 notes nos ambientes suportados. A confirmação jurídica da licença é um gate externo obrigatório para alterações de licença. + +## Fase 2 — Infraestrutura de testes + +### 2.1 Reorganizar a suíte + +- Dividir testes por responsabilidade, por exemplo `test-epiweek.R`, `test-alert-rules.R`, `test-fetch-cases.R` e `test-pipeline.R`. +- Colocar toda execução e expectativa dentro de `test_that()`. +- Remover `setwd()`, caminhos absolutos, `library()`, `require()` e dependência de objetos criados na sessão. +- Criar helpers apenas para preparação reutilizável; não esconder a intenção dos testes em abstrações excessivas. + +### 2.2 Cobrir contratos + +- Testar nomes e tipos de colunas, classes, chaves, ordenação, cardinalidade, valores ausentes e erros de validação. +- Separar testes unitários, de contrato, de integração, opcionais e de regressão. +- Testar explicitamente equivalência do comportamento protegido pelo baseline. +- Para funções estocásticas, fixar `seed` e documentar tolerâncias. + +### 2.3 Isolar infraestrutura + +- Usar um backend temporário para testes rápidos e PostgreSQL efêmero para semântica específica do banco. +- Criar e destruir schemas de teste de modo isolado, garantindo cleanup mesmo após falhas. +- Proteger testes de INLA, MEM e outras dependências opcionais com `skip_if_not_installed()` e condições documentadas. +- Medir cobertura como indicador; não perseguir percentual às custas de testes sem valor. + +**Gate da Fase 2:** suíte determinística executável por qualquer colaborador e pela CI, sem banco de produção, diretório corrente especial ou preparação manual da sessão. + +## Fase 3 — Camada de acesso a dados + +### 3.1 Definir a fronteira de dados + +- Criar funções internas de repositório para casos, registros individuais, clima, municípios, regiões, população, parâmetros e estações. +- Traduzir tabelas e colunas físicas para schemas de domínio estáveis dentro dessa camada. +- Centralizar configuração de schemas e tabelas sem codificar credenciais. +- Fazer `conn` obrigatório em toda função que acesse banco. + +### 3.2 Tornar SQL seguro e portável + +- Substituir interpolação por parâmetros vinculados. +- Usar `DBI::dbQuoteIdentifier()` para identificadores e `DBI::dbQuoteLiteral()` somente quando binding não for aplicável. +- Usar `DBI::dbGetQuery()` para leitura e `DBI::dbExecute()` para escrita. +- Evitar branches espalhados por classe concreta da conexão; encapsular diferenças inevitáveis do backend. +- Validar entradas antes de executar queries, incluindo geocódigos e intervalos de datas. + +### 3.3 Tornar escrita atômica e eficiente + +- Substituir inserts e updates linha a linha por operações em lote. +- Executar escrita em transação, com commit somente após sucesso completo e rollback garantido em falhas. +- Tornar a política de conflito explícita: `error`, `update` ou `ignore`. +- Testar falha parcial, rollback, idempotência e conflito. + +### 3.4 Remover estado global + +- Localizar todas as referências a `con`, inclusive valores default e chamadas internas que deixam de propagar a conexão. +- Propagar `conn` apenas pela camada que precisa de banco; remover conexão das funções computacionais. +- Adicionar testes que falhem se uma função depender de `con` no ambiente global. + +**Gate da Fase 3:** nenhum valor do usuário é concatenado diretamente em SQL; não há dependência de `con` global; toda operação de banco tem teste de integração; escrita é em lote, transacional e usa a função DBI apropriada. + +## Fase 4 — Núcleo epidemiológico puro + +### 4.1 Implementar calendário epidemiológico algorítmico + +- Formalizar com os especialistas a convenção epidemiológica usada pelo projeto. +- Implementar `as_epiweek()`, `epiweek_start()` e `epiweek_seq()` sem limite anual fixo. +- Usar a tabela `SE` existente temporariamente como fixture de equivalência. +- Testar viradas de ano, anos com semana 53, datas-limite e round trips. + +### 4.2 Extrair módulos computacionais + +- Separar normalização, incidência, nowcasting, Rt, MEM e classificação de alertas. +- Fazer cada função receber objetos em memória e retornar objetos em memória. +- Não permitir chamadas a DBI, leitura ou escrita de arquivos, `setwd()` ou objetos globais nesses módulos. +- Padronizar validações e mensagens de erro sem ocultar dados inválidos. + +### 4.3 Remover efeitos colaterais + +- Remover a escrita e leitura implícitas de `caselist.RData`. +- Fazer datas de referência, `seed`, `workers` e opções de verbosidade argumentos explícitos. +- Usar `workers = 1` por padrão, validar valores e fornecer fallback portável. +- Não alterar planos globais de paralelismo. + +### 4.4 Criar o objeto de resultado + +- Implementar a classe S3 `alerttools_result` com `data`, `alerts`, `parameters`, `metadata` e `diagnostics`. +- Validar invariantes no construtor. +- Implementar `print()`, `summary()` e `as.data.frame()`; implementar `plot()` apenas se houver requisito claro. +- Testar classe, estrutura, métodos e comportamento em entradas vazias ou inválidas. + +**Gate da Fase 4:** o pipeline computacional completo roda com fixtures em memória, de forma determinística, sem banco nem acesso ao diretório corrente. + +## Fase 5 — Nova API e compatibilidade + +### 5.1 Implementar a API em `snake_case` + +- Implementar as funções propostas no plano, começando pelas necessárias ao fluxo mínimo: `new_alert_inputs()`, `fetch_alert_inputs()`, `fetch_alert_parameters()`, `run_alert_pipeline()` e `write_alert_results()`. +- Em seguida implementar as funções específicas do mapeamento da API atual conforme necessidade comprovada. +- Usar consistentemente `conn`, `geocodes`, `start_date`, `end_date`, `start_week`, `report_week`, `disease`, `workers` e `verbose`. +- Documentar schema, classe, chaves e ordenação de todas as entradas e saídas públicas. +- Marcar funções ainda sujeitas a mudança como experimentais. + +### 5.2 Preservar a API legada + +- Converter cada função antiga em wrapper fino da nova API sempre que a equivalência for comprovada. +- Emitir aviso com `lifecycle::deprecate_warn()` e indicar a substituição. +- Preservar assinatura, defaults e forma de saída legada durante a janela de compatibilidade, adaptando internamente quando necessário. +- Não manter duas implementações independentes da mesma regra. + +### 5.3 Criar e testar a migração + +- Criar tabela de migração com função antiga/nova, argumentos, colunas, diferenças e versão de depreciação. +- Testar equivalência entre APIs para os cenários do baseline. +- Adicionar testes específicos dos wrappers, inclusive warnings e adaptação de argumentos. + +**Gate da Fase 5:** a nova API reproduz os resultados aprovados, a API antiga continua funcional por wrappers e as diferenças intencionais estão documentadas. + +## Fase 6 — Documentação e experiência de desenvolvimento + +### 6.1 Documentar o uso + +- Atualizar o README com instalação, requisitos e exemplo mínimo executável. +- Criar uma vignette do pipeline com banco e outra usando apenas dados em memória. +- Criar guia de migração da API antiga para a nova. +- Garantir que exemplos não dependam de credenciais, produção ou estado global. + +### 6.2 Documentar manutenção e release + +- Registrar como instalar dependências opcionais, executar testes, atualizar documentação e rodar checks. +- Documentar versionamento, depreciação, release candidata e release principal. +- Manter `NEWS.md` com alterações voltadas ao usuário. + +### 6.3 Automatizar qualidade e publicação + +- Configurar pkgdown e publicar somente após validação dos mantenedores. +- Adicionar badges de check e cobertura quando os respectivos serviços existirem. +- Configurar lintr e styler com regras aprovadas; separar mudanças puramente de estilo das mudanças funcionais. +- Configurar proteção do branch e revisão obrigatória apenas com autorização administrativa. + +**Gate da Fase 6:** uma pessoa nova consegue instalar, testar e executar o exemplo em memória seguindo apenas a documentação publicada. + +## Fase 7 — Migração e release principal + +### 7.1 Migrar consumidores + +- Atualizar cada consumidor catalogado, um por vez, com testes e plano de rollback próprios. +- Monitorar avisos de depreciação e registrar incompatibilidades reais. +- Corrigir problemas na nova API sem reintroduzir dependência global ou efeitos colaterais. + +### 7.2 Conduzir releases de transição + +- Seguir, salvo decisão posterior, a sequência: `1.1.1` para saneamento; `1.2.0` para camada de dados e API experimental; `1.3.0` para API estável e warnings; `1.4.x` para transição; `2.0.0` para remoções aprovadas. +- Publicar release candidata antes da versão principal. +- Definir e comunicar a janela de suporte da API antiga. + +### 7.3 Remover a API antiga com segurança + +- Remover wrappers somente após confirmação de que consumidores críticos migraram e de que a janela publicada terminou. +- Registrar cada remoção no `NEWS.md` e no guia de migração. +- Arquivar a documentação anterior sem apagar o histórico necessário aos usuários de versões antigas. + +**Gate da Fase 7:** consumidores críticos usam a nova API, não há depreciações relevantes em operação e a retirada dos wrappers não interrompe pipelines conhecidos. + +## Ordem de prioridade dentro das fases + +Quando houver escolha de tarefas, executar nesta ordem: + +1. **P0:** fixtures e testes de caracterização; `R CMD check` limpo; remoção de `con`; SQL parametrizado; remoção de arquivos temporários implícitos. +2. **P1:** núcleo puro; nova API e wrappers; CI multiplataforma. +3. **P2:** pkgdown, cobertura, lint e otimizações de desempenho. + +Não antecipar otimizações antes de estabilizar contratos e testes. Toda otimização deve incluir benchmark reproduzível e teste de equivalência. + +## Decisões que exigem participação humana + +O agente deve pausar o ponto afetado, continuar apenas em tarefas independentes e solicitar decisão quando houver: + +- confirmação ou mudança de licença; +- definição da convenção epidemiológica ou validação de resultados científicos; +- escolha de consumidores críticos e janela de depreciação; +- acesso a repositórios privados, dados, banco ou credenciais; +- alteração de infraestrutura externa, proteção de branch, publicação de site ou release; +- incompatibilidade que obrigue escolher entre preservar o legado e corrigir um bug. + +Na solicitação, apresentar evidências, opções, impacto e recomendação. Não escolher silenciosamente em nome dos mantenedores. + +## Formato do relatório ao concluir cada seção + +Usar este modelo: + +```md +## Seção concluída: + +### Resultado + + +### Alterações +- : + +### Verificações +- ``: passou/falhou +- Resultado do check: + +### Compatibilidade +- API: preservada/alterada +- Dados e resultados epidemiológicos: equivalentes/diferença aprovada + +### Pendências e riscos +- + +### Próxima seção recomendada + +``` + +## Checklist final da refatoração + +A tarefa completa somente pode ser declarada pronta quando todos os itens abaixo forem verdadeiros: + +- [ ] `R CMD check` tem 0 errors, 0 warnings e 0 notes. +- [ ] A CI cobre os sistemas e versões R acordados. +- [ ] Nenhuma função depende do objeto global `con`. +- [ ] Nenhuma função de cálculo acessa banco, arquivos ou diretório corrente. +- [ ] Todo SQL usa binding ou quoting seguro. +- [ ] Escritas são explícitas, em lote e transacionais. +- [ ] O núcleo executa integralmente com fixtures em memória. +- [ ] Schemas públicos estão documentados e testados. +- [ ] Paralelismo é explícito, portável e sequencial por padrão. +- [ ] A API antiga tem wrappers ou foi removida conforme a política publicada. +- [ ] Consumidores críticos foram migrados. +- [ ] README, vignettes, NEWS e guia de migração estão atualizados. +- [ ] Resultados epidemiológicos foram aprovados pelos responsáveis de domínio. +- [ ] Licença e metadados foram confirmados pelos mantenedores. + +## Instrução de início para o agente + +Comece sempre pela primeira seção ainda não concluída. Apresente o diagnóstico e o escopo da seção antes de editar. Ao final, execute as verificações aplicáveis, compare o resultado com o baseline e produza o relatório padronizado. Não avance para a seção seguinte se o gate atual não estiver satisfeito. diff --git a/NAMESPACE b/NAMESPACE index 0a9901b..ea78e77 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,14 +1,32 @@ # Generated by roxygen2: do not edit by hand +S3method(as.data.frame,alerttools_result) +S3method(print,alerttools_inputs) +S3method(print,alerttools_result) +S3method(summary,alerttools_result) export(Rt) export(SE2date) export(adjustIncidence) +export(alerttools_pipeline) +export(as_alert_history) +export(as_epiweek) export(bayesnowcasting) export(bestWU) +export(calculate_incidence) +export(classify_alerts) export(data2SE) export(daySEday) +export(define_alert_rules) export(epiYear) export(episem) +export(epiweek_seq) +export(epiweek_start) +export(estimate_rt) +export(fetch_alert_inputs) +export(fetch_alert_parameters) +export(fetch_case_records) +export(fetch_cases) +export(fetch_climate) export(fouralert) export(getCases) export(getCaseslist) @@ -24,9 +42,13 @@ export(infodengue_apply_mem) export(infodengue_apply_mem_agreg) export(mem_curve) export(nafill) +export(new_alert_inputs) +export(new_alerttools_result) +export(nowcast_cases) export(pipe_infodengue) export(read.cases) export(read.parameters) +export(run_alert_pipeline) export(seqSE) export(setCriteria) export(setWUstation) @@ -34,5 +56,52 @@ export(sevendigitgeocode) export(tabela_historico) export(tabela_historico_intra) export(temp.predict) +export(upsert_alert_parameters) +export(write_alert_results) export(write_alerta) export(write_parameters) +importFrom(assertthat,assert_that) +importFrom(dplyr,"%>%") +importFrom(dplyr,across) +importFrom(dplyr,all_of) +importFrom(dplyr,arrange) +importFrom(dplyr,bind_rows) +importFrom(dplyr,case_when) +importFrom(dplyr,filter) +importFrom(dplyr,full_join) +importFrom(dplyr,group_by) +importFrom(dplyr,join_by) +importFrom(dplyr,left_join) +importFrom(dplyr,mutate) +importFrom(dplyr,n) +importFrom(dplyr,rename) +importFrom(dplyr,select) +importFrom(dplyr,summarise) +importFrom(dplyr,summarize) +importFrom(graphics,legend) +importFrom(graphics,lines) +importFrom(purrr,map) +importFrom(purrr,transpose) +importFrom(stats,arima) +importFrom(stats,dnorm) +importFrom(stats,fitted) +importFrom(stats,lm) +importFrom(stats,median) +importFrom(stats,pbeta) +importFrom(stats,plnorm) +importFrom(stats,predict) +importFrom(stats,qbeta) +importFrom(stats,quantile) +importFrom(stats,rnbinom) +importFrom(stats,setNames) +importFrom(stringr,str_c) +importFrom(stringr,str_replace_all) +importFrom(tibble,rowid_to_column) +importFrom(tibble,tibble) +importFrom(tidyr,drop_na) +importFrom(tidyr,gather) +importFrom(tidyr,replace_na) +importFrom(tidyr,spread) +importFrom(utils,tail) +importFrom(zoo,na.approx) +importFrom(zoo,rollapply) diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 0000000..7661ee0 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,63 @@ +# AlertTools 1.2.0 + +## Refactoring baseline + +- Added an inventory of the legacy public API and internal consumers. +- Added synthetic fixtures and characterization tests for epidemiological + weeks, geocodes, Rt estimates, and alert classification. +- Began package metadata, dependency, documentation, and CI cleanup. +- Isolated all SQL behind an internal DBI repository with centralized physical + table mappings, bound values, quoted identifiers, and stable domain schemas. +- Removed fallback to a global `con`; database-backed public functions now + require an explicit `datasource` connection. +- Replaced row-at-a-time writes with transactional staging-table operations and + explicit `error`, `update`, and `ignore` conflict policies. +- Added integration coverage for cases, individual records, climate, + municipalities, regions, population, parameters, tweets, station links, + rollback, idempotency, and SQL-injection attempts. +- `tabela_historico()` and `tabela_historico_intra()` now receive model + parameters from their input attribute or an explicit `parameters` argument; + they no longer query a database during transformation. +- Added an algorithmic Sunday-to-Saturday epidemiological calendar through + `as_epiweek()`, `epiweek_start()`, and `epiweek_seq()`, without a fixed year + range. +- Added the pure in-memory `alerttools_pipeline()` and + `calculate_incidence()` computational entry points. +- Added the S3 `alerttools_result` contract and its `print()`, `summary()`, and + `as.data.frame()` methods. +- Removed the implicit `caselist.RData` write/read path; individual records are + now passed in memory. +- Nowcasting and generation-time computations default to one validated worker; + stochastic nowcasting accepts an explicit scoped seed and does not change the + caller's random state. +- Added the experimental `snake_case` workflow: `new_alert_inputs()`, + `fetch_alert_inputs()`, `fetch_alert_parameters()`, `run_alert_pipeline()`, + `as_alert_history()`, and `write_alert_results()`. +- Added focused readers and computational names including `fetch_cases()`, + `fetch_case_records()`, `fetch_climate()`, `estimate_rt()`, + `nowcast_cases()`, `define_alert_rules()`, and `classify_alerts()`. +- Legacy counterparts remain available as thin wrappers and emit staged + deprecation warnings through `lifecycle`. +- Added `upsert_alert_parameters()` for transactional parameter batches and a + migration table documenting functions, arguments, schemas, and intentional + differences. +- Reworked the README with installation requirements and executable examples + for both in-memory and database-backed workflows. +- Added reproducible in-memory and SQLite examples plus vignettes for both + workflows and a migration guide for the experimental `snake_case` API. +- Added a pkgdown site configuration and an explicitly manual publication + workflow guarded by a protected deployment environment. +- Documented contribution, semantic-versioning, deprecation, release-candidate, + production-release, rollback, and proposed branch-protection procedures. +- Added focused `lintr` rules, an opt-in `styler` script, documentation-example + tests, and a CI lint job. +- Catalogued known organizational consumers of the legacy API, including the + national pipeline, publishers, containers, intramunicipal routines, and + bulletins. +- Added a machine-checked migration registry, per-consumer validation and + rollback procedure, and a CI integrity gate that deliberately blocks legacy + API removal until critical consumers are validated and the approved support + window has elapsed. +- Documented the proposed transition releases and historical-documentation + retention policy; no wrapper, tag, or external release was removed or + published. diff --git a/R/AlertTools.R b/R/AlertTools.R index 8b13789..e754cd8 100755 --- a/R/AlertTools.R +++ b/R/AlertTools.R @@ -1 +1,40 @@ +#' AlertTools: utilities for the InfoDengue alert system +#' +#' AlertTools retrieves and organizes epidemiological and climate data, +#' adjusts notification series, estimates epidemiological indicators, and +#' calculates alert levels. Database access is isolated behind an internal DBI +#' repository, while computational functions operate on in-memory data frames. +#' +#' @keywords internal +#' @importFrom assertthat assert_that +#' @importFrom graphics legend lines +#' @importFrom dplyr "%>%" across all_of arrange bind_rows case_when filter full_join +#' group_by join_by left_join mutate n rename select summarise +#' summarize +#' @importFrom purrr map transpose +#' @importFrom stats arima dnorm fitted lm median pbeta plnorm predict +#' qbeta quantile rnbinom setNames +#' @importFrom stringr str_c str_replace_all +#' @importFrom tibble rowid_to_column tibble +#' @importFrom tidyr drop_na gather replace_na spread +#' @importFrom utils tail +#' @importFrom zoo na.approx rollapply +#' @aliases AlertTools-package +#' @name AlertTools +"_PACKAGE" +utils::globalVariables(c( + ".", "alerta", "ano_notif", "ano_sinpri", "cas_desc", "cas_lab", + "cas_prov", "casos", "Casos", "casos_est", "CID10", "cidade", + "classi_fin", "cotrue", "criterio", "cytrue", "data_dia", + "dataini", "Date", "Delay", "delay_epiweek", "dt_digita", + "dt_digita_epiweek", "dt_digita_epiyear", "dt_sin_pri", + "dt_sinpri_aux", "dt_sinpri_epiweek", "dt_sinpri_epiyear", + "dt_sinpri_week", "estacao", "Estacao_wu_estacao_id", "geocode", + "geocodigo", "level", "localidade", "mun", "municipio_geocodigo", + "Municipio_geocodigo", "nome", "numero", "p1", "pop", "populacao", + "pos", "pre", "se_notif", "se_sin_pri", "tcasesICmax", + "tcasesICmin", "tcasesmed", "temp_max", "temp_med", "temp_min", + "Time", "tweet", "umid_max", "umid_med", "umid_min", "veryhigh", + "write.parameters", "year" +)) diff --git a/R/Rt_functions.R b/R/Rt_functions.R index 6b756da..0017c65 100755 --- a/R/Rt_functions.R +++ b/R/Rt_functions.R @@ -5,20 +5,24 @@ #Rt ----------------------- -#'@description Calculates the effective reproductive number from the growth rate +#'@description Calculates the effective reproductive number from the growth rate #'of cases. Uses formula 4.2 in Wallinga and Lispitch (2007). Confidence interval assume -#'ratio between two Poissons (see Luis Max documentation). -#'@title Computes the effective reproductive number using alternative +#'ratio between two Poissons (see Luis Max documentation). +#'@title Computes the effective reproductive number using alternative #'distributions for the generation interval. -#'@param object a data.frame with variables "casos" and "SE", ideally from getCases(). -#'@param meangt if gtdist = "delta" it is the exact period between primary and +#'@param obj A data frame containing at least `SE` and the count column. +#'@param count Name of the case-count column in `obj`. +#'@param gtdist Generation-time distribution, either `"normal"` or `"delta"`. +#'@param meangt if gtdist = "delta" it is the exact period between primary and #'secondary infections). If gtdist = "normal", it is the mean generation time. -#'@param sdgt if gtdist = "normal", it is the standard deviation of the generation time +#'@param sdgt if gtdist = "normal", it is the standard deviation of the generation time #'distribution. -#'@param CI Model used to compute the confidence interval. Possible choice: "beta". -#'@export -#'@return data.frame with estimated Rt and confidence intervals. -#'@examples +#'@param CI Model used to compute the confidence interval. Possible choice: "beta". +#'@param alpha Confidence level. +#'@param a0,b0 Parameters of the beta prior. +#'@noRd +#'@return data.frame with estimated Rt and confidence intervals. +#'@examplesIf FALSE #'d <- getCases(cities = 3302205, lastday ="2018-03-10") # dengue #' # Rt original #'rt<-Rtoriginal(obj = d, count = "casos", meangt=3) @@ -36,51 +40,51 @@ #'lines(rtnorm$upr,lty = 3, col = 4) #'legend(30,3,c("original","delta","normal"),lty=1, col = c(1,3,4), cex = 0.7) -Rt<-function(obj, count = "casos", gtdist, meangt, sdgt, CI = "beta", alpha = .95, a0 = 2 , b0 = 3){ - - - if(!any(c(count,"SE") %in% names(obj))) stop("obj must be a data.frame with variables +.estimate_rt_impl <- function(obj, count = "casos", gtdist, meangt, sdgt, CI = "beta", alpha = .95, a0 = 2 , b0 = 3){ + + + if(!any(c(count,"SE") %in% names(obj))) stop("obj must be a data.frame with variables SE and var, at least. Consider using getCases") y <- obj[,count] le <- length(y) - if (le < 2*meangt) warning("you need a time series + if (le < 2*meangt) warning("you need a time series with size at least 2 generation intervals to estimate Rt") - + if (gtdist == "normal") ga <- rev(dnorm(x = 1:le, mean = meangt, sd = sdgt)) if (gtdist == "delta") { ga <- rep(0, le) ga[le - meangt] <- 1 } - + obj$Rt <- NA obj$lwr <- NA obj$upr <- NA obj$p1 <- NA - + for (t in ceiling(2*meangt):le){ num = y[t] deno = sum(y[1:t] * ga[(le-t+1):le]) # equation 4.1 in Wallinga and Lipsitch 2007 obj$Rt[t]<-num/deno if (CI == "beta"){ obj$p1[t] <- 1 - pbeta(.5, shape1 = num, shape2 = deno) - obj[t, c("lwr","upr")] <- ll(betaconf(alpha = alpha, x = num, + obj[t, c("lwr","upr")] <- ll(betaconf(alpha = alpha, x = num, n = num + deno, a = a0, b = b0 )) } } - + obj } ## obtain 100\lapha confidence/credibility intervals for the success probability \theta betaconf <- function(alpha = .95, x, n, a = 1, b = 1, CP = "FALSE"){ - if(CP=="TRUE"){ + if(CP=="TRUE"){ lower <- 1 - qbeta((1-alpha)/2, n + x - 1, x) upper <- 1 - qbeta((1+alpha)/2, n - x, x + 1) }else{ lower <- qbeta( (1-alpha)/2, a + x, b + n - x) - upper <- qbeta(( 1+alpha)/2, a + x, b + n - x) - } + upper <- qbeta(( 1+alpha)/2, a + x, b + n - x) + } return(c(lower, upper)) #CP stands for Clopper-Pearson #Default is 'Bayesian' with an uniform prior over p (a=b=1) @@ -93,10 +97,10 @@ ll <- function(x) {x/(1-x)} ################# NEW # Function for parameter in Extrinsic Incubation Period -lambdaEIP<-function(T,v=4.3,beta0=7.9,betat=-0.21,Tbar=0) v/exp(beta0+betat*(T-Tbar)) +lambdaEIP<-function(T,v=4.3,beta0=7.9,betat=-0.21,Tbar=0) v/exp(beta0+betat*(T-Tbar)) # Function for parameter in Intrinsic Incubation Period -lambdaIIP<-function(v=16,beta0=1.78) v/exp(beta0) +lambdaIIP<-function(v=16,beta0=1.78) v/exp(beta0) #GenTimeDist ----------------------------------------------------------------------- @@ -105,19 +109,30 @@ lambdaIIP<-function(v=16,beta0=1.78) v/exp(beta0) #' For details, see the reference Codeco et al (2018). #' @param serTemp : Temperature series #' @param GT.max : maximum number of weeks to consider for generation time -#' @param cid10 "A90" for dengue (default), "A92": chikungunya, "A92.8": zika. -#' @param smooth "sinusoidal" (default) or "raw" -#' @return matrix with generation time distributions per week, one row per week, one column per SE. +#' @param cid10 "A90" for dengue (default), "A92": chikungunya, "A92.8": zika. +#' @param smooth "sinusoidal" (default) or "raw" +#' @param workers Positive number of parallel workers; defaults to one. +#' @param nc Deprecated alias for `workers`. +#' @return matrix with generation time distributions per week, one row per week, one column per SE. #' @references Codeco et al (2018) https://doi.org/10.1016/j.epidem.2018.05.011 -#' @examples -#'cli = getWU(stations = 'SBGL', vars=c("temp_med"), datasource=con) %>% -#' mutate(temp_med = nafill(temp_med, rule = "arima")) +#' @examplesIf FALSE +#'cli = getWU(stations = 'SBGL', vars=c("temp_med"), datasource=connection) %>% +#' mutate(temp_med = nafill(temp_med, rule = "arima")) #'gt <- GenTimeDist(cli$temp_med[1:50]) #'contour(gt, ylab="time", xlab="generation time (week)") GenTimeDist <- function(serTemp, cid10 = "A90", GT.max = 10, - smooth = "sinusoidal", nc = 1){ - + smooth = "sinusoidal", workers = 1L, nc = workers){ + + if (!missing(nc)) workers <- nc + workers <- .validate_workers(workers) + if (!is.numeric(serTemp) || !length(serTemp) || any(!is.finite(serTemp))) { + stop("`serTemp` must be a non-empty finite numeric vector.", call. = FALSE) + } + if (!smooth %in% c("sinusoidal", "raw")) { + stop("`smooth` must be 'sinusoidal' or 'raw'.", call. = FALSE) + } + #disease-specific parameters -------------------- if (cid10 == "A90"){ # dengue par_a=c(16, 4.3, 1, 1) @@ -131,13 +146,10 @@ GenTimeDist <- function(serTemp, cid10 = "A90", GT.max = 10, par_a=c(16, 4.3, 1, 1) par_b=c(1/2.69821, 1/0.4623722, 1, 1) } - + Tmax = length(serTemp) tt = 1:Tmax - - if(any(is.na(serTemp))) { - message("temp must not contain NA. Use nafill()") - } + # raw temperature data or smoothed data? if(smooth == "sinusoidal"){ mod <- lm(serTemp ~ sin(2*pi/52*tt)+cos(2*pi/52*tt)) @@ -145,14 +157,19 @@ GenTimeDist <- function(serTemp, cid10 = "A90", GT.max = 10, } else { serie <- serTemp } - + # function calculates the distribution in a given week x evalGenTimeDist <- function(x, serT=serie, a=par_a, b=par_b) { mxx <- int_sum_gamma_T(1, a, b, Temp=serT[x:(Tmax+GT.max+1)], t=tt[x:(Tmax+GT.max+1)], max=GT.max, unitscale=7) mxx$pdf } # for all weeks... - gt <- parallel::mcmapply(evalGenTimeDist, tt, mc.cores=nc) + gt <- if (workers == 1L || .Platform$OS.type == "windows") { + vapply(tt, evalGenTimeDist, numeric(GT.max + 1L)) + } else { + parallel::mcmapply(evalGenTimeDist, tt, mc.cores = workers, + mc.preschedule = TRUE) + } class(gt) <- "generationtime" gt } @@ -161,54 +178,48 @@ GenTimeDist <- function(serTemp, cid10 = "A90", GT.max = 10, #applyGenTimeDist --------------------------------------------------------------- #' @title Calculate matrix of generation time distribution for cities in infodengue -#' @description Calculate the generation time for cities or from meteorological stations -#' @param cities : vector of geocodes +#' @description Calculate the generation time for cities or from meteorological stations +#' @param cities : vector of geocodes #' @param stations : vector of meteorological stations #' @param cid10 : "A90" for dengue, "A92" for chikungunya, "A92.8" for zika -#' @param ini : initial date (Date or epidemiological week) -#' @param end : final date (Date or epidemiological week) #' @param datasource : sql connection -#' @return list of generation time distributions matrices -#' @examples +#' @param ... Additional arguments passed to downstream helpers. +#' @return list of generation time distributions matrices +#' @examplesIf FALSE #'cid <- getCidades(uf="Rio de Janeiro")$municipio_geocodigo #'gt <- applyGenTimeDist(stations = c("SBGL","SBJR"), cid10 = "A90") #'system.time(gt <- applyGenTimeDist(cities = cid, cid10 = "A90")) -applyGenTimeDist <- function(cities, stations, cid10 = "A90", datasource = con,...){ - +applyGenTimeDist <- function(cities, stations, cid10 = "A90", datasource,...){ + #pars_table <- read.parameters(cities = cities, cid10 = cid10, datasource = datasource) - + # Look for the stations associated with the provided cities -------------------- - + if(missing(stations) & !missing(cities)){ - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - comando <- paste("SELECT id, nome_regional, municipio_geocodigo, codigo_estacao_wu, estacao_wu_sec from - \"Dengue_global\".regional_saude WHERE municipio_geocodigo IN (", sqlcity, - ")" , sep="") - city_table <- dbGetQuery(datasource,comando) - estacoes <- unique(c(city_table$estacao_wu_sec, city_table$codigo_estacao_wu)) + .db_validate_connection(datasource) + city_table <- .repo_regional_health(datasource, cities) + estacoes <- unique(c(city_table$estacao_wu_sec, city_table$codigo_estacao_wu)) } else if(!missing(stations) & missing(cities)){ estacoes <- stations } else if(!missing(stations) & !missing(cities)){ message("the function receives either cities or stations, not both") return(NULL) } - + # Reading the names of the meterological stations for each city print("usando dados de clima das estacoes:") print(estacoes) - + # Reading the meteorological data #print('Obtendo os dados de clima...') cliwu <- getWU(stations = estacoes, vars = "temp_med", datasource=datasource)%>% mutate(temp_med = nafill(temp_med, rule = "arima")) - + gt <- cliwu %>% split(.$estacao) %>% map(~GenTimeDist(.$temp_med)) - - - gt - } + gt + } diff --git a/R/adjust_incidence_functions.R b/R/adjust_incidence_functions.R index 411ab23..fc59005 100755 --- a/R/adjust_incidence_functions.R +++ b/R/adjust_incidence_functions.R @@ -8,115 +8,124 @@ #'@description This function estimate the time series of reported cases by adding #' the cases that will be reported in the future. #'@title Correct incidence data with notification delay (nowcasting). -#'@export -#'@param obj data.frame with crude weekly cases (not adjusted). This data.frame +#'@noRd +#'@param obj data.frame with crude weekly cases (not adjusted). This data.frame #'comes from the getCases function (if withdivision = FALSE), of getCases followed -#' by casesinlocality (if dataframe is available per bairro) +#' by casesinlocality (if dataframe is available per bairro) #' @param datas data.frame with notification data. Requires: municipio_geocodigo, -#' dt_sin_pro, dt_digita, dt_notific. +#' dt_sin_pro, dt_digita, dt_notific. #'@param method "bayesian" or "none". The later just repeats case values -#'@param pdig for the "fixedprob" method. It is a vector of probability of been +#'@param pdig for the "fixedprob" method. It is a vector of probability of been #'typed in the database up to 1, 2, 3, n, weeks after symptoms onset. DEPRECATED. #'@param Dmax for the "bayesian" method. Maximum number of weeks that is modeled -#'@param nyears for the "bayesian" method. Number of years of data used for fitting the model -#'@param safelimit if median estimate is larger than 'safelimit' times -#''sum(tail(cases, n=5))', nowcasting fails. -#'@param nowSE for the "bayesian" method. Epidemiological week to be considered +#'@param nyears for the "bayesian" method. Number of years of data used for fitting the model +#'@param safelimit if median estimate is larger than 'safelimit' times +#''sum(tail(cases, n=5))', nowcasting fails. +#'@param nowSE for the "bayesian" method. Epidemiological week to be considered #'for the nowcast. If NA, the maximum SE in obj is used. -#'@return data.frame with median and 95percent +#'@param datasource Database connection used by legacy adjustment methods. +#'@param seed Optional seed for stochastic Bayesian nowcasting. +#'@param workers Positive number of workers; defaults to portable serial execution. +#'@param verbose Whether to emit progress messages. +#'@param ... Additional arguments passed to the selected adjustment method. +#'@return data.frame with median and 95percent #'confidence interval for the predicted cases-to-be-notified -#'@examples +#'@examplesIf FALSE #'muns <- getCidades(uf = "Acre", regional = "Baixo Acre e Purus") #'t1 <- Sys.time() #'d <- getCases(cities = muns$municipio_geocodigo, dataini = "sinpri") #'d <- getCases(cities = 3302700, dataini = "sinpri") #'dd <- d[d$cidade == 1200401,] #'t1 <- Sys.time() -#'resfit0<-adjustIncidence(obj=dd, method = "bayesian", nowSE = 202414, -#'interation = TRUE, datasource = con) +#'resfit0<-adjustIncidence(obj=dd, method = "bayesian", nowSE = 202414, +#'interation = TRUE, datasource = connection) #'t2 <- Sys.time() #'message(paste("total time was", t2-t1)) #'# Using argument 'datas' is good to save time with dataset access #'t1 <- Sys.time() -#'load("caselist.RData") # output of getCases -#'resfit<-adjustIncidence(obj=dd, datas = caselist, method = "bayesian", -#'nowSE = 202414,datasource = con) +#'resfit<-adjustIncidence(obj=dd, datas = caselist, method = "bayesian", +#'nowSE = 202414,datasource = connection) #'t2 <- Sys.time() -adjustIncidence<-function(obj, datas, method = "none", pdig = plnorm((1:20)*7, 2.5016, 1.1013), - Dmax=10, nyears = 2, datasource = con, nowSE, safelimit = 5,...){ - city <- unique(obj$cidade) +.nowcast_cases_impl <- function(obj, datas = NULL, method = "none", + pdig = plnorm((1:20)*7, 2.5016, 1.1013), + Dmax = 10, nyears = 2, datasource = NULL, nowSE, + safelimit = 5, seed = NULL, workers = 1L, + verbose = FALSE, ...) { + workers <- .validate_workers(workers) + if (!method %in% c("none", "bayesian")) { + stop("adjustIncidence: method must be 'none' or 'bayesian'.", call. = FALSE) + } + inform <- function(...) if (isTRUE(verbose)) message(...) + city <- unique(obj$cidade) cid <- obj$CID10[1] # checking if only one city in obj - assert_that(length(city) == 1, + assert_that(length(city) == 1, msg = "adjustIncidence only works for one city at a time.") - le = nrow(obj) - + le = nrow(obj) + # checking date if(missing(nowSE)) { stop("adjustIncidence: nowSE must be provided") } # last date in the input object else{ - assert_that(nowSE <= max(obj$SE), + assert_that(nowSE <= max(obj$SE), msg = "adjustIncidence: lastSE larger than max(obj$SE). Check input.") obj <- subset(obj, SE <= nowSE) # assigned input } - + obj$tcasesICmin <- obj$casos obj$tcasesmed <- obj$casos obj$tcasesICmax <- obj$casos - - if(sum(tail(obj$casos, n = 52), na.rm = TRUE) <= 50 | + + if(sum(tail(obj$casos, n = 52), na.rm = TRUE) <= 50 | sum(tail(obj$casos, n = 5), na.rm = TRUE) <= 5){ - message("less than 50 cases in the last 12 months or less than 5 cases - in the last month. Nowcasting not done") + inform("less than 50 cases in the last 12 months or less than 5 cases in the last month. Nowcasting not done") return(obj) - } - + } + if (method == "bayesian"){ - message(paste("computing nowcasting for city ",city," date ",nowSE, "...")) - nowday <- SE2date(nowSE)$ini + 6 - if(missing(datas)){ - dados <- getdelaydata(cities=city, nyears = nyears, cid10 = cid, - lastday = nowday, datasource = datasource) - }else{ - dados <- datas %>% filter(municipio_geocodigo == city) - assert_that(dim(dados)[1] > 0, msg="adjustIncidence: city not in dataset") + inform(paste("computing nowcasting for city", city, "date", nowSE, "...")) + if (is.null(datas)) { + stop("adjustIncidence: Bayesian nowcasting requires in-memory `datas`.", + call. = FALSE) } - resfit<-bayesnowcasting(dados, Dmax = Dmax, nowSE = nowSE) - + dados <- datas %>% filter(municipio_geocodigo == city) + assert_that(dim(dados)[1] > 0, msg="adjustIncidence: city not in dataset") + resfit <- bayesnowcasting(dados, Dmax = Dmax, nowSE = nowSE, + seed = seed, workers = workers, verbose = verbose) + # checking estimates if(!is.null(resfit)){ - if(tail(resfit$Median, n = 1) > + if(tail(resfit$Median, n = 1) > safelimit * sum(tail(obj$casos, n = 5),na.rm = TRUE)){ - message("nowcast estimate is too large, returning the original count.") + inform("nowcast estimate is too large, returning the original count.") } else { - if(tail(resfit$LS, n = 1) > + if(tail(resfit$LS, n = 1) > 10 * safelimit * sum(tail(obj$casos, n = 5),na.rm = TRUE)){ - message("upper limit nowcasting too large, returning t_cases_max = NA") + inform("upper limit nowcasting too large, returning t_cases_max = NA") resfit$LS <- NA expl <- which(resfit$LS > 10000) # check if any LS was too big resfit$LS[expl] <- NA - message("upper limit nowcarting too large in some dates, - returning t_cases_max = NA") + inform("upper limit nowcasting too large in some dates, returning t_cases_max = NA") } - message("bayesnowcasting done") + inform("bayesnowcasting done") # adding to the alert data obj - + for(se in resfit$SE) { rse <- which(resfit$SE == se) - obj[obj$SE == se, c("tcasesICmin", "tcasesmed", "tcasesICmax")] <- - c(resfit$LI[rse], resfit$Median[rse], resfit$LS[rse]) + obj[obj$SE == se, c("tcasesICmin", "tcasesmed", "tcasesICmax")] <- + c(resfit$LI[rse], resfit$Median[rse], resfit$LS[rse]) } } - - } else {message("nowcasting failed, returning the original count")} - } - - if(method=="none") message("nowcasting not done, returning the original counts") - + + } else {inform("nowcasting failed, returning the original count")} + } + + if(method=="none") inform("nowcasting not done, returning the original counts") + obj } @@ -125,169 +134,177 @@ adjustIncidence<-function(obj, datas, method = "none", pdig = plnorm((1:20)*7, 2 #'@description This function estimate the Bayesian nowcast (new version) #'@title Correct incidence data with notification delay (nowcasting). #'@export -#'@param obj data.frame with individual cases, containing columns municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita +#'@param d data.frame with individual cases, containing columns municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita #'@param Dmax for the "bayesian" method. Maximum number of weeks that is nowcasted #'@param nweeks number of weeks used for model calibration, default is 50. -#'@param nowSE week of the nowcasting (ex. 202110). +#'@param nowSE week of the nowcasting (ex. 202110). #'@param interacao TRUE (default) to include in the model the delay-time interaction term #'@param tweet FALSE (default). TRUE to include tweet in the model -#'@return data.frame with median and 95percent confidence interval for the +#'@param seed Optional seed for posterior and predictive sampling. +#'@param workers Positive number of workers used by INLA. +#'@param verbose Whether to emit progress messages. +#'@return data.frame with median and 95percent confidence interval for the #'predicted cases-to-be-notified) -#'@examples -#'dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", -#'lastday = as.Date("2024-03-23"), datasource=con) # Not run without connection +#'@examplesIf FALSE +#'dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", +#'lastday = as.Date("2024-03-23"), datasource=connection) # Not run without connection #'resfitcIsT<-bayesnowcasting(dados, nowSE = 202412) -bayesnowcasting <- function(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, tweet = F){ - - # check input +bayesnowcasting <- function(d, Dmax = 10, nowSE, nweeks = 50, + interacao = FALSE, tweet = FALSE, seed = NULL, + workers = 1L, verbose = FALSE){ + + workers <- .validate_workers(workers) + inform <- function(...) if (isTRUE(verbose)) message(...) + + # check input if(is.null(names(d))) { - message("bayesnowcasting: no data, returning NULL") - return(NULL)} - + inform("bayesnowcasting: no data, returning NULL") + return(NULL)} + if(nrow(d) < 50) { - message("bayesnowcasting: few data, returning NULL") - return(NULL)} - + inform("bayesnowcasting: few data, returning NULL") + return(NULL)} + if(missing(nowSE)) stop("bayesnowcasting requires definition of nowcast week ") - + #check if d contains required columns assert_that(all(c("municipio_geocodigo", "dt_notific", "dt_sin_pri", "dt_digita") %in% names(d)), msg = "bayesnowcasting requires data with columns municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita") - # remove cases with wrong dt_sin_pri + # remove cases with wrong dt_sin_pri # this condition must be equal in the getCases function - + d$ininotif <- d$dt_notific - d$dt_sin_pri - wrongdates <- which(d$ininotif > 365 | d$ininotif < 0 | is.na(d$dt_sin_pri)) + wrongdates <- which(d$ininotif > 365 | d$ininotif < 0 | is.na(d$dt_sin_pri)) if(length(wrongdates) > 0) { - message(paste(length(wrongdates), "registros com datas de inicio de sintomas invalidas")) + inform(paste(length(wrongdates), "registros com datas de inicio de sintomas invalidas")) d <- d[-wrongdates,] - } - - # defining time period + } + + # defining time period # termino da semana nowcasted - Fim <- SE2date(nowSE)$ini + 6 # soma 6 para obter sabado (fim da semana) - Inicio <- Fim - nweeks * 7 - + Fim <- SE2date(nowSE)$ini + 6 # soma 6 para obter sabado (fim da semana) + Inicio <- Fim - nweeks * 7 + # removing those cases with onset prior to Inicio d <- d[-(which(d$dt_sin_pri < Inicio)),] - - + + # checking again if(is.null(names(d))) { - message("bayesnowcasting: no valid data, returning NULL") - return(NULL)} - + inform("bayesnowcasting: no valid data, returning NULL") + return(NULL)} + if(nrow(d) < 50) { - message("bayesnowcasting: few valid data, returning NULL") - return(NULL)} - - message(paste("nowcast will be calibrated with ", nrow(d), "cases")) - - ## getting tweet data + inform("bayesnowcasting: few valid data, returning NULL") + return(NULL)} + + inform(paste("nowcast will be calibrated with", nrow(d), "cases")) + + ## getting tweet data # if(tweet == TRUE){ - # tw <- getTweet(cities = unique(d$municipio_geocodigo), + # tw <- getTweet(cities = unique(d$municipio_geocodigo), # lastday = SE2date(nowSE)$ini) # tw <- tw %>% # mutate(dt_iniweek = SE2date(SE)$ini + 6) %>% # filter(dt_iniweek > min(d$dt_sinpri_week)) # } - # + # # nowcasting d <- d %>% mutate( - dt_sinpri_epiweek = epiweek(dt_sin_pri), # se da data sinpri + dt_sinpri_epiweek = lubridate::epiweek(dt_sin_pri), # se da data sinpri dt_sinpri_aux = as.numeric(format(as.Date(dt_sin_pri), "%w")), # dia da semana (0 = sunday) dt_sinpri_week = dt_sin_pri + 3 - dt_sinpri_aux, # colocar centrado na quarta da SE (formula y = -aux+3) - dt_sinpri_epiyear = epiyear(dt_sin_pri), + dt_sinpri_epiyear = lubridate::epiyear(dt_sin_pri), dt_sinpri_SE = dt_sinpri_epiyear*100 + dt_sinpri_epiweek, - dt_digita_epiweek = epiweek(dt_digita), - dt_digita_epiyear = epiyear(dt_digita), + dt_digita_epiweek = lubridate::epiweek(dt_digita), + dt_digita_epiyear = lubridate::epiyear(dt_digita), dt_digita_SE = dt_digita_epiyear*100 + dt_digita_epiweek, delay_epiweek = ifelse( dt_digita_epiyear == dt_sinpri_epiyear, as.numeric(dt_digita_epiweek - dt_sinpri_epiweek), - as.numeric(dt_digita_epiweek - dt_sinpri_epiweek) + + as.numeric(dt_digita_epiweek - dt_sinpri_epiweek) + 52 * (dt_digita_epiyear - dt_sinpri_epiyear) ) - ) - + ) + # casos observados por semama obs <- d %>% group_by(dt_sinpri_week) %>% summarize(casos = n()) - - - + + + # contruindo a matriz de atraso - running triang - tem que ser quarta. - Fim_now <- SE2date(nowSE)$ini + 3 # soma 3 para obter quarta (meio da semana) - Ini_now <- Fim_now - nweeks * 7 - tibble(Date = c(Ini_now,Fim_now) ) %>% + Fim_now <- SE2date(nowSE)$ini + 3 # soma 3 para obter quarta (meio da semana) + Ini_now <- Fim_now - nweeks * 7 + tibble(Date = c(Ini_now,Fim_now) ) %>% mutate(Weekday = weekdays(Date) ) - - tbl.dates <- tibble(dt_sinpri_week = seq(Ini_now, Fim_now, by = 7)) %>% + + tbl.dates <- tibble(dt_sinpri_week = seq(Ini_now, Fim_now, by = 7)) %>% rowid_to_column(var = "Time") Today <- max(tbl.dates$Time) # running time - - dados.ag <- d %>% - filter( dt_digita <= Fim & dt_digita >= Ini_now) %>% + + dados.ag <- d %>% + filter( dt_digita <= Fim & dt_digita >= Ini_now) %>% mutate( delay_epiweek = ifelse(delay_epiweek > Dmax, NA, delay_epiweek) - ) %>% + ) %>% drop_na(delay_epiweek) %>% # discard cases with delay > 10 weeks - group_by(dt_sinpri_week, delay_epiweek) %>% + group_by(dt_sinpri_week, delay_epiweek) %>% dplyr::summarise( Casos = n() ) %>% # View() # Passando para o formato wide spread(key = delay_epiweek, value = Casos) %>% # View() # Adicianoando todas as data, algumas semanas nao houveram casos - full_join( - y = tbl.dates, - by = "dt_sinpri_week" ) %>% # View() + full_join( + y = tbl.dates, + by = "dt_sinpri_week" ) %>% # View() # Voltando para o formato longo gather(key = "Delay", value = Casos, -dt_sinpri_week, -Time) %>% # View() mutate( Delay = as.numeric(Delay), # Preparing the run-off triangle - Casos = ifelse( - test = (Time + Delay) <= Today, - yes = replace_na(Casos, 0), + Casos = ifelse( + test = (Time + Delay) <= Today, + yes = replace_na(Casos, 0), no = NA) ) %>% #View() - dplyr::rename( Date = dt_sinpri_week) %>% #ungroup() %>% + dplyr::rename( Date = dt_sinpri_week) %>% #ungroup() %>% # Sorting by date - dplyr::arrange(Date) - - + dplyr::arrange(Date) + + ## Juntando tweet (se tweet == TRUE) # if (tweet == TRUE){ - # dados.ag <- dados.ag %>% + # dados.ag <- dados.ag %>% # left_join(tw[,c(3,4)], by = c("Date" = "dt_iniweek" )) %>% # mutate(tweet = replace_na(tweet, 0)) # } - + # nao vi esse obj sendo usado - # dados.ag.full <- d %>% - # group_by(dt_sinpri_week) %>% + # dados.ag.full <- d %>% + # group_by(dt_sinpri_week) %>% # dplyr::summarise( # Total = n() # ) %>% # View() # # Adicianoando todas as data, algumas semanas nao houveram casos - # right_join( - # y = tbl.dates, - # by = "dt_sinpri_week" ) %>% # View() + # right_join( + # y = tbl.dates, + # by = "dt_sinpri_week" ) %>% # View() # mutate( # Total = replace_na(Total, 0) # ) %>% # View() - # dplyr::rename( Date = dt_sinpri_week) %>% #ungroup() %>% + # dplyr::rename( Date = dt_sinpri_week) %>% #ungroup() %>% # # Sorting by date - # dplyr::arrange(Date) - # - + # dplyr::arrange(Date) + # + # Model equations (4 possibilities) if(interacao & !tweet) { - model.dengue <- Casos ~ 1 + + model.dengue <- Casos ~ 1 + f(Time, model = "rw2", constr = T #hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) #hyper = list("prec" = list(prior = half_normal_sd(.1) )) @@ -295,15 +312,15 @@ bayesnowcasting <- function(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, f(Delay, model = "rw1", constr = T # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) #hyper = list("prec" = list(prior = half_normal_sd(.1) )) - ) + + ) + # Efeito tempo-atraso f(TimeDelay, model = "iid", constr = T # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) ) - } - + } + if(!interacao & !tweet) { #default - model.dengue <- Casos ~ 1 + + model.dengue <- Casos ~ 1 + f(Time, model = "rw2", constr = T #hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) #hyper = list("prec" = list(prior = half_normal_sd(.1) )) @@ -314,7 +331,7 @@ bayesnowcasting <- function(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, ) # message("modelo de nowcasting sem interacao") } - + if(interacao & tweet) { model.dengue <- Casos ~ 1 + tweet + f(Time, model = "rw2", constr = T @@ -324,15 +341,15 @@ bayesnowcasting <- function(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, f(Delay, model = "rw1", constr = T # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) #hyper = list("prec" = list(prior = half_normal_sd(.1) )) - ) + + ) + # Efeito tempo-atraso f(TimeDelay, model = "iid", constr = T # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) ) - } - + } + if(!interacao & tweet) { - model.dengue <- Casos ~ 1 + tweet + + model.dengue <- Casos ~ 1 + tweet + f(Time, model = "rw2", constr = T #hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) #hyper = list("prec" = list(prior = half_normal_sd(.1) )) @@ -343,187 +360,38 @@ bayesnowcasting <- function(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, ) # message("modelo de nowcasting sem interacao") } - + output.dengue <- nowcast.INLA( - model.day = model.dengue, + model.day = model.dengue, dados.ag = dados.ag %>% - mutate(TimeDelay = paste(Time, Delay)) + mutate(TimeDelay = paste(Time, Delay)), + workers = workers, + verbose = verbose ) - + # we could save other features, like prob greater threshold - pred.dengue <- nowcasting(output.dengue, dados.ag, - Dm = Dmax, Fim = Fim) # max(dados.ag$Date)) - - - pred.dengue.summy <- pred.dengue %>% group_by(Date) %>% + pred.dengue <- nowcasting(output.dengue, dados.ag, + Dm = Dmax, Fim = Fim, seed = seed) # max(dados.ag$Date)) + + + pred.dengue.summy <- pred.dengue %>% group_by(Date) %>% dplyr::summarise( Mean = mean(Casos, na.rm = TRUE), - Median = median(Casos, na.rm = TRUE), + Median = median(Casos, na.rm = TRUE), LI = quantile(Casos, probs = 0.025, na.rm = TRUE), LS = quantile(Casos, probs = 0.975, na.rm = TRUE) ) %>% - left_join(obs, by = c("Date" = "dt_sinpri_week")) - + left_join(obs, by = c("Date" = "dt_sinpri_week")) + pred.dengue.summy$SE <- daySEday(pred.dengue.summy$Date)$SE - + pred.dengue.summy } -#' # bayesnowcasting --------------------------------------------------------------------- -#' #'@description This function estimate the Bayesian nowcast (new version) -#' #'@title Correct incidence data with notification delay (nowcasting). -#' #'@export -#' #'@param obj data.frame with individual cases, containing columns municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita -#' #'@param Dmax for the "bayesian" method. Maximum number of weeks that is modeled -#' #'@param Fim date for the nowcasting (date). Default is today. -#' #'@return data.frame with median and 95percent confidence interval for the -#' #'predicted cases-to-be-notified) -#' #'@examples -#' #' # bayesian -#' #'dd <- getdelaydata(cities=3167202, nyears=1, cid10="A90", datasource=con) -#' #'resfit<-bayesnowcasting(dd) -#' #'resfit -#' -#' bayesnowcasting <- function(d, Dmax = 10, Fim = Sys.Date()){ -#' -#' # check input -#' if(is.null(names(d))) { -#' message("bayesnowcasting: no data, returning NULL") -#' return(NULL)} -#' -#' if(nrow(d) < 50) { -#' message("bayesnowcasting: few data, returning NULL") -#' return(NULL)} -#' -#' -#' #d contains columns -#' assert_that(all(c("municipio_geocodigo", "dt_notific", "dt_sin_pri", "dt_digita") -#' %in% names(d)), msg = "bayesnowcasting requires data with columns -#' municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita") -#' -#' d <- d %>% mutate( -#' dt_notific_epiweek = epiweek(dt_notific), -#' dt_notific_aux = as.numeric(format(as.Date(dt_notific), "%w")), -#' dt_notific_week = dt_notific + 6 - dt_notific_aux, -#' dt_notific_epiyear = epiyear(dt_notific), -#' dt_digita_epiweek = epiweek(dt_digita), -#' dt_digita_epiyear = epiyear(dt_digita), -#' delay_epiweek = ifelse( dt_digita_epiyear == dt_notific_epiyear, -#' as.numeric(dt_digita_epiweek - dt_notific_epiweek), -#' as.numeric(dt_digita_epiweek - dt_notific_epiweek) + 52 -#' ) -#' ) -#' -#' # casos observados por semama -#' obs <- d %>% -#' group_by(dt_notific_week) %>% -#' summarize(casos = n()) -#' -#' Inicio <- min(d$dt_notific_week) -#' # Ultimo dia com notificacao ou digitacao -#' #Fim <- max(d$dt_digita, d$dt_notific, na.rm = T) -#' #Fim <- max(d$dt_digita, d$dt_notific, na.rm = T) -#' #Fim <- Fim + 6 - as.numeric(format(as.Date(Fim), "%w")) # why? -#' -#' # contruindo a matriz de atraso - running triang -#' tibble(Date = c(Inicio,Fim) ) %>% -#' mutate(Weekday = weekdays(Date) ) -#' -#' tbl.dates <- tibble(dt_notific_week = seq(Inicio, Fim, by = 7)) %>% -#' rowid_to_column(var = "Time") -#' Today = max(tbl.dates$Time) -#' -#' dados.ag <- d %>% -#' filter( dt_digita <= Fim) %>% -#' mutate( -#' delay_epiweek = ifelse(delay_epiweek > Dmax, NA, delay_epiweek) -#' ) %>% -#' drop_na(delay_epiweek) %>% -#' group_by(dt_notific_week, delay_epiweek) %>% -#' dplyr::summarise( -#' Casos = n() -#' ) %>% # View() -#' # Passando para o formato wide -#' spread(key = delay_epiweek, value = Casos) %>% # View() -#' # Adicianoando todas as data, algumas semanas nao houveram casos -#' full_join( -#' y = tbl.dates, -#' by = "dt_notific_week" ) %>% # View() -#' # Voltando para o formato longo -#' gather(key = "Delay", value = Casos, -dt_notific_week, -Time) %>% # View() -#' mutate( -#' Delay = as.numeric(Delay), -#' # Preparing the run-off triangle -#' Casos = ifelse( -#' test = (Time + Delay) <= Today, -#' yes = replace_na(Casos, 0), -#' no = NA) -#' ) %>% #View() -#' dplyr::rename( Date = dt_notific_week) %>% #ungroup() %>% -#' # Sorting by date -#' dplyr::arrange(Date) -#' -#' -#' dados.ag.full <- d %>% -#' group_by(dt_notific_week) %>% -#' dplyr::summarise( -#' Total = n() -#' ) %>% # View() -#' # Adicianoando todas as data, algumas semanas nao houveram casos -#' right_join( -#' y = tbl.dates, -#' by = "dt_notific_week" ) %>% # View() -#' mutate( -#' Total = replace_na(Total, 0) -#' ) %>% # View() -#' dplyr::rename( Date = dt_notific_week) %>% #ungroup() %>% -#' # Sorting by date -#' dplyr::arrange(Date) -#' -#' # Model equation -#' model.dengue <- Casos ~ 1 + -#' f(Time, model = "rw2", constr = T -#' #hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) -#' #hyper = list("prec" = list(prior = half_normal_sd(.1) )) -#' ) + -#' f(Delay, model = "rw1", constr = T -#' # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) -#' #hyper = list("prec" = list(prior = half_normal_sd(.1) )) -#' ) + -#' # Efeito tempo-atraso -#' f(TimeDelay, model = "iid", constr = T -#' # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) -#' ) -#' -#' -#' output.dengue <- nowcast.INLA( -#' model.day = model.dengue, -#' dados.ag = dados.ag %>% -#' mutate(TimeDelay = paste(Time, Delay)) -#' ) -#' -#' pred.dengue <- nowcasting(output.dengue, dados.ag, -#' Dm = Dmax, Fim = max(dados.ag$Date)) -#' -#' -#' pred.dengue.summy <- pred.dengue %>% group_by(Date) %>% -#' dplyr::summarise( Mean = mean(Casos, na.rm = TRUE), -#' Median = median(Casos, na.rm = TRUE), -#' LI = quantile(Casos, probs = 0.025, na.rm = TRUE), -#' LS = quantile(Casos, probs = 0.975, na.rm = TRUE) -#' ) %>% -#' left_join(obs, by = c("Date" = "dt_notific_week")) -#' -#' pred.dengue.summy$SE <- daySEday(pred.dengue.summy$Date)$SE -#' -#' pred.dengue.summy -#' } -#' - # getdelaydata ------------------------------------------------------------------ #'@description Gets delay data for one or more cities. Internal function used in -#' the delay fitting using inla. +#' the delay fitting using inla. #'@title Get delay data for one or more cities for delay analysis #'@export #'@param cities vector with geocodes @@ -532,76 +400,45 @@ bayesnowcasting <- function(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, #'@param nyears number of years of data used for fitting: Default = 2 years #'@param datasource valid connection to database #'@return list with d = data.frame with data. -#'@examples -#'dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", +#'@examplesIf FALSE +#'dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", #'lastday = as.Date("2023-12-31")) # Not run without connection -getdelaydata <- function(cities, nyears= 2, cid10 = "A90", lastday = Sys.Date(), - datasource = con){ - - ncities = length(cities) - #cities <- sapply(cities, function(x) sevendigitgeocode(x)) - - #dealing with synonimous cid - if (cid10 == "A90") cid <- "A90" # dengue, dengue hemorragica - if (cid10 %in% c("A92", "A920","A92.0")) {cid <-c("A92", "A920","A92.0"); cid10 <- "A92.0"} # chik - if (cid10 %in% c("A92.8","A928")) {cid <- c("A92.8","A928"); cid10 <- c("A92.8")} #zika - - # reading notification data form the database - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - sqlcid = paste("'", str_c(cid, collapse = "','"),"'", sep="") # dealing with multiple cids for the same disease - +getdelaydata <- function(cities, nyears= 2, cid10 = "A90", lastday = Sys.Date(), + datasource){ + + .db_validate_connection(datasource) + cities <- sapply(cities, sevendigitgeocode) + disease <- .normalize_cid(cid10) + assert_that(length(nyears) == 1L && is.numeric(nyears) && nyears > 0, + msg = "getdelaydata: nyears must be positive") + lastday <- as.Date(lastday) firstday <- lastday - nyears * 365 - - if(class(datasource) == "PostgreSQLConnection"){ - comando <- paste("SELECT municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita - from \"Municipio\".\"Notificacao\" WHERE dt_digita <= '",lastday, - "' AND dt_digita >= '",firstday, "' AND municipio_geocodigo IN (", sqlcity, - ") AND cid10_codigo IN(", sqlcid,")", sep="") - - dd <- dbGetQuery(datasource,comando) - } - - if(class(datasource) == "SQLiteConnection"){ - comando <- paste("SELECT municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita - from \"Notificacao\" WHERE dt_digita <= '",as.numeric(lastday), - "' AND dt_digita > '",as.numeric(firstday), "' AND municipio_geocodigo IN - (", sqlcity, ") AND cid10_codigo IN(", sqlcid,")", sep="") - - dd <- dbGetQuery(datasource,comando) - - if(nrow(dd)==0)stop("getCases found no data") - # fixing dates - dd$dt_notific <- as.Date(dd$dt_notific, origin = "1970-01-01") - dd$dt_sin_pri <- as.Date(dd$dt_sin_pri, origin = "1970-01-01") - dd$dt_digita <- as.Date(dd$dt_digita, origin = "1970-01-01") - dd <- dd %>% - filter(dt_digita <= lastday & dt_digita > firstday) - - } - - + dd <- .repo_notifications( + datasource, cities, disease$values, firstday, lastday, + columns = c("municipio_geocodigo", "dt_notific", "dt_sin_pri", "dt_digita") + ) + + if(nrow(dd) == 0){ - message(paste("getdelaydata: found no", cid, "data for", sqlcity )) + message(paste("getdelaydata: found no", disease$canonical, "data for", + paste(cities, collapse = ", "))) return(NULL) } else { #dd$SE_notif <- dd$ano_notif * 100 + dd$se_notif #dd$cid10 <- cid10 - - + + # Removing records with missing dt_digita nb <- nrow(dd) dd <- dd[!is.na(dd$dt_digita),] na.dtdigita <- nb - nrow(dd) - if (na.dtdigita > 0) message(paste("getdelaydata: number of records with + if (na.dtdigita > 0) message(paste("getdelaydata: number of records with missing dates: ",na.dtdigita, - " out of ",nb, "notifications. - This may cause consistency problems + " out of ",nb, "notifications. + This may cause consistency problems between obs and pred cases" )) - + dd } } - - - diff --git a/R/alert_functions.R b/R/alert_functions.R index 5d0ca6f..dba6a25 100644 --- a/R/alert_functions.R +++ b/R/alert_functions.R @@ -1,33 +1,33 @@ # PROJETO ALERTA DENGUE ------------------------------------- -# Funcoes de calculo do alerta +# Funcoes de calculo do alerta # Claudia Codeco 2015 -# +# #setCriteria ------------------------------------------------------------------- #'@title Define rules to issue a four level alert Green-Yellow-Orange-Red. -#'@description The criteria for transition between colors (alert levels) can be -#'chosen from existing rules or can be specified by the user. The built in rules are: -#'Af (minimum temperature defines yellow) and Aw (humidity does), AsAw (temp min and max humidity together). -#'@export -#'@param rule either a built-in rule ("Af", "Aw", "AsAw","Awi","AsAwi") or a list with three elements defining criteria for +#'@description The criteria for transition between colors (alert levels) can be +#'chosen from existing rules or can be specified by the user. The built in rules are: +#'Af (minimum temperature defines yellow) and Aw (humidity does), AsAw (temp min and max humidity together). +#'@noRd +#'@param rule either a built-in rule ("Af", "Aw", "AsAw","Awi","AsAwi") or a list with three elements defining criteria for #'transition to yellow (level 2), orange (level 3) and red (level 4). See description. #'@param delays list with three elements, each one is a vector: c(delay to turn on, delay to turn off) -#'@param values named vector of values for the critical parameters. Use character. -#'@return list with rules. To be useful, this list must contain variables that match those in the data. -#'@examples -#'Defining values manually +#'@param values named vector of values for the critical parameters. Use character. +#'@return list with rules. To be useful, this list must contain variables that match those in the data. +#'@examplesIf FALSE +#'# Defining values manually #'val <- c("varcli" ="temp_min", "limiar_preseason"="10","limiar_epidemico"="100", "clicrit"="22" #', "clicrit2" = "80", varcli2 = "umid_max") #'setCriteria(rule="Af",values=val) #'setCriteria(rule="AsAw",values=val) -#'Using infodengue parameters: +#'# Using infodengue parameters: #'val <- read.parameters(1200401) #'setCriteria(rule=val$codmodelo, values=val) -setCriteria <- function(rule=NULL, values=NULL, +.define_alert_rules_impl <- function(rule=NULL, values=NULL, delays = list(delayy = c(0,0), delayo = c(0,0), delayr = c(0,0))){ - + # checking input if(!is.null(rule)) assert_that(rule %in% c("Af","Aw","AsAw","Awi","AsAwi"), msg = "setcriteria: rule unknown. Try Af, Aw, Awi, AsAw or AsAwi") @@ -36,17 +36,17 @@ setCriteria <- function(rule=NULL, values=NULL, assert_that(any(names(values) %in% c("varcli", "clicrit", "limiar_preseason", "limiar_epidemico")), msg = "setcriteria: elements missing from arg values") } - - + + # pre-defined rules if(!is.null(rule)){ - + if(rule[1] == "Af"){ criteria <- list( crity = c("temp_min > temp_crit & inc > 0", 3, 0), #3,2 crito = c("p1 > 0.95 & inc > limiar_preseason", 2, 1), #3,2 critr = c("inc > limiar_epidemico & casos > 10", 2, 1) #2,2 - )} + )} if (rule[1] == "Aw"){ criteria = list( crity = c("umid_max > umid_crit & inc > 0", 3, 0), #3,2 @@ -71,17 +71,17 @@ setCriteria <- function(rule=NULL, values=NULL, crito = c("p1 > 0.95 & inc > limiar_preseason", 3, 0), #3,2 critr = c("inc > limiar_epidemico & casos > 10", 2, 0) #2,2 )} - # user defined rules - } else { + # user defined rules + } else { message("setcriteria function using user defined criteria") criteria<-lapply(1:3, function(x) c(rule[[x]], delays[[x]])) names(criteria) <- c("crity","crito","critr") } - + # substituting values (very bad coding, should be improved) if(!is.null(values)) { #used in the pipeline if (!("varcli2" %in% names(values))) values[["varcli2"]] <- "xx" - + if (rule[1] %in% c("Af", "AsAw","AsAwi")){ # reading temp assert_that(values[["varcli"]] == "temp_min" | values[["varcli2"]] == "temp_min", msg = "setcriteria: Af, AsAw and AsAwi require temp_min") @@ -89,7 +89,7 @@ setCriteria <- function(rule=NULL, values=NULL, if(tm == "varcli") values <- c(values, "temp_crit" = values[["clicrit"]]) if(tm == "varcli2") values[["temp_crit"]] <- c(values, "temp_crit" = values[["clicrit2"]]) } - + if (rule[1] %in% c("Aw", "AsAw")){ # reading umidmax assert_that(values[["varcli"]] == "umid_max" | values[["varcli2"]] == "umid_max", msg = "setcriteria: Aw and AsAw require umid_max") @@ -97,7 +97,7 @@ setCriteria <- function(rule=NULL, values=NULL, if(um == "varcli") values <- c(values, "umid_crit" = values[["clicrit"]]) if(um == "varcli2") values <- c(values, "umid_crit" = values[["clicrit2"]]) } - + if (rule[1] %in% c("Awi", "AsAwi")){ # reading umidmin assert_that(values[["varcli"]] == "umid_min" | values[["varcli2"]] == "umid_min", msg = "setcriteria: Awi and AsAwi require umid_min") @@ -105,78 +105,78 @@ setCriteria <- function(rule=NULL, values=NULL, if(um == "varcli") values <- c(values, "umid_crit" = values[["clicrit"]]) if(um == "varcli2") values <- c(values, "umid_crit" = values[["clicrit2"]]) } - - #if(class(values) == "data.frame") + + #if(class(values) == "data.frame") # { # handling values from read.parameters - values <- unlist(sapply(names(values),function(x) values[[x]])) + values <- unlist(sapply(names(values),function(x) values[[x]])) # } - - + + criteria <- lapply(criteria, function(x) c(str_replace_all(x[1], values), x[c(2,3)])) } - + criteria } #fouralert --------------------------------------------------------------------- #'@title Define conditions to issue a four level alert Green-Yellow-Orange-Red. #'@description Yellow is raised when environmental conditions required for -#'positive mosquito population growth are detected, green otherwise.Orange -#'indicates evidence of sustained transmission, red indicates evidence of -#'an epidemic scenario. -#'@export +#'positive mosquito population growth are detected, green otherwise.Orange +#'indicates evidence of sustained transmission, red indicates evidence of +#'an epidemic scenario. +#'@noRd #'@param obj dataset with data to feed the alert, containing the variables specified in crit. #'@param crit criteria for the alert colors. See setCriteria() -#'@param dy if inc > 0, and rt was orange or red at least once in the past -#'dy weeks -> level yellow. Default: dy=4 -#'@param miss how missing data is treated. "last" if last value is repeated. +#'@param dy if inc > 0, and rt was orange or red at least once in the past +#'dy weeks -> level yellow. Default: dy=4 +#'@param miss how missing data is treated. "last" if last value is repeated. #'It is currently the only option -#'@return returns an object of class "alerta" containing four elements: the data, -#'the alert indices, and the rules used to define the indices. -#'@examples +#'@return returns an object of class "alerta" containing four elements: the data, +#'the alert indices, and the rules used to define the indices. +#'@examplesIf FALSE #' # Parameters of the alert model #'val = c(varcli ="temp_min", "clicrit"="22","limiar_preseason"="10","limiar_epidemico"="100") #'criteria = setCriteria(rule="Af",values=val) -#'# Get, organize data -#'cas = getCases(cities = 3200300, cid10 = "A90") %>% +#'# Get, organize data +#'cas = getCases(cities = 3200300, cid10 = "A90") %>% #' Rt(count = "casos",gtdist="normal", meangt=3, sdgt = 1) %>% #' mutate(inc = casos/pop*100000) #'cli = getWU(stations = 'SBGL', vars="temp_min") %>% #' mutate(temp_min = nafill(temp_min, rule = "arima")) #'tw = getTweet(cities = 3200300) -#'# Calculate alert -#'ale <- plyr::join_all(list(cas,cli,tw), by="SE") +#'# Calculate alert +#'ale <- plyr::join_all(list(cas,cli,tw), by="SE") #'resf <- fouralert(ale, crit = criteria) -fouralert <- function(obj, crit, miss="last",dy=4){ - +.classify_alerts_impl <- function(obj, crit, miss="last",dy=4){ + # checking input assert_that(all(names(crit) %in% c("crity", "crito", "critr")) & all(sapply(crit,length) %in% 3), msg = "fouralert: argument crit is mispecified") - - + + # criteria #cyellow = crit[[1]]; corange = crit[[2]]; cred = crit[[3]] parsed_rules <- lapply(crit, function(x) parse(text=x[1])) delay_turnon <- lapply(crit, function(x) as.numeric(x[[2]])) delay_turnoff <- lapply(crit, function(x) as.numeric(x[[3]])) - - # checking delays + + # checking delays #assert_that(all(sapply(c(delay_turnon, delay_turnoff), is.count)), # msg = "fouralert: delays are mispecified") - - # fun to accumulate conditions + + # fun to accumulate conditions accumcond <- function(vec,lag){ if (lag ==1 )return(vec) zoo::rollapply(vec, lag, sum, align = "right", fill = NA) } - - # fun assert condition (week and accumulated) + + # fun assert condition (week and accumulated) assertcondition <- function(dd, nivel){ condtrue <- with(dd, as.numeric(eval(parsed_rules[[nivel]]))) mi <- which(is.na(condtrue)) # missing conditions - if (miss == "last"){ + if (miss == "last"){ #if(le %in% mi) message("missing condition, repeating last value") for (i in mi[mi!=1]) condtrue[i] <- condtrue[i-1] } @@ -184,81 +184,86 @@ fouralert <- function(obj, crit, miss="last",dy=4){ ncondtrue <- accumcond(condtrue, delay_turnon[[nivel]]) cbind(condtrue, ncondtrue) } - # + # le <- nrow(obj) - + indices <- data.frame(cbind(assertcondition(obj, 1), assertcondition(obj, 2), assertcondition(obj, 3))) names(indices) <- c("cytrue", "nytrue","cotrue", "notrue","crtrue", "nrtrue") - + # setting the alert level when delay_on is reached(1 = green, 2 = yellow, 3 = orange, 4 = red) indices$level <- 1 indices$level[indices$nytrue == delay_turnon[1]] <-2 indices$level[indices$notrue == delay_turnon[2]] <-3 indices$level[indices$nrtrue == delay_turnon[3]] <-4 - - - + + + # delayed turnoff delayturnoff <- function(level){ - delay_level = delay_turnoff[[(level-1)]]# as.numeric(as.character(cond[3])) - + delay_level = delay_turnoff[[(level-1)]]# as.numeric(as.character(cond[3])) + ifelse (delay_level == 0, return(indices), {pos <- which(indices$level==level) %>% # weeks with alert at level delay_level - lapply(.,function(x)x+seq(0,delay_level)) %>% # current and subsequent weeks - unlist() %>% + lapply(.,function(x)x+seq(0,delay_level)) %>% # current and subsequent weeks + unlist() %>% unique() pos <- pos[pos<=le] # remove inexisting rows indices$level[pos] <- level #unlist(lapply(indices$level[pos], function(x) max(x,2))) return(indices) }) } - + indices <- delayturnoff(level=4) indices <- delayturnoff(level=3) indices <- delayturnoff(level=2) - + # from orange-red to yellow: # if rt was orange or red at least once in the past dy weeks -> level yellow #contains_34 <- which(zoo::rollapply(indices$level,list(c(-dy:0)), # function(x) any(x>=3), fill=NA)) - + # to visualize how it works, descomment the following lines #indices$dy <- NA #indices$dy[contains_34]<-pmax(indices$level[contains_34], rep(2, length(contains_34))) - - #indices$level[contains_34]<-pmax(indices$level[contains_34], + + #indices$level[contains_34]<-pmax(indices$level[contains_34], # rep(2, length(contains_34))) - + ale <- list(data=obj, indices=indices, crit = crit, n=4) - class(ale)<-"alerta" - return(ale) + class(ale)<-"alerta" + return(ale) } #pipe_infodengue --------------------------------------------------------------------- -#'@title pipeline used by infodengue +#'@title pipeline used by infodengue #'@description wrap of functions used by Infodengue. #'@export #'@param cities In general, a vector of 7-digit geocodes. If it is a data.frame containing geocodes -#' and all parameters, these will replace the database's parameters. +#' and all parameters, these will replace the database's parameters. #'@param cid10 default is A90 (dengue). Chik = A92.0, Zika = A92.8 -#'@param narule how to treat missing climate data. Do nothing (default), "zero" fills +#'@param narule how to treat missing climate data. Do nothing (default), "zero" fills #'with zeros, "linear" for linear interpolation, "arima" for inter and extrapolation. -#'@param finalday if provided, uses only disease data reported up to that day -#'@param iniSE first date of the disease data. Default = 201501. Minimum = 201001. +#'@param finalday Explicit last reporting date. Required when `datarelatorio` +#'is not supplied; otherwise it is derived from that epidemiological week. +#'@param iniSE first date of the disease data. Default = 201501. Minimum = 201001. #'@param datarelatorio epidemiological week -#'@param "bayesian" for the dynamic model, "none" for not doing nowcast (default) -#'@param completetail if sinan data is older than final_day, fill in the tail with NA (default) or 0. -#'@param dataini "notif" (default) or "sinpri" +#'@param nowcasting `"bayesian"` for the dynamic model or `"none"` to skip nowcasting. +#'@param completetail if sinan data is older than final_day, fill in the tail with NA (default) or 0. +#'@param dataini "notif" (default) or "sinpri" #'@param writedb TRUE if it should write into the database, default is FALSE. #'@param datasource posgreSQL connection to project's database -#'@param firstday First date of the notification series passed to getCases(). -#' Defaults to 2018-01-01. -#'@return data.frame with the week condition and the number of weeks within the +#'@param workers Positive number of workers. Defaults to portable serial execution. +#'@param seed Optional seed for stochastic nowcasting. +#'@param verbose Whether to emit progress messages. +#'@param version_date Explicit model-version date used when writing results. +#'@param firstday First date of the notification series passed to fetch_cases(). +#' Defaults to 2018-01-01; supply an earlier date for historical backfills. +#'@return data.frame with the week condition and the number of weeks within the #'last lag weeks with conditions = TRUE. -#'@examples -#'cidades <- getCidades(uf = "Rio de Janeiro",datasource = con) +#'@examplesIf FALSE +#'cidades <- getCidades(uf = "Rio de Janeiro",datasource = connection) #'t1 <- Sys.time() #'res <- pipe_infodengue(cities = 3304557, cid10 = "A90", #'nowcasting="bayesian", dataini= "sinpri", completetail = 0, datarelatorio = 202419) @@ -270,180 +275,195 @@ fouralert <- function(obj, crit, miss="last",dy=4){ #'nowcasting="none", dataini= "sinpri", completetail = 0, #' datarelatorio = 202408) -pipe_infodengue <- function(cities, cid10="A90", datarelatorio, finalday = Sys.Date(), +pipe_infodengue <- function(cities, cid10="A90", datarelatorio, finalday = NULL, iniSE = 201001, nowcasting="none", narule=NULL, - writedb = FALSE, datasource = con, completetail = NA, - dataini = "notific", firstday = as.Date("2018-01-01")){ - - + writedb = FALSE, datasource, completetail = NA, + dataini = "notific", workers = 1L, seed = NULL, + verbose = FALSE, version_date = finalday, + firstday = as.Date("2018-01-01")){ + + .deprecate_api("pipe_infodengue()", "run_alert_pipeline()") + .db_validate_connection(datasource) + + if(missing(datarelatorio)) { - datarelatorio <- data2SE(finalday, format = "%Y-%m-%d") + if (is.null(finalday)) { + stop("Supply an explicit `datarelatorio` or `finalday`.", call. = FALSE) + } + datarelatorio <- data2SE(finalday, format = "%Y-%m-%d") } else { # if datarelatorio & finalday are given, priority is datarelatorio finalday <- SE2date(datarelatorio)$ini+6 } - + # If cities is a vector of geocodes, the pipeline reads the parameters from the dataframe if (class(cities) %in% c("integer","numeric")) { - pars_table <- read.parameters(cities = cities, cid10 = cid10) # poderia ser guardado localmente - message("reading parameters from database") + pars_table <- fetch_alert_parameters(conn = datasource, geocodes = cities, + disease = cid10) + if (isTRUE(verbose)) message("reading parameters from database") } else { # if city contains data already if(all(c("municipio_geocodigo","limiar_preseason", "limiar_posseason","limiar_epidemico", "varcli","clicrit","varcli2","clicrit2","cid10","codmodelo") %in% names(cities))) { - message("using user's provided parameters") - + if (isTRUE(verbose)) message("using user's provided parameters") + pars_table <- cities } - else({message("don't know how to run the pipeline for these inputs") - return(NULL)} - ) + else stop("`cities` must be geocodes or a complete parameter data frame.", + call. = FALSE) } - - # number of cities and other divisions - nlugares <- nrow(pars_table) + cidades <- pars_table$municipio_geocodigo - print(paste("sera'feita analise de",nlugares,"cidade(s):")) - print(cidades) - + if (isTRUE(verbose)) message("running analysis for ", length(cidades), " municipalities") + # Reading the meteorological data #print('Obtendo os dados de clima...') varscli <- c("umid_max", "temp_min", "umid_min","umid_med","temp_med","temp_max") - cli <- getClima(cities, vars = varscli, iniSE = iniSE, finalday = finalday) - message("getCli done") - # Reading Cases - print("Obtendo dados de notificacao ...") - casos <- getCases(cities, lastday = finalday, firstday = firstday, - cid10 = cid10, type = "all", # novo - dataini = dataini, completetail = completetail) - message("getCases done") - casos$inc <- casos$casos/casos$pop*100000 - casos$inc_prov <- casos$cas_prov/casos$pop*100000 # novo - caselist <- NA - - if(nowcasting == "bayesian") # - load("caselist.RData") - - # juntando - casoscli <- casos %>% - left_join(cli, by = join_by(cidade == geocodigo, SE)) - - # para cada cidade ... - - res <- mclapply(cidades, calc.alerta, - pars = list(casoscli, datarelatorio,nowcasting, - pars_table, caselist), mc.cores = detectCores()) %>% - setNames(cidades) # o nome e'o geocodigo - - if (writedb == TRUE) write_alerta(alerta) - + cli <- fetch_climate(conn = datasource, geocodes = cidades, + climate_vars = varscli, + start_date = epiweek_start(iniSE), end_date = finalday) + if (isTRUE(verbose)) message("climate data loaded") + casos <- fetch_cases( + conn = datasource, geocodes = cidades, disease = cid10, + start_date = firstday, end_date = finalday, + case_date = if (dataini == "notific") "notification" else "symptom_onset", + complete_tail = completetail, verbose = verbose + ) + if (isTRUE(verbose)) message("case data loaded") + case_records <- attr(casos, "case_records") + + inputs <- new_alert_inputs( + cases = casos, climate = cli, case_records = case_records, + metadata = list(report_week = datarelatorio, source = "legacy_pipeline") + ) + res <- run_alert_pipeline( + inputs = inputs, parameters = pars_table, report_week = datarelatorio, + nowcast = nowcasting, workers = workers, seed = seed, verbose = verbose + ) + + if (writedb == TRUE) { + write_alert_results(datasource, res, version_date = version_date, + conflict = "update") + } res } # calc.alerta ------------------------------------------- -#'@title Calculates the attention levels for one area. -#'@description Function to compute the alert levels for one spatial unit, defined by level. +#'@title Calculates the attention levels for one area. +#'@description Function to compute the alert levels for one spatial unit, defined by level. #'Internal function used by the dengue_pipeline. #'@param x filter variable indicating geocode at municipal, state or other level. -#'@param level default is municipio. Other options are: regional, macrorregiao +#'@param pars List containing input data, report week, nowcasting mode, parameters, and case records. +#'@param level default is municipio. Other options are: regional, macrorregiao #'and uf (not implemented yet) -#'@return data.frame with the data with alert level. +#'@param ... Reserved for compatibility. +#'@return data.frame with the data with alert level. calc.alerta <- function(x, pars, level = "municipio",...){ #x = cities[i] - - d <- pars[[1]] + + d <- pars[[1]] datarelatorio <- pars[[2]] nowcasting <- pars[[3]] pars_table <- pars[[4]] caselist <- pars[[5]] - - # casos + nowcasting + Rt + incidencia - + + # casos + nowcasting + Rt + incidencia + if(level == "municipio"){ - cas.x <- d %>% + cas.x <- d %>% filter(cidade == x) %>% - adjustIncidence(method = "none", - nowSE = datarelatorio, - nyears = 1) - + nowcast_cases(method = "none", + report_week = datarelatorio, + nyears = 1) + if(nowcasting == "bayesian"){ # handling errors in bayesian nowcast - try(cas.x <- d %>% + try(cas.x <- d %>% filter(cidade == x) %>% - adjustIncidence(method = nowcasting, datas = caselist, - nowSE = datarelatorio, - nyears = 1)) + nowcast_cases(method = nowcasting, case_records = caselist, + report_week = datarelatorio, + nyears = 1)) } - + cas.x <- cas.x %>% - Rt(count = "tcasesmed",gtdist="normal", meangt=3, sdgt = 1) %>% + estimate_rt(count = "tcasesmed", distribution="normal", + mean_generation_time=3, sd_generation_time = 1) %>% mutate(inc = tcasesmed/pop*100000) %>% arrange(SE) - - + + assert_that(nrow(cas.x)>0, msg = "check alertapipeline. error makes nrow = 0") # build rules crit.x <- pars_table[pars_table$municipio_geocodigo==x,] # parameters crit.x.vector <- structure(as.character(crit.x), names = as.character(names(crit.x))) # dataframe -> vector - criteriaU <- setCriteria(rule = crit.x$codmodelo, values = crit.x.vector) # valued criteria - + criteriaU <- define_alert_rules(rule = crit.x$codmodelo, values = crit.x.vector) + # Apply alert rules - y <- fouralert(cas.x, crit = criteriaU) # apply alert + y <- classify_alerts(cas.x, rules = criteriaU) } - y -} + y +} #tabela_historico -------------------------------------------------------------------- -#'@title Convert the alert object into a data.frame and calculate indicators -#'@description Function to organize the alert results for easy reading and inserting +#'@title Convert the alert object into a data.frame and calculate indicators +#'@description Function to organize the alert results for easy reading and inserting #'in the database. Also computes receptivity, transmission and incidence levels. -#'@export +#'@noRd #'@param obj object created by the pipeline. -#'@param ini_se first week of the table. Default is the first date in obj. -#'@param last_se last week of the table. Default is the last date in obj. To do. -#'@param type "notified", if it should return total counts, disregarding the -#'final classification. For compatibility reasons. -#'@param versao Default is current's date -#'@return data.frame with the data to be written. -#'@examples +#'@param iniSE first week of the table. Default is the first date in obj. +#'@param lastSE last week of the table. Default is the last date in obj. +#'@param type "notified", if it should return total counts, disregarding the +#'final classification. For compatibility reasons. +#'@param versao Explicit model-version date. +#'@param parameters Parameter data frame. Pipeline results carry it as an attribute; +#'direct alert objects must supply it explicitly. +#'@return data.frame with the data to be written. +#'@examplesIf FALSE #'# Several cities at once: -#'cidades <- getCidades(uf = "Mato Grosso", datasource = con) -#'res <- pipe_infodengue(cities = cidades$municipio_geocodigo[1:3], cid10 = "A90", +#'cidades <- getCidades(uf = "Mato Grosso", datasource = connection) +#'res <- pipe_infodengue(cities = cidades$municipio_geocodigo[1:3], cid10 = "A90", #'finalday= "2018-01-10") -#'restab <- tabela_historico_comp(res, iniSE = 202301, type = "all") +#'restab <- tabela_historico_comp(res, iniSE = 202301, type = "all") #'tail(restab) #'# One city: -#'res <- pipe_infodengue(cities = 3304557, cid10 = "A90", +#'res <- pipe_infodengue(cities = 3304557, cid10 = "A90", #'finalday= "2015-01-10") -#'restab <- tabela_historico(res) +#'restab <- tabela_historico(res) #'tail(restab) -tabela_historico <- function(obj, iniSE, lastSE, type = "all", versao = Sys.Date()){ - +.as_alert_history_impl <- function(obj, iniSE, lastSE, type = "all", versao, + parameters = if (inherits(obj, "alerttools_result")) obj$parameters else attr(obj, "parameters")){ + + if (missing(versao)) stop("tabela_historico requires an explicit `versao` date.", call. = FALSE) + # --------- create single data.frame ------------------# # if object created by pipe_infodengue(): - if(class(obj)=="list" & class(obj[[1]])=="alerta"){ + if (inherits(obj, "alerttools_result")) { + data <- obj$data + indices <- obj$alerts + } else if(class(obj)=="list" & class(obj[[1]])=="alerta"){ data <- transpose(obj)[[1]] %>% bind_rows() # unlist data indices <- transpose(obj)[[2]] %>% bind_rows() #unlist indices - + } else if (class(obj)=="alerta"){ #if object created directly by fouralert() data <- obj$data indices <- obj$indices } d <- cbind(data, indices) - + # defining the id (SE+julian(versaomodelo)+geocodigo+localidade) - gera_id <- function(x) paste(data$cidade[x], data$Localidade_id[x], data$SE[x], + location_id <- if ("Localidade_id" %in% names(data)) data$Localidade_id else data$localidade + gera_id <- function(x) paste(data$cidade[x], location_id[x], data$SE[x], as.character(julian(versao)), sep="") - d$id <- sapply(1:nrow(data), gera_id) - - + d$id <- sapply(1:nrow(data), gera_id) + + # ---------- filtering dates -------------------------# if(missing(iniSE)) iniSE <- 0 # sem filtro if(missing(lastSE)) lastSE <- 300000 # sem filtro - + d <- d %>% - filter(SE >= iniSE & SE <= lastSE) %>% + filter(SE >= iniSE & SE <= lastSE) %>% rename(municipio_geocodigo = cidade, municipio_nome = nome, casos_est = tcasesmed, @@ -463,17 +483,24 @@ tabela_historico <- function(obj, iniSE, lastSE, type = "all", versao = Sys.Date data_iniSE = SE2date(SE)$ini, versao_modelo = as.character(versao)) d$Rt[is.na(d$Rt)] <- 0 - - pars <- read.parameters(d$municipio_geocodigo, cid10 = d$CID10[1]) - + + if (is.null(parameters)) { + stop("tabela_historico requires `parameters`; database access is not implicit.", + call. = FALSE) + } + required_parameters <- c("municipio_geocodigo", "limiar_preseason", "limiar_epidemico") + assert_that(all(required_parameters %in% names(parameters)), + msg = "tabela_historico: invalid parameter schema") + pars <- parameters + d <- d %>% # new stuff rename( receptivo = cytrue, # weeks with receptive conditions transmissao = cotrue) # weeks with sustained transm - + d1 <- d %>% - left_join(pars[c("municipio_geocodigo", "limiar_preseason", - "limiar_epidemico")]) %>% + left_join(pars[c("municipio_geocodigo", "limiar_preseason", + "limiar_epidemico")], by = "municipio_geocodigo") %>% mutate( # compating estimated incidence with thresholds nivel_inc = case_when( p_inc100k < limiar_preseason ~ 0, @@ -482,18 +509,17 @@ tabela_historico <- function(obj, iniSE, lastSE, type = "all", versao = Sys.Date ) ) # --------- checking all required variables ------------# - varnames <-c("data_iniSE", "SE", "CID10","casos", "casos_est", + varnames <-c("data_iniSE", "SE", "CID10","casos", "casos_est", "casos_est_min", "casos_est_max", "municipio_geocodigo", "casprov", - "p_rt1", "p_inc100k", "Localidade_id", "nivel", "id", "versao_modelo", + "p_rt1", "p_inc100k", "Localidade_id", "nivel", "id", "versao_modelo", "municipio_nome", "Rt", "pop", "temp_min","temp_med", - "temp_max","umid_min","umid_med","umid_max", "receptivo", - "transmissao", "nivel_inc") - + "temp_max","umid_min","umid_med","umid_max", "receptivo", + "transmissao", "nivel_inc") if(all(varnames %in% names(d1))) { dfinal <- d1[,varnames] return(dfinal) } else { - message(paste("historico_alerta is not returning the required variables", + message(paste("historico_alerta is not returning the required variables", varnames[!varnames %in% names(d1)])) return(NULL) } @@ -502,43 +528,48 @@ tabela_historico <- function(obj, iniSE, lastSE, type = "all", versao = Sys.Date #tabela_historico_intra -------------------------------------------------------------------- #'@title Convert the alert object into a data.frame and calculate indicators for cities with subdivisions -#'@description Function to organize the alert results for easy reading and inserting -#'in the database. Specific for municipalities with subdivisions. +#'@description Function to organize the alert results for easy reading and inserting +#'in the database. Specific for municipalities with subdivisions. #'@export #'@param obj object created by the pipeline. -#'@param ini_se first week of the table. Default is the first date in obj. -#'@param last_se last week of the table. Default is the last date in obj. To do. -#'@param versao Default is current's date -#'@return data.frame with the data to be written. -#'@examples -#'NOT RUN without connection +#'@param iniSE first week of the table. Default is the first date in obj. +#'@param lastSE last week of the table. Default is the last date in obj. +#'@param versao Explicit model-version date. +#'@param parameters Parameter data frame. It is never read implicitly from a database. +#'@return data.frame with the data to be written. +#'@examplesIf FALSE +#'# NOT RUN without connection #'# Rio de Janeiro -#'alerio <- pipe_infodengue_intra(city = 3304557, datarelatorio=202105, +#'alerio <- pipe_infodengue_intra(city = 3304557, datarelatorio=202105, #'delaymethod="bayesian", cid10 = "A90", dataini = "sinpri") -#'restab <- tabela_historico_intra(alerio, iniSE = 201801) +#'restab <- tabela_historico_intra(alerio, iniSE = 201801, +#' versao = as.Date("2026-09-04")) #'tail(restab) -tabela_historico_intra <- function(obj, iniSE, lastSE, versao = Sys.Date()){ - +tabela_historico_intra <- function(obj, iniSE, lastSE, versao, + parameters = attr(obj, "parameters")){ + + if (missing(versao)) stop("tabela_historico_intra requires an explicit `versao` date.", call. = FALSE) + assert_that(class(obj) == "alerta_intra", msg = "tabela_historico_mun: obj must be of class alerta_intra.") - + # --------- create single data.frame ------------------# data <- transpose(obj)[[1]] %>% bind_rows() # unlist data indices <- transpose(obj)[[2]] %>% bind_rows() #unlist indices - + d <- cbind(data, indices) - + # defining the id (SE+julian(versaomodelo)+geocodigo+localidade) - gera_id <- function(x) paste(data$cidade[x], data$Localidade_id[x], data$SE[x], + gera_id <- function(x) paste(data$cidade[x], data$Localidade_id[x], data$SE[x], as.character(julian(versao)), sep="") - d$id <- sapply(1:nrow(data), gera_id) - + d$id <- sapply(1:nrow(data), gera_id) + # ---------- filtering dates -------------------------# if(missing(iniSE)) iniSE <- 0 if(missing(lastSE)) lastSE <- 300000 - + d <- d %>% - filter(SE >= iniSE & SE <= lastSE) %>% + filter(SE >= iniSE & SE <= lastSE) %>% rename(municipio_geocodigo = cidade, municipio_nome = nome, casos_est = tcasesmed, @@ -551,16 +582,24 @@ tabela_historico_intra <- function(obj, iniSE, lastSE, versao = Sys.Date()){ data_iniSE = SE2date(SE)$ini, versao_modelo = as.character(versao)) d$Rt[is.na(d$Rt)] <- 0 - - pars <- read.parameters(d$municipio_geocodigo, cid10 = d$CID10[1]) - + + if (is.null(parameters)) { + stop("tabela_historico_intra requires `parameters`; database access is not implicit.", + call. = FALSE) + } + required_parameters <- c("municipio_geocodigo", "limiar_preseason", "limiar_epidemico") + assert_that(all(required_parameters %in% names(parameters)), + msg = "tabela_historico_intra: invalid parameter schema") + pars <- parameters + d <- d %>% # new stuff rename( receptivo = cytrue, # weeks with receptive conditions transmissao = cotrue) # weeks with sustained transm - + d1 <- d %>% - left_join(pars[2:5]) %>% + left_join(pars[c("municipio_geocodigo", "limiar_preseason", + "limiar_epidemico")], by = "municipio_geocodigo") %>% mutate( # compating estimated incidence with thresholds nivel_inc = case_when( p_inc100k < limiar_preseason ~ 0, @@ -568,131 +607,121 @@ tabela_historico_intra <- function(obj, iniSE, lastSE, versao = Sys.Date()){ p_inc100k > limiar_epidemico ~ 2 ) ) - + d1 } #write_alerta -------------------------------------------------------------------- #'@title Write historico_alerta into the database. -#'@description Function to write the pipeline results into the database. +#'@description Function to write the pipeline results into the database. #'Receives the object created by the function historico.alerta. If writetofile == TRUE, #'it saves the sql command in a text file. If FALSE, it will write directly in the database -#'using the connection. -#'@export +#'using the connection. +#'@noRd #'@param d object created by tabela_historico() #'@param writetofile TRUE if an sql object will be the output; FALSE if not. -#'@param arq file name to store sql object +#'@param arq file name to store sql object #'@param datasource posgreSQL conn to project's database +#'@param conflict Conflict policy: `update`, `error`, or `ignore`. #'@return the same data.frame from the input -#'@examples -#'# Parameters for the model -#'cidades <- getCidades(regional = "Norte",uf = "Rio de Janeiro",datasource = con) -#'res <- pipe_infodengue(cities = cidades$municipio_geocodigo[1], cid10 = "A90", +#'@examplesIf FALSE +#'# Parameters for the model +#'cidades <- getCidades(regional = "Norte",uf = "Rio de Janeiro",datasource = connection) +#'res <- pipe_infodengue(cities = cidades$municipio_geocodigo[1], cid10 = "A90", #'datarelatorio = 202407, iniSE = 202301, nowcasting="none") #'restab <- tabela_historico(res) -#'res2 <- pipe_infodengue(cities = cidades$municipio_geocodigo[1], cid10 = "A90", +#'res2 <- pipe_infodengue(cities = cidades$municipio_geocodigo[1], cid10 = "A90", #'datarelatorio = 202406, iniSE = 202301, nowcasting="none") #'restab2 <- tabela_historico(res2) -#'# NOT RUN +#'# NOT RUN #'t1 <- Sys.time() #'write_alerta(restab[1:10,], writetofile = TRUE) #'t2 <- Sys.time() - t1 -write_alerta<-function(d, writetofile = FALSE, datasource = con, arq = "output.sql"){ - +.write_alert_results_impl <- function(d, writetofile = FALSE, datasource, arq = "output.sql", + conflict = c("update", "error", "ignore"), verbose = TRUE) { + # check input assert_that(class(d) == "data.frame", msg = "write_alerta: d is not a data.frame. d should be an output from tabela_historico.") - - if(writetofile == FALSE) assert_that(class(datasource) == "PostgreSQLConnection", msg = "write_alerta: - works only for writing into Infodengue's server") - + + conflict <- match.arg(conflict) + if (!writetofile) .db_validate_connection(datasource) + cid10 = unique(d$CID10) assert_that(length(cid10) == 1, msg = "write_alerta: d must contain only one cid10") - + dcolumns <- c("SE", "data_iniSE", "casos_est", "casos_est_min", "casos_est_max", "casos","casprov","municipio_geocodigo","p_rt1","p_inc100k","Localidade_id", "nivel","id","versao_modelo","municipio_nome","Rt", "pop", "receptivo","transmissao","nivel_inc","temp_min","temp_med","temp_max", "umid_min","umid_med","umid_max") - + if(!("temp_min" %in% names(d))) d$temp_min <- NA if(!("umid_max" %in% names(d))) d$umid_max <- NA - + assert_that(all(dcolumns %in% names(d)), msg = "write_alerta: check if d contains required columns") - + # nomes das tabelas para salvar os historicos: - if(cid10=="A90") {tabela <- "Historico_alerta"; constr.unico = "alertas_unicos"} - if(cid10=="A92.0") {tabela <- "Historico_alerta_chik"; constr.unico = "alertas_unicos_chik"} - if(cid10=="A92.8") {tabela <- "Historico_alerta_zika"; constr.unico = "alertas_unicos_zika"} - if(!(cid10 %in% c("A90", "A92.0", "A92.8"))) stop(paste("não sei onde salvar histórico para o agravo", cid10)) - - # ------ vars to write - - dados <- d %>% - select(all_of(dcolumns)) - - - # ------ sql command - varnamesforsql <- c("\"SE\"", "\"data_iniSE\"", "casos_est", "casos_est_min", "casos_est_max", - "casos","casprov","municipio_geocodigo","p_rt1","p_inc100k","\"Localidade_id\"", - "nivel","id","versao_modelo","municipio_nome", "\"Rt\"", "pop", - "tempmin","tempmed","tempmax","umidmin","umidmed","umidmax", - "receptivo", "transmissao","nivel_inc") - - varnames.sql <- str_c(varnamesforsql, collapse = ",") - updates = str_c(paste(varnamesforsql,"=excluded.",varnamesforsql,sep=""),collapse=",") # excluidos, se duplicado - - escreve_linha <- function(li){ # para escrever no sql - vetor <- dados[li,] - vetor$municipio_nome = gsub(vetor$municipio_nome, pattern = "'", replacement = "''") - linha = paste0(vetor$SE,",'", - as.character(vetor$data_iniSE), "',", - str_c(vetor[1,c("casos_est","casos_est_min","casos_est_max", - "casos","casprov","municipio_geocodigo","p_rt1","p_inc100k","Localidade_id","nivel","id")], collapse=","),",'", - as.character(vetor$versao_modelo),"','", - as.character(vetor$municipio_nome),"',", - str_c(vetor[1,c("Rt","pop","temp_min","temp_med","temp_max","umid_min","umid_med","umid_max")], collapse = ","), ",", - str_c(vetor[1,c("receptivo","transmissao","nivel_inc")], collapse = ",") - ) - - #if("temp_min" %in% names(vetor)) linha = paste0(linha,",", vetor$temp_min, ",","NA") - #if("umid_max" %in% names(vetor)) linha = paste0(linha,",", "NA", ",", vetor$umid_max) - linha = gsub("NA","NULL",linha) - linha = gsub("NaN","NULL",linha) - - - insert_sql = paste("INSERT INTO \"Municipio\".\"",tabela,"\" (" ,varnames.sql,") VALUES (", linha, ") - ON CONFLICT ON CONSTRAINT ",constr.unico," - DO UPDATE SET ",updates, ";",sep="") - - if(writetofile == FALSE) { - try(dbGetQuery(datasource, insert_sql)) + if(cid10=="A90") table_key <- "alert_dengue" + if(cid10=="A92.0") table_key <- "alert_chik" + if(cid10=="A92.8") table_key <- "alert_zika" + if(!(cid10 %in% c("A90", "A92.0", "A92.8"))) stop(paste("unknown disease destination for", cid10)) + + # ------ vars to write + + dados <- data.frame( + SE = d$SE, data_iniSE = d$data_iniSE, + casos_est = d$casos_est, casos_est_min = d$casos_est_min, + casos_est_max = d$casos_est_max, casos = d$casos, casprov = d$casprov, + municipio_geocodigo = d$municipio_geocodigo, p_rt1 = d$p_rt1, + p_inc100k = d$p_inc100k, Localidade_id = d$Localidade_id, + nivel = d$nivel, id = d$id, versao_modelo = d$versao_modelo, + municipio_nome = d$municipio_nome, Rt = d$Rt, pop = d$pop, + tempmin = d$temp_min, tempmed = d$temp_med, tempmax = d$temp_max, + umidmin = d$umid_min, umidmed = d$umid_med, umidmax = d$umid_max, + receptivo = d$receptivo, transmissao = d$transmissao, + nivel_inc = d$nivel_inc, check.names = FALSE + ) + key <- c("SE", "municipio_geocodigo", "Localidade_id") + + if (writetofile) { + driver <- DBI::ANSI() + config <- .db_table_config[[table_key]]$postgres + table_sql <- as.character(DBI::dbQuoteIdentifier( + driver, DBI::Id(schema = config[[1]], table = config[[2]]) + )) + column_sql <- as.character(DBI::dbQuoteIdentifier(driver, names(dados))) + row_sql <- apply(dados, 1L, function(row) { + values <- Map(function(value, template) { + if (is.na(value)) return(DBI::SQL("NULL")) + if (inherits(template, "Date")) value <- as.Date(value) + DBI::dbQuoteLiteral(driver, value) + }, as.list(row), dados[1, , drop = FALSE]) + paste0("(", paste(as.character(values), collapse = ", "), ")") + }) + sql <- paste("INSERT INTO", table_sql, + paste0("(", paste(column_sql, collapse = ", "), ") VALUES"), + paste(row_sql, collapse = ", ")) + if (conflict != "error") { + key_sql <- as.character(DBI::dbQuoteIdentifier(driver, key)) + sql <- paste(sql, "ON CONFLICT", paste0("(", paste(key_sql, collapse = ", "), ")")) + if (conflict == "ignore") { + sql <- paste(sql, "DO NOTHING") + } else { + update_columns <- setdiff(names(dados), key) + update_sql <- as.character(DBI::dbQuoteIdentifier(driver, update_columns)) + sql <- paste(sql, "DO UPDATE SET", + paste0(update_sql, " = excluded.", update_sql, collapse = ", ")) + } } - - insert_sql + writeLines(paste0(sql, ";"), arq, useBytes = TRUE) + if (isTRUE(verbose)) message("writing alerta into file ", arq) + } else { + if (isTRUE(verbose)) message("writing alerta into ", table_key) + .repo_write_rows(datasource, table_key, dados, key = key, conflict = conflict) } - - # escrevendo no sql - - - if(writetofile){ - f <- file(arq,open="w",encoding="utf8") - for(i in 1:nrow(d)) writeLines(escreve_linha(i), f) - message("writing alerta into file ", arq) - close(f) - - } else{ - print(paste("writing alerta into table", tabela)) - try(dbGetQuery(datasource, "BEGIN TRANSACTION;")) ## start a transaction - - 1:nrow(d) %>% map(escreve_linha) ## the sql inserts will only be processed after the end of the transaction - - try(dbGetQuery(datasource, "COMMIT TRANSACTION;")) ## finish the transaction and insert the lines - ## in case of failure is possible to roll back (undo) - ## ROLLBACK TRANSACTION; - } - + invisible(d) } diff --git a/R/api.R b/R/api.R new file mode 100644 index 0000000..f35f438 --- /dev/null +++ b/R/api.R @@ -0,0 +1,585 @@ +# Public API ----------------------------------------------------------------- + +.normalize_disease <- function(disease) { + if (length(disease) != 1L || !is.character(disease) || is.na(disease)) { + stop("`disease` must be one non-missing character value.", call. = FALSE) + } + key <- tolower(trimws(disease)) + if (key %in% c("dengue", "a90")) return("A90") + if (key %in% c("chik", "chikungunya", "a92", "a920", "a92.0")) return("A92.0") + if (key %in% c("zika", "a928", "a92.8")) return("A92.8") + stop("Unknown disease: ", disease, call. = FALSE) +} + +.validate_geocodes <- function(geocodes) { + if (!is.numeric(geocodes) || !length(geocodes) || anyNA(geocodes)) { + stop("`geocodes` must be a non-empty numeric vector.", call. = FALSE) + } + unique(vapply(geocodes, sevendigitgeocode, numeric(1))) +} + +.resolve_api_period <- function(start_week = NULL, report_week = NULL, + start_date = NULL, end_date = NULL) { + if (is.null(start_week) && is.null(start_date)) { + stop("Supply `start_week` or `start_date`.", call. = FALSE) + } + if (is.null(report_week) && is.null(end_date)) { + stop("Supply `report_week` or `end_date`.", call. = FALSE) + } + if (!is.null(start_date)) { + start_date <- as.Date(start_date) + if (length(start_date) != 1L || is.na(start_date)) { + stop("`start_date` must be one valid date.", call. = FALSE) + } + } + if (!is.null(end_date)) { + end_date <- as.Date(end_date) + if (length(end_date) != 1L || is.na(end_date)) { + stop("`end_date` must be one valid date.", call. = FALSE) + } + } + if (!is.null(start_week)) { + .validate_epiweek(start_week) + if (length(start_week) != 1L || is.na(start_week)) { + stop("`start_week` must be one epidemiological week.", call. = FALSE) + } + } + if (!is.null(report_week)) { + .validate_epiweek(report_week) + if (length(report_week) != 1L || is.na(report_week)) { + stop("`report_week` must be one epidemiological week.", call. = FALSE) + } + } + resolved_start_week <- if (is.null(start_week)) as_epiweek(start_date) else as.numeric(start_week) + resolved_report_week <- if (is.null(report_week)) as_epiweek(end_date) else as.numeric(report_week) + if (!is.null(start_date) && as_epiweek(start_date) != resolved_start_week) { + stop("`start_date` and `start_week` refer to different weeks.", call. = FALSE) + } + if (!is.null(end_date) && as_epiweek(end_date) != resolved_report_week) { + stop("`end_date` and `report_week` refer to different weeks.", call. = FALSE) + } + resolved_start_date <- if (is.null(start_date)) epiweek_start(resolved_start_week) else start_date + resolved_end_date <- if (is.null(end_date)) epiweek_start(resolved_report_week) + 6L else end_date + if (resolved_start_date > resolved_end_date || + epiweek_start(resolved_start_week) > epiweek_start(resolved_report_week)) { + stop("The start of the period must not be after its end.", call. = FALSE) + } + list( + start_week = resolved_start_week, report_week = resolved_report_week, + start_date = resolved_start_date, end_date = resolved_end_date + ) +} + +.normalize_population <- function(population) { + if (is.null(population)) return(NULL) + if (!is.data.frame(population)) stop("`population` must be a data frame.", call. = FALSE) + code <- intersect(c("cidade", "geocode", "municipio_geocodigo"), names(population)) + value <- intersect(c("pop", "populacao", "population"), names(population)) + if (!length(code) || !length(value)) { + stop("`population` must contain a geocode and population column.", call. = FALSE) + } + normalized <- data.frame( + cidade = as.numeric(population[[code[[1]]]]), + pop = as.numeric(population[[value[[1]]]]) + ) + if ("year" %in% names(population)) { + normalized$year <- as.integer(population$year) + normalized <- normalized[order(normalized$cidade, normalized$year), , drop = FALSE] + normalized <- normalized[!duplicated(normalized$cidade, fromLast = TRUE), , drop = FALSE] + normalized$year <- NULL + } + if (anyNA(normalized) || any(normalized$pop <= 0) || anyDuplicated(normalized$cidade)) { + stop("`population` must have one positive value per geocode.", call. = FALSE) + } + normalized +} + +#' Construct validated inputs for the alert pipeline +#' +#' `cases` has one row per municipality, disease, and epidemiological week and +#' must contain `SE`, `cidade`, `CID10`, `casos`, `cas_prov`, `cas_lab`, +#' `localidade`, and `nome`. It must also contain `pop`, unless `population` is +#' supplied. `climate` has one row per municipality and week, keyed by +#' `geocodigo` and `SE`. Rows are ordered by municipality and week. +#' +#' @param cases Weekly case data frame. +#' @param climate Weekly climate data frame. +#' @param population Optional population data with a geocode and population +#' column. When years are present, the latest value per municipality is used. +#' @param case_records Optional individual notification records used by +#' Bayesian nowcasting. +#' @param metadata Named list describing input provenance. +#' @return An experimental `alerttools_inputs` object. +#' @section Lifecycle: +#' This interface is experimental while operational consumers migrate from the +#' legacy API. +#' @export +new_alert_inputs <- function(cases, climate, population = NULL, + case_records = NULL, metadata = list()) { + .validate_columns( + cases, + c("SE", "cidade", "CID10", "casos", "cas_prov", "cas_lab", "localidade", "nome"), + "cases" + ) + .validate_columns(climate, c("SE", "geocodigo"), "climate") + if (!is.numeric(cases$SE) || !is.numeric(cases$cidade) || + !is.numeric(climate$SE) || !is.numeric(climate$geocodigo) || + !all(vapply(cases[c("casos", "cas_prov", "cas_lab")], is.numeric, logical(1)))) { + stop("Case and climate keys and counts must be numeric.", call. = FALSE) + } + .validate_epiweek(c(cases$SE, climate$SE)) + if (!is.null(case_records) && !is.data.frame(case_records)) { + stop("`case_records` must be NULL or a data frame.", call. = FALSE) + } + if (!is.list(metadata) || (length(metadata) && is.null(names(metadata)))) { + stop("`metadata` must be a named list.", call. = FALSE) + } + + population <- .normalize_population(population) + if (!"pop" %in% names(cases)) cases$pop <- NA_real_ + if (!is.null(population)) { + matched <- match(cases$cidade, population$cidade) + replace <- is.na(cases$pop) + cases$pop[replace] <- population$pop[matched[replace]] + } + if (anyNA(cases$pop) || any(cases$pop <= 0)) { + stop("Every case row must have a positive population.", call. = FALSE) + } + if (anyDuplicated(cases[c("cidade", "CID10", "SE")])) { + stop("`cases` keys (`cidade`, `CID10`, `SE`) must be unique.", call. = FALSE) + } + if (anyDuplicated(climate[c("geocodigo", "SE")])) { + stop("`climate` keys (`geocodigo`, `SE`) must be unique.", call. = FALSE) + } + cases <- cases[order(cases$cidade, cases$CID10, cases$SE), , drop = FALSE] + climate <- climate[order(climate$geocodigo, climate$SE), , drop = FALSE] + rownames(cases) <- NULL + rownames(climate) <- NULL + + structure( + list(cases = cases, climate = climate, population = population, + case_records = case_records, metadata = metadata), + class = "alerttools_inputs" + ) +} + +#' @export +print.alerttools_inputs <- function(x, ...) { + cat("\n") + cat(" case rows:", nrow(x$cases), "\n") + cat(" climate rows:", nrow(x$climate), "\n") + cat(" municipalities:", length(unique(x$cases$cidade)), "\n") + invisible(x) +} + +#' Fetch weekly cases +#' +#' @param conn A valid DBI connection. +#' @param geocodes Numeric seven-digit municipality codes. +#' @param disease Disease name (`"dengue"`, `"chikungunya"`, or `"zika"`) or +#' equivalent CID-10 code. +#' @param start_date,end_date Explicit inclusive date interval. +#' @param case_date Date used for aggregation. +#' @param complete_tail Value used for weeks beyond the latest report. +#' @param verbose Whether to emit progress messages. +#' @return A data frame ordered by `cidade` and `SE`, with one row per +#' `cidade`, `CID10`, and `SE`. Columns are `SE`, `cidade`, `CID10`, `casos`, +#' `cas_prov`, `cas_lab`, `localidade`, `nome`, and `pop`. +#' @export +fetch_cases <- function(conn, geocodes, disease = "dengue", start_date, + end_date, case_date = c("notification", "symptom_onset"), + complete_tail = NA, verbose = FALSE) { + .db_validate_connection(conn) + geocodes <- .validate_geocodes(geocodes) + case_date <- match.arg(case_date) + .fetch_cases_impl( + cities = geocodes, firstday = as.Date(start_date), lastday = as.Date(end_date), + cid10 = .normalize_disease(disease), + dataini = if (case_date == "notification") "notific" else "sinpri", + completetail = complete_tail, type = "all", datasource = conn, verbose = verbose + ) +} + +#' Fetch individual case records +#' +#' @inheritParams fetch_cases +#' @return A data frame with individual notification records. It includes +#' `municipio_geocodigo`, `dt_notific`, `dt_sin_pri`, and `dt_digita`; date +#' columns use class `Date`. +#' @export +fetch_case_records <- function(conn, geocodes, disease = "dengue", + start_date, end_date) { + .db_validate_connection(conn) + .fetch_case_records_impl( + cities = .validate_geocodes(geocodes), firstday = as.Date(start_date), + lastday = as.Date(end_date), cid10 = .normalize_disease(disease), datasource = conn + ) +} + +#' Fetch weekly municipal climate data +#' +#' @param climate_vars Climate columns to fetch. +#' @inheritParams fetch_cases +#' @return A data frame ordered and uniquely keyed by `geocodigo` and `SE`, +#' followed by the requested climate columns. +#' @export +fetch_climate <- function(conn, geocodes, start_date, end_date, + climate_vars = c("temp_min", "temp_max", "temp_med", + "umid_min", "umid_med", "umid_max")) { + .db_validate_connection(conn) + .fetch_climate_impl( + cities = .validate_geocodes(geocodes), vars = climate_vars, + iniSE = as_epiweek(as.Date(start_date)), finalday = as.Date(end_date), + datasource = conn + ) +} + +#' Fetch all inputs required by the alert pipeline +#' +#' Exactly one representation of each boundary is sufficient: use weeks, dates, +#' or both when they refer to the same epidemiological weeks. +#' +#' @inheritParams fetch_cases +#' @param start_week First epidemiological week. +#' @param report_week Last epidemiological week included in the report. +#' @param climate_vars Climate columns to fetch. +#' @return An experimental `alerttools_inputs` object. +#' @section Lifecycle: +#' This database orchestration interface is experimental. +#' @export +fetch_alert_inputs <- function(conn, geocodes, disease = "dengue", + start_week = NULL, report_week = NULL, + start_date = NULL, end_date = NULL, + case_date = c("notification", "symptom_onset"), + complete_tail = NA, + climate_vars = c("temp_min", "temp_max", "temp_med", + "umid_min", "umid_med", "umid_max"), + verbose = FALSE) { + period <- .resolve_api_period(start_week, report_week, start_date, end_date) + geocodes <- .validate_geocodes(geocodes) + cid10 <- .normalize_disease(disease) + cases <- fetch_cases( + conn, geocodes, cid10, period$start_date, period$end_date, + case_date = match.arg(case_date), complete_tail = complete_tail, verbose = verbose + ) + records <- attr(cases, "case_records") + attr(cases, "case_records") <- NULL + climate <- fetch_climate( + conn, geocodes, period$start_date, period$end_date, + climate_vars = climate_vars + ) + new_alert_inputs( + cases, climate, case_records = records, + metadata = c(period, list(geocodes = geocodes, disease = cid10, source = "database")) + ) +} + +#' Fetch alert parameters +#' +#' @inheritParams fetch_cases +#' @return A data frame with one row per `municipio_geocodigo` and `cid10`, in +#' requested geocode order. Pipeline columns include `limiar_preseason`, +#' `limiar_epidemico`, `varcli`, `clicrit`, and `codmodelo`. +#' @export +fetch_alert_parameters <- function(conn, geocodes, disease = "dengue") { + .db_validate_connection(conn) + geocodes <- .validate_geocodes(geocodes) + cid10 <- .normalize_disease(disease) + result <- .repo_parameters(conn, geocodes, cid10) + if (!nrow(result) || !all(geocodes %in% result$municipio_geocodigo)) { + stop("Alert parameters were not found for every requested geocode and disease.", + call. = FALSE) + } + result <- result[order(match(result$municipio_geocodigo, geocodes)), , drop = FALSE] + rownames(result) <- NULL + result +} + +#' Run the alert pipeline +#' +#' This experimental entry point performs computation only. It never reads from +#' or writes to a database. +#' +#' @param inputs An `alerttools_inputs` object. +#' @param parameters Alert parameter data frame, keyed by municipality and disease. +#' @param report_week Explicit report week. Defaults to the value recorded by +#' `fetch_alert_inputs()`. +#' @param nowcast Either `"none"` or `"bayesian"`. +#' @param workers Positive worker count; defaults to one. +#' @param seed Optional deterministic seed. +#' @param verbose Whether to emit progress messages. +#' @return An `alerttools_result` object ordered by municipality and week, with +#' `data`, `alerts`, `parameters`, `metadata`, and `diagnostics` fields. +#' @section Lifecycle: +#' This orchestration interface is experimental. +#' @export +run_alert_pipeline <- function(inputs, parameters, report_week = NULL, + nowcast = c("none", "bayesian"), workers = 1L, + seed = NULL, verbose = FALSE) { + if (!inherits(inputs, "alerttools_inputs")) { + stop("`inputs` must be created by new_alert_inputs() or fetch_alert_inputs().", + call. = FALSE) + } + if (is.null(report_week)) report_week <- inputs$metadata$report_week + if (is.null(report_week)) stop("Supply an explicit `report_week`.", call. = FALSE) + alerttools_pipeline( + cases = inputs$cases, climate = inputs$climate, parameters = parameters, + case_records = inputs$case_records, report_week = report_week, + nowcasting = match.arg(nowcast), workers = workers, seed = seed, verbose = verbose + ) +} + +#' Convert an alert result to the persistence schema +#' +#' @param result An `alerttools_result` object. +#' @param version_date Explicit model-version date. +#' @param start_week,end_week Optional inclusive week filter. +#' @return A data frame keyed by `SE`, `municipio_geocodigo`, and `Localidade_id`. +#' @export +as_alert_history <- function(result, version_date, start_week = NULL, end_week = NULL) { + if (!inherits(result, "alerttools_result")) { + stop("`result` must be an alerttools_result.", call. = FALSE) + } + args <- list(obj = result, versao = as.Date(version_date)) + if (!is.null(start_week)) args$iniSE <- start_week + if (!is.null(end_week)) args$lastSE <- end_week + do.call(.as_alert_history_impl, args) +} + +#' Write alert results explicitly +#' +#' @param conn A valid DBI connection. +#' @param result An `alerttools_result` object or an alert-history data frame. +#' @param version_date Explicit model-version date, required when `result` is an +#' `alerttools_result`. +#' @param conflict Conflict policy: `"update"`, `"error"`, or `"ignore"`. +#' @param start_week,end_week Optional inclusive week filter. +#' @param verbose Whether to emit a persistence message. +#' @return `result`, invisibly. +#' @export +write_alert_results <- function(conn, result, version_date = NULL, + conflict = c("update", "error", "ignore"), + start_week = NULL, end_week = NULL, + verbose = FALSE) { + .db_validate_connection(conn) + conflict <- match.arg(conflict) + history <- if (inherits(result, "alerttools_result")) { + if (is.null(version_date)) { + stop("`version_date` is required for an alerttools_result.", call. = FALSE) + } + as_alert_history(result, version_date, start_week, end_week) + } else { + if (!is.data.frame(result)) stop("`result` must be an alerttools_result or data frame.", call. = FALSE) + result + } + .write_alert_results_impl(history, datasource = conn, conflict = conflict, + verbose = verbose) + invisible(result) +} + +#' Upsert alert parameters +#' +#' @param conn A valid DBI connection. +#' @param parameters Parameter data frame keyed by `municipio_geocodigo` and `cid10`. +#' @param conflict Conflict policy: `"update"`, `"error"`, or `"ignore"`. +#' @return The persisted parameter rows. +#' @export +upsert_alert_parameters <- function(conn, parameters, + conflict = c("update", "error", "ignore")) { + .db_validate_connection(conn) + .validate_columns(parameters, c("municipio_geocodigo", "cid10"), "parameters") + if (any(!vapply(as.character(parameters$cid10), function(value) { + identical(.normalize_disease(value), value) + }, logical(1)))) { + stop("`parameters$cid10` must contain canonical CID-10 codes.", call. = FALSE) + } + if (anyDuplicated(parameters[c("municipio_geocodigo", "cid10")])) { + stop("Parameter keys must be unique.", call. = FALSE) + } + conflict <- match.arg(conflict) + .repo_write_rows(conn, "parameters", parameters, + key = c("municipio_geocodigo", "cid10"), conflict = conflict) + observed <- lapply(split(parameters, parameters$cid10), function(rows) { + .repo_parameters(conn, rows$municipio_geocodigo, rows$cid10[[1]]) + }) + dplyr::bind_rows(observed) +} + +# Focused snake_case aliases for pure computational responsibilities. + +#' Estimate the effective reproductive number +#' +#' @param data In-memory weekly data. +#' @param count Name of the count column. +#' @param distribution Generation-time distribution. +#' @param mean_generation_time,sd_generation_time Generation-time parameters. +#' @param ... Additional arguments passed to `Rt()`. +#' @return `data` with `Rt`, interval, and probability columns. +#' @export +estimate_rt <- function(data, count = "casos", distribution = "normal", + mean_generation_time = 3, sd_generation_time = 1, ...) { + .estimate_rt_impl(data, count = count, gtdist = distribution, + meangt = mean_generation_time, sdgt = sd_generation_time, ...) +} + +#' Nowcast weekly cases +#' +#' @param data In-memory weekly case data for one municipality. +#' @param case_records Optional individual notification records. +#' @param method Either `"none"` or `"bayesian"`. +#' @param report_week Explicit report week. +#' @param workers Positive worker count. +#' @param seed Optional deterministic seed. +#' @param verbose Whether to emit progress messages. +#' @param ... Additional nowcasting arguments. +#' @return The weekly data with adjusted-count columns. +#' @export +nowcast_cases <- function(data, case_records = NULL, + method = c("none", "bayesian"), report_week, + workers = 1L, seed = NULL, verbose = FALSE, ...) { + .nowcast_cases_impl(data, datas = case_records, method = match.arg(method), + nowSE = report_week, workers = workers, seed = seed, + verbose = verbose, ...) +} + +#' Define alert rules +#' +#' @param rule Rule identifier. +#' @param values Named parameter vector. +#' @param delays Number of weeks used by delayed criteria. +#' @return A validated list of alert criteria. +#' @export +define_alert_rules <- function(rule, values, delays = 3) { + .define_alert_rules_impl(rule = rule, values = values, delays = delays) +} + +#' Classify epidemiological alerts +#' +#' @param data In-memory epidemiological indicator data. +#' @param rules Rules returned by `define_alert_rules()`. +#' @param missing Whether missing climate values activate the legacy missing-data rule. +#' @param minimum_history Minimum history used by the classifier. +#' @return An object of class `alerta`. +#' @export +classify_alerts <- function(data, rules, missing = FALSE, minimum_history = 8) { + .classify_alerts_impl(data, crit = rules, miss = missing, dy = minimum_history) +} + +# Legacy wrappers ------------------------------------------------------------ + +.deprecate_api <- function(old, replacement) { + lifecycle::deprecate_warn("1.1.0", old, replacement, user_env = parent.frame(2L)) +} + +#' Legacy Rt estimator +#' @param obj,count,gtdist,meangt,sdgt,CI,alpha,a0,b0 Legacy arguments. +#' @export +Rt <- function(obj, count = "casos", gtdist, meangt, sdgt, CI = "beta", + alpha = .95, a0 = 2, b0 = 3) { + .deprecate_api("Rt()", "estimate_rt()") + .estimate_rt_impl(obj, count, gtdist, meangt, sdgt, CI, alpha, a0, b0) +} + +#' Legacy nowcasting interface +#' @param obj,datas,method,pdig,Dmax,nyears,datasource,nowSE,safelimit,seed,workers,verbose,... Legacy arguments. +#' @export +adjustIncidence <- function(obj, datas = NULL, method = "none", + pdig = stats::plnorm((1:20) * 7, 2.5016, 1.1013), + Dmax = 10, nyears = 2, datasource = NULL, nowSE, + safelimit = 5, seed = NULL, workers = 1L, + verbose = FALSE, ...) { + .deprecate_api("adjustIncidence()", "nowcast_cases()") + .nowcast_cases_impl(obj, datas, method, pdig, Dmax, nyears, datasource, + nowSE, safelimit, seed, workers, verbose, ...) +} + +#' Legacy alert-rule constructor +#' @param rule,values,delays Legacy arguments. +#' @export +setCriteria <- function(rule = NULL, values = NULL, delays = 3) { + .deprecate_api("setCriteria()", "define_alert_rules()") + .define_alert_rules_impl(rule, values, delays) +} + +#' Legacy alert classifier +#' @param obj,crit,miss,dy Legacy arguments. +#' @export +fouralert <- function(obj, crit, miss = "last", dy = 4) { + .deprecate_api("fouralert()", "classify_alerts()") + .classify_alerts_impl(obj, crit, miss, dy) +} + +#' Legacy history converter +#' @param obj,iniSE,lastSE,type,versao,parameters Legacy arguments. +#' @export +tabela_historico <- function(obj, iniSE, lastSE, type = "all", versao, + parameters = if (inherits(obj, "alerttools_result")) obj$parameters else attr(obj, "parameters")) { + .deprecate_api("tabela_historico()", "as_alert_history()") + args <- list(obj = obj, type = type, parameters = parameters) + if (!missing(iniSE)) args$iniSE <- iniSE + if (!missing(lastSE)) args$lastSE <- lastSE + if (!missing(versao)) args$versao <- versao + do.call(.as_alert_history_impl, args) +} + +#' Legacy case reader +#' @inheritParams fetch_cases +#' @param cities,lastday,firstday,cid10,dataini,completetail,type,datasource Legacy arguments. +#' @export +getCases <- function(cities, lastday = Sys.Date(), firstday = as.Date("2018-01-01"), + cid10 = "A90", dataini = "notific", completetail = NA, + type = "notified", datasource, verbose = FALSE) { + .deprecate_api("getCases()", "fetch_cases()") + .fetch_cases_impl(cities, lastday, firstday, cid10, dataini, completetail, + type, datasource, verbose) +} + +#' Legacy individual-case reader +#' @param cities,lastday,firstday,cid10,datasource Legacy arguments. +#' @export +getCaseslist <- function(cities, lastday = Sys.Date(), firstday = as.Date("2022-01-01"), + cid10 = "A90", datasource) { + .deprecate_api("getCaseslist()", "fetch_case_records()") + .fetch_case_records_impl(cities, lastday, firstday, cid10, datasource) +} + +#' Legacy climate reader +#' @param cities,vars,finalday,iniSE,lastSE,datasource Legacy arguments. +#' @export +getClima <- function(cities, vars = c("temp_min", "temp_max", "temp_med", "umid_min", "ampT", + "umid_med", "umid_max", "precip_tot", "precip_max"), + finalday = Sys.Date(), iniSE = 201501, lastSE, datasource) { + .deprecate_api("getClima()", "fetch_climate()") + args <- list(cities = cities, vars = vars, finalday = finalday, + iniSE = iniSE, datasource = datasource) + if (!missing(lastSE)) args$lastSE <- lastSE + do.call(.fetch_climate_impl, args) +} + +#' Legacy alert-parameter reader +#' @param cities,cid10,datasource Legacy arguments. +#' @export +read.parameters <- function(cities, cid10 = "A90", datasource) { + .deprecate_api("read.parameters()", "fetch_alert_parameters()") + .fetch_alert_parameters_impl(cities, cid10, datasource) +} + +#' Legacy alert-parameter writer +#' @param city,cid10,params,overwrite,datasource,conflict Legacy arguments. +#' @export +write_parameters <- function(city, cid10, params, overwrite = FALSE, datasource, + conflict = c("ignore", "update", "error")) { + .deprecate_api("write_parameters()", "upsert_alert_parameters()") + .write_parameters_impl(city, cid10, params, overwrite, datasource, conflict) +} + +#' Legacy alert-result writer +#' @param d,writetofile,datasource,arq,conflict Legacy arguments. +#' @export +write_alerta <- function(d, writetofile = FALSE, datasource, arq = "output.sql", + conflict = c("update", "error", "ignore")) { + .deprecate_api("write_alerta()", "write_alert_results()") + args <- list(d = d, writetofile = writetofile, arq = arq, conflict = conflict) + if (!missing(datasource)) args$datasource <- datasource + do.call(.write_alert_results_impl, args) +} diff --git a/R/auxfun_for_Rt.R b/R/auxfun_for_Rt.R index 442765a..4a921f8 100644 --- a/R/auxfun_for_Rt.R +++ b/R/auxfun_for_Rt.R @@ -20,29 +20,29 @@ sum_gamma_dist <- function (y, a, b, K=100){ b1 <- min(b) rho <- sum(a) C <- exp(sum(a*log(b1/b))) - + delta <- gammav <- c(1,rep(0,K)) - + gammav <- sapply(1:K, function(x) {gammak(a,b,x)}) #for (k in 1:K) { # gammav[k] <- gammak(a,b,k) #} - + delta[1] <- 1 - + for (k in 0:(K-1)) { ss2 <- (1:(k+1))*gammav[1:(k+1)]*delta[1+k+1 - (1:(k+1))] delta[(k+1)+1] <- sum(ss2)/(k+1) } - - xx <- log(delta) + - (rho-1 + 1:(K+1))*log(y) -(y/b1) - lgamma(rho+1:(K+1)) - + + xx <- log(delta) + + (rho-1 + 1:(K+1))*log(y) -(y/b1) - lgamma(rho+1:(K+1)) - (rho + 1:(K+1))*log(b1) - gy <- C*sum(exp(xx)) + gy <- C*sum(exp(xx)) gy } -# Function to compute the probability distribution, +# Function to compute the probability distribution, # given by \int_0^{y} f(x) dx # y: the input value # a: shape @@ -76,13 +76,13 @@ int_sum_gamma <- function(y, a, b, K=200, step=.1, max=50) { # p: the probability value # a: shape # b: scale -t_sum_gamma_v3 <- function(p, a, b, K=200, step=.1, max=100, res=.1) { +t_sum_gamma_v3 <- function(p, a, b, K=200, step=.1, max=100, res=.1) { xa <- 0 xb <- max while ((xb-xa)>res) { y <- (xa+xb)/2.0 - px <- int_sum_gamma(y, a, b, max=max) - + px <- int_sum_gamma(y, a, b, max=max) + if (px$yres>p) {xb <- y} else {xa <- y} } @@ -90,7 +90,7 @@ t_sum_gamma_v3 <- function(p, a, b, K=200, step=.1, max=100, res=.1) { } # It is better to rename the function -t_sum_gamma <- function(p, a, b, K=200, step=.1, max=100, res=.1) { +t_sum_gamma <- function(p, a, b, K=200, step=.1, max=100, res=.1) { t_sum_gamma_v3(p, a, b, K, step, max, res) } @@ -100,21 +100,21 @@ t_sum_gamma <- function(p, a, b, K=200, step=.1, max=100, res=.1) { # p: the probability value # a: shape # b: scale -t_sum_gamma_v2 <- function(p, a, b, K=100, step=.1, max=40) { +t_sum_gamma_v2 <- function(p, a, b, K=100, step=.1, max=40) { inc <- .1 y <- 0 px <- 0 while (pxp) tequiv <- rx[rt[1]] @@ -122,7 +122,7 @@ t_sum_gamma_max <- function(p, a, b, K=100, step=.1, max=40) { } -# Function to compute the probability distribution, +# Function to compute the probability distribution, # given by \int_0^{y} f(x) dx # and using time series of temperature values # y: the input value @@ -132,10 +132,10 @@ t_sum_gamma_max <- function(p, a, b, K=100, step=.1, max=40) { # t: time when Temp[t+1] start # Temp has to have length = length(t) + 1 # Temp: 27 21 23 -# t: 4 5 +# t: 4 5 # The idea is to have # P( X <= t) = P(X > t_i) * P(X > t | X> t_i), -# where t_i is the instant in which temperature has changed previous to +# where t_i is the instant in which temperature has changed previous to # time t # Then, P(X>t | X > t_i) has a time rescaling # P(X>t | X > t_i) = 1 - \int_{t_{i}}^{t} f(\tau + t_{equiv} - t_{i}, \mathbf{\theta}, \mathbf{\beta(Temp_i)})/P(X > t_i) @@ -152,26 +152,26 @@ int_sum_gamma_T <- function(y, a, b, Temp, t, K=200, step=.1, max=50, withbreak= if ((withbreak) && (summ>0.999)) { j <- ceiling(i) pdf[j+1] <- pdf[j+1] + 0.0 - res[round(i/step)] <- summ + res[round(i/step)] <- summ } else { b[2] <- 1/lambdaEIP(T=Temp[c]) if (c<=length(t)) { if (i>t[c]) { c <- c+1 - b[2] <- 1/lambdaEIP(T=Temp[c]) + b[2] <- 1/lambdaEIP(T=Temp[c]) tsum <- t_sum_gamma_v3(summ, a, b/unitscale, max=max) tdiff <- tsum - i } - } + } # xx <- sum_gamma_dist(max(i+tdiff, 0),a,b, K)*(step*unitscale) xx <- sum_gamma_dist(max(i+tdiff, 0),a,b/unitscale, K)*(step) - + summ <- summ + xx # j <- ceiling(i/unitscale) j <- ceiling(i) pdf[j+1] <- pdf[j+1] + xx - res[round(i/step)] <- summ + res[round(i/step)] <- summ } } list(yres=res[y/step], dist=res, i=(1:(max/step))*step, pdf = pdf) diff --git a/R/core_pipeline.R b/R/core_pipeline.R new file mode 100644 index 0000000..5d87421 --- /dev/null +++ b/R/core_pipeline.R @@ -0,0 +1,230 @@ +# Pure epidemiological pipeline ---------------------------------------------- + +.validate_workers <- function(workers) { + if (length(workers) != 1L || !is.numeric(workers) || is.na(workers) || + workers < 1 || workers != floor(workers)) { + stop("`workers` must be a positive integer.", call. = FALSE) + } + as.integer(workers) +} + +.with_seed <- function(seed, code) { + if (is.null(seed)) return(force(code)) + if (length(seed) != 1L || !is.numeric(seed) || is.na(seed)) { + stop("`seed` must be NULL or a non-missing numeric scalar.", call. = FALSE) + } + had_seed <- exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE) + if (had_seed) old_seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE) + on.exit({ + if (had_seed) { + assign(".Random.seed", old_seed, envir = .GlobalEnv) + } else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) { + rm(".Random.seed", envir = .GlobalEnv) + } + }, add = TRUE) + set.seed(as.integer(seed)) + force(code) +} + +.map_workers <- function(x, fun, workers = 1L) { + workers <- .validate_workers(workers) + if (workers == 1L || .Platform$OS.type == "windows") return(lapply(x, fun)) + parallel::mclapply(x, fun, mc.cores = workers, mc.preschedule = TRUE) +} + +.validate_columns <- function(data, required, name, allow_empty = FALSE) { + if (!is.data.frame(data)) stop("`", name, "` must be a data frame.", call. = FALSE) + missing_columns <- setdiff(required, names(data)) + if (length(missing_columns)) { + stop("`", name, "` is missing columns: ", paste(missing_columns, collapse = ", "), + call. = FALSE) + } + if (!allow_empty && !nrow(data)) stop("`", name, "` must not be empty.", call. = FALSE) + invisible(data) +} + +#' Calculate incidence from in-memory vectors +#' +#' @param count Numeric vector of case counts. +#' @param population Numeric vector of positive population values. +#' @param scale Incidence scale, conventionally 100,000 inhabitants. +#' @return A numeric incidence vector. +#' @export +calculate_incidence <- function(count, population, scale = 100000) { + if (!is.numeric(count) || !is.numeric(population) || length(count) != length(population)) { + stop("`count` and `population` must be numeric vectors of equal length.", call. = FALSE) + } + if (length(scale) != 1L || !is.numeric(scale) || is.na(scale) || scale <= 0) { + stop("`scale` must be a positive numeric scalar.", call. = FALSE) + } + if (any(count < 0, na.rm = TRUE)) { + stop("`count` must not contain negative values.", call. = FALSE) + } + if (any(population <= 0, na.rm = TRUE)) { + stop("`population` must contain only positive values.", call. = FALSE) + } + count / population * scale +} + +#' Construct an AlertTools pipeline result +#' +#' @param data In-memory epidemiological data frame. +#' @param alerts In-memory alert-index data frame. +#' @param parameters Parameter data frame used by the computation. +#' @param metadata Named list describing the run. +#' @param diagnostics Named list of diagnostic information. +#' @return An object of class `alerttools_result`. +#' @export +new_alerttools_result <- function(data, alerts, parameters, + metadata = list(), diagnostics = list()) { + .validate_columns(data, character(), "data", allow_empty = TRUE) + .validate_columns(alerts, character(), "alerts", allow_empty = TRUE) + .validate_columns(parameters, character(), "parameters", allow_empty = TRUE) + if (anyDuplicated(names(data)) || anyDuplicated(names(alerts)) || + anyDuplicated(names(parameters))) { + stop("Result data frames must not contain duplicate column names.", call. = FALSE) + } + if (nrow(data) != nrow(alerts)) { + stop("`data` and `alerts` must have the same number of rows.", call. = FALSE) + } + if (!is.list(metadata) || (length(metadata) && is.null(names(metadata)))) { + stop("`metadata` must be a named list.", call. = FALSE) + } + if (!is.list(diagnostics) || (length(diagnostics) && is.null(names(diagnostics)))) { + stop("`diagnostics` must be a named list.", call. = FALSE) + } + structure( + list(data = data, alerts = alerts, parameters = parameters, + metadata = metadata, diagnostics = diagnostics), + class = "alerttools_result" + ) +} + +#' Run the pure in-memory AlertTools pipeline +#' +#' This function performs no database or file access and does not depend on the +#' current working directory. +#' +#' @param cases Weekly case data using the `getCases()` domain schema. +#' @param climate Weekly municipal climate data with `SE` and `geocodigo`. +#' @param parameters Alert parameters, one row per municipality and disease. +#' @param case_records Optional individual notification records for Bayesian +#' nowcasting. +#' @param report_week Epidemiological week through which to compute results. +#' @param nowcasting Either `"none"` or `"bayesian"`. +#' @param workers Positive number of workers. The default is portable and serial. +#' @param seed Optional deterministic seed for stochastic nowcasting. +#' @param verbose Whether orchestration should emit progress messages. +#' @return An `alerttools_result` object. +#' @export +alerttools_pipeline <- function(cases, climate, parameters, case_records = NULL, + report_week = max(cases$SE), + nowcasting = c("none", "bayesian"), + workers = 1L, seed = NULL, verbose = FALSE) { + nowcasting <- match.arg(nowcasting) + workers <- .validate_workers(workers) + if (!is.logical(verbose) || length(verbose) != 1L || is.na(verbose)) { + stop("`verbose` must be TRUE or FALSE.", call. = FALSE) + } + .validate_columns( + cases, + c("SE", "cidade", "CID10", "casos", "cas_prov", "cas_lab", + "localidade", "nome", "pop"), + "cases" + ) + .validate_columns(climate, c("SE", "geocodigo"), "climate") + .validate_columns( + parameters, + c("municipio_geocodigo", "limiar_preseason", "limiar_epidemico", + "varcli", "clicrit", "cid10", "codmodelo"), + "parameters" + ) + if (length(report_week) != 1L || !is.numeric(report_week) || is.na(report_week)) { + stop("`report_week` must be one epidemiological week.", call. = FALSE) + } + .validate_epiweek(report_week) + if (nowcasting == "bayesian" && is.null(case_records)) { + stop("Bayesian nowcasting requires in-memory `case_records`.", call. = FALSE) + } + + input <- dplyr::left_join(cases, climate, by = c("cidade" = "geocodigo", "SE" = "SE")) + if (!"tweet" %in% names(input)) input$tweet <- NA_real_ + input$inc <- calculate_incidence(input$casos, input$pop) + cities <- unique(as.numeric(parameters$municipio_geocodigo)) + if (!all(cities %in% input$cidade)) { + stop("Parameters contain municipalities absent from `cases`.", call. = FALSE) + } + if (!all(parameters$cid10 %in% input$CID10)) { + stop("Parameters contain diseases absent from `cases`.", call. = FALSE) + } + + compute_city <- function(city) { + city_data <- input[input$cidade == city & input$SE <= report_week, , drop = FALSE] + city_parameters <- parameters[parameters$municipio_geocodigo == city, , drop = FALSE] + if (nrow(city_parameters) != 1L) { + stop("Each municipality must have exactly one parameter row.", call. = FALSE) + } + records <- if (is.null(case_records)) NULL else { + case_records[case_records$municipio_geocodigo == city, , drop = FALSE] + } + city_seed <- if (is.null(seed)) NULL else seed + match(city, cities) - 1L + adjusted <- nowcast_cases( + city_data, case_records = records, method = nowcasting, report_week = report_week, + seed = city_seed, workers = workers, verbose = verbose + ) + estimated <- estimate_rt(adjusted, count = "tcasesmed", distribution = "normal", + mean_generation_time = 3, sd_generation_time = 1) + estimated$inc <- calculate_incidence(estimated$tcasesmed, estimated$pop) + values <- structure(as.character(city_parameters[1, ]), names = names(city_parameters)) + criteria <- define_alert_rules(rule = city_parameters$codmodelo[[1]], values = values) + alert <- classify_alerts(estimated, rules = criteria, + missing = "last", minimum_history = 4) + list(data = alert$data, alerts = alert$indices, criteria = criteria) + } + + computed <- .with_seed(seed, .map_workers(cities, compute_city, workers)) + data <- dplyr::bind_rows(lapply(computed, `[[`, "data")) + alerts <- dplyr::bind_rows(lapply(computed, `[[`, "alerts")) + diagnostics <- list( + cities = length(cities), + rows = nrow(data), + missing_climate = sum(!stats::complete.cases(input[setdiff(names(climate), c("SE", "geocodigo"))])) + ) + metadata <- list( + report_week = as.numeric(report_week), nowcasting = nowcasting, + workers = workers, seed = seed, deterministic = nowcasting == "none" || !is.null(seed) + ) + new_alerttools_result(data, alerts, parameters, metadata, diagnostics) +} + +#' @export +print.alerttools_result <- function(x, ...) { + cat("\n") + cat(" rows:", nrow(x$data), "\n") + cat(" municipalities:", x$diagnostics$cities %||% length(unique(x$data$cidade)), "\n") + cat(" report week:", x$metadata$report_week %||% NA, "\n") + invisible(x) +} + +#' @export +summary.alerttools_result <- function(object, ...) { + levels <- if ("level" %in% names(object$alerts)) { + table(factor(object$alerts$level, levels = 1:4), useNA = "ifany") + } else integer() + list( + rows = nrow(object$data), + municipalities = object$diagnostics$cities %||% length(unique(object$data$cidade)), + alert_levels = levels, + metadata = object$metadata, + diagnostics = object$diagnostics + ) +} + +#' @export +as.data.frame.alerttools_result <- function(x, row.names = NULL, optional = FALSE, ...) { + duplicate <- intersect(names(x$data), names(x$alerts)) + alerts <- x$alerts[setdiff(names(x$alerts), duplicate)] + as.data.frame(cbind(x$data, alerts), row.names = row.names, optional = optional) +} + +`%||%` <- function(x, y) if (is.null(x)) y else x diff --git a/R/data.R b/R/data.R new file mode 100644 index 0000000..7c9525b --- /dev/null +++ b/R/data.R @@ -0,0 +1,14 @@ +#' Example and reference datasets +#' +#' Legacy datasets bundled with AlertTools. `SE` contains the epidemiological +#' calendar currently used by the date conversion helpers. The remaining +#' objects are historical examples retained for compatibility and should not +#' be interpreted as current operational data. +#' +#' @format Objects with structures specific to their historical examples. Use +#' `utils::data()` and inspect an object with `str()` before use. +#' @source AlertTools historical package data. +#' @aliases WUdata bairro2APS cliSBCB locs sinan tw +#' @name SE +#' @docType data +NULL diff --git a/R/data_repository.R b/R/data_repository.R new file mode 100644 index 0000000..8253f39 --- /dev/null +++ b/R/data_repository.R @@ -0,0 +1,309 @@ +# Internal database boundary ------------------------------------------------- + +.db_table_config <- list( + notifications = list(postgres = c("Municipio", "Notificacao"), sqlite = "Notificacao"), + municipalities = list(postgres = c("Dengue_global", "Municipio"), sqlite = "Municipio"), + station_catalog = list(postgres = c("Municipio", "Estacao_wu"), sqlite = "estacao_wu"), + station_climate = list(postgres = c("Municipio", "Clima_wu"), sqlite = "wu"), + municipal_climate = list(postgres = c("weather", "copernicus_bra"), sqlite = "copernicus_bra"), + tweets = list(postgres = c("Municipio", "Tweet"), sqlite = "tweet"), + parameters = list(postgres = c("Dengue_global", "parameters"), sqlite = "parameters"), + regional_health = list(postgres = c("Dengue_global", "regional_saude"), sqlite = "regional_saude"), + alert_dengue = list(postgres = c("Municipio", "Historico_alerta"), sqlite = "Historico_alerta"), + alert_chik = list(postgres = c("Municipio", "Historico_alerta_chik"), sqlite = "Historico_alerta_chik"), + alert_zika = list(postgres = c("Municipio", "Historico_alerta_zika"), sqlite = "Historico_alerta_zika") +) + +.db_validate_connection <- function(conn) { + if (missing(conn) || is.null(conn) || !inherits(conn, "DBIConnection") || + !DBI::dbIsValid(conn)) { + stop("A valid DBI connection must be supplied in `conn`/`datasource`.", call. = FALSE) + } + invisible(conn) +} + +.db_backend <- function(conn) { + .db_validate_connection(conn) + if (inherits(conn, "SQLiteConnection")) return("sqlite") + if (inherits(conn, c("PqConnection", "PostgreSQLConnection"))) return("postgres") + stop("Unsupported database backend; use SQLite or PostgreSQL.", call. = FALSE) +} + +.db_table <- function(conn, key) { + config <- .db_table_config[[key]] + if (is.null(config)) stop("Unknown repository table: ", key, call. = FALSE) + location <- config[[.db_backend(conn)]] + identifier <- if (length(location) == 2L) { + DBI::Id(schema = location[[1]], table = location[[2]]) + } else { + DBI::Id(table = location[[1]]) + } + as.character(DBI::dbQuoteIdentifier(conn, identifier)) +} + +.db_columns <- function(conn, columns) { + paste(as.character(DBI::dbQuoteIdentifier(conn, columns)), collapse = ", ") +} + +.db_placeholders <- function(conn, count, offset = 0L) { + if (.db_backend(conn) == "postgres") { + paste0("$", seq_len(count) + offset) + } else { + rep("?", count) + } +} + +.db_in_clause <- function(conn, values, offset = 0L) { + if (!length(values)) stop("Repository filters must not be empty.", call. = FALSE) + paste0("(", paste(.db_placeholders(conn, length(values), offset), collapse = ", "), ")") +} + +.db_date_param <- function(conn, value) { + value <- as.Date(value) + if (length(value) != 1L || is.na(value)) stop("Dates must be valid scalar values.", call. = FALSE) + if (.db_backend(conn) == "sqlite") as.numeric(value) else value +} + +.db_normalize_dates <- function(data, columns) { + for (column in intersect(columns, names(data))) { + if (!inherits(data[[column]], "Date")) { + data[[column]] <- if (is.numeric(data[[column]])) { + as.Date(data[[column]], origin = "1970-01-01") + } else { + as.Date(data[[column]]) + } + } + } + data +} + +.normalize_cid <- function(cid10) { + if (identical(cid10, "A90")) return(list(canonical = "A90", values = "A90")) + if (cid10 %in% c("A92", "A920", "A92.0")) { + return(list(canonical = "A92.0", values = c("A92", "A920", "A92.0"))) + } + if (cid10 %in% c("A92.8", "A928")) { + return(list(canonical = "A92.8", values = c("A92.8", "A928"))) + } + stop("Unknown CID-10: ", cid10, call. = FALSE) +} + +.repo_notifications <- function(conn, cities, cids, firstday = NULL, + lastday = NULL, start_year = NULL, + end_year = NULL, columns = "*") { + .db_validate_connection(conn) + cities <- as.numeric(cities) + if (!length(cities) || anyNA(cities)) stop("`cities` must contain geocodes.", call. = FALSE) + if (!length(cids) || anyNA(cids)) stop("`cids` must contain disease codes.", call. = FALSE) + + selected <- if (identical(columns, "*")) "*" else .db_columns(conn, columns) + params <- c(as.list(cities), as.list(as.character(cids))) + city_filter <- .db_in_clause(conn, cities) + cid_filter <- .db_in_clause(conn, cids, length(cities)) + where <- c( + paste0(.db_columns(conn, "municipio_geocodigo"), " IN ", city_filter), + paste0(.db_columns(conn, "cid10_codigo"), " IN ", cid_filter) + ) + offset <- length(params) + if (!is.null(firstday)) { + where <- c(where, paste0(.db_columns(conn, "dt_digita"), " >= ", + .db_placeholders(conn, 1L, offset))) + params <- c(params, list(.db_date_param(conn, firstday))) + offset <- offset + 1L + } + if (!is.null(lastday)) { + where <- c(where, paste0(.db_columns(conn, "dt_digita"), " <= ", + .db_placeholders(conn, 1L, offset))) + params <- c(params, list(.db_date_param(conn, lastday))) + offset <- offset + 1L + } + if (!is.null(start_year)) { + where <- c(where, paste0(.db_columns(conn, "ano_notif"), " >= ", + .db_placeholders(conn, 1L, offset))) + params <- c(params, list(as.integer(start_year))) + offset <- offset + 1L + } + if (!is.null(end_year)) { + where <- c(where, paste0(.db_columns(conn, "ano_notif"), " <= ", + .db_placeholders(conn, 1L, offset))) + params <- c(params, list(as.integer(end_year))) + } + + sql <- paste("SELECT", selected, "FROM", .db_table(conn, "notifications"), + "WHERE", paste(where, collapse = " AND ")) + result <- DBI::dbGetQuery(conn, sql, params = unname(params)) + .db_normalize_dates(result, c("dt_notific", "dt_sin_pri", "dt_digita")) +} + +.repo_municipalities <- function(conn, cities = NULL, uf = NULL, + regional = NULL, macroregional = NULL, + columns = c("geocodigo", "nome", "populacao")) { + .db_validate_connection(conn) + filters <- list() + params <- list() + add_filter <- function(column, values) { + offset <- length(params) + filters <<- c(filters, paste0(.db_columns(conn, column), " IN ", + .db_in_clause(conn, values, offset))) + params <<- c(params, as.list(values)) + } + if (!is.null(cities)) add_filter("geocodigo", as.numeric(cities)) + if (!is.null(uf)) add_filter("uf", as.character(uf)) + if (!is.null(regional)) add_filter("regional", as.character(regional)) + if (!is.null(macroregional)) add_filter("macroregional", as.character(macroregional)) + + sql <- paste("SELECT", .db_columns(conn, columns), "FROM", + .db_table(conn, "municipalities")) + if (length(filters)) sql <- paste(sql, "WHERE", paste(filters, collapse = " AND ")) + DBI::dbGetQuery(conn, sql, params = unname(params)) +} + +.repo_parameters <- function(conn, cities, cid10 = NULL) { + .db_validate_connection(conn) + params <- as.list(as.numeric(cities)) + filters <- paste0(.db_columns(conn, "municipio_geocodigo"), " IN ", + .db_in_clause(conn, cities)) + if (!is.null(cid10)) { + filters <- c(filters, paste0(.db_columns(conn, "cid10"), " = ", + .db_placeholders(conn, 1L, length(params)))) + params <- c(params, list(as.character(cid10))) + } + sql <- paste("SELECT * FROM", .db_table(conn, "parameters"), "WHERE", + paste(filters, collapse = " AND ")) + DBI::dbGetQuery(conn, sql, params = unname(params)) +} + +.repo_station_links <- function(conn, cities) { + params <- as.list(as.numeric(cities)) + sql <- paste( + "SELECT", .db_columns(conn, c("municipio_geocodigo", "codigo_estacao_wu", "estacao_wu_sec")), + "FROM", .db_table(conn, "parameters"), + "WHERE", paste0(.db_columns(conn, "municipio_geocodigo"), " IN ", + .db_in_clause(conn, cities)) + ) + DBI::dbGetQuery(conn, sql, params = unname(params)) +} + +.repo_station_catalog <- function(conn, stations) { + if (.db_backend(conn) == "sqlite") { + return(data.frame(estacao_id = as.character(stations), nome = as.character(stations))) + } + sql <- paste("SELECT", .db_columns(conn, c("estacao_id", "nome")), "FROM", + .db_table(conn, "station_catalog"), "WHERE", + paste0(.db_columns(conn, "estacao_id"), " IN ", .db_in_clause(conn, stations))) + DBI::dbGetQuery(conn, sql, params = as.list(as.character(stations))) +} + +.repo_station_climate <- function(conn, stations, lastday) { + station_column <- "Estacao_wu_estacao_id" + params <- c(as.list(as.character(stations)), list(.db_date_param(conn, lastday))) + sql <- paste( + "SELECT * FROM", .db_table(conn, "station_climate"), "WHERE", + paste0(.db_columns(conn, station_column), " IN ", .db_in_clause(conn, stations)), + "AND", paste0(.db_columns(conn, "data_dia"), " <= ", + .db_placeholders(conn, 1L, length(stations))) + ) + result <- DBI::dbGetQuery(conn, sql, params = unname(params)) + .db_normalize_dates(result, "data_dia") +} + +.repo_municipal_climate <- function(conn, cities, columns, firstday, lastday) { + params <- c(as.list(as.numeric(cities)), list(.db_date_param(conn, firstday), + .db_date_param(conn, lastday))) + offset <- length(cities) + sql <- paste( + "SELECT", .db_columns(conn, columns), "FROM", .db_table(conn, "municipal_climate"), + "WHERE", paste0(.db_columns(conn, "geocode"), " IN ", .db_in_clause(conn, cities)), + "AND", paste0(.db_columns(conn, "date"), " >= ", .db_placeholders(conn, 1L, offset)), + "AND", paste0(.db_columns(conn, "date"), " <= ", .db_placeholders(conn, 1L, offset + 1L)) + ) + result <- DBI::dbGetQuery(conn, sql, params = unname(params)) + .db_normalize_dates(result, "date") +} + +.repo_tweets <- function(conn, cities, lastday) { + params <- c(as.list(as.numeric(cities)), list(.db_date_param(conn, lastday))) + city_column <- "Municipio_geocodigo" + sql <- paste( + "SELECT", .db_columns(conn, c(city_column, "data_dia", "numero")), + "FROM", .db_table(conn, "tweets"), "WHERE", + paste0(.db_columns(conn, city_column), " IN ", .db_in_clause(conn, cities)), + "AND", paste0(.db_columns(conn, "data_dia"), " <= ", + .db_placeholders(conn, 1L, length(cities))) + ) + result <- DBI::dbGetQuery(conn, sql, params = unname(params)) + .db_normalize_dates(result, "data_dia") +} + +.repo_regional_health <- function(conn, cities) { + columns <- c("id", "nome_regional", "municipio_geocodigo", + "codigo_estacao_wu", "estacao_wu_sec") + sql <- paste("SELECT", .db_columns(conn, columns), "FROM", + .db_table(conn, "regional_health"), "WHERE", + paste0(.db_columns(conn, "municipio_geocodigo"), " IN ", + .db_in_clause(conn, cities))) + DBI::dbGetQuery(conn, sql, params = as.list(as.numeric(cities))) +} + +.repo_write_rows <- function(conn, table, data, key, conflict = c("error", "update", "ignore")) { + .db_validate_connection(conn) + conflict <- match.arg(conflict) + if (!is.data.frame(data) || !nrow(data)) stop("`data` must contain at least one row.", call. = FALSE) + if (!all(key %in% names(data))) stop("Conflict keys are missing from `data`.", call. = FALSE) + + target <- .db_table(conn, table) + columns <- names(data) + quoted_columns <- as.character(DBI::dbQuoteIdentifier(conn, columns)) + temp_name <- "alerttools_stage" + temp_id <- DBI::Id(table = temp_name) + temp_table <- as.character(DBI::dbQuoteIdentifier(conn, temp_id)) + + DBI::dbWithTransaction(conn, { + DBI::dbWriteTable(conn, temp_id, data, temporary = TRUE, overwrite = TRUE) + on.exit(try(DBI::dbRemoveTable(conn, temp_id), silent = TRUE), add = TRUE) + sql <- paste("INSERT INTO", target, paste0("(", paste(quoted_columns, collapse = ", "), ")"), + "SELECT", paste(quoted_columns, collapse = ", "), "FROM", temp_table, + "WHERE 1 = 1") + if (conflict != "error") { + quoted_key <- as.character(DBI::dbQuoteIdentifier(conn, key)) + sql <- paste(sql, "ON CONFLICT", paste0("(", paste(quoted_key, collapse = ", "), ")")) + if (conflict == "ignore") { + sql <- paste(sql, "DO NOTHING") + } else { + updates <- setdiff(columns, key) + if (!length(updates)) stop("Update policy requires at least one non-key column.", call. = FALSE) + quoted_updates <- as.character(DBI::dbQuoteIdentifier(conn, updates)) + assignments <- paste0(quoted_updates, " = excluded.", quoted_updates) + sql <- paste(sql, "DO UPDATE SET", paste(assignments, collapse = ", ")) + } + } + DBI::dbExecute(conn, sql) + }) +} + +.repo_update_station_links <- function(conn, data) { + .db_validate_connection(conn) + required <- c("municipio_geocodigo", "codigo_estacao_wu", "estacao_wu_sec") + if (!is.data.frame(data) || !nrow(data) || !all(required %in% names(data))) { + stop("Station link data has an invalid schema.", call. = FALSE) + } + data <- data[required] + target <- .db_table(conn, "parameters") + stage_id <- DBI::Id(table = "alerttools_station_stage") + stage <- as.character(DBI::dbQuoteIdentifier(conn, stage_id)) + city <- .db_columns(conn, "municipio_geocodigo") + primary <- .db_columns(conn, "codigo_estacao_wu") + secondary <- .db_columns(conn, "estacao_wu_sec") + + DBI::dbWithTransaction(conn, { + DBI::dbWriteTable(conn, stage_id, data, temporary = TRUE, overwrite = TRUE) + on.exit(try(DBI::dbRemoveTable(conn, stage_id), silent = TRUE), add = TRUE) + sql <- paste( + "UPDATE", target, "SET", + paste0(primary, " = stage.", primary, ", ", secondary, " = stage.", secondary), + "FROM", stage, "AS stage WHERE", + paste0(target, ".", city, " = stage.", city) + ) + DBI::dbExecute(conn, sql) + }) +} diff --git a/R/dengue-mem.R b/R/dengue-mem.R index 6dfbf34..ecfc207 100755 --- a/R/dengue-mem.R +++ b/R/dengue-mem.R @@ -22,7 +22,7 @@ bindseason <- function(df1=data.frame(), df2=data.frame(), baseyear=integer()){ :df3: data.frame df2 with 2 new colums from df1$SE and df1$inc based on df1$SE within season of base year, which is from winter of baseyear to winter of baseyear+1 (south hemisphere). " - + if (missing(df1) | missing(df2) | missing(baseyear)){ #logerror('missing argument on function call', logger='dengue-mem.bindseason') return(NULL) @@ -36,100 +36,88 @@ bindseason <- function(df1=data.frame(), df2=data.frame(), baseyear=integer()){ newse <- paste0('SE',suff) newinc <- suff df3 <- plyr::rename(df3, c('SE'=newse, 'inc'=newinc)) - + #loginfo('Function executed and exited with status 0', logger='dengue-mem.bindseason') return(df3) } # applymem ------------------------------------ -#'@description Function to apply epimem algorithm on df.data and generate full -#'reports as well as a data frame with summary of relevant thresholds (pre, pos, mid, high, veryhigh) +#'@description Function to apply epimem algorithm on df.data and generate full +#'reports as well as a data frame with summary of relevant thresholds (pre, pos, mid, high, veryhigh) #'@title Get epidemic thresholds for a list of cities #'@param df.data data frame with municipio_geocodigo in a column named municipio_geocodigo, #' and incidence seasons in each column each row gives the incidence in each season, #' for each municipio_geocodigo, for each week. -#'@param l.seasons vector with incidence columns to be used. Additional arguments +#'@param l.seasons vector with incidence columns to be used. Additional arguments #'accepted by memmodel function -#' @param i.n.max Number of pre-epidemic values used to calculate the threshold. -#' @param i.type.curve Type of confidence interval to calculate the modelled curve. -#' @param i.level.threshold Level of confidence interval to calculate the threshold. -#' @param i.level.curve Level of confidence interval to calculate the modelled curve. -#' @param i.data Data frame of input data. -#' @param i.seasons Maximum number of seasons to use. -#' @param i.type.threshold Type of confidence interval to calculate the threshold. -#' @param i.tails.threshold Tails for the confidence interval to calculate the threshold. -#' @param i.type.intensity Type of confidence interval to calculate the intensity thresholds. -#' @param i.level.intensity Levels of confidence interval to calculate the intensity thresholds. -#' @param i.tails.intensity Tails for the confidence interval to calculate the threshold. -#' @param i.type.other Type of confidence interval to calculate length, start and percentages. -#' @param i.level.other Level of confidence interval to calculate length, start and percentages. -#' @param i.method Method to calculate the optimal timing of the epidemic. -#' @param i.param Parameter to calculate the optimal timing of the epidemic. -#' @param i.type.boot Type of bootstrap technique. -#' @param i.iter.boot Number of bootstrap iterations. +#'@param typicalcurve Whether to retain the typical epidemic curve. +#'@param ... Additional arguments passed to `mem::memmodel()`. #'@author Marcelo F Gomes -#'@details internal function, used by info.dengue.apply.mem. Defatul arguments +#'@details internal function, used by info.dengue.apply.mem. Defatul arguments #'passed to memmodel function: #'@return epithresholds: list with full epimem report for each municipio_geocodigo, #' keyed by AP's name. dfthresholds: data frame with thresholds for each AP. applymem <- function(df.data, l.seasons, typicalcurve = FALSE, ...){ + if (!requireNamespace("mem", quietly = TRUE)) { + stop("applymem requires the optional package 'mem'.", call. = FALSE) + } if (missing(df.data)){ #logerror('missing argument on function call', logger='dengue-mem.applymem') message('missing argument on function call: applymem') return(NULL) } - + # List of municipio_geocodigos municipio_geocodigoids <- unique(df.data$municipio_geocodigo) - + # Prepare output objects epithresholds <- list() df.typ.real.curve <-data.frame() # Typical seasonal curve dfthresholds <- data.frame(municipio_geocodigoids) dfthresholds <- plyr::rename(dfthresholds, c('municipio_geocodigoids'='municipio_geocodigo')) - + dfthresholds['pre'] <- NULL # Pre-epidemic threshold (at .95 confidence interval by default) dfthresholds['pos'] <- NULL # Post-epidemic threshold dfthresholds['veryhigh'] <- NULL # Very high activity threshold (corresponding to 0.95 quantile by default) dfthresholds['inicio'] <- NULL # Typical begining of epidemic activity dfthresholds['duracao'] <- NULL # Typical duration - + for (geocodid in municipio_geocodigoids){ f <- function(geocod, l.seasons, ...){ # Firstly, use all seasons df.geocodid <- df.data[df.data$municipio_geocodigo==geocod, l.seasons] non.null.seasons <- df.geocodid[, colSums(df.geocodid)>0] l.seasons.geocodid <- names(non.null.seasons) - epitmp <- memmodel(i.data=non.null.seasons, ...) - + epitmp <- mem::memmodel(i.data=non.null.seasons, ...) + # Discard seasons that are below threshold and rerun. # This is useful for properly defining activity levels during an epidemic discard <- NULL prethreshold <- epitmp$pre.post.intervals[1,3] postthreshold <- epitmp$pre.post.intervals[2,3] - epitmp$typ.real.curve <- epitmp$typ.curve + epitmp$typ.real.curve <- epitmp$typ.curve typ.real.curve <- plyr::rename(data.frame(epitmp$typ.real.curve), c('X1'='baixo', 'X2'='mediano' ,'X3'='alto')) # Clean typical curve: typ.real.curve$mediano[is.na(typ.real.curve$mediano)] <- 0 typ.real.curve$baixo[typ.real.curve$baixo < 0] <- 0 typ.real.curve$baixo[is.na(typ.real.curve$baixo)] <- typ.real.curve$mediano[is.na(typ.real.curve$baixo)] typ.real.curve$alto[is.na(typ.real.curve$alto)] <- typ.real.curve$mediano[is.na(typ.real.curve$alto)] - + episeasons <- sapply(non.null.seasons, max, na.rm=TRUE) > prethreshold - epitmp <- memmodel(i.data=non.null.seasons[, episeasons], ...) - epitmp$typ.real.curve <- epitmp$typ.curve + epitmp <- mem::memmodel(i.data=non.null.seasons[, episeasons], ...) + epitmp$typ.real.curve <- epitmp$typ.curve prethreshold <- epitmp$pre.post.intervals[1,3] postthreshold <- epitmp$pre.post.intervals[2,3] - + # Store full report in epithresholds: epithresholds[[geocod]] <- epitmp - + # Store typical curves from full set of seasons epithresholds[[geocod]]$typ.real.curve <- typ.real.curve epithresholds[[geocod]]$typ.real.curve['SE'] <- c(seq(41,52), seq(1,40)) - + # Store epidemic thresholds dfthresholds$pre[dfthresholds$municipio_geocodigo==geocod] <- prethreshold dfthresholds$pos[dfthresholds$municipio_geocodigo==geocod] <- postthreshold @@ -153,13 +141,13 @@ applymem <- function(df.data, l.seasons, typicalcurve = FALSE, ...){ epitmp$ci.length[1,3], ']') return(list("epithresholds.tmp"=epithresholds, "dfthresholds.tmp"=dfthresholds)) } - + res <- try(f(geocod=geocodid, l.seasons=l.seasons, ...), TRUE) if (!inherits(res, "try-error")){ epithresholds <- res$epithresholds.tmp dfthresholds <- res$dfthresholds } - + } #loginfo('Function executed and exited with status 0!', logger='dengue-mem.applymem') return(list("epimemthresholds"=epithresholds, "dfthresholds"=dfthresholds)) @@ -170,53 +158,55 @@ applymem <- function(df.data, l.seasons, typicalcurve = FALSE, ...){ ## teste de funcao para retornar curva tipica mem (usar em infodengue_apply_mem::memcurve) fit.mem <- function(df.data, l.seasons, ...){ + if (!requireNamespace("mem", quietly = TRUE)) { + stop("fit.mem requires the optional package 'mem'.", call. = FALSE) + } if (missing(df.data)){ #logerror('missing argument on function call', logger='dengue-mem.applymem') message('missing argument on function call: applymem') return(NULL) } - + # List of municipio_geocodigos (1 so!) geocodid <- unique(df.data$municipio_geocodigo) - + # Prepare output objects epithresholds <- list() df.typ.real.curve <-data.frame() # Typical seasonal curve dfthresholds <- data.frame(geocodid) dfthresholds <- plyr::rename(dfthresholds, c('geocodid'='municipio_geocodigo')) - + dfthresholds['pre'] <- NULL # Pre-epidemic threshold (at .95 confidence interval by default) dfthresholds['pos'] <- NULL # Post-epidemic threshold dfthresholds['veryhigh'] <- NULL # Very high activity threshold (corresponding to 0.95 quantile by default) dfthresholds['inicio'] <- NULL # Typical begining of epidemic activity dfthresholds['duracao'] <- NULL # Typical duration - + # Firstly, use all seasons df.geocodid <- df.data[df.data$municipio_geocodigo==geocodid, l.seasons] non.null.seasons <- df.geocodid[, colSums(df.geocodid)>0] l.seasons.geocodid <- names(non.null.seasons) - epitmp <- memmodel(i.data=non.null.seasons, ...) - + epitmp <- mem::memmodel(i.data=non.null.seasons, ...) + # Discard seasons that are below threshold and rerun. # This is useful for properly defining activity levels during an epidemic discard <- NULL prethreshold <- epitmp$pre.post.intervals[1,3] postthreshold <- epitmp$pre.post.intervals[2,3] - epitmp$typ.real.curve <- epitmp$typ.curve + epitmp$typ.real.curve <- epitmp$typ.curve typ.real.curve <- plyr::rename(data.frame(epitmp$typ.real.curve), c('X1'='baixo', 'X2'='mediano' ,'X3'='alto')) # Clean typical curve: typ.real.curve$mediano[is.na(typ.real.curve$mediano)] <- 0 typ.real.curve$baixo[typ.real.curve$baixo < 0] <- 0 typ.real.curve$baixo[is.na(typ.real.curve$baixo)] <- typ.real.curve$mediano[is.na(typ.real.curve$baixo)] typ.real.curve$alto[is.na(typ.real.curve$alto)] <- typ.real.curve$mediano[is.na(typ.real.curve$alto)] - + episeasons <- sapply(non.null.seasons, max, na.rm=TRUE) > prethreshold - epitmp <- memmodel(i.data=non.null.seasons[, episeasons], ...) - epitmp$typ.real.curve <- epitmp$typ.curve - - + epitmp <- mem::memmodel(i.data=non.null.seasons[, episeasons], ...) + epitmp$typ.real.curve <- epitmp$typ.curve + + return(epitmp$typ.real.curve) } - - + diff --git a/R/epiweek.R b/R/epiweek.R new file mode 100644 index 0000000..8ada329 --- /dev/null +++ b/R/epiweek.R @@ -0,0 +1,90 @@ +# Algorithmic epidemiological calendar -------------------------------------- + +.epi_year_start <- function(year) { + year <- as.integer(year) + january_fourth <- as.Date(sprintf("%04d-01-04", year)) + january_fourth - as.integer(format(january_fourth, "%w")) +} + +.validate_epiweek <- function(x) { + if (!is.numeric(x) || any(!is.finite(x) & !is.na(x)) || + any(x != floor(x), na.rm = TRUE)) { + stop("Epidemiological weeks must be finite integers in YYYYWW format.", call. = FALSE) + } + valid <- !is.na(x) + year <- floor(x[valid] / 100) + week <- x[valid] %% 100 + maximum <- as.integer((.epi_year_start(year + 1L) - .epi_year_start(year)) / 7) + invalid <- year < 1L | week < 1L | week > maximum + if (any(invalid)) { + stop("Invalid epidemiological week: ", paste(x[valid][invalid], collapse = ", "), call. = FALSE) + } + invisible(x) +} + +#' Convert dates to epidemiological weeks +#' +#' Uses the Brazilian Sunday-to-Saturday convention in which epidemiological +#' week 1 is the week containing 4 January. +#' +#' @param x A vector coercible to `Date`. +#' @param format Format used for character input. +#' @return An integer vector in `YYYYWW` format. +#' @export +#' @examples +#' as_epiweek(as.Date(c("2020-12-27", "2021-01-03"))) +as_epiweek <- function(x, format = "%Y-%m-%d") { + dates <- if (inherits(x, "Date")) x else as.Date(x, format = format) + result <- rep(NA_integer_, length(dates)) + valid <- !is.na(dates) + if (!any(valid)) return(result) + + calendar_year <- as.integer(format(dates[valid], "%Y")) + start <- .epi_year_start(calendar_year) + epi_year <- calendar_year + before <- dates[valid] < start + epi_year[before] <- epi_year[before] - 1L + next_start <- .epi_year_start(epi_year + 1L) + after <- dates[valid] >= next_start + epi_year[after] <- epi_year[after] + 1L + start <- .epi_year_start(epi_year) + week <- as.integer(as.numeric(dates[valid] - start) %/% 7) + 1L + result[valid] <- epi_year * 100L + week + result +} + +#' Return the start date of epidemiological weeks +#' +#' @param x Epidemiological weeks in `YYYYWW` format. +#' @return A `Date` vector containing Sundays. +#' @export +#' @examples +#' epiweek_start(c(202052, 202101)) +epiweek_start <- function(x) { + .validate_epiweek(x) + result <- as.Date(rep(NA_real_, length(x)), origin = "1970-01-01") + valid <- !is.na(x) + year <- floor(x[valid] / 100) + week <- x[valid] %% 100 + result[valid] <- .epi_year_start(year) + (week - 1L) * 7L + result +} + +#' Create an inclusive epidemiological-week sequence +#' +#' @param from First epidemiological week in `YYYYWW` format. +#' @param to Last epidemiological week in `YYYYWW` format. +#' @return An integer vector of epidemiological weeks. +#' @export +#' @examples +#' epiweek_seq(202052, 202101) +epiweek_seq <- function(from, to) { + .validate_epiweek(c(from, to)) + if (length(from) != 1L || length(to) != 1L || is.na(from) || is.na(to)) { + stop("`from` and `to` must be non-missing scalar epidemiological weeks.", call. = FALSE) + } + start <- epiweek_start(from) + end <- epiweek_start(to) + if (start > end) stop("`from` must not be after `to`.", call. = FALSE) + as_epiweek(seq(start, end, by = "7 days")) +} diff --git a/R/get_timeseries.R b/R/get_timeseries.R index 4c608ec..84a42c8 100755 --- a/R/get_timeseries.R +++ b/R/get_timeseries.R @@ -7,91 +7,57 @@ #'@title Get Climate Data #'@export #'@param stations station code (4 digits). -#'@param vars vector with meteorological variables. Available variables: "temp_min" (default), +#'@param vars vector with meteorological variables. Available variables: "temp_min" (default), #'"temp_max","temp_med","data_dia","umid_min","umid_med","umid_max","pressao_min","pressao_med","pressao_max" -#'@param finalday last day. Default is the last available. Format = Y-m-d. +#'@param finalday last day. Default is the last available. Format = Y-m-d. +#'@param iniSE First epidemiological week to return. #'@param datasource Use "data/WUdata.rda" to use test dataset. Use the connection to the Postgresql server if using project data. See also DenguedbConnect -#' to open the database connection. +#' to open the database connection. #'@return data.frame with the weekly data (cidade estacao data temp_min tmed tmax umin umed umax pressaomin pressaomed pressaomax) -#'@examples -#'NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +#'@examplesIf FALSE +#'# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") #'res = getWU(stations = c('SBRJ','SBGL'), vars="temp_min", iniSE = 201201) #'res = getWU(stations = 'SBRJ', vars=c("temp_min", "temp_med")) #'tail(res) getWU <- function(stations, vars = "temp_min", finalday = Sys.Date(), iniSE = 201001, - datasource=con) { - + datasource) { + # validade climate variables wuvars <- c("temp_min","temp_max","temp_med","umid_min","umid_med","umid_max", "pressao_min","pressao_med","pressao_max") if(any(!(vars %in% wuvars))) stop("wu climate variable(s) unknown or mispecified") - # check if all stations exist - sqlstations = paste("'", str_c(stations, collapse = "','"),"'", sep="") - - - if(class(datasource) == "PostgreSQLConnection"){ - checkStationComm <- paste("SELECT estacao_id, nome FROM - \"Municipio\".\"Estacao_wu\" WHERE estacao_id - IN (", sqlstations, ")",sep="") - stanames <- dbGetQuery(datasource,checkStationComm) - if(nrow(stanames)==0) stop("'stations' unknown. Check their names.") - notfoundsta <- stations[!(stations %in% stanames$estacao_id)] - if(length(notfoundsta) > 0) warning(paste("station",notfoundsta, - "does not exist in the database.")) - - # Geting the data from the available stations - message(paste("are the wu stations used", cat(stanames$nome))) - sqlstations = paste("'", str_c(stanames$estacao_id, collapse = "','"),"'", sep="") - - comando <- paste("SELECT * from \"Municipio\".\"Clima_wu\" WHERE - \"Estacao_wu_estacao_id\" IN (", sqlstations, ") AND - data_dia <= '",finalday,"'",sep="") - - d <- dbGetQuery(datasource,comando) - } - - if(class(datasource) == "SQLiteConnection"){ - allsta <- unique(dbGetQuery(datasource, 'SELECT Estacao_wu_estacao_id FROM wu')$Estacao_wu_estacao_id) - notfoundsta <- stations[!(stations %in% allsta)] - if(length(notfoundsta) > 0) warning(paste("station",notfoundsta, - "does not exist in the database.")) - - # Geting the data from the available stations - foundsta <- stations[stations %in% allsta] - if(length(foundsta) > 0){ - message(paste("these are the wu stations used", cat(foundsta))) - finaldaynum <- as.numeric(finalday) - sqlstations = paste("'", str_c(foundsta, collapse = "','"),"'", sep="") - comando <- paste("SELECT * from wu WHERE - \"Estacao_wu_estacao_id\" IN (", sqlstations, ")" ,sep="") - - d <- dbGetQuery(datasource, comando) - - # fixing dates - d$data_dia <- as.Date(d$data_dia, origin = "1970-01-01") - d <- d %>% - filter(d$data_dia <= finalday) - } + .db_validate_connection(datasource) + stations <- unique(as.character(stations)) + catalog <- .repo_station_catalog(datasource, stations) + foundsta <- intersect(stations, as.character(catalog$estacao_id)) + d <- .repo_station_climate(datasource, stations, finalday) + foundsta <- intersect(foundsta, unique(as.character(d$Estacao_wu_estacao_id))) + notfoundsta <- setdiff(stations, foundsta) + if (length(notfoundsta)) { + warning(paste("station", notfoundsta, "does not exist in the database.")) } - - + if (!length(foundsta)) stop("'stations' unknown. Check their names.") + message("these are the wu stations used: ", paste(foundsta, collapse = ", ")) + d <- d[d$Estacao_wu_estacao_id %in% foundsta, , drop = FALSE] + + # agregando vars climaticas por semana (ignora NAs) - d1 = d %>% - mutate(estacao = Estacao_wu_estacao_id) %>% + d1 = d %>% + mutate(estacao = Estacao_wu_estacao_id) %>% mutate(SE = data2SE(data_dia, format = "%Y-%m-%d")) %>% # creating column SE group_by(estacao,SE) %>% - summarise_at(vars(vars),list(mean),na.rm=TRUE) - + summarise(across(all_of(vars), ~ mean(.x, na.rm = TRUE)), .groups = "drop") + # criar serie temporal----------------------------------------- - st <- expand.grid(estacao = stations, + st <- expand.grid(estacao = stations, SE = seqSE(from = iniSE, to = max(d1$SE))$SE, stringsAsFactors = FALSE) %>% left_join(.,d1,by = c("estacao", "SE")) %>% arrange(estacao,SE) st - + } #bestWU ----------------------------------------------------------------- @@ -101,32 +67,32 @@ getWU <- function(stations, vars = "temp_min", finalday = Sys.Date(), iniSE = 20 #'@title Chooses the most updated meteorological data for a city from a set of two choices #'@param series list of the competing time series. #'See examples. -#'@param var name of the meteorological variable -#'@return data.frame with the best series -#'@examples -#'NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") -#'series1 = getWU(stations = 'SBCP',vars="temp_min", datasource= con) -#'series2 = getWU(stations = 'SBME',vars="temp_min", datasource= con) +#'@param var name of the meteorological variable +#'@return data.frame with the best series +#'@examplesIf FALSE +#'# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +#'series1 = getWU(stations = 'SBCP',vars="temp_min", datasource= connection) +#'series2 = getWU(stations = 'SBME',vars="temp_min", datasource= connection) #'res = bestWU(list(series1, series2),var="temp_min") #'tail(res) bestWU <- function(series,var){ - + if(missing(var))stop("bestWU: please specify a valid meteorological variable") if(class(series)!="list") stop("bestWU: WU data must be in a list") - + # prop missing data propNA <- sapply(series,function(x,v=var) sum(is.na(x[,v]))/nrow(x)) # last date with data if(sum(propNA == 1) == 1) { ser <- series[[which(propNA != 1)]] emptysta <- unique(series[[which(propNA == 1)]]$estacao) - sta <- unique(ser$estacao) + sta <- unique(ser$estacao) message(paste("WU station",emptysta, "has no data. Using", sta )) - + return(ser) } - + if(sum(propNA) == 2) { #none has data message("WARNING: Both stations without data. Returning the first one with NAs") ser <- series[[1]] @@ -138,350 +104,274 @@ bestWU <- function(series,var){ } # getClima -------------------------------------------------------- -#'@description Create weekly climate time series from satellite data in server +#'@description Create weekly climate time series from satellite data in server #'taking the mean of the daily values. Data source: ERA5. #'@title Get Climate Data -#'@export +#'@noRd #'@param cities list of geocodes. -#'@param vars vector with meteorological variables. Minimum set of vars +#'@param vars vector with meteorological variables. Minimum set of vars #'"temp_min", "temp_max". Default: all of them -#'@param iniSE first epiweek. Default is 012015 +#'@param iniSE first epiweek. Default is 012015 #'@param lastSE last epiweek. Optional. Default is the last available -#'@param finalday alternative to lastSE. Default is the last day available. Format = Y-m-d. -#'@param datasource a valid database connection +#'@param finalday alternative to lastSE. Default is the last day available. Format = Y-m-d. +#'@param datasource a valid database connection #'@return data.frame with the weekly data (cidade data temp_min tmed tmax umin umed umax pressaomin pressaomed pressaomax) -#'@examples +#'@examplesIf FALSE #'res = getClima(cities = c(3304557), vars=c("temp_min","temp_max") , iniSE = 202201) #'res = getClima(cities = c(3304557, 3200300), iniSE = 202403) #'tail(res) -getClima <- function(cities, vars = c("temp_min","temp_max","temp_med","umid_min","ampT", +.fetch_climate_impl <- function(cities, vars = c("temp_min","temp_max","temp_med","umid_min","ampT", "umid_med","umid_max", "precip_tot","precip_max"), - finalday = Sys.Date(), iniSE = 201501, lastSE, datasource=con) { - - # validate climate variables - if(any(!(vars %in% vars))) stop("climate variable(s) unknown or mispecified") + finalday = Sys.Date(), iniSE = 201501, lastSE, datasource) { + + allowed_vars <- c("temp_min", "temp_max", "temp_med", "umid_min", "ampT", + "umid_med", "umid_max", "precip_tot", "precip_max") + if(any(!(vars %in% allowed_vars))) stop("climate variable(s) unknown or mispecified") if("ampT" %in% vars) {varsred = vars[-which(vars == "ampT")]} else {varsred = vars} - - assert_that(all(c("temp_min","temp_max") %in% varsred), msg="getClima: vars should + + assert_that(all(c("temp_min","temp_max") %in% varsred), msg="getClima: vars should include temp_min, temp_max. Check it!") # dates #if(missing(lastSE)) lastSE <- epiweek(finalday, format = "Y-m-d") iniday <- SE2date(iniSE)$ini - - if(class(datasource) == "PostgreSQLConnection"){ - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - varscomplete = c("geocode", "date", varsred) - sqlvars = paste("", str_c(varscomplete, collapse = ","), sep="") - - comando <- paste("SELECT ", sqlvars ," from \"weather\".\"copernicus_bra\" - WHERE geocode IN (", sqlcity, ") AND - date <= '",finalday,"' AND date >= '", iniday, "'",sep="") - - d <- dbGetQuery(datasource,comando) - } - + + .db_validate_connection(datasource) + cities <- sapply(cities, sevendigitgeocode) + varscomplete <- c("geocode", "date", varsred) + d <- .repo_municipal_climate(datasource, cities, varscomplete, iniday, finalday) + # agregando vars climaticas por semana - d1 <- d %>% + d1 <- d %>% mutate(SE = data2SE(date, format = "%Y-%m-%d")) %>% # creating column SE group_by(geocode,SE) %>% - summarise_at(vars(varsred),list(mean),na.rm=TRUE) %>% + summarise(across(all_of(varsred), ~ mean(.x, na.rm = TRUE)), .groups = "drop") %>% rename(geocodigo = geocode) - + d1$geocodigo <- as.numeric(d1$geocodigo) - - if("ampT" %in% vars) d1$ampT = d1$temp_max - d1$temp_min - - + + if("ampT" %in% vars) d1$ampT = d1$temp_max - d1$temp_min + + # check output----------------------------------------- assert_that(all(c("geocodigo","SE") %in% names (d1)), msg = "debug getClima required") - + d1 - + } # getPop -------------------------------------------------------- -#'@description Get population time series, using the brpop package. +#'@description Get population time series, using the brpop package. #'Currently has estimates from 2000 to 2021 -#'@title Get population data at municipal level. +#'@title Get population data at municipal level. #'@export #'@param cities list of geocodes. -#'@param iniY first year. Default is 2010 -#'@param lastY last year. Default is the last available -#'@return tibble with columns geocode, year, pop -#'@examples +#'@param iniY first year. Default is 2010 +#'@param endY last year. Default is the last available +#'@return tibble with columns geocode, year, pop +#'@examplesIf FALSE #'cities <- getCidades(uf = "Paraná")$municipio_geocodigo #'pop <- getPop(cities, iniY = 2018, endY = 2019) #'tail(pop) getPop <- function(cities, iniY = 2010, endY) { - + if (!requireNamespace("brpop", quietly = TRUE)) { + stop("getPop requires the optional package 'brpop'.", call. = FALSE) + } + # check input - assert_that(all(c(iniY) >= 2000), + assert_that(all(c(iniY) >= 2000), msg = "getPop: check dates, getPop only has data from 2000 to 2021.") - - assert_that(all(c(iniY,endY) <= 2021), + + assert_that(all(c(iniY,endY) <= 2021), msg = "getPop: check dates, getPop only has data from 2000 to 2021.") - - require(brpop) + cities6 <- sapply(cities, function(x) floor(x/10)) - x <- mun_pop_totals() %>% + x <- brpop::mun_pop_totals() %>% filter(mun %in% cities6 & year >= iniY & year <= endY) %>% select(geocode6 = mun, year, - pop) - + pop) + x$geocode <- sapply(x$geocode6, function(x) sevendigitgeocode(x)) - + # check output - assert_that(all(cities %in% x$geocode), + assert_that(all(cities %in% x$geocode), msg = "getPop: not all cities with pop data. check geocodes") - + x[,c("geocode", "year", "pop")] } # GetCases -------------------------------------------------------------- -#'@description Create weekly time series from case data from server. The source is the SINAN. +#'@description Create weekly time series from case data from server. The source is the SINAN. #'@title Get Case Data and aggregate per week and area -#'@export +#'@noRd #'@param cities cities' geocode. #'@param lastday last day. Default is the last available. Format: "yyyy-mm-dd" #'@param completetail if sinan data is older than final_day, fill in the tail with NA (default) or 0. #'@param dataini "notific" if data aggregated by notification date or "sinpri" if data aggregated #' if aggregated by date of first symptoms #'@param firstday is the first date of the time series to be produced. Format: "yyyy-mm-dd" -#'@param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8", -#'@param type case definition. Default = "notified". Other options: "probable", -#'"lab_confirmed", "all". All means returning the three counts. -#'@param datasource PostgreSQLConnection to project database. -#'@param returndata TRUE if returns individual data as well. +#'@param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8", +#'@param type case definition. Default = "notified". Other options: "probable", +#'"lab_confirmed", "all". All means returning the three counts. +#'@param datasource PostgreSQLConnection to project database. +#'@param verbose Whether to emit progress messages. #'@return data.frame with the data aggregated per week according to disease onset date. -#'Notice that the names of the columns and the number of columns will change according to type. +#'Notice that the names of the columns and the number of columns will change according to type. #'To recover the original function behavior, use the default type. -#'@examples -#'NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +#'@examplesIf FALSE +#'# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") #'d <- getCases(cities = 3106200, dataini = "sinpri", type = "all") # dengue #'d <- getCases(cities = 3300936, completetail = 0) # dengue #'d <- getCases(cities = 3304557, cid10="A92.0") # chikungunya, until last day available #'cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") -#'d <- getCases(cities = cid$municipio_geocodigo[1:2], -#'firstday = as.Date("2023-01-01"), dataini = "sinpri") +#'d <- getCases(cities = cid$municipio_geocodigo[1:2], +#'firstday = as.Date("2023-01-01"), dataini = "sinpri") #'tail(d) -getCases <- function(cities, lastday = Sys.Date(), firstday = as.Date("2018-01-01"), - cid10 = "A90", dataini = "notific", completetail = NA, - type = "notified", datasource=con) { - - require(lubridate) - assert_that(class(cities) %in% c("integer","numeric"), - msg = "cities should be a vector of numeric geocodes") - - assert_that(dataini %in% c("sinpri", "notific"), msg="getCases: dataini should +.fetch_cases_impl <- function(cities, lastday = Sys.Date(), firstday = as.Date("2018-01-01"), + cid10 = "A90", dataini = "notific", completetail = NA, + type = "notified", datasource, verbose = FALSE) { + + assert_that(class(cities) %in% c("integer","numeric"), + msg = "cities should be a vector of numeric geocodes") + + assert_that(dataini %in% c("sinpri", "notific"), msg="getCases: dataini should be sinpri or notific. Check it!") cities <- sapply(cities, function(x) sevendigitgeocode(x)) - - # dealing with synonimous cid - if (cid10 == "A90") {cid <- cid10} else{ # dengue, dengue hemorragica - if (cid10 %in% c("A92", "A920","A92.0")) { # chik - cid <-c("A92", "A920","A92.0") - cid10 <- "A92.0"} else{ - if (cid10 %in% c("A92.8","A928")){ # zika - cid <- c("A92.8","A928") - cid10 <- "A92.8" - } - } - } - if (!(cid10 %in% c("A90","A92.0","A92.8")))stop(paste("Eu nao conheco esse cid10",cid10)) - - # reading notification data form the database - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - sqlcid = paste("'", str_c(cid, collapse = "','"),"'", sep="") # dealing with multiple cids for the same disease - - - if(class(datasource) == "PostgreSQLConnection"){ - comando <- paste("SELECT * from \"Municipio\".\"Notificacao\" WHERE dt_digita <= '",lastday, - "' AND dt_digita >= '",firstday, "' AND municipio_geocodigo IN (", sqlcity, - ") AND cid10_codigo IN(", sqlcid,")", sep="") - - dd <- dbGetQuery(datasource,comando) - - if(nrow(dd)==0)stop("getCases found no data") - - # pegando nome da cidade e populacao - sql2 <- paste("SELECT nome,populacao,geocodigo from \"Dengue_global\".\"Municipio\" WHERE geocodigo IN(", sqlcity,")") - varglobais <- dbGetQuery(datasource,sql2) - - } - if(class(datasource) == "SQLiteConnection"){ - - comando <- paste("SELECT * from \"Notificacao\" WHERE - municipio_geocodigo IN (", sqlcity, - ") AND cid10_codigo IN(", sqlcid,")", sep="") - - dd <- dbGetQuery(datasource,comando) - - if(nrow(dd)==0)stop("getCases found no data") - # fixing dates - dd$dt_notific <- as.Date(dd$dt_notific, origin = "1970-01-01") - dd$dt_sin_pri <- as.Date(dd$dt_sin_pri, origin = "1970-01-01") - dd$dt_digita <- as.Date(dd$dt_digita, origin = "1970-01-01") - - dd <- dd %>% - filter(dt_digita <= lastday) - - # pegando nome da cidade e populacao - sql2 <- paste("SELECT nome,populacao,geocodigo from \"Municipio\" WHERE - geocodigo IN(", sqlcity,")") - varglobais <- dbGetQuery(datasource,sql2) - - } - + + .db_validate_connection(datasource) + firstday <- as.Date(firstday) + lastday <- as.Date(lastday) + assert_that(!is.na(firstday) && !is.na(lastday) && firstday <= lastday, + msg = "getCases: firstday must not be after lastday") + disease <- .normalize_cid(cid10) + cid10 <- disease$canonical + dd <- .repo_notifications(datasource, cities, disease$values, firstday, lastday) + if(nrow(dd)==0) stop("getCases found no data") + varglobais <- .repo_municipalities(datasource, cities = cities) + # definindo a data para calculo da semana if(dataini == "notific"){ - message("cases aggregated by notification date") - dd <- dd %>% + if (isTRUE(verbose)) message("cases aggregated by notification date") + dd <- dd %>% mutate(SE = ano_notif*100+se_notif) } if(dataini == "sinpri"){ - # fixing wrong dt_sinpri's using the median time to notification (3days) - #w <- (dd$dt_notific - dd$dt_sin_pri) > 60 + # fixing wrong dt_sinpri's using the median time to notification (3days) + #w <- (dd$dt_notific - dd$dt_sin_pri) > 60 #lw <- sum(w, na.rm = TRUE); plw <- round((lw / nrow(dd) * 100), digits = 2) - + #message(paste("there are", lw, "(",plw ,"%)","cases with implausible dt_sinpri. Imputed with dt_notific")) #dd$dt_sin_pri[which(w==TRUE)] <- dd$dt_notific[which(w==TRUE)] - 3 # median delay - - # remove cases with wrong dt_sin_pri + + # remove cases with wrong dt_sin_pri # this condition must be equal in the bayesnowcasting function - + dd$ininotif <- dd$dt_notific - dd$dt_sin_pri wrongdates <- which(dd$ininotif > 365 | dd$ininotif < 0 | is.na(dd$dt_sin_pri)) # tirar o 30? if(length(wrongdates) > 0) { - message(paste(length(wrongdates), "registros com datas de inicio de sintomas invalidas")) + if (isTRUE(verbose)) message(length(wrongdates), " records with invalid symptom dates") dd <- dd[-wrongdates,] } # calculating epiweek from dt_sin_pri - dd$se_sin_pri <- epiweek(as.Date(dd$dt_sin_pri, format = "%Y-%m-%d")) - dd <- dd %>% - mutate(ano_sinpri = epiyear(dt_sin_pri), + dd$se_sin_pri <- lubridate::epiweek(as.Date(dd$dt_sin_pri, format = "%Y-%m-%d")) + dd <- dd %>% + mutate(ano_sinpri = lubridate::epiyear(dt_sin_pri), SE = ano_sinpri*100+se_sin_pri) - message("cases aggregated by symptom onset date") - + if (isTRUE(verbose)) message("cases aggregated by symptom onset date") + } - + # identificando os casos de acordo com a definicao #dd$tipo <- NA #dd$tipo[dd$classi_fin == 5] <- "discarded" #dd$tipo[dd$classi_fin != 5] <- "probable" - # contando os casos de acordo com a definicao - - casos <- dd %>% + # contando os casos de acordo com a definicao + + casos <- dd %>% group_by(municipio_geocodigo, SE) %>% summarise( casos = length(classi_fin), cas_desc = sum(classi_fin == 5, na.rm = TRUE), cas_lab = sum(classi_fin != 5 & criterio == 1 , na.rm = TRUE)) %>% mutate(cas_prov = casos - cas_desc) - - # criando serie - lastSE <- data2SE(lastday, format = "%Y-%m-%d") - firstSE <- data2SE(firstday, format = "%Y-%m-%d") - - sem <- expand.grid(municipio_geocodigo = cities, + + # criando serie + lastSE <- data2SE(lastday, format = "%Y-%m-%d") + firstSE <- data2SE(firstday, format = "%Y-%m-%d") + + sem <- expand.grid(municipio_geocodigo = cities, SE = seqSE(from = firstSE, to = lastSE)$SE) - - st <- left_join(sem, casos, by = c("municipio_geocodigo", "SE")) %>% + + st <- left_join(sem, casos, by = c("municipio_geocodigo", "SE")) %>% arrange(municipio_geocodigo, SE) %>% mutate(localidade = 0) %>% # para uso qdo tiver divisao submunicipal mutate(geocodigo = municipio_geocodigo) %>% mutate(CID10 = cid10)%>% left_join(.,varglobais,"geocodigo") %>% - select(SE, cidade = municipio_geocodigo,CID10, casos, cas_prov, - cas_lab, localidade, nome, pop=populacao) - + select(SE, cidade = municipio_geocodigo,CID10, casos, cas_prov, + cas_lab, localidade, nome, pop=populacao) + # substitute NA for zero to indicate that no case was reported that week - st$casos[(is.na(st$casos))] <- 0 - st$cas_prov[(is.na(st$cas_prov))] <- 0 - st$cas_lab[(is.na(st$cas_lab))] <- 0 - + st$casos[(is.na(st$casos))] <- 0 + st$cas_prov[(is.na(st$cas_prov))] <- 0 + st$cas_lab[(is.na(st$cas_lab))] <- 0 + if(any(is.na(st$pop))) warning("getCases function failed to import pop data for one or more cities", cities) - + # choosing what to return #if(type == "notified") return(subset(st, select = -c(cas_prov, cas_lab))) #if(type == "probable") return(subset(st, select = -c(casos, cas_lab))) #if(type == "lab_confirmed") return(subset(st, select = -c(casos, cas_prov))) #if(type == "all") return(st) - caselist <- dd - save(caselist, file ="caselist.RData") - message("individual data saved in caselist.RData.") - st + attr(st, "case_records") <- dd + st } # read.cases -------------------------------------------------------------- #' @title Function to extract case count for covered municipalities -#' @description Function \code{read.cases} extract notification data from database +#' @description Function \code{read.cases} extract notification data from database #' and aggregate by epiweek. Used by mem. #' @export #' @param start_year first year of the time series #' @param end_year last year of the time series #' @param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8" #' @param datasource Infodengue connection -#' @param mun_list vector with the municipalities' 7 digit geocodes +#' @param mun_list vector with the municipalities' 7 digit geocodes #' @author Marcelo F C Gomes -#' @examples +#' @examplesIf FALSE #' dd <- read.cases(2019, 2020, mun_list = c(4108304, 3300936)) #' dd <- read.cases(2019, 2020, cid10 = "A92.0", mun_list = c(4108304, 3300936)) -read.cases <- function(start_year, end_year, cid10 = "A90", datasource=con, mun_list){ - - mun_list_txt <- paste0(mun_list, collapse=',') - - if (!(cid10 %in% c("A90","A92.0","A92.8")))stop(paste("Eu nao conheco esse cid10",cid10)) - - - sqlcid = paste("'", cid10,"'", sep="") - - - if(class(datasource) == "PostgreSQLConnection"){ - sqlquery = paste0("SELECT dt_notific, se_notif, ano_notif, municipio_geocodigo - FROM \"Municipio\".\"Notificacao\" ") - - sqlquery <- paste0(sqlquery, " WHERE (ano_notif >= ", start_year, - " AND ano_notif <= ", end_year, - " AND cid10_codigo = ", sqlcid, - " AND municipio_geocodigo IN (", mun_list_txt,"));" ) - - df.cases.weekly <- dbGetQuery(conn = datasource, sqlquery, - stringsAsFactors=FALSE) - - } - - - if(class(datasource) == "SQLiteConnection"){ - sqlquery = paste0("SELECT dt_notific, se_notif, ano_notif, municipio_geocodigo - FROM \"Notificacao\" ") - - sqlquery <- paste0(sqlquery, " WHERE (ano_notif >= ", start_year, - " AND ano_notif <= ", end_year, - " AND AND cid10_codigo = ", sqlcid, - " AND municipio_geocodigo IN (", mun_list_txt,"));" ) - - df.cases.weekly <- dbGetQuery(conn = datasource, sqlquery, - stringsAsFactors=FALSE) - df.cases.weekly$dt_notific <- as.Date(df.cases.weekly$dt_notific, origin = "1970-01-01") - - } - # In the database we have each single notification. So we'll have to aggregate +read.cases <- function(start_year, end_year, cid10 = "A90", datasource, mun_list){ + .db_validate_connection(datasource) + assert_that(length(start_year) == 1L && length(end_year) == 1L && + is.numeric(start_year) && is.numeric(end_year) && start_year <= end_year, + msg = "read.cases: invalid year interval") + disease <- .normalize_cid(cid10) + df.cases.weekly <- .repo_notifications( + datasource, + cities = sapply(mun_list, sevendigitgeocode), + cids = disease$values, + start_year = start_year, + end_year = end_year, + columns = c("dt_notific", "se_notif", "ano_notif", "municipio_geocodigo") + ) + if (!nrow(df.cases.weekly)) stop("read.cases found no data", call. = FALSE) + # In the database we have each single notification. So we'll have to aggregate #later on We'll use an object name "weekly" from the start since we'll overwrite #it with the aggregate later. - - - + + + # Auxiliary function to correctly generate SE in the format YYYYWW from columns # notification week (WW) and current year. Since dates in the begining(end) of an year # can belong to epidemiological weeks from the previous(year), we must check the week and month @@ -497,24 +387,24 @@ read.cases <- function(start_year, end_year, cid10 = "A90", datasource=con, mun_ } return(as.integer(y*100 + w)) } - + df.cases.weekly$SE <- mapply(function(w, m, y) f.se(w,m,y) , df.cases.weekly$se_notif, format(df.cases.weekly$dt_notific, '%m'), df.cases.weekly$ano_notif) - + # Aggregate by municipio_geocodigo and SE. # Using table is faster than using aggregateby.notified.cases.R function df.cases.weekly <- data.frame(table(df.cases.weekly[, c('municipio_geocodigo', 'SE')]), stringsAsFactors = FALSE) names(df.cases.weekly) <- c('municipio_geocodigo', 'SE', 'casos') - + # Fill all epiweeks: df.epiweeks <- data.frame(municipio_geocodigo=integer(), SE=integer()) # List of locations: mun_list <- unique(df.cases.weekly$municipio_geocodigo) df.cases.weekly$SE <- as.integer((levels(df.cases.weekly$SE))[df.cases.weekly$SE]) - effec_start_year <- min(round(df.cases.weekly$SE/100)) + effec_start_year <- min(floor(df.cases.weekly$SE/100)) years.list <- c(effec_start_year:end_year) for (mun in mun_list){ - + for (y in years.list){ epiweeks <- c() lweek <- as.integer(lastepiweek(y)) @@ -523,166 +413,114 @@ read.cases <- function(start_year, end_year, cid10 = "A90", datasource=con, mun_ } df.epiweeks <- rbind(df.epiweeks, data.frame(list(municipio_geocodigo=mun, SE=epiweeks))) } - + } - + df.cases.weekly <- merge(df.epiweeks, df.cases.weekly, by=c('municipio_geocodigo', 'SE'), all.x=T) df.cases.weekly[is.na(df.cases.weekly)] <- 0 df.cases.weekly$municipio_geocodigo <- as.integer(df.cases.weekly$municipio_geocodigo) - + return(df.cases.weekly) } # getTweet -------------------------------------------------------------- -#'@description Create weekly time series from tweeter data from server. The +#'@description Create weekly time series from tweeter data from server. The #'source of this data is the Observatorio da Dengue (UFMG). #'@title Get Tweeter Data #'@export #'@param cities cities's geocode. Use getCidades() #'@param cid10 default is A90 (dengue). If not dengue, returns NA -#'@param finalday last day. Default is the last available. -#'@param datasource Use the connection to the Postgresql server for using project data. +#'@param lastday last day. Default is the last available. +#'@param datasource Use the connection to the Postgresql server for using project data. #'@return data.frame with weekly counts of people tweeting on dengue. -#'@examples -#'NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +#'@examplesIf FALSE +#'# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") #'tw <- getTweet(cities = c(3302205,3200300), lastday = "2014-03-01") #'tw <- getTweet(cities = 3304557, finalday = "2016-03-01") #'cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") -#'tw <- getTweet(cities = cid$municipio_geocodigo) +#'tw <- getTweet(cities = cid$municipio_geocodigo) #'tail(tw) -getTweet <- function(cities, lastday = Sys.Date(), cid10 = "A90", datasource=con) { - +getTweet <- function(cities, lastday = Sys.Date(), cid10 = "A90", datasource) { + cities <- sapply(cities, function(x) sevendigitgeocode(x)) - - # get tweets on dengue - if (cid10 == "A90"){ - - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - - if(class(datasource) == "PostgreSQLConnection"){ - - comando <- paste("SELECT \"Municipio_geocodigo\", data_dia, numero - FROM \"Municipio\".\"Tweet\" WHERE \"Municipio_geocodigo\" IN (", - sqlcity,") AND data_dia <= '", lastday,"'",sep="") - - tw <- dbGetQuery(datasource,comando) - } - - if(class(datasource) == "SQLiteConnection"){ - - comando <- paste("SELECT * from tweet WHERE - \"Municipio_geocodigo\" IN (", sqlcity, ")" ,sep="") - - tw <- dbGetQuery(datasource, comando) - - # fixing dates and filtering - tw$data_dia <- as.Date(tw$data_dia, origin = "1970-01-01") - tw <- tw %>% - filter(tw$data_dia <= as.Date(lastday)) - } - + + # get tweets on dengue + if (cid10 == "A90"){ + + .db_validate_connection(datasource) + tw <- .repo_tweets(datasource, cities, as.Date(lastday)) + } else {stop(paste("there is no tweet for", cid10,"in the database"))} - - # no tweets found for these cities + + # no tweets found for these cities if(nrow(tw) == 0){ message(paste("cidade(s)",cities,"nunca tweetou sobre dengue")) tw <- expand.grid(Municipio_geocodigo = cities, - SE = seqSE(from = 201001, - to = data2SE(lastday, + SE = seqSE(from = 201001, + to = data2SE(lastday, format = "%Y-%m-%d"))$SE) tw$tweet <- 0 return(tw) } - + # checking if tweets were partially found tots = tapply(tw$numero,tw$Municipio_geocodigo,sum) if (any(tots==0)) message(paste("cidade(s)",cities[which(tots==0)],"nunca tweetou sobre dengue")) - + # Counting number of tweets per SE and city - tw <- tw %>% # + tw <- tw %>% # mutate(SE = data2SE(data_dia, format = "%Y-%m-%d")) # creating column SE - - sem <- expand.grid(Municipio_geocodigo = cities, - SE = seqSE(from = 201001, to = data2SE(lastday, + + sem <- expand.grid(Municipio_geocodigo = cities, + SE = seqSE(from = 201001, to = data2SE(lastday, format = "%Y-%m-%d"))$SE) - st <- full_join(sem,tw,by = c("Municipio_geocodigo", "SE")) %>% + st <- full_join(sem,tw,by = c("Municipio_geocodigo", "SE")) %>% arrange(Municipio_geocodigo,SE) %>% group_by(Municipio_geocodigo,SE) %>% summarize(tweet = sum(numero, na.rm = TRUE)) %>% select(Municipio_geocodigo, SE, tweet) - - return(as.data.frame(st)) - + + return(as.data.frame(st)) + } # GetCaseslist -------------------------------------------------------------- -#'@description Get case data from server. +#'@description Get case data from server. #'@title Get Case Data -#'@export +#'@noRd #'@param cities cities' geocode. #'@param lastday last day. Default is the last available. Format: "yyyy-mm-dd" -#'@param dataini "notific" if data aggregated by notification date or "sinpri" if data aggregated -#' if aggregated by date of first symptoms #'@param firstday is the first date of the time series to be produced. Format: "yyyy-mm-dd" -#'@param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8", -#'@param type case definition. Default = "notified". Other options: "probable", -#'"lab_confirmed", "all". All means returning the three counts. -#'@param datasource PostgreSQLConnection to project database. +#'@param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8", +#'@param datasource PostgreSQLConnection to project database. #'@return data.frame with the data aggregated per week according to disease onset date. -#'Notice that the names of the columns and the number of columns will change according to type. +#'Notice that the names of the columns and the number of columns will change according to type. #'To recover the original function behavior, use the default type. -#'@examples -#'NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +#'@examplesIf FALSE +#'# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") #'d <- getCaseslist(cities = c(4209102, 3304557),firstday = as.Date("2024-01-01")) # dengue #'d <- getCaseslist(cities = 3304557, cid10="A92.0") # chikungunya, until last day available #'cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") -#'d <- getCaseslist(cities = 3304557, firstday = as.Date("2023-01-01"),dataini) +#'d <- getCaseslist(cities = 3304557, firstday = as.Date("2023-01-01"),dataini) #'tail(d) -getCaseslist <- function(cities, lastday = Sys.Date(), firstday = as.Date("2022-01-01"), cid10 = "A90", - datasource=con) { - - require(lubridate) - assert_that(class(cities) %in% c("integer","numeric"), - msg = "cities should be a vector of numeric geocodes") - - assert_that(dataini %in% c("sinpri", "notific"), msg="getCases: dataini should - be sinpri or notific. Check it!") - cities <- sapply(cities, function(x) sevendigitgeocode(x)) - - # dealing with synonimous cid - if (cid10 == "A90") {cid <- cid10} else{ # dengue, dengue hemorragica - if (cid10 %in% c("A92", "A920","A92.0")) { # chik - cid <-c("A92", "A920","A92.0") - cid10 <- "A92.0"} else{ - if (cid10 %in% c("A92.8","A928")){ # zika - cid <- c("A92.8","A928") - cid10 <- "A92.8" - } - } - } - if (!(cid10 %in% c("A90","A92.0","A92.8")))stop(paste("Eu nao conheco esse cid10",cid10)) - - # reading notification data form the database - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - sqlcid = paste("'", str_c(cid, collapse = "','"),"'", sep="") # dealing with multiple cids for the same disease - - - comando <- paste("SELECT * from \"Municipio\".\"Notificacao\" WHERE dt_digita <= '",lastday, - "' AND dt_digita >= '",firstday, "' AND municipio_geocodigo IN (", sqlcity, - ") AND cid10_codigo IN(", sqlcid,")", sep="") - - dd <- dbGetQuery(datasource,comando) - - if(nrow(dd)==0)stop("getCaseslist found no data") - - # pegando nome da cidade e populacao - sql2 <- paste("SELECT nome,populacao,geocodigo from \"Dengue_global\".\"Municipio\" WHERE geocodigo IN(", sqlcity,")") - varglobais <- dbGetQuery(datasource,sql2) - - return(dd) -} +.fetch_case_records_impl <- function(cities, lastday = Sys.Date(), firstday = as.Date("2022-01-01"), cid10 = "A90", + datasource) { + assert_that(class(cities) %in% c("integer","numeric"), + msg = "cities should be a vector of numeric geocodes") + cities <- sapply(cities, function(x) sevendigitgeocode(x)) + .db_validate_connection(datasource) + firstday <- as.Date(firstday) + lastday <- as.Date(lastday) + assert_that(!is.na(firstday) && !is.na(lastday) && firstday <= lastday, + msg = "getCaseslist: firstday must not be after lastday") + disease <- .normalize_cid(cid10) + dd <- .repo_notifications(datasource, cities, disease$values, firstday, lastday) + if(nrow(dd)==0) stop("getCaseslist found no data") + + return(dd) +} diff --git a/R/infodengue_apply_mem.R b/R/infodengue_apply_mem.R index 02e96d1..2d966f8 100644 --- a/R/infodengue_apply_mem.R +++ b/R/infodengue_apply_mem.R @@ -16,17 +16,19 @@ #' @param write Whether results should be saved into project's database. Default: 'no' #' 'no' return data.table without writing in database. #' 'db' writes data.table to InfoDengue's database using \code{write.parameters} from AlerttTools package. -#' @param con Connection to PostGreSQL database, using \code{dbConnect} from RPostgreSQL package +#' @param database DBI connection. #' @param passwd database password for writing output to db if write='db'. #' @param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8" #' @param i.n.max Number of points by seasons to be used for pre-epidemic and epidemic regions to calculate each threshold. #' If 0 (default), uses all points in those regions. Else, uses n max values in each region per season. #' This value is passed to i.n.max parameter in \code{memmodel}, from MEM package. +#' @param i.type.curve,i.type.threshold,i.type.intensity MEM configuration values. #' @param limiar.preseason Level of confidence interval to calculate pre/post-season thresholds. Default: 0.9. #' This value is passed to i.level.threshold parameter in \code{memmodel}, from MEM package. #' @param limiar.epidemico Level of confidence interval to calculate high activity during epidemic region. Default: 0.95. #' This value is passed to i.level.intensity parameter in \code{memmodel}, from MEM package. #' @param mincases.pre minimum number of cases to launch a preseason alert. Default: 5 +#' @param mincases.pos minimum number of cases to end a seasonal alert. Default: 5 #' @param mincases.epi minimum number of cases to launch an epidemic alert. Default: 10 #' @param ... Optional arguments passed to \code{memmodel}, from MEM package. #' @return Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, @@ -41,14 +43,14 @@ #' \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, #' limiar_epidemico.} #' } -#' @examples -#' Generate thresholds for municipalities using the whole history. -#' Return object instead of writing to data base: +#' @examplesIf FALSE +#' # Generate thresholds for municipalities using the whole history. +#' # Return object instead of writing to data base: #' mun_list <- c(4212650, 4209102,4216503,4214607,4212502,4218905,4212601,4214805, #' 4212650,4217006,4212700,4214706,4213104,4200804) -#' mun_list <- getCidades(uf = "Maranhão", datasource=con)$municipio_geocodigo -#' thresC <- infodengue_apply_mem(mun_list, cid10 = "A92.0", database=con) -#' A nice way to visualize the calculated thresholds +#' mun_list <- getCidades(uf = "Maranhão", datasource=connection)$municipio_geocodigo +#' thresC <- infodengue_apply_mem(mun_list, cid10 = "A92.0", database=connection) +#' # A nice way to visualize the calculated thresholds #' plot(thres) @@ -57,55 +59,42 @@ infodengue_apply_mem <- function(mun_list, start_year=2010, end_year=as.integer( limiar.preseason=0.95, limiar.epidemico=0.95, i.type.curve=2, i.type.threshold=2, i.type.intensity=2, mincases.pre = 5, mincases.pos = 5, mincases.epi=10, ...){ - - require(mem, quietly=TRUE, warn.conflicts=FALSE) - #require(plyr, quietly=TRUE, warn.conflicts=FALSE) - require(data.table, quietly=TRUE, warn.conflicts=FALSE) + if (!requireNamespace("mem", quietly = TRUE)) { + stop("infodengue_apply_mem requires the optional package 'mem'.", call. = FALSE) + } + if (!requireNamespace("data.table", quietly = TRUE)) { + stop("infodengue_apply_mem requires the optional package 'data.table'.", call. = FALSE) + } + .db_validate_connection(database) #stopifnot(is.numeric(mun_list),"MEM: mun_list should be a numeric vector") - - + + if (!(cid10 %in% c("A90","A92.0","A92.8")))stop(paste("Eu nao conheco esse cid10",cid10)) if(cid10 %in% c("A92.0","A92.8") & start_year < 2015) { start_year = 2015 message("start_year reset to 2015") } - - # Read population table - sqlcity = paste("'", str_c(mun_list, collapse = "','"),"'", sep="") - - if(class(con) == "PostgreSQLConnection"){ - comando <- paste0("SELECT geocodigo, populacao FROM - \"Dengue_global\".\"Municipio\" WHERE geocodigo - IN (", sqlcity, ")") - - df.pop <- dbGetQuery(conn=con, comando) + + df.pop <- .repo_municipalities(database, cities = mun_list, + columns = c("geocodigo", "populacao")) names(df.pop)[1] <- "municipio_geocodigo" - } - - if(class(con) == "SQLiteConnection"){ - comando <- paste0("SELECT geocodigo, populacao FROM - \"Municipio\" WHERE geocodigo - IN (", sqlcity, ")") - - df.pop <- dbGetQuery(conn=con, comando) - names(df.pop)[1] <- "municipio_geocodigo" - } - + # Process data in chuncks for 300 municipalities at a time: mun_list <- split(mun_list, ceiling(seq_along(mun_list)/20)) # Prepare output data table #thresholds.table <- data.table('municipio_geocodigo'=integer(), 'ano_inicio'=integer(), 'ano_fim'=integer(), # 'pre'=double(), 'pos'=double(), 'muitoalta'=double()) - thresholds.table <- data.table(NULL) + thresholds.table <- data.table::data.table(NULL) # Run by chuncks: for (mun_chunck in mun_list){ print(mun_chunck) # Read historical cases table - df.inc <- read.cases(start_year, end_year, cid10 = cid10, mun_list=mun_chunck) # o que acontece quando nao ha casos? - effec_start_year <- min(round(df.inc$SE/100)) + df.inc <- read.cases(start_year, end_year, cid10 = cid10, + datasource = database, mun_list=mun_chunck) + effec_start_year <- min(floor(df.inc$SE/100)) # Build incidence df.inc <- merge.data.frame(df.inc, df.pop, by='municipio_geocodigo') df.inc['inc'] <- df.inc$casos * 100000.0 / df.inc$populacao @@ -131,7 +120,7 @@ infodengue_apply_mem <- function(mun_list, start_year=2010, end_year=as.integer( quant_epidemico = max(mincases.epi,quantile(casos, probs = limiar.epidemico), na.rm = TRUE)/mean(populacao)*1e5) # Apply mem method - thresholds.tab <- data.table(municipio_geocodigo=mun_chunck) + thresholds.tab <- data.table::data.table(municipio_geocodigo=mun_chunck) base.cols <- c('municipio_geocodigo', 'pre', 'pos', 'veryhigh') thresholds <- data.frame(municipio_geocodigo = mun_chunck, pre = NA_real_, pos = NA_real_, veryhigh = NA_real_, @@ -167,12 +156,12 @@ infodengue_apply_mem <- function(mun_list, start_year=2010, end_year=as.integer( thresholds.tab$ano_inicio <- start_year thresholds.tab$ano_fim <- end_year #thresholds.tab <- thresholds.tab[, c('municipio_geocodigo', 'ano_inicio', 'ano_fim','pre', 'pos', 'muitoalta')] - thresholds.table <- rbindlist(list(thresholds.table, thresholds.tab)) + thresholds.table <- data.table::rbindlist(list(thresholds.table, thresholds.tab)) } - + thresholds.table$cid10 <- cid10 - + #thresholds.table <- plyr::rename(thresholds.table, replace=c('pre'='limiar_preseason', 'pos'='limiar_posseason', # 'muitoalta'='limiar_epidemico')) @@ -196,123 +185,112 @@ infodengue_apply_mem <- function(mun_list, start_year=2010, end_year=as.integer( # infodengue_apply_mem_agreg ----------------------------------- # Function to apply MEM algorithm to generate pre-epidemic, post-epidemic, and high activity thresholds # to municipalities covered by InfoDengue project -#' +#' #' Function \code{infodengue_apply_mem} uses MEM package to generate activity thresholds. #' Apply MEM algorithm discarding seasons below local pre-epidemic threshold. #' For each municipality, pre-epidemic (limiar_preseason) threshold has a minimum set at 5 cases. -#' If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set +#' If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set #' to either the 90% quantile or 10, whichever is the greatest. The thresholds are given both in number of cases or -#' as incidence. The alert model uses incidence. +#' as incidence. The alert model uses incidence. #' @name infodengue_apply_mem_agreg #' @export #' @param start_year Historical data starting year to consider. Default: 0 (i.e., as old as possible) #' @param end_year Historical data final year to consider. Default: previous year from Sys.Date() #' @param mun_list Vector of municipalities geocode. Default: NULL (i.e., all municipalites) -#' @param write Whether results should be saved into project's database. Default: 'no' -#' 'no' return data.table without writing in database. -#' 'db' writes data.table to InfoDengue's database using \code{write.parameters} from AlerttTools package. -#' @param con Connection to PostGreSQL database, using \code{dbConnect} from RPostgreSQL package +#' @param nome Name assigned to the aggregation. +#' @param database DBI connection. #' @param passwd database password for writing output to db if write='db'. #' @param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8" #' @param i.n.max Number of points by seasons to be used for pre-epidemic and epidemic regions to calculate each threshold. #' If 0 (default), uses all points in those regions. Else, uses n max values in each region per season. #' This value is passed to i.n.max parameter in \code{memmodel}, from MEM package. +#' @param i.type.curve,i.type.threshold,i.type.intensity MEM configuration values. #' @param limiar.preseason Level of confidence interval to calculate pre/post-season thresholds. Default: 0.9. #' This value is passed to i.level.threshold parameter in \code{memmodel}, from MEM package. #' @param limiar.epidemico Level of confidence interval to calculate high activity during epidemic region. Default: 0.95. #' This value is passed to i.level.intensity parameter in \code{memmodel}, from MEM package. #' @param mincases.pre minimum number of cases to launch a preseason alert. Default: 5 +#' @param mincases.pos minimum number of cases to end a seasonal alert. Default: 5 #' @param mincases.epi minimum number of cases to launch an epidemic alert. Default: 10 #' @param ... Optional arguments passed to \code{memmodel}, from MEM package. -#' @return Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, -#' by simple percentile and the choice used in the infodengue model, by municipality: +#' @return Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, +#' by simple percentile and the choice used in the infodengue model, by municipality: #' \describe{ -#' \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = +#' \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = #' pos-season incidence threshold, inc_epidemico = high incidence threshold, inicio and inicio.ic = estimated begining of the season -#' duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} +#' duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} #' \item{percentiles: threshold values calculated as percentiles (incidence)}{quant_pre = preseason incidence threshold, -#' quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} -#' \item{min_threshold_inc:}{pre-defined minimum threshold.} -#' \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, -#' limiar_epidemico.} +#' quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} +#' \item{min_threshold_inc:}{pre-defined minimum threshold.} +#' \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, +#' limiar_epidemico.} #' } -#' @examples -#' Generate thresholds for municipalities using the whole history. -#' Return object instead of writing to data base: +#' @examplesIf FALSE +#' # Generate thresholds for municipalities using the whole history. +#' # Return object instead of writing to data base: #' mun_list <- c(4212650, 4209102,4216503,4214607,4212502,4218905,4212601,4214805, #' 4212650,4217006,4212700,4214706,4213104,4200804) -#' mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=con) +#' mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=connection) #' thres <- infodengue_apply_mem_agreg(mun_list$municipio_geocodigo, cid10 = "A92.0") -infodengue_apply_mem_agreg <- function(mun_list, +infodengue_apply_mem_agreg <- function(mun_list, start_year=2010, end_year=as.integer(format(Sys.Date(), '%Y'))-1, nome = "x", database, passwd=NULL, i.n.max=0,cid10 = "A90", limiar.preseason=0.95, limiar.epidemico=0.95, i.type.curve=2, i.type.threshold=2, i.type.intensity=2, mincases.pre = 5, mincases.pos = 5, mincases.epi=10, ...){ - - require(mem, quietly=TRUE, warn.conflicts=FALSE) - #require(plyr, quietly=TRUE, warn.conflicts=FALSE) - require(data.table, quietly=TRUE, warn.conflicts=FALSE) - + + if (!requireNamespace("mem", quietly = TRUE)) { + stop("infodengue_apply_mem_agreg requires the optional package 'mem'.", call. = FALSE) + } + if (!requireNamespace("data.table", quietly = TRUE)) { + stop("infodengue_apply_mem_agreg requires the optional package 'data.table'.", call. = FALSE) + } + .db_validate_connection(database) + # check inputs - + if (!(cid10 %in% c("A90","A92.0","A92.8")))stop(paste("Eu nao conheco esse cid10",cid10)) if(cid10 %in% c("A92.0","A92.8") & start_year < 2015) { start_year = 2015 message("start_year reset to 2015") } - - # Read population table - sqlcity = paste("'", str_c(mun_list, collapse = "','"),"'", sep="") - if(class(con) == "PostgreSQLConnection"){ - comando <- paste0("SELECT geocodigo, populacao FROM - \"Dengue_global\".\"Municipio\" WHERE geocodigo - IN (", sqlcity, ")") - - df.pop <- dbGetQuery(conn=con, comando) - names(df.pop)[1] <- "municipio_geocodigo" - } - if(class(con) == "SQLiteConnection"){ - comando <- paste0("SELECT geocodigo, populacao FROM - \"Municipio\" WHERE geocodigo - IN (", sqlcity, ")") - - df.pop <- dbGetQuery(conn=con, comando) - names(df.pop)[1] <- "municipio_geocodigo" - } - - pop = sum(df.pop$populacao) + + df.pop <- .repo_municipalities(database, cities = mun_list, + columns = c("geocodigo", "populacao")) + names(df.pop)[1] <- "municipio_geocodigo" + + pop = sum(df.pop$populacao) # Read historical cases table - df.inc <- read.cases(start_year, end_year, - cid10 = cid10, mun_list=mun_list) - - + df.inc <- read.cases(start_year, end_year, + cid10 = cid10, datasource = database, mun_list=mun_list) + + # somando tudo df.inc.a <- df.inc %>% group_by(SE) %>% summarise(casos = sum(casos)) %>% mutate(municipio_geocodigo = nome) # variavel nao usada, trocar depois pela regional - + df.inc.a['populacao'] <- pop - + # Prepare output data table #thresholds.table <- data.table('municipio_geocodigo'=integer(), 'ano_inicio'=integer(), 'ano_fim'=integer(), # 'pre'=double(), 'pos'=double(), 'muitoalta'=double()) - thresholds.table <- data.table(NULL) - - effec_start_year <- min(round(df.inc$SE/100)) + thresholds.table <- data.table::data.table(NULL) + + effec_start_year <- min(floor(df.inc$SE/100)) # Build incidence - df.inc.a['inc'] <- df.inc.a$casos * 100000.0 / df.inc.a['populacao'] + df.inc.a['inc'] <- df.inc.a$casos * 100000.0 / df.inc.a['populacao'] #df.inc['municipio_geocodigo'] <- nome - + # Store only necessary data, separating seasons by columns #dfsimple <- df.inc[df.inc$SE > max(df.inc$SE[df.inc$SE<(effec_start_year+1)*100])-12 & # df.inc$SE < (effec_start_year+1)*100+41, c('municipio_geocodigo', 'SE', 'inc')] dfsimple <- df.inc.a[df.inc.a$SE > max(df.inc.a$SE[df.inc.a$SE<(effec_start_year+1)*100])-12 & df.inc.a$SE < (effec_start_year+1)*100+41, c("municipio_geocodigo",'SE', 'inc')] - + effec_start_year_lbl <- paste0(effec_start_year,'-',effec_start_year+1) dfsimple <- plyr::rename(dfsimple, c('SE'=paste0('SE',effec_start_year_lbl), 'inc'=effec_start_year_lbl)) seasons <- c(effec_start_year_lbl) @@ -322,26 +300,26 @@ infodengue_apply_mem_agreg <- function(mun_list, seasons <- cbind(seasons, paste0(i,'-',i+1)) } } - + # Apply quantile method (new) - quantile.tab <- df.inc.a %>% + quantile.tab <- df.inc.a %>% summarise(quant_pre = max(mincases.pre, quantile(casos, probs = 0.10), na.rm = TRUE)/mean(populacao)*1e5, quant_pos = max(mincases.pre,quantile(casos, probs = 0.10), na.rm = TRUE)/mean(populacao)*1e5, quant_epidemico = max(mincases.epi,quantile(casos, probs = limiar.epidemico), na.rm = TRUE)/mean(populacao)*1e5) - + # Apply mem method - + thresholdsMEM <- try(applymem(dfsimple, seasons, i.n.max=i.n.max, i.level.threshold=limiar.preseason, i.level.intensity=limiar.epidemico, i.type.curve=i.type.curve, i.type.threshold=i.type.threshold, i.type.intensity=i.type.intensity)$dfthresholds)#[base.cols] - + thresholds.tab <- cbind(thresholdsMEM, quantile.tab[2:length(quantile.tab)]) - + thresholds.tab$mininc_pre <- mincases.pre/pop*1e5 thresholds.tab$mininc_pos <- mincases.pos/pop*1e5 thresholds.tab$mininc_epi <- mincases.epi/pop*1e5 - + # thresholds.tab <- thresholds.tab %>% # mutate(limiar_preseason = case_when( # as.numeric(is.na(pre)) == 0 & pre > mininc_pre ~ pre, TRUE ~ quant_pre), @@ -352,136 +330,122 @@ infodengue_apply_mem_agreg <- function(mun_list, # rename(inc_preseason = pre, # inc_posseason = pos, # inc_epidemico = veryhigh) - # - - + # + + thresholds.tab$ano_inicio <- start_year thresholds.tab$ano_fim <- end_year thresholds.tab$populacao <- pop thresholds.tab$cid10 <- cid10 - names(thresholds.tab)[1] <- "nome" - + names(thresholds.tab)[1] <- "nome" + return(thresholds.tab) - + } # mem_curve ----------------------------------- # Function to apply MEM algorithm to generate pre-epidemic, post-epidemic, and high activity thresholds # to municipalities covered by InfoDengue project -#' +#' #' Function \code{infodengue_apply_mem} uses MEM package to generate activity thresholds. #' Apply MEM algorithm discarding seasons below local pre-epidemic threshold. #' For each municipality, pre-epidemic (limiar_preseason) threshold has a minimum set at 5 cases. -#' If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set +#' If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set #' to either the 90% quantile or 10, whichever is the greatest. The thresholds are given both in number of cases or -#' as incidence. The alert model uses incidence. -#' @name infodengue_apply_mem_agreg +#' as incidence. The alert model uses incidence. +#' @name mem_curve #' @export #' @param start_year Historical data starting year to consider. Default: 0 (i.e., as old as possible) #' @param end_year Historical data final year to consider. Default: previous year from Sys.Date() #' @param mun_list Vector of municipalities geocode. Default: NULL (i.e., all municipalites) -#' @param write Whether results should be saved into project's database. Default: 'no' -#' 'no' return data.table without writing in database. -#' 'db' writes data.table to InfoDengue's database using \code{write.parameters} from AlerttTools package. -#' @param con Connection to PostGreSQL database, using \code{dbConnect} from RPostgreSQL package +#' @param nome Name assigned to the aggregation. +#' @param database DBI connection. #' @param passwd database password for writing output to db if write='db'. #' @param cid10 cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8" #' @param i.n.max Number of points by seasons to be used for pre-epidemic and epidemic regions to calculate each threshold. #' If 0 (default), uses all points in those regions. Else, uses n max values in each region per season. #' This value is passed to i.n.max parameter in \code{memmodel}, from MEM package. +#' @param i.type.curve,i.type.threshold,i.type.intensity MEM configuration values. #' @param limiar.preseason Level of confidence interval to calculate pre/post-season thresholds. Default: 0.9. #' This value is passed to i.level.threshold parameter in \code{memmodel}, from MEM package. #' @param limiar.epidemico Level of confidence interval to calculate high activity during epidemic region. Default: 0.95. #' This value is passed to i.level.intensity parameter in \code{memmodel}, from MEM package. -#' @param mincases.pre minimum number of cases to launch a preseason alert. Default: 5 -#' @param mincases.epi minimum number of cases to launch an epidemic alert. Default: 10 #' @param ... Optional arguments passed to \code{memmodel}, from MEM package. -#' @return Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, -#' by simple percentile and the choice used in the infodengue model, by municipality: +#' @return Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, +#' by simple percentile and the choice used in the infodengue model, by municipality: #' \describe{ -#' \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = +#' \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = #' pos-season incidence threshold, inc_epidemico = high incidence threshold, inicio and inicio.ic = estimated begining of the season -#' duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} +#' duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} #' \item{percentiles: threshold values calculated as percentiles (incidence)}{quant_pre = preseason incidence threshold, -#' quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} -#' \item{min_threshold_inc:}{pre-defined minimum threshold.} -#' \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, -#' limiar_epidemico.} +#' quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} +#' \item{min_threshold_inc:}{pre-defined minimum threshold.} +#' \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, +#' limiar_epidemico.} #' } -#' @examples -#' mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=con) +#' @examplesIf FALSE +#' mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=connection) #' thres <- mem_curve(mun_list$municipio_geocodigo, cid10 = "A92.0") #' thres <- mem_curve(muns) -mem_curve <- function(mun_list, +mem_curve <- function(mun_list, start_year=2010, end_year=as.integer(format(Sys.Date(), '%Y'))-1, nome = "x", database, passwd=NULL, i.n.max=0,cid10 = "A90", limiar.preseason=0.95, limiar.epidemico=0.95, i.type.curve=2, i.type.threshold=2, i.type.intensity=2, ...){ - - require(mem, quietly=TRUE, warn.conflicts=FALSE) - #require(plyr, quietly=TRUE, warn.conflicts=FALSE) - require(data.table, quietly=TRUE, warn.conflicts=FALSE) - + + if (!requireNamespace("mem", quietly = TRUE)) { + stop("mem_curve requires the optional package 'mem'.", call. = FALSE) + } + if (!requireNamespace("data.table", quietly = TRUE)) { + stop("mem_curve requires the optional package 'data.table'.", call. = FALSE) + } + .db_validate_connection(database) + # check inputs - + if (!(cid10 %in% c("A90","A92.0","A92.8")))stop(paste("Eu nao conheco esse cid10",cid10)) if(cid10 %in% c("A92.0","A92.8") & start_year < 2015) { start_year = 2015 message("start_year reset to 2015") } - - # Read population table - sqlcity = paste("'", str_c(mun_list, collapse = "','"),"'", sep="") - if(class(con) == "PostgreSQLConnection"){ - comando <- paste0("SELECT geocodigo, populacao FROM - \"Dengue_global\".\"Municipio\" WHERE geocodigo - IN (", sqlcity, ")") - - df.pop <- dbGetQuery(conn=con, comando) - names(df.pop)[1] <- "municipio_geocodigo" - } - if(class(con) == "SQLiteConnection"){ - comando <- paste0("SELECT geocodigo, populacao FROM - \"Municipio\" WHERE geocodigo - IN (", sqlcity, ")") - - df.pop <- dbGetQuery(conn=con, comando) - names(df.pop)[1] <- "municipio_geocodigo" - } - - pop = sum(df.pop$populacao) + + df.pop <- .repo_municipalities(database, cities = mun_list, + columns = c("geocodigo", "populacao")) + names(df.pop)[1] <- "municipio_geocodigo" + + pop = sum(df.pop$populacao) # Read historical cases table - df.inc <- read.cases(start_year, end_year, - cid10 = cid10, mun_list=mun_list) - - + df.inc <- read.cases(start_year, end_year, + cid10 = cid10, datasource = database, mun_list=mun_list) + + # somando tudo df.inc.a <- df.inc %>% group_by(SE) %>% summarise(casos = sum(casos)) %>% mutate(municipio_geocodigo = nome) # variavel nao usada, trocar depois pela regional - + df.inc.a['populacao'] <- pop - + # Prepare output data table #thresholds.table <- data.table('municipio_geocodigo'=integer(), 'ano_inicio'=integer(), 'ano_fim'=integer(), # 'pre'=double(), 'pos'=double(), 'muitoalta'=double()) - thresholds.table <- data.table(NULL) - - effec_start_year <- min(round(df.inc$SE/100)) + thresholds.table <- data.table::data.table(NULL) + + effec_start_year <- min(floor(df.inc$SE/100)) # Build incidence - - df.inc.a['inc'] <- df.inc.a$casos * 100000.0 / df.inc.a['populacao'] + + df.inc.a['inc'] <- df.inc.a$casos * 100000.0 / df.inc.a['populacao'] #df.inc['municipio_geocodigo'] <- nome - + # Store only necessary data, separating seasons by columns #dfsimple <- df.inc[df.inc$SE > max(df.inc$SE[df.inc$SE<(effec_start_year+1)*100])-12 & # df.inc$SE < (effec_start_year+1)*100+41, c('municipio_geocodigo', 'SE', 'inc')] dfsimple <- df.inc.a[df.inc.a$SE > max(df.inc.a$SE[df.inc.a$SE<(effec_start_year+1)*100])-12 & df.inc.a$SE < (effec_start_year+1)*100+41, c("municipio_geocodigo",'SE', 'inc')] - + effec_start_year_lbl <- paste0(effec_start_year,'-',effec_start_year+1) dfsimple <- plyr::rename(dfsimple, c('SE'=paste0('SE',effec_start_year_lbl), 'inc'=effec_start_year_lbl)) seasons <- c(effec_start_year_lbl) @@ -491,13 +455,12 @@ mem_curve <- function(mun_list, seasons <- cbind(seasons, paste0(i,'-',i+1)) } } - + curveMEM <- fit.mem(dfsimple, seasons, i.n.max=i.n.max, i.level.threshold=limiar.preseason, i.level.intensity=limiar.epidemico, i.type.curve=i.type.curve, i.type.threshold=i.type.threshold, i.type.intensity=i.type.intensity) - + return(curveMEM) - -} +} diff --git a/R/nowcasting_fun.R b/R/nowcasting_fun.R index ecd2802..499637c 100644 --- a/R/nowcasting_fun.R +++ b/R/nowcasting_fun.R @@ -1,6 +1,6 @@ # PROJETO ALERTA DENGUE ------------------------------------- # Auxiliar functions for nowcasting -# Leo Bastos 2020 +# Leo Bastos 2020 # ----------------------------------------------------------- # Auxiliar function, sampling from a negative binomial likelihood @@ -17,9 +17,9 @@ gg <- function(x, dados, idx, Fim.sat, Dmax){ # do domingo da respectiva ultima epiweek # com dados faltantes filter(Date >= Fim.sat - Dmax*7 ) %>% - group_by(Date) %>% - dplyr::summarise( - Casos = sum(Casos) + group_by(Date) %>% + dplyr::summarise( + Casos = sum(Casos) ) data.aggregated } @@ -27,110 +27,111 @@ gg <- function(x, dados, idx, Fim.sat, Dmax){ # Algorithm to get samples for the predictive distribution for the number of cases -nowcasting <- function(output.day, dadosRio.ag, Dm, Fim){ +nowcasting <- function(output.day, dadosRio.ag, Dm, Fim, seed = NULL, samples = 1000L){ + if (!requireNamespace("INLA", quietly = TRUE)) { + stop("nowcasting requires the optional package 'INLA'.", call. = FALSE) + } index.missing = which(is.na(dadosRio.ag$Casos)) - - + + # Step 1: Sampling from the approximate posterior distribution using INLA - srag.samples.list <- inla.posterior.sample(n = 1000, output.day) - - # Step 2: Sampling the missing triangle (in vector form) from the likelihood using INLA estimates - vector.samples <- lapply(X = srag.samples.list, - FUN = ff, - idx = index.missing - ) - - # Step 3: Calculate N_t for each triangle sample {N_t : t=Tactual-Dmax+1,...Tactual} - tibble.samples <- lapply( X = vector.samples, - FUN = gg, - dados = dadosRio.ag, - idx = index.missing, - Fim.sat = Fim, - Dmax = Dm - ) - - # Nowcasting - srag.pred <- bind_rows(tibble.samples, .id = "sample") - - srag.pred + if (length(samples) != 1L || !is.numeric(samples) || samples < 1 || samples != floor(samples)) { + stop("`samples` must be a positive integer.", call. = FALSE) + } + .with_seed(seed, { + srag.samples.list <- INLA::inla.posterior.sample( + n = as.integer(samples), output.day + ) + + # Step 2: sample the missing triangle from the likelihood. + vector.samples <- lapply( + X = srag.samples.list, FUN = ff, idx = index.missing + ) + + # Step 3: aggregate each sampled triangle by onset date. + tibble.samples <- lapply( + X = vector.samples, FUN = gg, dados = dadosRio.ag, + idx = index.missing, Fim.sat = Fim, Dmax = Dm + ) + + bind_rows(tibble.samples, .id = "sample") + }) } # Running INLA for the nowcasting model -nowcast.INLA <- function(dados.ag, model.day,...){ - +nowcast.INLA <- function(dados.ag, model.day, workers = 1L, verbose = FALSE, ...){ + if (!requireNamespace("INLA", quietly = TRUE)) { + stop("nowcast.INLA requires the optional package 'INLA'.", call. = FALSE) + } + + workers <- .validate_workers(workers) output <- tryCatch( - {inla(formula = model.day, - family = "nbinomial", + {INLA::inla(formula = model.day, + family = "nbinomial", data = dados.ag, - num.threads = 4,verbose = FALSE, + num.threads = workers, verbose = verbose, control.predictor = list(link = 1, compute = T), control.compute = list( config = T), ... - # control.family = list( + # control.family = list( # hyper = list("theta" = list( # prior = "loggamma", param = c(1, 0.1))) # ) )}, error=function(cond) { - message("nowcast failed") - message("Here's the original error message:") - message(cond) - # Choose a return value in case of error - return(NULL) + if (isTRUE(verbose)) message("nowcast failed: ", conditionMessage(cond)) + NULL }, warning=function(cond) { - message("nowcast failed") - message("Here's the original warning message:") - message(cond) - # Choose a return value in case of warning - return(NULL) + if (isTRUE(verbose)) message("nowcast warning: ", conditionMessage(cond)) + NULL }) - + output } # Plot nowcasting # plot.nowcast <- function(dadosRio.ag, pred.summy, nowcast = T){ -# +# # dadosRio.ag.day.plot <- dadosRio.ag %>% group_by(Date) %>% -# dplyr::summarise( Casos = sum(Casos, na.rm = T)) %>% -# left_join(pred.summy, by = "Date") %>% +# dplyr::summarise( Casos = sum(Casos, na.rm = T)) %>% +# left_join(pred.summy, by = "Date") %>% # mutate( # Casos = ifelse(Date > Fim, NA, Casos), # Forecast = ifelse(is.na(Mean), NA, 0) + ifelse(Date > Fim, 1, 0) # ) -# +# # # Time series -# p0.day <- dadosRio.ag.day.plot %>% -# ggplot(aes(x = Date, y = Casos, -# color = "Casos notificados", -# linetype = "Casos notificados")) + -# geom_line(size = 1, na.rm = T) -# +# p0.day <- dadosRio.ag.day.plot %>% +# ggplot(aes(x = Date, y = Casos, +# color = "Casos notificados", +# linetype = "Casos notificados")) + +# geom_line(size = 1, na.rm = T) +# # if(nowcast){ -# p0.day <- p0.day + -# geom_ribbon( aes( ymin=LI, ymax=LS), fill = 'gray', -# color = 'gray', alpha = 0.5, -# show.legend = F) + -# geom_line(aes(x = Date, y = Median, -# colour = "Nowcasting", -# linetype = "Nowcasting"), +# p0.day <- p0.day + +# geom_ribbon( aes( ymin=LI, ymax=LS), fill = 'gray', +# color = 'gray', alpha = 0.5, +# show.legend = F) + +# geom_line(aes(x = Date, y = Median, +# colour = "Nowcasting", +# linetype = "Nowcasting"), # size = 1, na.rm = T) + -# scale_colour_manual(name = "", -# values = c("black", "black"), +# scale_colour_manual(name = "", +# values = c("black", "black"), # guide = guide_legend(reverse=F)) + -# scale_linetype_manual(name = "", -# values = c("solid", "dotted"), +# scale_linetype_manual(name = "", +# values = c("solid", "dotted"), # guide = guide_legend(reverse=F)) # } -# -# p0.day <- p0.day + -# #ylab("Casos hospitalização de SRAG") + +# +# p0.day <- p0.day + +# #ylab("Casos hospitalização de SRAG") + # #xlab("Tempo") + # theme_bw( base_size = 14) + -# theme( legend.position = c(0.2, 0.8), legend.title = element_blank()) -# +# theme( legend.position = c(0.2, 0.8), legend.title = element_blank()) +# # p0.day # } diff --git a/R/utility_tools.R b/R/utility_tools.R index 3fb750a..feed532 100644 --- a/R/utility_tools.R +++ b/R/utility_tools.R @@ -5,126 +5,76 @@ # epiYear --------------------------------------------------------------------- -#'@description Find to which epidemiological year belongs a given epidemiological week. +#'@description Find to which epidemiological year belongs a given epidemiological week. #'@title Define Epidemiological Year. #'@export #'@param se numeric vector with epidemiological weeks to be converted #'@param cut epidemiological week that separates consecutive epidemiological years. Default = 41 -#'@return vector of epidemiological years. -#'@examples +#'@return vector of epidemiological years. +#'@examplesIf FALSE #'epiYear(se = 201012) #'epiYear(se = 201012:201522) epiYear <- function(se, cut = 41){ - + d <- tibble(se = se) d %>% - mutate(year = round(se/100), + mutate(year = floor(se/100), eweek = se - year*100, eyear = case_when( eweek < cut ~ year - 1, # if se < cut, eYear = previous calendar Year - TRUE ~ year # if se >= cut, eYear = current calendar Year - )) -} + TRUE ~ year # if se >= cut, eYear = current calendar Year + )) +} # data2SE --------------------------------------------------------------------- -#'@description Find to which epidemiological week belongs a given day. Uses episem function +#'@description Find to which epidemiological week belongs a given day. Uses episem function #'(formula generated data). #'@title Define Epidemiological Week. #'@export #'@param days string vector with dates to be converted #'@param format date format -#'@return numeric vector with the epidemiological weeks. -#'@examples +#'@return numeric vector with the epidemiological weeks. +#'@examplesIf FALSE #'data2SE("01-02-2020",format="%d-%m-%Y") #'data2SE("12-02-2008",format="%d-%m-%Y") #'data2SE(c("03-04-2013","07-01-2019"),format="%d-%m-%Y") data2SE <- function(days, format = "%d/%m/%Y"){ - sem <- rep(NA,length(days)) - days<-as.Date(as.character(days),format=format) - for (i in 1:length(days)) { - sem[i]<-episem(days[i]) - } - sem + as.numeric(as_epiweek(as.Date(as.character(days), format = format))) } # episem --------------------------------------------------------------------- -#' @description Find to which epidemiological week belongs a given day +#' @description Find to which epidemiological week belongs a given day #' @author Oswaldo Cruz #' @title Define Epidemiological Week. #' @export -#' @param date date to be converted (class Date) +#' @param x date to be converted (class Date) +#' @param format date format used when `x` is not already a `Date`. #' @param separa symbol between year and week #' @param retorna What should be return, if epidemiological year and week ('YW'), #' epi. year only ('Y') or epi. week only ('W'). #' Default: 'YW'. -#' @return epidemiological week or year. If separa = '', the output is numeric; +#' @return epidemiological week or year. If separa = '', the output is numeric; #' otherwise is a character. -#' @examples +#' @examplesIf FALSE #' episem(x= as.Date("2018-12-31", format="%Y-%m-%d")) #' episem(x= as.Date("2015-01-01", format="%Y-%m-%d"), separa='-') #' episem(x= as.Date("2015-01-01", format="%Y-%m-%d"), retorna='Y') episem <- function(x, format="%Y-%m-%d", separa='', retorna='YW') { - # semana epi 1 de 2000 02/01/2000 - if (class(x)!= "Date") { - x <- as.Date(x, format = format) - #warning("Precisa ser do tipo Date - Convertendo de texto") - } - if (is.na(x) == T) { - message("episem: Date not valid, returning NA") - return(NA) - } - ## funcoes auxiliares - poderia usar a lubridate mas achei assim mais simples - - year <- function(dt) {as.numeric(format(dt,"%Y"))} ## retorna ano - wday <- function(dt) {as.numeric(format(dt,"%w"))} ## retorna dia sendo 0 = domingo a 6= sabado - passado <- function(dt,diff=1) {as.Date(paste(as.numeric(format(dt,"%Y"))-diff,format(dt,"%m-%d"),sep="-"))} ## ano - x - - ## Inicio - - ano <- year(x) # extrai ano - dia1 <- as.Date(paste(ano,'01','01',sep='-'),format = "%Y-%m-%d") # primeiro do ano - - diasem <- wday(dia1) #descobre o dia da semana do dia1 - fwd <- ifelse (diasem <=3, dia1 - diasem , dia1 + (7 - diasem) ) #se for menor ou igua a 3 (quarta) - fwd <- as.Date(fwd,origin = '1970-01-01') # reformata em data pois ela perde a formatacao - - ## caso a data seja menor que a da 1o semana do ano (fwd) - if (x < fwd) { - dia1 <- passado(dia1) # ano -1 - diasem <- wday(dia1) #dia da semana - fwd <- ifelse (diasem <=3, dia1 - diasem , dia1 + (7 - diasem) ) - fwd <- as.Date(fwd,origin = '1970-01-01') - } - - diafim <- as.Date(paste(ano,'12','31',sep='-')) #Ultimo dia do ano - diasem <- wday(diafim) #dia semana do ultimo dia - - ewd <- ifelse (diasem < 3, diafim - diasem - 1, diafim + 6 - diasem) - ewd <- as.Date(ewd,origin = '1970-01-01') # ultima semana epi do ano - - if (x > ewd) fwd <- ewd + 1 #caso a data (x) seja maior ou igual a ultiam semaan do ano - epiweek <- floor(as.numeric(x - fwd) / 7 ) + 1 #numero de semanas e a diff da data e da primeira semana div por 7 - - if(epiweek==0) epiweek <- 1 ## gatilho se for 0 vira semana 1 - epiyear <- year(fwd + 180) ## ano epidemiologico - - if (retorna=='YW'){ - out <- sprintf("%4d%s%02d",epiyear,separa,epiweek) ## formata string com separador - } else if (retorna=='Y') { - out <- epiyear - } else { - out <- epiweek - } - - if (separa =="") { - return(as.numeric(out)) - } else { - return(out) + dates <- if (inherits(x, "Date")) x else as.Date(x, format = format) + weeks <- as_epiweek(dates) + year <- floor(weeks / 100) + week <- weeks %% 100 + assert_that(retorna %in% c("YW", "Y", "W"), + msg = "episem: retorna must be YW, Y or W") + out <- if (retorna == "Y") year else if (retorna == "W") week else weeks + if (retorna == "YW" && nzchar(separa)) { + out <- ifelse(is.na(weeks), NA_character_, sprintf("%04d%s%02d", year, separa, week)) } + if (nzchar(separa)) as.character(out) else as.numeric(out) } #' lastepiweek ----------------------------------- @@ -133,40 +83,26 @@ episem <- function(x, format="%Y-%m-%d", separa='', retorna='YW') { #' @author Marcelo F Gomes #' @param ano Year #' @keywords internal -#' @examples +#' @examplesIf FALSE #' lastepiweek(2018) lastepiweek <- function(ano){ - - # Calcula o valor da ultima semana do ano - - diafim <- as.Date(paste(ano,'12','31',sep='-')) #Ultimo dia do ano - diasem <- as.numeric(format(diafim,"%w")) #dia semana do ultimo dia - - ewd <- ifelse (diasem < 3, diafim - diasem - 1, diafim + 6 - diasem) # Obtem a data do ultimo sabado - ewd <- as.Date(ewd,origin = '1970-01-01') # ultima semana epi do ano - - return(episem(ewd,retorna='W')) + as.numeric((.epi_year_start(as.integer(ano) + 1L) - .epi_year_start(ano)) / 7) } # SE2date --------------------------------------------------------------------- #'@description Return the first day of the Epidemiological Week #'@title Return the first day of the Epidemiological Week #'@export -#'@param SE string vector with dates to be converted, format 201420 +#'@param se numeric vector with epidemiological weeks, for example 201420. #'@return data.frame with SE and first day. -#'@examples +#'@examplesIf FALSE #'SE2date(se=202612) #'SE2date(se = c(202001:202209)) SE2date <- function(se){ - if(!class(se[1]) %in% c("numeric","integer")) stop("se should be numeric or integer") - - #load("R/sysdata.rda") - #SE$sem <- SE$Ano*100 + SE$SE - res <- data.frame(SE = se, ini = as.Date("1970-01-01")) - for (i in 1:length(res$SE)) res$ini[i] <- SE$Inicio[SE$SE == res$SE[i]] - res + if(!is.numeric(se)) stop("se should be numeric or integer") + data.frame(SE = se, ini = epiweek_start(se)) } # daySEday--------------------------------------------------------------------- @@ -174,34 +110,17 @@ SE2date <- function(se){ #'@title Return the first day of the Epidemiological Week and vice-versa #'@export #'@param x numeric vector with epidemiological weeks , format 201945, or date +#'@param format date format used for character input. #'@return data.frame with SE and first day. -#'@examples +#'@examplesIf FALSE #'daySEday(x=202612) #'daySEday(x = c(202541:202604)) #'daySEday(x = c("2015-12-23", "2015-10-23", "2026-10-16")) daySEday <- function(x, format = "%Y-%m-%d"){ - #load("R/sysdata.rda") - n <- length(x) - if(class(x[1]) %in% c("numeric","integer")) { - assert_that(all(x > 200952 & x < 202700), msg = "day2SE: SE format = - 201612, btw 201001 and 202652") - - res <- data.frame(SE = x, ini = as.Date("1970-01-01")) - - for (i in 1:n) res$ini[i] <- SE$Inicio[SE$SE == res$SE[i]] - return(res) - - } - if(class(x[1]) == "character") x <- as.Date(x, format = format) - assert_that(all(x <= "2027/01/03" & x >= "2010/01/01")) - res <- data.frame(SE = NA, ini = x) - for (i in 1:n) res$SE[i] <- SE[which(SE$Inicio<=x[i] & SE$Termino >= x[i]), "SE"] - return(res) - - - #SE$sem <- SE$Ano*100 + SE$SE - + if (is.numeric(x)) return(data.frame(SE = x, ini = epiweek_start(x))) + dates <- if (inherits(x, "Date")) x else as.Date(x, format = format) + data.frame(SE = as.numeric(as_epiweek(dates)), ini = dates) } @@ -211,59 +130,27 @@ daySEday <- function(x, format = "%Y-%m-%d"){ #'@export #'@param from first week in format 201401 #'@param to first week in format 201401 -#'@return data.frame with the epidemiological weeks and corresponding extreme days. +#'@return data.frame with the epidemiological weeks and corresponding extreme days. #'WARNING: only works from 2010 to 2024. -#'@examples +#'@examplesIf FALSE #'seqSE(202442, 202510) seqSE <- function(from, to){ - #load("R/sysdata.rda") - #SE$SE <- SE$Ano*100 + SE$SE - N <- dim(SE)[1] - - if (from < SE$SE[1]){ - from <- SE$SE[1] - #warning(paste("first SE set to", from)) - } - - if (to > SE$SE[N]){ - to <- SE$SE[N] - warning(paste("This function only works from 2010 to - ",max(SE$Ano),". Last returned date is", to)) - } - - SE[which(SE$SE==from):which(SE$SE==to),] + weeks <- epiweek_seq(from, to) + starts <- epiweek_start(weeks) + data.frame(Ano = floor(weeks / 100), SE = as.numeric(weeks), + Inicio = starts, Termino = starts + 6L) } -# lastDBdate --------------------------------------------------------------------- -#'@description Useful to check if the database is up-to-date. -#'@title Returns the most recent date present in the database table. -#'@export -#'@param tab table in the database. Either (sinan, clima_wu, tweet, historico, -#'historico_mrj). -#'@param cities vector of geocodes. -#'@param cid10 relevant for sinan, tweeter or historico. Codes are: dengue "A90", -#'chik "A92.0", zika "A92.8". -#'@param stations vector with wu stations. Ex. c("SGBL", "SBRL") -#'@param datasource -#'@return vector with two elements: data.max = most recent date in the collection of cities or stations; -#'se = corresponding epidemiological week. -#'@examples -#'cidades <- getCidades(regional = "Sete Lagoas", uf = "Minas Gerais") -#'lastDBdate(tab = "tweet", cities = cidades$municipio_geocodigo, cid10 = "A90") -#'lastDBdate(tab = "sinan", cities = cidades$municipio_geocodigo, cid10 = "A92.8") -#'lastDBdate(tab = "clima_wu", stations = "SBAF", datasource=con) -#'lastDBdate(tab = "clima_wu", cities = cidades$municipio_geocodigo, datasource=con) - - # sevendigitgeocode --------------------------------------------------------------------- -#'@description calculates the verification digit of brazilian municipalities. Required -#'to convert 6 digits to 7 digits geocodes. -#'@title convert 6 to 7 digits geocodes. +#'@description calculates the verification digit of brazilian municipalities. Required +#'to convert 6 digits to 7 digits geocodes. +#'@title convert 6 to 7 digits geocodes. #'@export -#'@return 7 digits municipality geocode. -#'@examples +#'@param dig Six- or seven-digit municipality geocode. +#'@return 7 digits municipality geocode. +#'@examplesIf FALSE #'sevendigitgeocode(330455) #'sevendigitgeocode(3304557) #'sevendigitgeocode(261153) @@ -272,20 +159,20 @@ sevendigitgeocode <- function(dig){ ndig = nchar(as.character(dig)) if (ndig == 7) return(dig) if (ndig!=6) stop("this funtion receives 6 digits geocodes only") - - # there are 9 cities with inconsistent seventh digit. + + # there are 9 cities with inconsistent seventh digit. digspatologicos <- c(220191, 220198, 220225, 261153, 311783, 315213, 430587, 520396, 520393) if(dig %in% digspatologicos){ pos <- which(digspatologicos == dig) dig7 <- c(2201919,2201988,2202251,2611533,3117836,3152131,4305871,5203962,5203939)[pos] return(dig7) - } - # for all the remaining, there is this rule + } + # for all the remaining, there is this rule peso <- c(1, 2, 1, 2, 1, 2, 0) soma <- 0 digchar <- strsplit(as.character(dig),"")[[1]] ndig <- length(digchar) - + for (i in 1:6){ valor <- as.integer(digchar[i]) * peso[i] nvalor <- ifelse(valor < 10, valor, trunc(valor/10) + valor%%10) @@ -294,20 +181,21 @@ sevendigitgeocode <- function(dig){ dv <- ifelse(soma%%10 == 0, 0, 10 - (soma%%10)) return(dig*10+dv) } - + # nafill ------------------------------------ -#'@description collection of imputation procedures -#'@title methods to substitute NAs. Use the function na.approx from package zoo. +#'@description collection of imputation procedures +#'@title methods to substitute NAs. Use the function na.approx from package zoo. #'@export #'@param v vector with missing elements. #'@param rule rule for filling the missing cells. "zero" just fills them with 0; "linear" #' interpolate using zoo::na.approx. In this case, the tails are not filled. If "arima", then it interpolates using -#' linear and extrapolates using arima (calling AlertTools::temp.predict) +#' linear and extrapolates using arima (calling AlertTools::temp.predict) #'@param maxgap maximum number of consecutive NAs to fill. Longer gaps will be left unchanged. Only works for rule = "zero" #' or "linear" -#'@return vector -#'@examples +#'@param verbose Whether to emit information about missing values. +#'@return vector +#'@examplesIf FALSE #'# Interpolation: #'v <- c(1,2,3,NA,5,6,NA,NA,9,10,NA,NA) #'nafill(v, rule = "zero") @@ -316,7 +204,7 @@ sevendigitgeocode <- function(dig){ #'cliSBCB <- getWU(station = "SBCB") #'summary(cliSBCB) #'cliSBCB <- getWU(station = "SBCB") %>% -#' mutate(nafill("temp_min", rule = "arima")) +#' mutate(nafill("temp_min", rule = "arima")) nafill <- function(v, rule, maxgap = 4, verbose = F){ Nna = sum(is.na(v)) @@ -331,12 +219,13 @@ nafill <- function(v, rule, maxgap = 4, verbose = F){ } # temp.predict ------------------------------------ -#'@description function for extrapolating temperature using arima -#'@title Fit arima to fill in missing data at the end of temperature time series. +#'@description function for extrapolating temperature using arima +#'@title Fit arima to fill in missing data at the end of temperature time series. #'@export #'@param v vector with temperature data. +#'@param plotar Whether to plot observed and predicted values. #'@return vector with replaced NA. -#'@examples +#'@examplesIf FALSE #'head(cliSBCB) #'temp.predict(v=cli[,3], plotar = T) @@ -345,51 +234,51 @@ temp.predict <- function(v, plotar = FALSE){ datarange <- range(which(!is.na(v))) # tamanho do tail de na: Nna = Nv - datarange[2] - + x <- zoo::na.approx(v) - + if(Nna > 0){ - + # Para saber os coeficientes da parte ARIMA atraves de criterios de selecao automatica: #automatica: c.a <- forecast::auto.arima(x, max.p=5, max.q=5, max.P=5, max.Q=5)$arma # Modelo considerando a sazonalidade, e a parte ARIMA sugerida anteriormente: modelo.sarima <- arima(zoo::na.approx(v),order=c.a[c(1,6,2)],seasonal=list(order=c(c.a[3],1,c.a[4]),period=52)) - + message(paste("temperature predicted", Nna, "steps ahead" )) predito<-predict(modelo.sarima,n.ahead=Nna)$pred - + if (plotar == T){ - fitado <- forecast::fitted(modelo.sarima) + fitado <- stats::fitted(modelo.sarima) # Plot para ver o desempenho do modelo in/outsample plot(c(fitado,predito),col="orange",type="l",ylab="") lines(x,type="l") legend("bottomleft",c("Observado","Estimado"),col=c("black","orange"),lty=1) } - + # juntando dados com predito v[(datarange[2]+1):Nv] <-predito } v[datarange[1]:datarange[2]] <- x - + v } # getRegionais ------------------------------------ -#'@description consult database to get list of regionais -#'@title get list of regionais. +#'@description consult database to get list of regionais +#'@title get list of regionais. #'@export #'@param uf full name of the state. #'@param cities cities' geocodes -#'@param sortedby the options are: 'a' alphabetically, 'id' regional id number (only valid for regional), +#'@param sortedby the options are: 'a' alphabetically, 'id' regional id number (only valid for regional), #'if available -#'@param macroreg TRUE if getRegionais should return macroreg instead of reg. Default: False -#'@param output if "names" returns only a vector with names of regionais or macros. +#'@param macroreg TRUE if getRegionais should return macroreg instead of reg. Default: False +#'@param output if "names" returns only a vector with names of regionais or macros. #'If "complete" , returns municipalities and their regs #'@param datasource name of the database #'@return vector with names of the regionais. -#'@examples +#'@examplesIf FALSE #'getRegionais(uf="Rio de Janeiro") #'head(getRegionais(uf="Rio de Janeiro",output="complete",macroreg = TRUE)) #'head(getRegionais(uf="Rio de Janeiro",output="complete")) @@ -397,240 +286,161 @@ temp.predict <- function(v, plotar = FALSE){ #'getRegionais(cities = c(3304128,3306107,3300159), uf="Rio de Janeiro", macroreg = TRUE) #'getRegionais(uf="Rio de Janeiro", sortedby = 'id') -getRegionais <- function(cities, uf, sortedby = "a", macroreg = FALSE, - datasource=con, output = "names"){ - - assert_that(!missing(uf), - msg = "getRegionais: please specify uf. Ex. uf = \"Ceará\" ") - - if(class(datasource) == "PostgreSQLConnection"){ - sqlquery = paste("SELECT geocodigo, nome, regional, id_regional, - macroregional, macroregional_id, uf FROM \"Dengue_global\".\"Municipio\" - where uf = '", uf, "'", sep="") - d = DBI::dbGetQuery(datasource, sqlquery) - } - assert_that(nrow(d) > 0, - msg = (paste("getRegionais: +getRegionais <- function(cities, uf, sortedby = "a", macroreg = FALSE, + datasource, output = "names"){ + + assert_that(!missing(uf), + msg = "getRegionais: please specify uf. Ex. uf = \"Ceara\" ") + + .db_validate_connection(datasource) + d <- .repo_municipalities( + datasource, + cities = if (!missing(cities)) cities else NULL, + uf = uf, + columns = c("geocodigo", "nome", "regional", "id_regional", + "macroregional", "macroregional_id", "uf") + ) + assert_that(nrow(d) > 0, + msg = (paste("getRegionais: Database does not have the health areas for ", uf))) - + names(d) <- c("municipio_geocodigo","cidade","regional","codigo_regional", "macroregional","codigo_macroregional","uf") - + if(!missing(cities)) { - d <- d %>% filter(municipio_geocodigo %in% cities) - assert_that(nrow(d) == length(cities), - msg = (paste("getRegionais: Database does not have the health + assert_that(nrow(d) == length(cities), + msg = (paste("getRegionais: Database does not have the health districts for all listed cities in", uf))) } - + if(output == "names" & macroreg == TRUE) return(unique(d$macroregional)) if(output == "names" & macroreg == FALSE) return(unique(d$regional)) - + return(d) } # getCidades ------------------------------------ #'@description consult database to get list of cities for regional, macroregional or uf. -#'@title get list of cities. +#'@title get list of cities. #'@export #'@param uf full name of the state. -#'@param regional full name of the regional. Use getRegionais() to obtain the correct spelling. +#'@param regional full name of the regional. Use getRegionais() to obtain the correct spelling. #'@param macroregional full name of the macroregional. #'@param datasource name of the database #'@return vector with names of the cities. -#'@examples +#'@examplesIf FALSE #'getCidades(regional = "Metropolitana I", uf="Rio de Janeiro") #'getCidades(uf="Acre") -#'getCidades(uf="Maranhão", macroregional = "NORTE") - -getCidades <- function(regional, macroregional, uf, datasource=con){ - - if(missing(uf)) stop("getCidades: specify uf's full name. Ex: São Paulo") - if(!missing(regional)){ # all cities in the regionais - - sqlquery = paste("SELECT geocodigo, nome, regional, id_regional, - macroregional, macroregional_id, uf FROM \"Dengue_global\".\"Municipio\" - WHERE uf = '", uf, "' AND regional = '", regional ,"'", sep="") - d = DBI::dbGetQuery(datasource, sqlquery) - - assert_that(nrow(d) > 0, msg = "getCidades: found no city. Check names.") - names(d) <- c("municipio_geocodigo", "cidade", "regional", - "regional_id", "macroregional","macroregional_id","uf") - return(d) - } - - if(!missing(macroregional)){ # all cities in the macroregional - - sqlquery = paste("SELECT geocodigo, nome, regional, id_regional, - macroregional, macroregional_id, uf FROM \"Dengue_global\".\"Municipio\" - WHERE uf = '", uf, "' AND macroregional = '", macroregional ,"'", sep="") - - d <- dbGetQuery(datasource, sqlquery) - assert_that(nrow(d)>0, msg = "getCidades: found no city. Check names.") - names(d) <- c("municipio_geocodigo", "cidade", "regional", "regional_id", - "macroregional","macroregional_id","uf") - return(d) - } - - # else: retorna para todo o estado - sqlquery = paste("SELECT geocodigo, nome, regional, id_regional, - macroregional, macroregional_id, uf FROM \"Dengue_global\".\"Municipio\" - where uf = '", uf, "'", sep="") - d <- DBI::dbGetQuery(datasource, sqlquery) +#'getCidades(uf="Maranhao", macroregional = "NORTE") + +getCidades <- function(regional, macroregional, uf, datasource){ + + if(missing(uf)) stop("getCidades: specify uf's full name. Ex: Sao Paulo") + .db_validate_connection(datasource) + d <- .repo_municipalities( + datasource, + uf = uf, + regional = if (!missing(regional)) regional else NULL, + macroregional = if (!missing(macroregional)) macroregional else NULL, + columns = c("geocodigo", "nome", "regional", "id_regional", + "macroregional", "macroregional_id", "uf") + ) assert_that(nrow(d)>0, msg = "getCidades: found no city") - names(d) <- c("municipio_geocodigo", "cidade", "regional", "regional_id", + names(d) <- c("municipio_geocodigo", "cidade", "regional", "regional_id", "macroregional","macroregional_id","uf") - return(d) - + return(d) + } # write_parameters ------------------------------------ -#'@description Write the alert parameters for each city into the database, to be used in the update.alert. +#'@description Write the alert parameters for each city into the database, to be used in the update.alert. #'Currently, the parameters are: "limiar_preseason", "limiar_posseason", -#'"limiar_epidemico,"varcli", "varcli2", "clicrit", "clicrit2" , "cid10", "codmodelo". +#'"limiar_epidemico,"varcli", "varcli2", "clicrit", "clicrit2" , "cid10", "codmodelo". #' City must be already in the regionais table. -#'@title City's parameterization. -#'@export -#'@param params vector of the names of the params to be inserted in the table. Limiar is given as incidence. -#'It can be a subset of the default. -#'@return the new line in the parameters table -#'@examples -#'pars = data.frame(municipio_geocodigo = 3506003,limiar_preseason = 4.50243, limiar_posseason = 3.962566, -#'limiar_epidemico = 67.72364, varcli = "temp_min", clicrit = 22, cid10 = "A90", codmodelo = "Af") +#'@title City's parameterization. +#'@noRd +#'@param params vector of the names of the params to be inserted in the table. Limiar is given as incidence. +#'It can be a subset of the default. +#'@param city Seven-digit municipality geocode. +#'@param cid10 Disease code. +#'@param overwrite Whether to replace existing parameters. +#'@param datasource Database connection. +#'@param conflict Conflict policy: `ignore`, `update`, or `error`. `overwrite = TRUE` +#'selects `update` for backwards compatibility. +#'@return the new line in the parameters table +#'@examplesIf FALSE +#'pars = data.frame(municipio_geocodigo = 3506003,limiar_preseason = 4.50243, limiar_posseason = 3.962566, +#'limiar_epidemico = 67.72364, varcli = "temp_min", clicrit = 22, cid10 = "A90", codmodelo = "Af") #'res = write_parameters(params$municipio_geocodigo, params$cid10, params = pars) -write_parameters<-function(city, cid10, params, overwrite = FALSE, datasource = con){ - - # checking inputs - assert_that(class(params) == "data.frame", +.write_parameters_impl <- function(city, cid10, params, overwrite = FALSE, datasource, + conflict = c("ignore", "update", "error")) { + assert_that(is.data.frame(params), msg = "write_parameters: params should be a data.frame") - - assert_that(nrow(params) == 1 , + assert_that(nrow(params) == 1, msg = "write_parameters write one line only") - - assert_that(cid10 %in% c("A90","A92.0","A92.8"), - msg = paste("write_parameters: not prepared for cid10 = ",params$cid10)) - - assert_that(all(c("municipio_geocodigo","cid10") %in% names(params)), - msg = paste("write.parameters: params must contain municipio_geocodigo, cid10")) - - assert_that(class(datasource) == "PostgreSQLConnection", - msg = paste("write.parameters: datasource must be a connection to the Infodengue server")) - - # check if city is already in the system (Regional table) - they all are - - #sql1 = paste("SELECT * from \"Dengue_global\".regional_saude SET - # WHERE municipio_geocodigo = ",city, sep="") - #cityregtable = try(dbGetQuery(datasource, sql1)) - - #assert_that(nrow(cityregtable)>0, - # msg = paste("geocode", city, "not implemented in Infodengue. Use insertCityinAlerta()") ) - - # Next step, check if there are any parameters for this cid10? - sql2 = paste("SELECT * from \"Dengue_global\".parameters SET - WHERE municipio_geocodigo = ",city," AND cid10 = $$", - cid10,"$$", sep="") - - parline = try(DBI::dbGetQuery(datasource, sql2)) - - assert_that(nrow(parline) < 2, - msg = paste("parameter table has something wrong. more than one line for", - params$cid10, "for city", city, ".")) - - # now let's write the data - # if line does not exist, create one with the cid and geocode: - if(nrow(parline) == 1 & overwrite == FALSE){ - message("the following parameters were found. Rerun with overwrite = T to replace them") - print(parline) - return(parline) - } - - if(nrow(parline) == 0){ # - message(paste("no previous param found. Inserting new param line for city", params$municipio_geocodigo)) - linha = paste(as.character(params$municipio_geocodigo), ",\'",params$cid10, "\'",sep="") - sql = paste("insert into \"Dengue_global\".parameters (municipio_geocodigo, cid10) values(", linha ,")") - DBI::dbGetQuery(datasource, sql) - - # check if was correctly created - parline_now = try(DBI::dbGetQuery(datasource, sql2)) - - assert_that(nrow(parline_now) == 1, - msg = paste("parameter table has something wrong. number of lines for ", - params$cid10, "for city", city, "is:", nrow(parline_now) )) - } - - vars <- params %>% dplyr::select(-c("municipio_geocodigo", "cid10")) - nvars <- length(vars) - - # updating parameter values - - for (i in 1:nvars) { - linha = paste(names(vars)[i], " = '", vars[[i]], "'", sep = "") - update_sql = paste("UPDATE \"Dengue_global\".parameters SET ", linha , - " WHERE municipio_geocodigo = ", params$municipio_geocodigo, - " AND cid10 = \'", cid10, "\'", sep="") - try(DBI::dbGetQuery(datasource, update_sql)) - } - - + assert_that(cid10 %in% c("A90", "A92.0", "A92.8"), + msg = paste("write_parameters: not prepared for cid10 =", cid10)) + assert_that(all(c("municipio_geocodigo", "cid10") %in% names(params)), + msg = "write.parameters: params must contain municipio_geocodigo, cid10") + .db_validate_connection(datasource) + + conflict <- match.arg(conflict) + if (isTRUE(overwrite)) conflict <- "update" + assert_that(as.numeric(params$municipio_geocodigo) == as.numeric(city) && + as.character(params$cid10) == as.character(cid10), + msg = "write_parameters: keys in params must match city and cid10") + + .repo_write_rows( + datasource, "parameters", params, + key = c("municipio_geocodigo", "cid10"), conflict = conflict + ) + .repo_parameters(datasource, city, cid10) } # read.parameters ------------------------------------ -#'@description Read the alert parameters for a set of cities from the database, to be used in the infodengue pipeline. -#'Currently, the parameters are: "limiar_preseason" (pre-season incidence threshold calculated using MEM), -#'"limiar_posseason" (pos-season incidence threshold), "limiar_epidemico"(epidemic threshold), "varcli" (name of the critical +#'@description Read the alert parameters for a set of cities from the database, to be used in the infodengue pipeline. +#'Currently, the parameters are: "limiar_preseason" (pre-season incidence threshold calculated using MEM), +#'"limiar_posseason" (pos-season incidence threshold), "limiar_epidemico"(epidemic threshold), "varcli" (name of the critical #'meteorological variable), "clicrit" (critical value of the meteorological variable), "cid10", -#'"codmodelo" (name of the heuristic decision model, see serCriteria()). These parameters are specified when the city is initiated +#'"codmodelo" (name of the heuristic decision model, see serCriteria()). These parameters are specified when the city is initiated #'in the pipeline. #'@title Get city-level alert parameters for the infodengue pipeline. -#'@export -#'@param cities cities' geocodes. Tip: find them using getCidades(). +#'@noRd +#'@param cities cities' geocodes. Tip: find them using getCidades(). #'@param cid10 Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8" #'@param datasource SQL connection to the database #'@return dataframe with all parameters -#'@examples +#'@examplesIf FALSE #'read.parameters(cities = 3118601, cid10 = "A90") #'cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") #'read.parameters(cities = cid$municipio_geocodigo, cid10 = "A90") -read.parameters<-function(cities, cid10 = "A90", datasource=con){ - +.fetch_alert_parameters_impl <- function(cities, cid10 = "A90", datasource){ + cities <- sapply(cities, function(x) sevendigitgeocode(x)) if(!cid10 %in% c("A90", "A92.0")) { warning("Parameter table currently supports only A90 (dengue) and A92.0 (chikungunya). Using dengue parameters (A90).") cid10 <- "A90" } - - # regra específica: Espírito Santo (só tem parâmetros de dengue) + + # specific rule: Espirito Santo only has dengue parameters if(any(grepl("^32", cities)) && cid10 != "A90") { - warning("Parameters for Espírito Santo are only available for dengue (A90). Using A90.") + warning("Parameters for Espirito Santo are only available for dengue (A90). Using A90.") cid10 <- "A90" } - - # reading parameters from database - - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - - if(class(datasource) == "PostgreSQLConnection"){ - comando = paste("SELECT * FROM \"Dengue_global\".parameters WHERE cid10 = '", cid10 , - "' AND municipio_geocodigo IN (", sqlcity,")", sep="") - } - - if(class(datasource) == "SQLiteConnection"){ - comando = paste("SELECT * FROM parameters WHERE cid10 = '", cid10 , - "' AND municipio_geocodigo IN (", sqlcity,")", sep="") - } - - try(dd <- DBI::dbGetQuery(datasource,comando)) - - assert_that(all(cities %in% dd$municipio_geocodigo),msg = ("check if cities and cid10 are in the parameter table")) - + + .db_validate_connection(datasource) + dd <- .repo_parameters(datasource, cities, cid10) + + assert_that(all(cities %in% dd$municipio_geocodigo),msg = ("check if cities and cid10 are in the parameter table")) + return(dd) } - + # getWUstation ------------------------------------------ #'@description Get the meteorological stations associated with one or more cities #'@title get meteorological stations @@ -638,80 +448,60 @@ read.parameters<-function(cities, cid10 = "A90", datasource=con){ #'@param cities vector with geocodes #'@param datasource connection to the project database #'@return data.frame -#'@examples +#'@examplesIf FALSE #'getWUstation(cities = 3304557) #'cidades <- getCidades(regional = "Sete Lagoas", uf = "Minas Gerais") #'getWUstation(cities = cidades$municipio_geocodigo) -getWUstation <- function(cities, datasource = con){ - sqlcity = paste("'", str_c(cities, collapse = "','"),"'", sep="") - - if(class(datasource) == "PostgreSQLConnection"){ - comando <- paste("SELECT municipio_geocodigo, codigo_estacao_wu, estacao_wu_sec from - \"Dengue_global\".parameters WHERE municipio_geocodigo IN (", sqlcity, - ")" , sep="") - } - if(class(datasource) == "SQLiteConnection"){ - comando <- paste("SELECT municipio_geocodigo, codigo_estacao_wu, estacao_wu_sec from - parameters WHERE municipio_geocodigo IN (", sqlcity, - ")" , sep="") - } - - city_table <- DBI::dbGetQuery(datasource,comando) - return(city_table) +getWUstation <- function(cities, datasource){ + .db_validate_connection(datasource) + .repo_station_links(datasource, cities) } # setWUstation ------------------------------------------ -#'@description Set primary and secondary meteorological stations associated +#'@description Set primary and secondary meteorological stations associated #'with one or more cities of the same state #'@title set meteorological stations #'@export -#'@param st data.frame containing municipio_geocodigo, primary_station, +#'@param st data.frame containing municipio_geocodigo, primary_station, #'secondary_station #'@param UF name of the state.Ex. "Rio de Janeiro" -#'@param senha for the connection to the project database -#'@examples -#'NOT RUN +#'@param datasource connection to the project database +#'@examplesIf FALSE +#'# NOT RUN #'wudata = data.frame(municipio_geocodigo = 3107802, primary_station = "SBIP", #'secondary_station = "SBGV") #'setWUstation(wudata, UF = "Minas Gerais") #'getWUstation(cities =wudata$municipio_geocodigo) -setWUstation <- function(st, UF, datasource = con){ - +setWUstation <- function(st, UF, datasource){ + ncities <- nrow(st) - + # checking inputs - assert_that(class(st) == "data.frame", + assert_that(class(st) == "data.frame", msg = "setWUstation: st should be a data.frame") - + assert_that(all(names(st) %in% c("municipio_geocodigo" , "primary_station", - "secondary_station")), - msg = "setWUstation: st should contain columns municipio_geocodigo, + "secondary_station")), + msg = "setWUstation: st should contain columns municipio_geocodigo, primary_station, secondary_station") - - assert_that(class(datasource) == "PostgreSQLConnection", - msg = paste("setWUstation: datasource must be a connection to the Infodengue server")) - + + .db_validate_connection(datasource) + # check if city is already in the system (Regional table) cities_table <- getCidades(uf = UF, datasource = datasource) cities_in <- st$municipio_geocodigo %in% cities_table$municipio_geocodigo - - assert_that(sum(cities_in)==ncities, - msg = paste("geocodes", st$municipio_geocodigo[cities_in == FALSE] , + + assert_that(sum(cities_in)==ncities, + msg = paste("geocodes", st$municipio_geocodigo[cities_in == FALSE] , "not implemented in Infodengue.") ) - - ## writing - - for (i in 1:ncities) { - el1 = paste("'", as.character(st$primary_station[i]),"'",sep="") - el2 = paste("'", as.character(st$secondary_station[i]),"'",sep="") - linha = paste("codigo_estacao_wu = ", el1, ",", "estacao_wu_sec = ", el2, sep = "") - update_sql = paste("UPDATE \"Dengue_global\".parameters SET ", linha , " WHERE - municipio_geocodigo = ", st$municipio_geocodigo[i], sep="") - cityline = try(DBI::dbGetQuery(datasource, update_sql)) - } - - return() -} + updates <- data.frame( + municipio_geocodigo = st$municipio_geocodigo, + codigo_estacao_wu = st$primary_station, + estacao_wu_sec = st$secondary_station, + stringsAsFactors = FALSE + ) + invisible(.repo_update_station_links(datasource, updates)) +} diff --git a/README.md b/README.md index e809a96..4bc1569 100644 --- a/README.md +++ b/README.md @@ -1 +1,129 @@ +# AlertTools + +[![R-CMD-check](https://github.com/AlertaDengue/AlertTools/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/AlertaDengue/AlertTools/actions/workflows/R-CMD-check.yaml) [![DOI](https://zenodo.org/badge/346099537.svg)](https://zenodo.org/doi/10.5281/zenodo.13326581) + +AlertTools reúne as rotinas usadas pelo InfoDengue para organizar dados +epidemiológicos e climáticos, corrigir atrasos de notificação, estimar Rt e +classificar níveis de alerta. A API moderna separa leitura, cálculo e escrita; +o núcleo também pode ser usado sem banco de dados. + +## Requisitos + +- R 3.5 ou mais recente; +- dependências regulares instaladas automaticamente pelo gerenciador de pacotes; +- RSQLite apenas para o exemplo local com banco; +- RPostgres apenas para conexão com PostgreSQL; +- INLA e mem somente para os modelos opcionais correspondentes. + +Nenhum exemplo desta página exige credenciais, dados de produção ou um objeto +global chamado `con`. + +## Instalação + +Instale a versão de desenvolvimento diretamente do GitHub: + +```r +install.packages("pak") +pak::pak("AlertaDengue/AlertTools") +``` + +Para desenvolver o pacote a partir de um clone: + +```r +pak::pak() +devtools::load_all() +``` + +## Exemplo mínimo sem banco + +O pacote inclui um exemplo autocontido que cria dados sintéticos, executa o +pipeline e deixa o resultado no objeto `result`: + +```r +example_file <- system.file( + "examples", "in-memory-pipeline.R", + package = "AlertTools", + mustWork = TRUE +) +sys.source(example_file, envir = environment()) + +result +summary(result) +head(as.data.frame(result)) +``` + +O fluxo equivalente é composto por duas chamadas principais: + +```r +inputs <- new_alert_inputs(cases, climate) + +result <- run_alert_pipeline( + inputs = inputs, + parameters = parameters, + report_week = 202512, + nowcast = "none", + workers = 1 +) +``` + +## Fluxo com banco + +Leitura, processamento e escrita são operações separadas: + +```r +inputs <- fetch_alert_inputs( + conn = conn, + geocodes = 3304557, + disease = "dengue", + start_week = 202501, + report_week = 202512 +) + +parameters <- fetch_alert_parameters( + conn = conn, + geocodes = 3304557, + disease = "dengue" +) + +result <- run_alert_pipeline(inputs, parameters, nowcast = "none") + +write_alert_results( + conn = conn, + result = result, + version_date = as.Date("2026-09-05"), + conflict = "update" +) +``` + +O arquivo `inst/examples/sqlite-pipeline.R` demonstra esse fluxo com um banco +SQLite temporário e dados sintéticos. + +## Documentação + +- `vignette("in-memory-pipeline", package = "AlertTools")`: uso reproduzível + sem banco; +- `vignette("database-pipeline", package = "AlertTools")`: fronteira DBI com + SQLite temporário e adaptação para PostgreSQL; +- [guia de migração](docs/refactoring/api-migration.md): correspondência entre + a API legada e a API em `snake_case`; +- [transição dos consumidores](docs/refactoring/consumer-migration.md): ordem, + validações e rollback da migração operacional; +- [guia de contribuição](CONTRIBUTING.md): testes, estilo e revisão; +- [processo de release](docs/RELEASE.md): versionamento e publicação. + +## Desenvolvimento rápido + +```r +devtools::document() +devtools::test() +devtools::check() +``` + +Veja [CONTRIBUTING.md](CONTRIBUTING.md) antes de alterar regras +epidemiológicas, schemas públicos ou interfaces depreciadas. + +## Licença + +Consulte o arquivo `LICENSE`. Qualquer mudança de licença exige decisão +explícita dos mantenedores. diff --git a/_pkgdown.yml b/_pkgdown.yml new file mode 100644 index 0000000..b29881b --- /dev/null +++ b/_pkgdown.yml @@ -0,0 +1,118 @@ +url: https://alertadengue.github.io/AlertTools/ +destination: pkgdown-site + +template: + bootstrap: 5 + +home: + title: AlertTools — epidemiological alert utilities + description: > + Reproducible data access, epidemiological computation, and alert + classification for the InfoDengue alert system. + +navbar: + structure: + left: [intro, reference, articles, news] + right: [search, github] + components: + intro: + text: Início + href: index.html + articles: + text: Guias + menu: + - text: Pipeline sem banco + href: articles/in-memory-pipeline.html + - text: Pipeline com DBI + href: articles/database-pipeline.html + - text: Migração da API + href: articles/migrating-to-snake-case.html + github: + icon: fab fa-github + href: https://github.com/AlertaDengue/AlertTools + aria-label: GitHub + +reference: + - title: Fluxo principal + contents: + - new_alert_inputs + - fetch_alert_inputs + - fetch_alert_parameters + - run_alert_pipeline + - as_alert_history + - write_alert_results + - alerttools_pipeline + - new_alerttools_result + - title: Leitura e persistência + contents: + - fetch_cases + - fetch_case_records + - fetch_climate + - upsert_alert_parameters + - title: Núcleo epidemiológico + contents: + - as_epiweek + - epiweek_start + - epiweek_seq + - calculate_incidence + - estimate_rt + - nowcast_cases + - define_alert_rules + - classify_alerts + - title: Compatibilidade legada + desc: Interfaces preservadas temporariamente durante a migração. + contents: + - Rt + - SE2date + - adjustIncidence + - fouralert + - getCases + - getCaseslist + - getClima + - pipe_infodengue + - read.parameters + - setCriteria + - tabela_historico + - write_alerta + - write_parameters + - title: Demais funções + contents: + - bayesnowcasting + - bestWU + - calc.alerta + - data2SE + - daySEday + - epiYear + - episem + - getCidades + - getPop + - getRegionais + - getTweet + - getWU + - getWUstation + - getdelaydata + - GenTimeDist + - infodengue_apply_mem + - infodengue_apply_mem_agreg + - mem_curve + - nafill + - applyGenTimeDist + - applymem + - read.cases + - SE + - seqSE + - setWUstation + - sevendigitgeocode + - tabela_historico_intra + - temp.predict + +articles: + - title: Uso + navbar: ~ + contents: + - in-memory-pipeline + - database-pipeline + - migrating-to-snake-case + +development: + mode: auto diff --git a/docs/BRANCH_PROTECTION.md b/docs/BRANCH_PROTECTION.md new file mode 100644 index 0000000..268719f --- /dev/null +++ b/docs/BRANCH_PROTECTION.md @@ -0,0 +1,18 @@ +# Controles administrativos recomendados + +Estas configurações não foram aplicadas automaticamente. Elas exigem acesso +administrativo e decisão dos mantenedores no GitHub. + +Para `main` ou `master`, recomenda-se: + +- exigir pull request antes de merge; +- exigir ao menos uma revisão aprovada; +- invalidar aprovações após novos commits; +- exigir resolução de conversas; +- impedir force-push e exclusão do branch; +- exigir os checks da matriz `R-CMD-check`, integração PostgreSQL e lint; +- restringir bypass aos responsáveis por incidentes; +- proteger o ambiente `pkgdown-production` com aprovação dos mantenedores. + +Antes de ativar, confirme nomes exatos dos branches e checks, responsáveis por +aprovação, estratégia para correções urgentes e impacto em automações atuais. diff --git a/docs/RELEASE.md b/docs/RELEASE.md new file mode 100644 index 0000000..9f0c407 --- /dev/null +++ b/docs/RELEASE.md @@ -0,0 +1,101 @@ +# Processo de release do AlertTools + +Este documento separa preparação técnica, validação científica e publicação. +Publicação, tags, GitHub Pages e proteção de branch exigem autorização dos +mantenedores. + +## Versionamento + +O projeto segue versionamento semântico: + +- patch: correções compatíveis e documentação; +- minor: funcionalidades compatíveis e API experimental; +- major: remoções ou mudanças incompatíveis anunciadas. + +Sequência de transição proposta pelo plano: + +| Versão | Conteúdo | +|---|---| +| 1.1.1 | saneamento, documentação, dependências e CI | +| 1.2.0 | camada de dados e API experimental | +| 1.3.0 | API estável e início formal dos warnings | +| 1.4.x | migração de consumidores e correções | +| 2.0.0 | remoções previamente aprovadas | + +A versão 1.2.0 foi aprovada pelo mantenedor como release candidata para reunir +o saneamento e a API experimental. A 1.1.1 não foi publicada separadamente; +essa decisão não antecipa a estabilização da API prevista para 1.3.0. + +## Depreciação + +1. Introduza a substituição e prove equivalência por testes. +2. Mantenha o wrapper legado e indique a substituição com `lifecycle`. +3. Registre argumentos e diferenças no guia de migração e em `NEWS.md`. +4. Monitore consumidores e estabeleça uma janela pública de suporte. +5. Remova somente em versão major aprovada, após confirmação dos consumidores + críticos. + +O registro de consumidores e a política aprovada ficam em +`docs/refactoring/consumer-registry.csv` e +`docs/refactoring/transition-policy.dcf`. Durante a transição, valide sua +integridade com: + +```sh +Rscript tools/check-migration-readiness.R +``` + +Antes de remover qualquer wrapper, o comando abaixo precisa passar: + +```sh +Rscript tools/check-migration-readiness.R --for-removal +``` + +Ele permanece bloqueado enquanto a janela não estiver formalmente aprovada ou +houver consumidor crítico/de alta prioridade sem validação ou aposentadoria. + +## Checklist da release candidata + +- [ ] branch limpo e revisão aprovada; +- [ ] versão e data confirmadas pelos mantenedores; +- [ ] documentação roxygen atualizada; +- [ ] `NEWS.md` voltado ao usuário; +- [ ] exemplos e vignettes executados sem credenciais; +- [ ] testes SQLite e PostgreSQL efêmero aprovados; +- [ ] CI aprovada em Linux, macOS, Windows e R-devel; +- [ ] `R CMD check` com 0 errors, warnings e notes; +- [ ] lint aprovado e cobertura revisada como indicador; +- [ ] validação científica registrada quando necessária; +- [ ] pacote fonte e site construídos como artefatos; +- [ ] plano de rollback definido. +- [ ] registro de consumidores atualizado e warnings de depreciação revisados; +- [ ] política de suporte aprovada, se a release alterar depreciações. + +Crie uma tag candidata, por exemplo `v1.2.0-rc.1`, e disponibilize o pacote +fonte para validação. Não publique a versão principal antes do aceite da RC. + +## Release principal + +Após aceite da candidata: + +1. atualize versão, data e `NEWS.md`; +2. execute novamente toda a matriz de qualidade; +3. gere o pacote fonte a partir do commit aprovado; +4. crie tag assinada e release com notas de migração; +5. publique o site pelo workflow manual `pkgdown`, digitando `publish`; +6. monitore instalação, warnings e pipelines consumidores; +7. reverta a tag/release ou publique correção patch conforme o plano de + rollback se houver regressão. + +Uma release `2.0.0` não está autorizada apenas por atingir o número de versão: +ela também exige aprovação explícita da janela e gate de remoção verde. Tags e +releases candidatas não são criadas automaticamente por este repositório. + +## Artefatos e evidências + +Anexe à release: + +- tarball produzido por `R CMD build`; +- resultados de check; +- cobertura em `coverage.rds` gerada pela CI; +- link para documentação publicada; +- decisões científicas e incompatibilidades aprovadas. diff --git a/docs/refactoring/api-inventory.md b/docs/refactoring/api-inventory.md new file mode 100644 index 0000000..c90a3df --- /dev/null +++ b/docs/refactoring/api-inventory.md @@ -0,0 +1,94 @@ +# Inventário inicial da API do AlertTools + +Baseline levantado no commit `975f347` em 20 de agosto de 2026. Este inventário descreve a API exportada pelo `NAMESPACE` atual; não constitui aprovação dos contratos nem autorização para remover interfaces. + +## Resumo + +- 36 funções exportadas. +- Há funções que combinam acesso direto ou indireto a banco com cálculo e orquestração. +- 16 funções exportadas usam `datasource = con` como default explícito. +- O pipeline principal não propaga `datasource` para todas as chamadas internas. +- Há funções exportadas de baixo nível e nomes com quatro convenções diferentes: `camelCase`, `snake_case`, nomes pontuados e siglas. + +## Funções exportadas + +| Função | Arquivo | Argumentos atuais | Retorno/efeito observado ou documentado | Grupo | Estado no baseline | +|---|---|---|---|---|---| +| `Rt()` | `R/Rt_functions.R` | `obj, count, gtdist, meangt, sdgt, CI, alpha, a0, b0` | data frame de entrada acrescido de `Rt`, `lwr`, `upr` e `p1` | núcleo | caracterizado com fixture | +| `SE2date()` | `R/utility_tools.R` | `se` | data frame `SE`, `ini` | calendário | caracterizado com fixture | +| `adjustIncidence()` | `R/adjust_incidence_functions.R` | `obj, datas, method, pdig, Dmax, nyears, datasource, nowSE, safelimit, ...` | série acrescida de estimativas de casos | núcleo misturado com dados | teste atual depende de INLA/dados | +| `bayesnowcasting()` | `R/adjust_incidence_functions.R` | `d, Dmax, nowSE, nweeks, interacao, tweet` | resultado de nowcasting | núcleo | dependência opcional INLA | +| `bestWU()` | `R/get_timeseries.R` | `series, var` | seleção/composição de séries meteorológicas | núcleo auxiliar | não caracterizado | +| `data2SE()` | `R/utility_tools.R` | `days, format` | vetor numérico de semanas | calendário | caracterizado com fixture | +| `daySEday()` | `R/utility_tools.R` | `x, format` | data frame `SE`, `ini` | calendário | teste existente | +| `epiYear()` | `R/utility_tools.R` | `se, cut` | tibble com `se`, `year`, `eweek`, `eyear` | calendário | teste existente | +| `episem()` | `R/utility_tools.R` | `x, format, separa, retorna` | semana/ano numérico ou texto | calendário | caracterizado com fixture | +| `fouralert()` | `R/alert_functions.R` | `obj, crit, miss, dy` | objeto S3 `alerta` | regras de alerta | caracterizado com fixture | +| `getCases()` | `R/get_timeseries.R` | `cities, lastday, firstday, cid10, dataini, completetail, type, datasource` | série semanal; grava `caselist.RData` | leitura com efeito colateral | depende de banco e `con` | +| `getCaseslist()` | `R/get_timeseries.R` | `cities, lastday, firstday, cid10, datasource` | registros individuais | leitura | depende de banco e `con` | +| `getCidades()` | `R/utility_tools.R` | `regional, macroregional, uf, datasource` | tabela de municípios e regiões | leitura | depende de banco e `con` | +| `getClima()` | `R/get_timeseries.R` | `cities, vars, finalday, iniSE, lastSE, datasource` | série climática municipal | leitura/cálculo | depende de banco e `con` | +| `getPop()` | `R/get_timeseries.R` | `cities, iniY, endY` | tabela `geocode`, `year`, `pop` | leitura externa | depende de `brpop` | +| `getRegionais()` | `R/utility_tools.R` | `cities, uf, sortedby, macroreg, datasource, output` | vetor ou tabela de regiões | leitura | depende de banco e `con` | +| `getTweet()` | `R/get_timeseries.R` | `cities, lastday, cid10, datasource` | série semanal de tweets | leitura | depende de banco e `con` | +| `getWU()` | `R/get_timeseries.R` | `stations, vars, finalday, iniSE, datasource` | série climática por estação | leitura/cálculo | depende de banco e `con` | +| `getWUstation()` | `R/utility_tools.R` | `cities, datasource` | associação município-estação | leitura | depende de banco e `con` | +| `getdelaydata()` | `R/adjust_incidence_functions.R` | `cities, nyears, cid10, lastday, datasource` | dados de atraso de notificação | leitura | depende de banco e `con` | +| `infodengue_apply_mem()` | `R/infodengue_apply_mem.R` | `mun_list, start_year, end_year, write, database, passwd, ...` | parâmetros MEM por município; escrita opcional | cálculo/dados/persistência | depende de banco e `mem` | +| `infodengue_apply_mem_agreg()` | `R/infodengue_apply_mem.R` | `mun_list, start_year, end_year, nome, database, passwd, ...` | parâmetros MEM agregados | cálculo/dados | depende de banco e `mem` | +| `mem_curve()` | `R/infodengue_apply_mem.R` | `mun_list, start_year, end_year, nome, database, passwd, ...` | curva MEM agregada | cálculo/dados | depende de banco e `mem` | +| `nafill()` | `R/utility_tools.R` | `v, rule, maxgap, verbose` | vetor com ausências tratadas | núcleo auxiliar | teste existente | +| `pipe_infodengue()` | `R/alert_functions.R` | `cities, cid10, datarelatorio, finalday, iniSE, nowcasting, narule, writedb, datasource, completetail, dataini` | lista nomeada de objetos `alerta`; escrita opcional | orquestração | depende de banco, arquivo e `con` | +| `read.cases()` | `R/get_timeseries.R` | `start_year, end_year, cid10, datasource, mun_list` | casos semanais para MEM | leitura | depende de banco e `con` | +| `read.parameters()` | `R/utility_tools.R` | `cities, cid10, datasource` | tabela de parâmetros | leitura | depende de banco e `con` | +| `seqSE()` | `R/utility_tools.R` | `from, to` | fatia da tabela interna `SE` | calendário | caracterizado com fixture | +| `setCriteria()` | `R/alert_functions.R` | `rule, values, delays` | lista `crity`, `crito`, `critr` | regras de alerta | caracterizado com fixture | +| `setWUstation()` | `R/utility_tools.R` | `st, UF, datasource` | atualização de associação de estações | persistência | depende de banco e `con` | +| `sevendigitgeocode()` | `R/utility_tools.R` | `dig` | geocódigo municipal de sete dígitos | validação | caracterizado com fixture | +| `tabela_historico()` | `R/alert_functions.R` | `obj, iniSE, lastSE, type, versao` | tabela para histórico municipal | transformação/dados | relê parâmetros do banco | +| `tabela_historico_intra()` | `R/alert_functions.R` | `obj, iniSE, lastSE, versao` | tabela para histórico intramunicipal | transformação/dados | relê parâmetros do banco | +| `temp.predict()` | `R/utility_tools.R` | `v, plotar` | vetor com cauda prevista | núcleo auxiliar | teste existente; referência inválida a `forecast::fitted` | +| `write_alerta()` | `R/alert_functions.R` | `d, writetofile, datasource, arq` | escreve SQL/arquivo ou banco | persistência | depende de banco/arquivo e `con` | +| `write_parameters()` | `R/utility_tools.R` | `city, cid10, params, overwrite, datasource` | escreve e retorna parâmetros | persistência | depende de banco e `con` | + +## Uso interno conhecido + +| Consumidor local | Funções/contratos consumidos | Criticidade | Responsável | Observação | +|---|---|---|---|---| +| `R/alert_functions.R` | `data2SE`, `SE2date`, `read.parameters`, `getClima`, `getCases`, `adjustIncidence`, `Rt`, `setCriteria`, `fouralert`, `write_alerta` | alta | a confirmar | compõe o pipeline operacional | +| `R/Rt_functions.R` | `getWU`, `nafill`, `GenTimeDist` e consultas diretas | média | a confirmar | `GenTimeDist` não está exportada, mas participa do núcleo | +| `R/infodengue_apply_mem.R` | `read.cases`, tabelas de população, DBI e `mem` | alta | a confirmar | combina cálculo, leitura e escrita | +| `tests/testthat/test_alertfunctions.R` | `setCriteria`, `getCases`, `getWU`, `Rt`, `fouralert` | média | testes | executa código fora de `test_that()` e requer `con` | +| `tests/testthat/test_timeseriespipeline.R` | `getCases`, `getWU`, `adjustIncidence`, `Rt` | média | testes | requer `con` e INLA | +| `tests/testthat/test_utilityfunctions.R` | utilitários de calendário, geocódigo, preenchimento e funções de banco | média | testes | 49 expectativas passam no baseline atual | +| Exemplos em `man/` e roxygen | maioria da API exportada | média | documentação | vários exemplos pressupõem `con` | + +## Consumidores externos + +O repositório local não contém referências a `AlertTools::` nem permite concluir quais sistemas externos usam o pacote. Antes da Fase 5, os mantenedores devem completar a tabela abaixo com pesquisa na organização AlertaDengue. + +| Consumidor | Repositório/script | Funções | Colunas lidas | Criticidade | Responsável | Situação | +|---|---|---|---|---|---|---| +| A confirmar | A confirmar | A confirmar | A confirmar | A confirmar | A confirmar | inventário externo pendente | + +## Atualização da Fase 7 + +Uma busca de código na organização pública `AlertaDengue`, realizada em 5 de +setembro de 2026, confirmou consumidores externos da API legada. O inventário +operacional, com arquivos, criticidade, evidência, bloqueios e rollback, passou +a ser mantido em `docs/refactoring/consumer-registry.csv`; o procedimento está +em `docs/refactoring/consumer-migration.md`. + +Entre os consumidores críticos encontrados estão o pipeline nacional em +`AlertaDengueAnalise`, seu publicador e container, o cliente R de migração, +rotinas intramunicipais e boletins. A linha histórica acima permanece intacta +para registrar que esses consumidores ainda eram desconhecidos no baseline. + +## Contratos que não podem mudar sem validação + +- Convenção brasileira de semanas epidemiológicas, principalmente viradas de ano e semana 53. +- Fórmulas, intervalos e tolerâncias numéricas de Rt. +- Regras, delays e precedência dos quatro níveis de alerta. +- Nomes, tipos, chaves e ordenação das tabelas consumidas externamente. +- Interpretação dos CID-10 equivalentes para dengue, chikungunya e zika. +- Política de casos notificados, prováveis e confirmados por laboratório. diff --git a/docs/refactoring/api-migration.md b/docs/refactoring/api-migration.md new file mode 100644 index 0000000..8e443af --- /dev/null +++ b/docs/refactoring/api-migration.md @@ -0,0 +1,99 @@ +# Migração para a API `snake_case` + +Versão de início da depreciação: 1.1.0. + +A API nova separa leitura, cálculo e persistência. Funções experimentais estão +identificadas na ajuda do pacote e podem receber ajustes compatíveis antes de +serem declaradas estáveis. A API legada permanece disponível durante a janela +de migração e emite avisos `lifecycle` com a substituição indicada. + +Consumidores confirmados, ordem de transição, evidências e rollback são +mantidos em `consumer-migration.md` e `consumer-registry.csv`. A política de +suporte ainda está proposta; nenhuma data de remoção foi aprovada. + +## Fluxo mínimo + +| Etapa | API nova | Contrato | +|---|---|---| +| Construir dados em memória | `new_alert_inputs()` | retorna `alerttools_inputs` | +| Buscar dados operacionais | `fetch_alert_inputs()` | somente leitura; `conn` explícito | +| Buscar parâmetros | `fetch_alert_parameters()` | uma linha por município e doença | +| Executar cálculo | `run_alert_pipeline()` | sem banco ou arquivos; retorna `alerttools_result` | +| Converter histórico | `as_alert_history()` | conversão explícita com `version_date` | +| Persistir | `write_alert_results()` | transação e conflito explícitos | + +## Funções e argumentos + +| API legada | API nova | Adaptação principal | Situação | +|---|---|---|---| +| `getCases()` | `fetch_cases()` | `datasource` → `conn`; `cities` → `geocodes`; `cid10` → `disease`; `firstday`/`lastday` → `start_date`/`end_date`; `dataini` → `case_date` | wrapper depreciado desde 1.1.0 | +| `getCaseslist()` | `fetch_case_records()` | mesmos argumentos de conexão, local, doença e datas | wrapper depreciado desde 1.1.0 | +| `getClima()` | `fetch_climate()` | `vars` → `climate_vars`; datas explícitas | wrapper depreciado desde 1.1.0 | +| `read.parameters()` | `fetch_alert_parameters()` | `datasource` → `conn`; `cities` → `geocodes`; nomes de doenças aceitos | wrapper depreciado desde 1.1.0 | +| `pipe_infodengue()` | `fetch_alert_inputs()` + `run_alert_pipeline()` | leitura e cálculo passam a ser chamadas separadas; escrita removida do cálculo | wrapper depreciado desde 1.1.0 | +| `Rt()` | `estimate_rt()` | argumentos longos em `snake_case` | wrapper depreciado desde 1.1.0 | +| `adjustIncidence()` | `nowcast_cases()` | `datas` → `case_records`; `nowSE` → `report_week` | wrapper depreciado desde 1.1.0 | +| `setCriteria()` | `define_alert_rules()` | `delays` preservado | wrapper depreciado desde 1.1.0 | +| `fouralert()` | `classify_alerts()` | `crit` → `rules`; `miss` → `missing`; `dy` → `minimum_history` | wrapper depreciado desde 1.1.0 | +| `tabela_historico()` | `as_alert_history()` | `versao` → `version_date`; `iniSE`/`lastSE` → `start_week`/`end_week` | wrapper depreciado desde 1.1.0 | +| `write_alerta()` | `write_alert_results()` | recebe diretamente `alerttools_result`; não exporta arquivo implicitamente | wrapper depreciado desde 1.1.0 | +| `write_parameters()` | `upsert_alert_parameters()` | aceita lote; `overwrite` é substituído por `conflict` | wrapper depreciado desde 1.1.0 | + +As demais funções legadas permanecem estáveis nesta fase porque não são +necessárias ao fluxo mínimo comprovado. Novos nomes somente serão adicionados +quando houver contrato e cenário de uso testado, evitando ampliar a API sem +necessidade observada. + +## Valores de doença + +O argumento `disease` aceita nomes de domínio ou os códigos equivalentes: + +| Nome | CID-10 canônico | Valores aceitos | +|---|---|---| +| dengue | `A90` | `dengue`, `A90` | +| chikungunya | `A92.0` | `chikungunya`, `chik`, `A92`, `A920`, `A92.0` | +| zika | `A92.8` | `zika`, `A928`, `A92.8` | + +## Schemas públicos + +### `alerttools_inputs` + +Campos: `cases`, `climate`, `population`, `case_records` e `metadata`. + +- `cases`: chave única `cidade`, `CID10`, `SE`; contagens `casos`, `cas_prov`, + `cas_lab`; população positiva em `pop`; ordenação por cidade, doença e semana; +- `climate`: chave única `geocodigo`, `SE`; ordenação por município e semana; +- `population`: opcional, normalizada para `cidade`, `pop`; +- `case_records`: registros individuais opcionais para nowcasting; +- `metadata`: lista nomeada com proveniência e período. + +### `alerttools_result` + +Campos: `data`, `alerts`, `parameters`, `metadata` e `diagnostics`. `data` e +`alerts` possuem a mesma cardinalidade. A combinação tabular é obtida com +`as.data.frame()`. + +### Histórico persistível + +`as_alert_history()` retorna uma linha por `SE`, `municipio_geocodigo` e +`Localidade_id`, incluindo contagens, incidência, Rt, nível, indicadores +climáticos e `versao_modelo`. + +## Diferenças intencionais + +- Toda leitura ou escrita nova exige `conn`; não existe fallback global. +- Períodos são explícitos e datas são objetos `Date`. +- `run_alert_pipeline()` nunca persiste resultados. +- `write_alert_results()` não oferece exportação SQL para arquivo; esse recurso + permanece apenas no wrapper legado enquanto houver consumidores. +- A API nova rejeita doença desconhecida, chaves duplicadas, população ausente + ou não positiva e períodos contraditórios, em vez de aplicar fallback oculto. +- `workers = 1` e `verbose = FALSE` são os padrões portáveis. + +## Remoção e documentação histórica + +Nenhum wrapper pode ser removido enquanto +`Rscript tools/check-migration-readiness.R --for-removal` falhar. Além da +aprovação da janela de suporte, consumidores críticos precisam estar validados +ou formalmente aposentados. Documentação de versões antigas será preservada por +tag ou site versionado, sem apagar o histórico deste guia e do `NEWS.md`. diff --git a/docs/refactoring/consumer-migration.md b/docs/refactoring/consumer-migration.md new file mode 100644 index 0000000..cbdbf28 --- /dev/null +++ b/docs/refactoring/consumer-migration.md @@ -0,0 +1,169 @@ +# Plano controlado de migração dos consumidores + +Data da última busca: 5 de setembro de 2026. + +## Objetivo e limite + +Este documento transforma a Fase 7 em uma transição verificável. A busca de +código na organização pública `AlertaDengue` encontrou consumidores reais da +API legada, mas não autoriza alterações nesses repositórios, execução contra +produção, escolha de responsáveis ou publicação de releases. + +O registro canônico está em `consumer-registry.csv`. A busca cobre o conteúdo +indexado nos branches padrão acessíveis ao usuário que realizou a auditoria; +chamadas dinâmicas, branches não indexados e repositórios sem acesso ainda +precisam ser confirmados pelos mantenedores. + +## Situação encontrada + +Os consumidores de maior risco são: + +| Consumidor | Uso legado observado | Risco atual | +|---|---|---| +| pipeline nacional (`AlertaDengueAnalise/main/main_BR.R`) | `pipe_infodengue()` e `tabela_historico()` | execução operacional, conexão global e arquivos de saída | +| publicador nacional | `tabela_historico()` e `write_alerta()` | persistência e geração de SQL | +| container de análise | pipeline e persistência legados | imagem de execução operacional | +| cliente R da migração | `pipe_infodengue()` | papel operacional a confirmar | +| pacote e relatórios intramunicipais | `fouralert()` | classificação epidemiológica | +| boletins municipais | `getCases()` e `read.parameters()` | dados e parâmetros operacionais | + +A inspeção estática revelou incompatibilidades concretas que precisam ser +tratadas nos consumidores: + +- conexões mantidas em `con` global precisam ser passadas como `conn`; +- `pipe_infodengue()` deve ser substituída pelas etapas explícitas + `fetch_alert_inputs()`, `fetch_alert_parameters()` e + `run_alert_pipeline()`; +- o resultado moderno é `alerttools_result`, e a persistência requer + `as_alert_history()` ou `write_alert_results()` com `version_date` explícita; +- geração de arquivo SQL não faz parte da API moderna e precisa de decisão + própria no consumidor; +- fallbacks por município, paralelismo, artefatos `.RData` e publicação remota + pertencem ao orquestrador consumidor, não ao núcleo do pacote. + +Essas diferenças não devem ser ocultadas reintroduzindo `con` global ou escrita +implícita no AlertTools. + +## Ordem de migração + +Cada item deve ser migrado em pull request e release próprios, nesta ordem: + +1. pipeline nacional em `AlertaDengueAnalise`; +2. publicador nacional e container derivado; +3. cliente R de migração, após confirmar se ainda está ativo; +4. pacote `infodengue_intramunicipal`; +5. relatórios do repositório `intramunicipal`; +6. boletins operacionais; +7. tutoriais, relatórios históricos e pesquisa. + +Não avance um consumidor dependente antes de validar o contrato do anterior. + +## Procedimento por consumidor + +### 1. Baseline + +- atribuir responsável e criticidade no registro; +- fixar o commit do consumidor e a versão do AlertTools; +- executar um período epidemiológico representativo em infraestrutura + descartável; +- guardar apenas schemas, cardinalidades, hashes e métricas não sensíveis; +- registrar depreciações com `options(lifecycle_verbosity = "warning")`. + +### 2. Migração + +- tornar a conexão DBI explícita e com ciclo de vida local; +- separar leitura, cálculo, transformação e escrita; +- preservar lógica de retentativa, paralelismo e publicação no consumidor; +- trocar cada função conforme `api-migration.md`; +- não alterar simultaneamente regras científicas ou formatação ampla. + +O esqueleto esperado para o pipeline municipal é: + +```r +inputs <- fetch_alert_inputs( + conn = conn, + geocodes = cities, + disease = disease, + start_week = start_week, + report_week = report_week +) +parameters <- fetch_alert_parameters(conn, cities, disease) +result <- run_alert_pipeline( + inputs, + parameters, + report_week = report_week, + nowcast = nowcast, + workers = workers +) +history <- as_alert_history( + result, + version_date = version_date, + start_week = history_start_week +) +``` + +### 3. Validação + +- executar testes unitários e de integração do consumidor; +- comparar schemas, tipos, chaves, ordenação e cardinalidades; +- comparar Rt, intervalos, casos estimados e níveis de alerta com tolerâncias + aprovadas pelo domínio; +- executar ao menos duas viradas de ano e um cenário com semana 53; +- confirmar ausência de warnings de depreciação; +- obter aceite do responsável operacional e, quando aplicável, científico. + +### 4. Rollback + +- manter a versão anterior do consumidor implantável; +- fixar a última versão aprovada do AlertTools no lockfile ou imagem; +- não alterar tabelas destrutivamente durante a transição; +- definir um critério observável de rollback antes do deploy; +- registrar versão restaurada, motivo e artefatos afetados. + +O template de pull request em +`.github/PULL_REQUEST_TEMPLATE/consumer-migration.md` padroniza as evidências. + +## Monitoramento e gate + +Valide a integridade do registro durante a transição: + +```sh +Rscript tools/check-migration-readiness.R +``` + +Antes de qualquer PR que remova wrappers, execute: + +```sh +Rscript tools/check-migration-readiness.R --for-removal +``` + +O segundo comando falha enquanto a política de suporte não estiver aprovada ou +qualquer consumidor crítico/de alta prioridade não estiver `validated` ou +`retired`. Esse bloqueio é intencional. + +Depois de cada release candidata, mantenha `lifecycle_verbosity = "warning"` +nos testes e logs controlados dos consumidores durante a janela de observação. +Registre cada incompatibilidade real no campo `blocker`, com issue, evidência e +decisão; nunca silencie o warning sem migrar ou justificar formalmente. + +## Janela de suporte aprovada + +A sequência técnica permanece: + +- `1.1.1`: saneamento; +- `1.2.0`: camada de dados e API experimental; +- `1.3.0`: API nova estável e início formal dos warnings; +- `1.4.x`: migração e correções de transição; +- `2.0.0`: primeira versão elegível para remoções aprovadas. + +A janela aprovada mantém os wrappers por pelo menos duas releases minor e seis +meses, usando o critério que terminar por último. O prazo começa com os warnings +formais da 1.3.0; a 2.0.0 continua sendo apenas a primeira versão elegível para +remoções e ainda depende do gate de consumidores. + +## Arquivo da documentação histórica + +Ao estabilizar uma release, preserve uma versão do site por tag e mantenha o +guia correspondente à linha suportada. Ao remover wrappers, mova exemplos +legados para uma seção versionada ou release anterior; não apague `NEWS.md`, o +guia de migração, o inventário nem as decisões que expliquem contratos antigos. diff --git a/docs/refactoring/consumer-registry.csv b/docs/refactoring/consumer-registry.csv new file mode 100644 index 0000000..56b66c1 --- /dev/null +++ b/docs/refactoring/consumer-registry.csv @@ -0,0 +1,11 @@ +consumer_id,repository,path,legacy_api,criticality,owner,status,last_checked,evidence,blocker,rollback +national-pipeline,AlertaDengue/AlertaDengueAnalise,main/main_BR.R,"pipe_infodengue;tabela_historico",critical,TBD,discovered,2026-09-05,GitHub code search and source inspection,"Needs maintainer ownership; disposable PostgreSQL validation; output comparison","Pin last approved AlertTools release and restore the consumer commit" +national-publisher,AlertaDengue/AlertaDengueAnalise,config/publicar_alerta.R,"tabela_historico;write_alerta",critical,TBD,discovered,2026-09-05,GitHub code search,"Must migrate after national pipeline contract is approved","Keep generated SQL and run legacy publisher with pinned package" +analysis-container,AlertaDengue/ADAnalise-container,main.R,"pipe_infodengue;tabela_historico;write_alerta",critical,TBD,discovered,2026-09-05,GitHub code search,"Derived deployment must follow the national pipeline migration","Redeploy the previous immutable container image" +migration-r-client,AlertaDengue/AlertaDengue-migration,containers/r-client/scripts/pipeline.R,pipe_infodengue,high,TBD,discovered,2026-09-05,GitHub code search,"Purpose and production status require maintainer confirmation","Restore previous script and package lock" +intramunicipal-package,AlertaDengue/infodengue_intramunicipal,R/calcular_alerta.R;R/calcular_alerta_novo.R;R/calcular_alerta_helpers_novo.R,fouralert,high,TBD,discovered,2026-09-05,GitHub code search,"Requires package tests and scientific output comparison","Revert consumer patch and pin prior AlertTools version" +intramunicipal-reports,AlertaDengue/intramunicipal,funcoes_submunicipal.R;df/funcoes_submunicipal.R,fouralert,high,TBD,discovered,2026-09-05,GitHub code search,"Requires representative report render and alert-level comparison","Revert helpers and render with prior package lock" +municipal-bulletins,AlertaDengue/boletins,gera_boletim_municipio.R;dados/atualiza-parametros-boletim.R,"getCases;read.parameters",high,TBD,discovered,2026-09-05,GitHub code search,"Needs owner and a disposable database fixture","Revert scripts and restore prior package lock" +biweekly-bulletin,AlertaDengue/BoletimQuinzenal,scripts/mapa_predicao.R,tabela_historico,medium,TBD,discovered,2026-09-05,GitHub code search,"Needs representative report snapshot","Revert report script and pin prior AlertTools version" +analysis-tutorials,AlertaDengue/AlertaDengueAnalise,tutoriais/;parameters/;report/,"getCases;adjustIncidence;fouralert;read.parameters",low,TBD,discovered,2026-09-05,GitHub code search,"Migrate after operational consumers to avoid documenting an unapproved flow","Keep archived tutorial links for the matching package version" +rt-research,AlertaDengue/WP-estimating-Rt,Rt_Rio.rmd;Rt_Foz.rmd,getCases,low,TBD,discovered,2026-09-05,GitHub code search,"Confirm whether repository is maintained","Archive or pin the historical package version" diff --git a/docs/refactoring/master-integration-2026-10-01.md b/docs/refactoring/master-integration-2026-10-01.md new file mode 100644 index 0000000..ea8cd41 --- /dev/null +++ b/docs/refactoring/master-integration-2026-10-01.md @@ -0,0 +1,95 @@ +# Integração do master — 01/10/2026 + +## Entrega + +A branch `codex/alerttools-1.2.0-rc1`, vinculada ao PR #20, foi atualizada até +`origin/master` (`e460b3b`). O merge local pendente do PR #19 foi concluído, +preservando a refatoração e a remoção do campo tweet. O histórico publicado foi +preservado por merge, sem rebase ou force push. + +Commits publicados: `84158ba` e `aaf7ab2`. + +- PR #22: `firstday` foi integrado ao wrapper refatorado e encaminhado a + `fetch_cases(start_date = firstday)`, com padrão `2018-01-01`. Use o argumento + pelo nome; ele foi acrescentado após os argumentos da release candidata para + preservar as posições existentes. `iniSE` continua delimitando o clima. +- PR #24: ambos os objetos SE corrigidos foram incorporados. A regressão das + semanas 201814–201816, continuidade, duração, correspondência com `episem()` e + equivalência entre os calendários público e interno foi preservada. +- Os testes antigos substituídos na refatoração não foram reintroduzidos. + O novo teste de histórico usa parâmetros e data de versão explícitos, + sem sobrescrever bindings bloqueados ou carregar fontes no ambiente de testes. +- O workflow já existente no PR #20 foi mantido. A instalação explícita de + `devtools` foi adicionada ao job PostgreSQL, que executa `devtools::test()`. + +## Evidências + +- Suíte completa: **297 expectativas aprovadas, 0 falhas, 0 warnings, 1 skip**. + O skip é a integração PostgreSQL opt-in, que exige banco efêmero. +- R CMD build completo, incluindo vignettes: aprovado, utilizando o Pandoc + instalado com RStudio via RSTUDIO_PANDOC. +- R CMD check --no-manual, com _R_CHECK_FORCE_SUGGESTS_=false: **0 erros, + 0 warnings, 1 NOTE**, exclusivamente pela ausência local de `lintr`. +- Lint não executado: pacote `lintr` indisponível localmente. +- Workflow YAML: leitura sintática aprovada; isso não confirma execução remota. +- Registro de migração: íntegro; remoção de APIs legadas continua bloqueada + pelos sete consumidores críticos/altos ainda pendentes, conforme política. +- `git diff --check`: aprovado. `origin/master` é ancestral da branch publicada. +- A consulta inicial do conector não retornou execuções. A API pública + confirmou depois que o CI executou e falhou ao resolver a dependência INLA. + O repositório adicional já declarado no DESCRIPTION foi incluído explicitamente + em setup-r para os jobs que instalam dependências. A nova execução será + acompanhada antes de registrar aprovação remota. + +Os arquivos locais `plano_refatoracao_alerttools.html` e +`plano_refatoracao_alerttools.qmd` foram preservados sem alterações. + +## Issue #25: Enable automated package checks and regression tests on master + +https://github.com/AlertaDengue/AlertTools/issues/25 + +Após #22 e #24, a equipe pediu execução automática de testes no AlertTools. +O master ainda não contém R-CMD-check. O PR #20 já introduz checks de pacote +em Linux/macOS/Windows, PostgreSQL efêmero, cobertura, lint e validação do +registro de migração. Acompanhar a entrega por esse PR evita implementação +duplicada. Relacionar à issue de falhas de testes abaixo quando criada. + +Critérios de aceite: + +- [ ] Executar em pull requests e pushes para master. +- [ ] Instalar dependências em runners limpos. +- [ ] Executar a suíte completa, incluindo calendário e firstday. +- [ ] Instalar devtools explicitamente no job PostgreSQL. +- [ ] Expor falhas e logs no GitHub Actions. +- [ ] Registrar execução remota aprovada antes de entregar ao master. + +## Issue #26: Deliver fixes for the three preexisting test failures reported in PR #24 + +https://github.com/AlertaDengue/AlertTools/issues/26 + +O comentário de validação de #24 registra três falhas anteriores à correção: +`assert_that` ausente em test_alertfunctions.R, `con` ausente em +test_timeseriespipeline.R e binding bloqueado de `read.parameters` no teste +histórico. As duas primeiras já foram tratadas pelo PR #20 com fixtures, +imports e conexões explícitas. A integração do teste histórico agora elimina +mutação do namespace e carregamento direto de fontes. Relacionar à issue de CI +acima quando criada. + +Critérios de aceite: + +- [ ] Entregar ao master uma suíte completa sem falhas ou warnings. +- [ ] Exercitar o pacote carregado sem sobrescrever bindings bloqueados. +- [ ] Preservar regressões do calendário e de firstday. +- [ ] Confirmar os resultados em CI antes da entrega. + +## Pendências externas + +A criação de issue pelo conector retornou HTTP 403 (Resource not accessible +by integration). A autenticação local do gh também está inválida. O Git +conseguiu publicar a branch, mas a revisão automática bloqueou a reutilização +da credencial do Git para a API: exige autorização específica do usuário. +Após autorização específica do usuário, as issues #25 e #26 foram criadas +utilizando a autenticação do Git, sem exibir ou salvar o token. A edição da +descrição do PR pelo conector também retornou 403; ela ainda contém os números +da validação anterior. Este relatório registra os números atuais. Não houve +merge do PR #20 no master. diff --git a/docs/refactoring/phase-0-baseline.md b/docs/refactoring/phase-0-baseline.md new file mode 100644 index 0000000..581ca22 --- /dev/null +++ b/docs/refactoring/phase-0-baseline.md @@ -0,0 +1,102 @@ +# Baseline da Fase 0 + +Data do levantamento: 20 de agosto de 2026 + +Commit de referência: `975f347` (`master`) + +Ambiente observado: R 4.4.3, macOS arm64 + +## Escopo desta entrega + +Esta primeira implementação cobre o que pode ser reproduzido apenas com o repositório local: + +- inventário dos 36 símbolos exportados e dos consumidores internos; +- fixtures sintéticas de casos, clima, população e parâmetros; +- resultados de referência para calendário epidemiológico, Rt e classificação de alertas; +- testes de caracterização que não acessam banco nem gravam arquivos. + +Não foram alteradas funções do pacote. Correções de namespace, testes preexistentes, SQL, estado global e efeitos colaterais pertencem às fases seguintes. + +## Baseline da suíte preexistente + +Comando: + +```sh +Rscript -e 'devtools::test()' +``` + +Resultado antes das adições desta fase: + +| Métrica | Resultado | +|---|---:| +| Falhas | 2 | +| Warnings | 0 | +| Skips | 0 | +| Expectativas aprovadas | 49 | + +Falhas preexistentes: + +1. `test_alertfunctions.R` chama `setCriteria()` fora de `test_that()` e a função não encontra `assert_that` no namespace. +2. `test_timeseriespipeline.R` chama `getCases()` fora de `test_that()` e procura o objeto global `con`. + +Após as adições da Fase 0, a suíte completa preserva as mesmas duas falhas e passa em 77 expectativas, das quais 28 pertencem ao novo baseline. + +Um novo build e check foram executados em diretório temporário, sem reutilizar `AlertTools.Rcheck` ou o tarball presentes na raiz: + +```sh +R CMD build /caminho/para/alertools +R CMD check --no-manual AlertTools_1.1.0.tar.gz +``` + +O resultado reproduz o baseline do plano: 2 errors, 9 warnings e 6 notes. Entre as causas estão documentação inválida, licença `CCO`, dependências ausentes, chamadas `library()`/`require()` no pacote, símbolos globais e falhas dos testes acima. O check também não conseguiu consultar os índices CRAN/Bioconductor devido à rede restrita do ambiente; isso não alterou as contagens finais, mas deve ser repetido pela CI com rede disponível. + +## Cenário sintético de referência + +As fixtures descrevem um município fictício, com geocódigo estruturalmente válido `3304557`, população constante de 10.000 habitantes e dengue (`A90`). A série vai de `202052` a `202106`, cobrindo: + +- mudança do ano epidemiológico; +- semana epidemiológica 53; +- semanas sem casos e com incidência acima dos dois limiares; +- mudança das condições climáticas; +- ativação e desligamento dos níveis de alerta. + +Os dados são integralmente sintéticos e não contêm registros individuais ou informações identificáveis. O município, população e valores não devem ser usados como dado operacional. + +Arquivos: + +- `tests/testthat/fixtures/cases.csv`; +- `tests/testthat/fixtures/climate.csv`; +- `tests/testthat/fixtures/population.csv`; +- `tests/testthat/fixtures/parameters.csv`; +- `tests/testthat/fixtures/expected-epiweeks.csv`; +- `tests/testthat/fixtures/expected-rt.csv`; +- `tests/testthat/fixtures/expected-alerts.csv`. + +## Classificação dos comportamentos + +| Comportamento | Classificação inicial | Evidência | Validação pendente | +|---|---|---|---| +| Semana `202053` começa em 2020-12-27 e `202101` em 2021-01-03 | esperado | tabela interna `SE`, `SE2date()` e `episem()` concordam | responsável de domínio | +| `sevendigitgeocode(330455)` retorna `3304557` | esperado | implementação e testes preexistentes | não | +| `Rt()` mantém as colunas de entrada e acrescenta `Rt`, `lwr`, `upr`, `p1` | esperado | execução sobre fixture | responsável de domínio para tolerâncias | +| Primeiros cinco valores de Rt são `NA` com `meangt = 3` | legado | loop começa em `ceiling(2 * meangt)` | confirmar se é contrato ou detalhe interno | +| `fouralert()` retorna classe S3 `alerta` com `data`, `indices`, `crit`, `n` | esperado | execução sobre fixture | não | +| Nível vermelho aparece em `202105`, após condições vermelhas em `202103` e `202104` | legado potencialmente surpreendente | ordem de cálculo e `delay_turnoff` em `fouralert()` | responsável de domínio deve aprovar ou classificar como bug | +| `getCases()` grava `caselist.RData` | legado a remover | chamada `save()` em `R/get_timeseries.R` | já identificado no plano | +| Funções de banco procuram `con` global | bug arquitetural conhecido | defaults `datasource = con` | já identificado no plano | + +## Tolerâncias numéricas + +Os resultados de Rt são comparados com tolerância absoluta de `1e-7`. Essa tolerância protege contra pequenas diferenças de ponto flutuante sem aceitar mudança substantiva na fórmula. Ela deve ser revista com os responsáveis científicos antes de estabilizar a nova API. + +## Gate e pendências humanas + +O baseline local é reproduzível sem banco de produção. O gate completo da Fase 0 ainda depende de: + +- inventariar repositórios e scripts externos da organização AlertaDengue; +- confirmar quais consumidores são críticos e seus responsáveis; +- aprovar os municípios/períodos que formarão fixtures operacionais anonimizadas; +- validar a convenção epidemiológica, resultados científicos e tolerâncias; +- classificar o deslocamento do alerta vermelho descrito acima como comportamento esperado ou bug. + +Enquanto essas decisões estiverem pendentes, as fixtures sintéticas funcionam como proteção técnica inicial, não como validação científica final. diff --git a/docs/refactoring/phase-1-report.md b/docs/refactoring/phase-1-report.md new file mode 100644 index 0000000..ad3d2a7 --- /dev/null +++ b/docs/refactoring/phase-1-report.md @@ -0,0 +1,71 @@ +# Relatório da Fase 1 — Saneamento do pacote + +Data: 20 de agosto de 2026 + +## Resultado + +O pacote pode ser construído, instalado, carregado, documentado e verificado +sem errors, warnings ou notes no ambiente local de referência. + +## Alterações + +- `DESCRIPTION`: metadados atualizados; dependências específicas substituem o + metapacote `tidyverse`; dependências opcionais estão em `Suggests`; + `testthat` edition 3, URL e rastreador de issues foram declarados. +- `NAMESPACE` e `man/`: regenerados com roxygen2 a partir do código-fonte. +- `R/`: removidas chamadas ativas a `library()` e `require()`; chamadas + externas passaram a ser qualificadas ou importadas seletivamente. +- Dependências opcionais `brpop`, `INLA`, `mem` e `data.table` agora são + verificadas explicitamente antes do uso. +- A referência inválida a `forecast::fitted()` foi substituída por + `stats::fitted()`. +- Datasets públicos foram documentados. Os três datasets históricos com + codificação inválida (`bairro2APS`, `locs` e `sinan`) foram excluídos do + artefato de build, mas preservados no repositório para avaliação posterior. +- O diretório RStudio `AlertTools/.Rproj.user` e a `.Rbuildignore` aninhada + foram removidos. +- Foram adicionados `NEWS.md`, `CONTRIBUTING.md` e um workflow multiplataforma + de `R CMD check`. +- Testes legados que dependem de banco foram transformados em skips explícitos; + o baseline em memória permanece ativo. + +## Verificações + +| Verificação | Resultado | +|---|---| +| `devtools::document()` | passou | +| `devtools::test()` | 82 passaram, 3 skips explícitos, 0 falhas | +| `R CMD build` | passou | +| `R CMD check --no-manual` | **Status: OK** | + +O check foi executado com R 4.4.3 em macOS arm64. O ambiente não conseguiu +consultar índices remotos durante o check, mas todas as dependências sugeridas +estavam instaladas e a verificação completa terminou com sucesso. + +## Compatibilidade + +- Nenhum símbolo foi removido do `NAMESPACE`. +- Assinaturas públicas foram preservadas. +- Os 28 testes de caracterização da Fase 0 continuam passando. +- Três integrações dependentes de banco permanecem sem execução até a criação + da infraestrutura temporária prevista na Fase 2. + +## Licença + +O campo `License` passou a apontar para `file LICENSE`, tornando o arquivo GPL-3 +já presente no repositório a fonte textual do build sem inferir se a intenção +dos mantenedores era substituir `CCO` por `GPL-3`. A confirmação jurídica da +licença continua obrigatória antes de uma publicação. + +## Pendências e riscos + +- Executar o workflow recém-criado no GitHub Actions; ele não pode ser validado + integralmente apenas no ambiente local. +- Confirmar a licença pretendida e a compatibilidade das contribuições. +- Decidir se os datasets históricos excluídos do build devem ser recodificados, + internalizados ou removidos em versão futura. +- Substituir os skips de banco por testes com backend temporário na Fase 2. + +## Próxima seção recomendada + +Fase 2 — Infraestrutura de testes. diff --git a/docs/refactoring/phase-2-report.md b/docs/refactoring/phase-2-report.md new file mode 100644 index 0000000..39a9147 --- /dev/null +++ b/docs/refactoring/phase-2-report.md @@ -0,0 +1,84 @@ +# Relatório da Fase 2 — Infraestrutura de testes + +Data: 20 de agosto de 2026 + +## Resultado + +A suíte foi reorganizada por responsabilidade e pode ser executada localmente +sem banco de produção, objeto global de conexão, mudança manual do diretório ou +preparação prévia da sessão. O backend rápido usa SQLite em memória; a semântica +PostgreSQL fica coberta por um serviço efêmero dedicado na CI. + +## Organização da suíte + +- `test-epiweek.R`: calendário epidemiológico, limites de ano, tipos e schemas. +- `test-alert-rules.R`: validação das regras e regressão dos níveis de alerta. +- `test-fetch-cases.R`: validação, contrato e integração de `getCases()`. +- `test-rt.R`: baseline numérico de Rt, com tolerância explícita de `1e-7`. +- `test-fixture-contracts.R`: schemas, chaves e cardinalidade das fixtures. +- `test-utilities.R`: geocódigos, preenchimento, extrapolação e erros de entrada. +- `test-optional-models.R`: disponibilidade condicional de MEM e INLA. +- `helper-fixtures.R` e `helper-database.R`: somente preparação reutilizável. + +Os testes legados monolíticos e os skips incondicionais de banco foram +substituídos. Todas as expectativas estão dentro de blocos `test_that()`; os +arquivos de teste não usam `setwd()`, caminhos absolutos, `library()` ou +`require()`. + +## Contrato de dados + +Foram adicionadas fixtures sintéticas de notificações e da saída semanal +esperada. O teste de `getCases()` verifica: + +- nomes e ordem das nove colunas públicas; +- classes tabulares e tipos das colunas; +- cardinalidade semanal e ausência de duplicação da chave + `(SE, cidade, CID10)`; +- ordenação por semana; +- ausência de valores ausentes nas colunas obrigatórias; +- contagens notificadas, prováveis e confirmadas por laboratório; +- arquivo lateral legado `caselist.RData`, confinado a um diretório temporário; +- erros de validação antes do acesso ao banco. + +## Isolamento de banco + +O caminho local cria tabelas `Notificacao` e `Municipio` em uma conexão SQLite +em memória e garante desconexão automática, inclusive após falhas. + +O job `postgres-integration` da CI inicia `postgres:16`, cria o banco dedicado +`alerttools_test` e executa a suíte completa. O helper recusa qualquer outro +nome de banco, recria somente os schemas `Municipio` e `Dengue_global` dentro +desse banco e registra cleanup automático. O teste PostgreSQL é omitido fora +desse ambiente por `ALERTTOOLS_TEST_POSTGRES=true`. + +## Cobertura + +A CI ganhou um job separado que calcula `covr::package_coverage()` e publica o +objeto `coverage.rds` como artefato. A linha de base local desta fase é **18,46%**. +O valor foi registrado como indicador para orientar testes futuros, sem impor +uma meta artificial. + +## Verificações locais + +| Verificação | Resultado | +|---|---| +| `devtools::test()` | 98 passaram, 1 skip PostgreSQL condicionado, 0 falhas | +| `covr::package_coverage()` | 18,46% | +| `R CMD build` | passou | +| `R CMD check --no-manual` | **Status: OK** | + +O check foi executado com R 4.4.3 em macOS arm64. O contêiner PostgreSQL não +pôde ser executado localmente porque o daemon Docker não estava disponível; o +workflow dedicado é a validação reproduzível desse caminho e ainda precisa ser +observado em uma execução do GitHub Actions. + +## Gate da fase + +O gate local foi atendido: qualquer colaborador com as dependências sugeridas +pode executar a suíte determinística sem infraestrutura externa. PostgreSQL, +MEM e INLA possuem condições explícitas e não exigem acesso a sistemas de +produção. + +## Próxima seção recomendada + +Fase 3 — Camada de acesso a dados. diff --git a/docs/refactoring/phase-3-report.md b/docs/refactoring/phase-3-report.md new file mode 100644 index 0000000..795a577 --- /dev/null +++ b/docs/refactoring/phase-3-report.md @@ -0,0 +1,124 @@ +# Relatório da Fase 3 — Camada de acesso a dados + +Data: 4 de setembro de 2026 + +## Resultado + +Todo acesso SQL do pacote foi concentrado em `R/data_repository.R`. As funções +públicas recebem conexões DBI explicitamente, valores de entrada são enviados +por binding posicional e as escritas usam staging em lote dentro de transações. +Não existe mais fallback para um objeto global `con`. + +## Fronteira de dados + +O repositório interno contém operações para: + +- notificações e registros individuais; +- municípios, regiões e população municipal; +- clima por estação e clima municipal; +- tweets; +- parâmetros e associação de estações; +- associação regional usada pela distribuição do tempo de geração; +- históricos de alerta para dengue, chikungunya e zika. + +O mapeamento das tabelas físicas PostgreSQL e SQLite está centralizado em +`.db_table_config`. Datas armazenadas como números no SQLite legado são +normalizadas para `Date` na fronteira. Os consumidores recebem schemas de +domínio iguais nos dois backends. + +## SQL seguro e portável + +- Valores de cidades, CID-10, estados, regiões, estações, anos e datas usam + parâmetros vinculados em `DBI::dbGetQuery()`. +- Identificadores fixos são gerados com `DBI::dbQuoteIdentifier()`. +- A única geração de SQL fora do repositório é a exportação explícita para + arquivo em `write_alerta()`; seus valores passam por + `DBI::dbQuoteLiteral(DBI::ANSI(), ...)`. +- Diferenças de placeholders, nomes físicos e representação de datas estão + encapsuladas na camada interna, sem branches por classe nas funções públicas. +- Entradas inválidas são rejeitadas antes da consulta, inclusive intervalos de + datas, anos, geocódigos, CIDs e conexões ausentes. + +## Escrita transacional + +`.repo_write_rows()` grava todas as linhas em uma tabela temporária e executa +um único `INSERT ... SELECT` dentro de `DBI::dbWithTransaction()`. A política de +conflito é obrigatoriamente uma destas opções: + +- `error`: aborta a operação completa; +- `update`: atualiza as colunas não pertencentes à chave; +- `ignore`: mantém as linhas já existentes. + +`write_parameters()` e `write_alerta()` expõem essa política. A compatibilidade +de `overwrite = TRUE` em `write_parameters()` seleciona `update`. +`setWUstation()` usa staging e um único `UPDATE ... FROM`, também transacional. + +Os testes verificam escrita em lote, atualização idempotente, conflito, +rollback sem linha parcial e exportação segura de texto contendo tentativa de +injeção SQL. + +## Remoção de estado global + +Os argumentos `datasource` das funções com acesso ao banco não possuem mais +default. O pipeline propaga a mesma conexão para parâmetros, clima, casos e +persistência. Um teste instala deliberadamente um objeto `con` no ambiente +global e confirma que ele não é consultado. + +As transformações `tabela_historico()` e `tabela_historico_intra()` deixaram de +reler parâmetros do banco. Resultados de `pipe_infodengue()` carregam os +parâmetros em um atributo; chamadas diretas devem fornecê-los pelo novo +argumento `parameters`. + +## Correções encontradas pelos contratos + +- `read.cases()` usava `round(SE / 100)` para encontrar o primeiro ano. Nas + semanas 52 e 53 isso arredondava para o ano seguinte e descartava casos. A + extração agora usa `floor(SE / 100)`. +- `getCaseslist()` validava a variável inexistente `dataini`; a validação foi + removida e o intervalo de datas passou a ser validado e aplicado no banco. +- `getClima()` comparava `vars` consigo mesmo e aceitava nomes desconhecidos; + agora usa uma lista explícita de variáveis permitidas. +- O pipeline não propagava `datasource` às chamadas internas e tentava escrever + um objeto inexistente chamado `alerta`; ambos os fluxos foram corrigidos. + +## Verificações + +| Verificação | Resultado | +|---|---| +| `devtools::test()` | 143 passaram, 1 skip PostgreSQL condicionado, 0 falhas | +| `covr::package_coverage()` | 41,67% | +| ausência de `con` em `R/` | confirmada | +| argumentos `datasource` obrigatórios | confirmados em 16 funções | +| `git diff --check` | passou | +| `R CMD build` | passou | +| `R CMD check --no-manual` | **Status: OK** | + +O check foi executado com R 4.4.3 em macOS arm64. `RPostgres` substituiu +`RPostgreSQL` como dependência sugerida para garantir suporte atual ao binding +de parâmetros. A integração PostgreSQL continuará sendo executada no job +efêmero `postgres:16` configurado na CI; não havia daemon Docker local para +reproduzir o serviço nesta máquina. + +## Compatibilidade e migração + +Esta fase contém mudanças deliberadas de chamada: + +- toda função que consulta ou grava banco exige `datasource = connection`; +- `tabela_historico()` e `tabela_historico_intra()` exigem parâmetros em memória + quando o objeto não veio do pipeline; +- `write_alerta()` e `write_parameters()` aceitam `conflict` explícito. + +Nenhum símbolo exportado foi removido e os schemas de retorno protegidos pelas +fixtures foram preservados. + +## Gate da fase + +O gate foi atendido no código e no backend SQLite: não há concatenação direta +de valores do usuário em SQL, dependência de `con`, leitura usada para escrita +ou escrita linha a linha. Todas as operações do repositório possuem cobertura +de integração. A execução do job PostgreSQL no GitHub Actions permanece como +verificação externa do backend efêmero. + +## Próxima seção recomendada + +Fase 4 — Núcleo epidemiológico puro. diff --git a/docs/refactoring/phase-4-report.md b/docs/refactoring/phase-4-report.md new file mode 100644 index 0000000..9528769 --- /dev/null +++ b/docs/refactoring/phase-4-report.md @@ -0,0 +1,120 @@ +# Relatório da Fase 4 — Núcleo epidemiológico puro + +Data: 4 de setembro de 2026 + +## Resultado + +O fluxo computacional completo pode ser executado por `alerttools_pipeline()` +somente com objetos em memória. O resultado é determinístico quando o +nowcasting é desativado ou recebe uma semente, não consulta banco, não lê ou +grava arquivos e não depende do diretório corrente. + +## Calendário epidemiológico + +Foram implementadas três funções algorítmicas: + +- `as_epiweek()`: converte datas em semanas `YYYYWW`; +- `epiweek_start()`: retorna o domingo inicial da semana; +- `epiweek_seq()`: produz sequências inclusivas entre semanas. + +A convenção preservada é domingo a sábado, com a semana 1 contendo 4 de +janeiro. O algoritmo não possui tabela ou limite anual. A tabela legada `SE` +foi usada como fixture de equivalência. Ela contém uma anomalia isolada na +semana 201815, registrada com início em uma quarta-feira e duração de dez dias; +o novo algoritmo retorna corretamente 8 a 14 de abril de 2018. + +Os testes cobrem viradas de ano, anos com 53 semanas, intervalos entre 1900 e +2101, uma data em 2150, round trips, valores ausentes e semanas inválidas. +As funções legadas `data2SE()`, `SE2date()`, `episem()`, `daySEday()`, +`lastepiweek()` e `seqSE()` agora delegam à convenção algorítmica. + +## Módulos computacionais + +O novo núcleo coordena operações já separadas e puras para: + +- validação e normalização dos schemas de domínio; +- incidência por `calculate_incidence()`; +- correção de atraso por `adjustIncidence()` e `bayesnowcasting()`; +- número reprodutivo por `Rt()`; +- limiares MEM por `applymem()`; +- critérios e classificação por `setCriteria()` e `fouralert()`. + +Essas entradas computacionais recebem data frames ou vetores em memória. Um +teste estrutural protege o núcleo contra chamadas a DBI, leitura e escrita de +arquivos e alteração do diretório corrente. Dados inválidos, como população +não positiva, contagem negativa, schemas incompletos e número de trabalhadores +inválido, produzem erros explícitos. + +## Efeitos colaterais e determinismo + +`getCases()` não grava mais `caselist.RData`. Quando registros individuais são +necessários, eles são carregados pela camada de dados, anexados em memória e +passados ao núcleo pelo argumento `case_records`. + +O nowcasting bayesiano não consulta mais o banco internamente. `seed`, +`workers` e `verbose` são argumentos propagados pelo pipeline. A semente cobre +tanto a amostragem posterior quanto a preditiva e o estado aleatório do +chamador é restaurado ao final. `workers = 1` é o padrão; valores são validados, +e plataformas sem `fork` usam execução serial sem alterar planos globais. + +`pipe_infodengue()` exige `datarelatorio` ou `finalday` explícito. A data de +versão também é propagada explicitamente para persistência. +`tabela_historico()` e `tabela_historico_intra()` não consultam o relógio e +exigem `versao`. + +## Objeto de resultado + +`new_alerttools_result()` cria a classe S3 `alerttools_result` com os campos: + +- `data`; +- `alerts`; +- `parameters`; +- `metadata`; +- `diagnostics`. + +O construtor valida tipos, cardinalidade, nomes duplicados e listas nomeadas. +Foram implementados `print.alerttools_result()`, +`summary.alerttools_result()` e `as.data.frame.alerttools_result()`. Não foi +adicionado `plot()`, pois o plano condiciona esse método à existência de um +requisito visual claro. + +## Verificações + +| Verificação | Resultado | +|---|---| +| `devtools::test()` | 201 passaram, 1 skip PostgreSQL condicionado, 0 falhas | +| `covr::package_coverage()` | 54,08% | +| pipeline repetido com fixture e mesma semente | resultados idênticos | +| ausência de arquivos novos após o pipeline | confirmada em diretório temporário | +| restauração de `.Random.seed` | confirmada | +| equivalência com calendário legado válido | confirmada | +| `R CMD build` | passou | +| `R CMD check --no-manual` | **Status: OK**, sem erros, avisos ou notas | + +O check foi executado com R 4.4.3 em macOS arm64. O teste PostgreSQL permanece +condicionado ao serviço efêmero da CI; os testes unitários e de integração +SQLite foram executados localmente. + +## Compatibilidade e migração + +As funções legadas de infraestrutura continuam disponíveis. As mudanças +deliberadas desta fase são: + +- `pipe_infodengue()` retorna `alerttools_result`; +- `pipe_infodengue()` requer uma semana ou data final explícita; +- `tabela_historico*()` requer `versao` explícita; +- nowcasting bayesiano requer registros individuais em memória; +- `GenTimeDist()` usa `workers = 1`, mantendo `nc` como alias depreciado. + +Nenhum símbolo exportado anterior foi removido. A camada de compatibilidade e +os nomes finais da nova API pertencem à fase 5. + +## Gate da fase + +O gate foi atendido: o pipeline epidemiológico completo roda com fixtures em +memória, de forma determinística, sem banco, arquivos auxiliares ou dependência +do diretório corrente. + +## Próxima seção recomendada + +Fase 5 — Nova API e compatibilidade. diff --git a/docs/refactoring/phase-5-report.md b/docs/refactoring/phase-5-report.md new file mode 100644 index 0000000..eb34178 --- /dev/null +++ b/docs/refactoring/phase-5-report.md @@ -0,0 +1,125 @@ +# Relatório da Fase 5 — Nova API e compatibilidade + +Data: 4 de setembro de 2026 + +## Resultado + +O pacote agora oferece um fluxo público coerente em `snake_case`, separado em +construção ou leitura de entradas, cálculo, transformação e persistência. A API +nova reproduz o resultado protegido pelo baseline, enquanto as funções legadas +continuam disponíveis como adaptadores com avisos graduais de depreciação. + +## Fluxo público mínimo + +Foram implementadas as funções exigidas pelo plano: + +- `new_alert_inputs()` constrói e valida entradas em memória; +- `fetch_alert_inputs()` busca casos, registros individuais e clima; +- `fetch_alert_parameters()` busca parâmetros por município e doença; +- `run_alert_pipeline()` executa apenas cálculo; +- `write_alert_results()` persiste explicitamente em transação. + +O fluxo é complementado por `as_alert_history()` e +`upsert_alert_parameters()`. A leitura granular pode ser feita com +`fetch_cases()`, `fetch_case_records()` e `fetch_climate()`. + +Argumentos públicos usam consistentemente `conn`, `geocodes`, `start_date`, +`end_date`, `start_week`, `report_week`, `disease`, `workers` e `verbose`. +Nomes de domínio para dengue, chikungunya e zika são traduzidos para CID-10 +canônico na fronteira. + +## Contrato de entradas + +`new_alert_inputs()` retorna a classe experimental `alerttools_inputs`, com: + +- `cases`: chave única `cidade`, `CID10`, `SE`; +- `climate`: chave única `geocodigo`, `SE`; +- `population`: população opcional normalizada; +- `case_records`: registros individuais opcionais; +- `metadata`: proveniência e período. + +O construtor valida schemas, tipos numéricos, semanas epidemiológicas, +população positiva, unicidade das chaves e listas nomeadas. Casos e clima são +ordenados de forma determinística. Populações históricas usam o ano mais +recente por município. + +## API computacional + +Também foram expostos nomes consistentes para responsabilidades puras: + +- `estimate_rt()`; +- `nowcast_cases()`; +- `define_alert_rules()`; +- `classify_alerts()`. + +Essas funções e a API antiga chamam as mesmas implementações internas. O +pipeline também usa esses pontos únicos, eliminando duplicação de regras. + +## Compatibilidade gradual + +As seguintes interfaces são wrappers depreciados desde 1.1.0: + +- `getCases()` e `getCaseslist()`; +- `getClima()`; +- `read.parameters()` e `write_parameters()`; +- `Rt()` e `adjustIncidence()`; +- `setCriteria()` e `fouralert()`; +- `pipe_infodengue()`; +- `tabela_historico()`; +- `write_alerta()`. + +Os wrappers preservam assinaturas, defaults e formatos de retorno e emitem +`lifecycle::deprecate_warn()` indicando a substituição. O pipeline legado agora +compõe a nova construção de entradas, execução e escrita explícita em vez de +manter uma segunda implementação. + +A tabela completa de funções, argumentos, colunas e diferenças intencionais +está em `docs/refactoring/api-migration.md`. + +## Diferenças intencionais + +- A API nova exige `conn` em operações externas e nunca consulta estado global. +- Períodos são explícitos e consistentes entre datas e semanas. +- `run_alert_pipeline()` não possui opção de escrita. +- `write_alert_results()` recebe um resultado ou histórico e aplica uma + política de conflito explícita. +- Exportação de SQL para arquivo permanece somente na API legada. +- Entradas inválidas são rejeitadas em vez de receber fallback oculto. +- As fachadas de inputs e orquestração estão marcadas como experimentais. + +## Testes de migração + +`tests/testthat/test-api.R` cobre: + +- construção, schema, ordenação e erros de `alerttools_inputs`; +- equivalência exata entre `run_alert_pipeline()` e o pipeline puro aprovado; +- leitura integrada de inputs e parâmetros em SQLite; +- persistência de resultados e parâmetros; +- tradução de argumentos legados; +- avisos com a função substituta; +- equivalência dos wrappers de casos, registros, clima, parâmetros, Rt, + nowcasting, regras, classificação e histórico. + +## Verificações + +| Verificação | Resultado | +|---|---| +| `devtools::test()` | 250 passaram, 1 skip PostgreSQL condicionado, 0 falhas ou warnings | +| testes específicos da nova API | 49 passaram | +| `covr::package_coverage()` | 57,75% | +| `git diff --check` | passou | +| `R CMD build` | passou | +| `R CMD check --no-manual` | **Status: OK**, sem erros, avisos ou notas | + +O check foi executado com R 4.4.3 em macOS arm64. A integração PostgreSQL +continua condicionada ao serviço efêmero configurado na CI. + +## Gate da fase + +O gate foi atendido: a API nova reproduz os resultados aprovados, a API antiga +permanece funcional por wrappers e as diferenças intencionais e instruções de +migração estão documentadas. + +## Próxima seção recomendada + +Fase 6 — Documentação e experiência de desenvolvimento. diff --git a/docs/refactoring/phase-6-report.md b/docs/refactoring/phase-6-report.md new file mode 100644 index 0000000..c53f768 --- /dev/null +++ b/docs/refactoring/phase-6-report.md @@ -0,0 +1,100 @@ +# Relatório da Fase 6 — Documentação e experiência de desenvolvimento + +Data: 5 de setembro de 2026 + +## Resultado + +O pacote agora possui uma trilha documentada e testada para instalação, +desenvolvimento, uso em memória, uso com banco e migração da API legada. A +documentação executável não usa credenciais, produção nem estado global. + +O site pkgdown e sua publicação manual foram configurados, mas não publicados. +A publicação e os controles administrativos permanecem deliberadamente +dependentes da validação e autorização dos mantenedores. + +## Uso e onboarding + +O `README.md` passou a documentar: + +- requisitos e instalação da versão de desenvolvimento; +- preparação de um clone para desenvolvimento; +- exemplo mínimo executável sem banco; +- separação entre leitura, cálculo e escrita no fluxo com DBI; +- acesso às vignettes, migração e manutenção; +- ausência de credenciais, dados de produção e conexão global nos exemplos. + +Foram adicionados dois scripts reproduzíveis em `inst/examples/`: + +- `in-memory-pipeline.R`, com casos, clima e parâmetros sintéticos; +- `sqlite-pipeline.R`, com banco SQLite em memória e tabelas descartáveis. + +Os scripts sustentam as vignettes `in-memory-pipeline`, `database-pipeline` e +`migrating-to-snake-case`. Um teste dedicado executa os dois exemplos em +ambientes limpos e protege seu contrato de onboarding. + +## Manutenção e release + +O `CONTRIBUTING.md` registra dependências opcionais, documentação, testes, +lint, cobertura, check, vignettes, site, segurança de banco e revisão de +mudanças científicas. + +`docs/RELEASE.md` documenta versionamento semântico, janela de depreciação, +release candidata, release principal, artefatos, rollback e a sequência de +versões proposta. O `NEWS.md` foi atualizado com alterações voltadas a quem +usa e mantém o pacote. + +## Qualidade e publicação + +Foram configurados: + +- site pkgdown Bootstrap 5, referência agrupada e três guias; +- workflow `pkgdown` acionado apenas manualmente, condicionado à confirmação + textual e ao ambiente protegido `pkgdown-production`; +- badge do workflow `R-CMD-check`, que já possui serviço correspondente; +- cobertura como indicador e artefato `coverage.rds` na CI; +- job de lint na CI e regras locais focadas em caminhos absolutos, whitespace + e alteração do diretório de trabalho; +- script opt-in do `styler`, limitado aos arquivos modernos e com orientação + para commits exclusivamente de estilo; +- recomendações de proteção de branch e revisão obrigatória em + `docs/BRANCH_PROTECTION.md`. + +Não foi criado badge de porcentagem de cobertura porque ainda não existe um +serviço público de cobertura confirmado. Não foram publicados o site, tags ou +releases, nem alteradas configurações do GitHub. + +## Verificações + +| Verificação | Resultado | +|---|---| +| exemplos documentados | 8 testes passaram | +| `devtools::test()` | 258 passaram, 1 skip PostgreSQL condicionado, 0 falhas ou warnings | +| `lintr::lint_package()` | passou sem lints | +| `covr::package_coverage()` | 57,96% | +| sintaxe dos workflows e do pkgdown | YAML válido | +| construção local do pkgdown | passou, incluindo referência e 3 artigos | +| `R CMD build` | passou, incluindo construção das vignettes | +| `R CMD check --no-manual` | **Status: OK**, 0 errors, 0 warnings e 0 notes | + +O check foi executado com R 4.4.3 em macOS arm64. A integração PostgreSQL +continua condicionada ao serviço efêmero configurado na CI. + +## Gate da fase + +O percurso técnico do gate foi atendido localmente: uma instalação construída +do pacote contém o exemplo em memória, as vignettes são construídas e o exemplo +é executado automaticamente pela suíte. A disponibilização desse percurso na +URL pública depende apenas da validação dos mantenedores e da execução manual +do workflow de publicação, como exigido pelo próprio plano. + +## Decisões externas pendentes + +- validar e publicar o site pkgdown; +- criar e proteger o ambiente `pkgdown-production` no GitHub; +- aprovar e aplicar proteção do branch e revisão obrigatória; +- escolher um serviço público antes de adicionar badge de cobertura; +- confirmar versão, tag e calendário da próxima release candidata. + +## Próxima seção recomendada + +Fase 7 — Migração e release principal. diff --git a/docs/refactoring/phase-7-report.md b/docs/refactoring/phase-7-report.md new file mode 100644 index 0000000..6d188be --- /dev/null +++ b/docs/refactoring/phase-7-report.md @@ -0,0 +1,109 @@ +# Relatório da Fase 7 — Migração e release principal + +Data: 5 de setembro de 2026 + +## Resultado + +A infraestrutura controlada de transição foi implementada, mas o gate final da +Fase 7 permanece bloqueado por condições externas reais. Uma busca somente +leitura na organização pública `AlertaDengue` substituiu o inventário “a +confirmar” por dez grupos de consumidores; sete são críticos ou de alta +prioridade e ainda usam a API legada. + +Nenhum wrapper foi removido. Após autorização expressa do mantenedor, a versão +foi preparada como 1.2.0 e a janela foi aprovada; tags, releases e publicação +continuam condicionadas à validação da candidata e dos consumidores. + +## Alterações + +- `consumer-registry.csv`: registro versionado de repositório, arquivo, API + legada, criticidade, situação, evidência, bloqueio e rollback de cada grupo; +- `consumer-migration.md`: ordem de migração, baseline, transformação, testes, + comparação epidemiológica, monitoramento e rollback por consumidor; +- `transition-policy.dcf`: sequência de versões e janela aprovada; +- `tools/check-migration-readiness.R`: valida o registro, impede regressão para + chamadas legadas internas e bloqueia remoções prematuras; +- workflow `R-CMD-check`: novo job de integridade do inventário; +- template de PR: evidências e rollback obrigatórios por consumidor; +- README, guia de migração, vignette, contribuição, release e NEWS: comunicação + da transição e retenção de documentação histórica. + +## Consumidores confirmados + +Foram encontrados usos em: + +- `AlertaDengue/AlertaDengueAnalise`; +- `AlertaDengue/ADAnalise-container`; +- `AlertaDengue/AlertaDengue-migration`; +- `AlertaDengue/infodengue_intramunicipal`; +- `AlertaDengue/intramunicipal`; +- `AlertaDengue/boletins`; +- `AlertaDengue/BoletimQuinzenal`; +- `AlertaDengue/WP-estimating-Rt`. + +O pipeline nacional ainda usa `pipe_infodengue()` e `tabela_historico()` e +mantém uma conexão `con` global. Outros consumidores usam `write_alerta()`, +`getCases()`, `read.parameters()` e `fouralert()`. A busca não garante cobertura +de chamadas dinâmicas, branches não indexados ou repositórios sem acesso. + +## Incompatibilidades registradas + +- a nova API exige conexão DBI explícita; +- leitura, cálculo, transformação e persistência agora são etapas separadas; +- o resultado moderno usa a classe `alerttools_result`; +- `version_date` é obrigatória na conversão e persistência; +- exportação de arquivo SQL, retentativas, paralelismo, `.RData` e publicação + remota devem permanecer no orquestrador consumidor. + +Essas diferenças não foram mascaradas com retorno ao estado global ou efeitos +colaterais implícitos. + +## Releases de transição + +A sequência `1.1.1`, `1.2.0`, `1.3.0`, `1.4.x` e `2.0.0` foi documentada. A +janela foi aprovada pelo mantenedor por no mínimo duas +releases minor e seis meses, contados a partir dos warnings formais da 1.3.0. A +`2.0.0` continua sendo somente a primeira versão elegível para remoções; não +constitui autorização automática. + +## Verificações + +| Verificação | Resultado | +|---|---| +| busca organizacional | 10 grupos catalogados; 7 críticos/de alta prioridade pendentes | +| chamadas legadas no código operacional de `R/` | 0 | +| integridade do registro | passou | +| gate `--for-removal` | bloqueou como esperado | +| `devtools::test()` | 258 passaram, 1 skip PostgreSQL condicionado, 0 falhas ou warnings | +| `lintr::lint_package()` | passou sem lints | +| `covr::package_coverage()` | 57,96% | +| construção local do pkgdown | passou, incluindo a vignette atualizada | +| `R CMD build` | passou, incluindo vignettes | +| `R CMD check --no-manual` | **Status: OK**, 0 errors, 0 warnings e 0 notes | + +## Compatibilidade + +- API: wrappers preservados; versão candidata preparada como 1.2.0; +- dados e resultados epidemiológicos: código computacional inalterado e suíte + equivalente; consumidores externos ainda precisam de comparação própria; +- documentação histórica: política de retenção registrada. + +## Gate da fase + +**Não atendido ainda.** O gate exige consumidores críticos na API nova, ausência +de depreciações relevantes em operação e remoção comprovadamente segura. O +registro mostra sete consumidores críticos/de alta prioridade pendentes. + +O comando abaixo materializa esse bloqueio e deve continuar falhando até que as +condições sejam realmente atendidas: + +```sh +Rscript tools/check-migration-readiness.R --for-removal +``` + +## Decisões e autorizações necessárias + +- confirmar quais consumidores são críticos e atribuir responsáveis; +- autorizar alterações, testes e PRs nos repositórios consumidores; +- fornecer infraestrutura descartável e critérios de equivalência científica; +- validar a release candidata e autorizar a principal após a migração. diff --git a/docs/refactoring/transition-policy.dcf b/docs/refactoring/transition-policy.dcf new file mode 100644 index 0000000..2d11eed --- /dev/null +++ b/docs/refactoring/transition-policy.dcf @@ -0,0 +1,8 @@ +Status: approved +Warnings-Start: 1.3.0 +Transition-Releases: 1.4.x +Earliest-Removal: 2.0.0 +Minimum-Support-Months: 6 +Minimum-Support-Minor-Releases: 2 +Approved-By: BaruqueRodrigues (package maintainer) +Approved-At: 2026-09-05 diff --git a/inst/examples/in-memory-pipeline.R b/inst/examples/in-memory-pipeline.R new file mode 100644 index 0000000..8ba0b97 --- /dev/null +++ b/inst/examples/in-memory-pipeline.R @@ -0,0 +1,55 @@ +library(AlertTools) + +weeks <- epiweek_seq(202501, 202512) +case_counts <- c(0, 1, 2, 4, 8, 13, 18, 15, 9, 5, 2, 1) + +cases <- data.frame( + SE = weeks, + cidade = 3304557, + CID10 = "A90", + casos = case_counts, + cas_prov = case_counts, + cas_lab = floor(case_counts / 2), + localidade = 0, + nome = "Município sintético", + pop = 100000 +) + +climate <- data.frame( + SE = weeks, + geocodigo = 3304557, + temp_min = c(20, 20, 21, 22, 23, 24, 24, 23, 22, 21, 20, 20), + temp_med = c(25, 25, 26, 27, 28, 29, 29, 28, 27, 26, 25, 25), + temp_max = c(30, 30, 31, 32, 33, 34, 34, 33, 32, 31, 30, 30), + umid_min = 45, + umid_med = 65, + umid_max = 85 +) + +parameters <- data.frame( + municipio_geocodigo = 3304557, + limiar_preseason = 10, + limiar_posseason = 5, + limiar_epidemico = 100, + varcli = "temp_min", + clicrit = 22, + varcli2 = NA_character_, + clicrit2 = NA_real_, + cid10 = "A90", + codmodelo = "Af" +) + +inputs <- new_alert_inputs(cases = cases, climate = climate) +result <- run_alert_pipeline( + inputs = inputs, + parameters = parameters, + report_week = 202512, + nowcast = "none", + workers = 1 +) + +stopifnot( + inherits(inputs, "alerttools_inputs"), + inherits(result, "alerttools_result"), + nrow(result$data) == length(weeks) +) diff --git a/inst/examples/sqlite-pipeline.R b/inst/examples/sqlite-pipeline.R new file mode 100644 index 0000000..d1b9dd7 --- /dev/null +++ b/inst/examples/sqlite-pipeline.R @@ -0,0 +1,85 @@ +library(AlertTools) + +if (!requireNamespace("RSQLite", quietly = TRUE)) { + stop("Install RSQLite to run this example.") +} + +conn <- DBI::dbConnect(RSQLite::SQLite(), ":memory:") + +weeks <- epiweek_seq(202501, 202512) +dates <- epiweek_start(weeks) +case_counts <- c(0, 1, 2, 4, 8, 13, 18, 15, 9, 5, 2, 1) +notification_dates <- rep(dates, case_counts) + +notifications <- data.frame( + municipio_geocodigo = 3304557, + cid10_codigo = "A90", + dt_notific = notification_dates, + dt_sin_pri = notification_dates, + dt_digita = notification_dates, + ano_notif = as.integer(format(notification_dates, "%Y")), + se_notif = as_epiweek(notification_dates) %% 100, + classi_fin = 1, + criterio = 1 +) +date_columns <- c("dt_notific", "dt_sin_pri", "dt_digita") +notifications[date_columns] <- lapply( + notifications[date_columns], as.numeric +) + +municipality <- data.frame( + geocodigo = 3304557, + nome = "Município sintético", + populacao = 100000 +) + +climate <- data.frame( + geocode = 3304557, + date = as.numeric(dates), + temp_min = c(20, 20, 21, 22, 23, 24, 24, 23, 22, 21, 20, 20), + temp_med = c(25, 25, 26, 27, 28, 29, 29, 28, 27, 26, 25, 25), + temp_max = c(30, 30, 31, 32, 33, 34, 34, 33, 32, 31, 30, 30), + umid_min = 45, + umid_med = 65, + umid_max = 85 +) + +parameters_table <- data.frame( + municipio_geocodigo = 3304557, + limiar_preseason = 10, + limiar_posseason = 5, + limiar_epidemico = 100, + varcli = "temp_min", + clicrit = 22, + varcli2 = NA_character_, + clicrit2 = NA_real_, + cid10 = "A90", + codmodelo = "Af" +) + +DBI::dbWriteTable(conn, "Notificacao", notifications) +DBI::dbWriteTable(conn, "Municipio", municipality) +DBI::dbWriteTable(conn, "copernicus_bra", climate) +DBI::dbWriteTable(conn, "parameters", parameters_table) + +inputs <- fetch_alert_inputs( + conn = conn, + geocodes = 3304557, + disease = "dengue", + start_week = 202501, + report_week = 202512 +) +parameters <- fetch_alert_parameters( + conn = conn, + geocodes = 3304557, + disease = "dengue" +) +result <- run_alert_pipeline(inputs, parameters, nowcast = "none") + +DBI::dbDisconnect(conn) + +stopifnot( + inherits(inputs, "alerttools_inputs"), + inherits(result, "alerttools_result"), + nrow(result$data) == length(weeks) +) diff --git a/man/AlertTools-package.Rd b/man/AlertTools-package.Rd deleted file mode 100755 index 037c3fc..0000000 --- a/man/AlertTools-package.Rd +++ /dev/null @@ -1,35 +0,0 @@ -\name{AlertTools-package} -\alias{AlertTools-package} -\alias{AlertTools} -\docType{package} -\title{ -\packageTitle{AlertTools} -} -\description{ -\packageDescription{AlertTools} -} -\details{ - -The DESCRIPTION file: -\packageDESCRIPTION{AlertTools} -\packageIndices{AlertTools} -~~ An overview of how to use the package, including the most important functions ~~ -} -\author{ -\packageAuthor{AlertTools} - -Maintainer: \packageMaintainer{AlertTools} -} -\references{ -~~ Literature or other references for background information ~~ -} -~~ Optionally other standard keywords, one per line, from file KEYWORDS in the R ~~ -~~ documentation directory ~~ -\keyword{ package } -\seealso{ -~~ Optional links to other man pages, e.g. ~~ -~~ \code{\link[:-package]{}} ~~ -} -\examples{ -~~ simple examples of the most important functions ~~ -} diff --git a/man/AlertTools.Rd b/man/AlertTools.Rd new file mode 100644 index 0000000..a9f62eb --- /dev/null +++ b/man/AlertTools.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AlertTools.R +\docType{package} +\name{AlertTools} +\alias{AlertTools} +\alias{AlertTools-package} +\title{AlertTools: utilities for the InfoDengue alert system} +\description{ +AlertTools retrieves and organizes epidemiological and climate data, +adjusts notification series, estimates epidemiological indicators, and +calculates alert levels. Database access is isolated behind an internal DBI +repository, while computational functions operate on in-memory data frames. +} +\seealso{ +Useful links: +\itemize{ + \item \url{https://github.com/AlertaDengue/AlertTools} + \item Report bugs at \url{https://github.com/AlertaDengue/AlertTools/issues} +} + +} +\author{ +\strong{Maintainer}: Claudia Codeco \email{claudia.codeco@gmail.com} + +} +\keyword{internal} diff --git a/man/GenTimeDist.Rd b/man/GenTimeDist.Rd index 5b0f2e0..9a31fe3 100644 --- a/man/GenTimeDist.Rd +++ b/man/GenTimeDist.Rd @@ -4,7 +4,14 @@ \alias{GenTimeDist} \title{Calculates temperature dependent generation time distribution} \usage{ -GenTimeDist(serTemp, cid10 = "A90", GT.max = 10, smooth = "sinusoidal", nc = 1) +GenTimeDist( + serTemp, + cid10 = "A90", + GT.max = 10, + smooth = "sinusoidal", + workers = 1L, + nc = workers +) } \arguments{ \item{serTemp}{: Temperature series} @@ -14,6 +21,10 @@ GenTimeDist(serTemp, cid10 = "A90", GT.max = 10, smooth = "sinusoidal", nc = 1) \item{GT.max}{: maximum number of weeks to consider for generation time} \item{smooth}{"sinusoidal" (default) or "raw"} + +\item{workers}{Positive number of parallel workers; defaults to one.} + +\item{nc}{Deprecated alias for `workers`.} } \value{ matrix with generation time distributions per week, one row per week, one column per SE. @@ -23,10 +34,12 @@ Function to produce matrix of generation time distribution that depends on tempe For details, see the reference Codeco et al (2018). } \examples{ -cli = getWU(stations = 'SBGL', vars=c("temp_med"), datasource=con) \%>\% - mutate(temp_med = nafill(temp_med, rule = "arima")) +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +cli = getWU(stations = 'SBGL', vars=c("temp_med"), datasource=connection) \%>\% + mutate(temp_med = nafill(temp_med, rule = "arima")) gt <- GenTimeDist(cli$temp_med[1:50]) contour(gt, ylab="time", xlab="generation time (week)") +\dontshow{\}) # examplesIf} } \references{ Codeco et al (2018) https://doi.org/10.1016/j.epidem.2018.05.011 diff --git a/man/Rt.Rd b/man/Rt.Rd index 81be8c9..c498b86 100644 --- a/man/Rt.Rd +++ b/man/Rt.Rd @@ -1,9 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Rt_functions.R +% Please edit documentation in R/api.R \name{Rt} \alias{Rt} -\title{Computes the effective reproductive number using alternative -distributions for the generation interval.} +\title{Legacy Rt estimator} \usage{ Rt( obj, @@ -18,39 +17,8 @@ Rt( ) } \arguments{ -\item{meangt}{if gtdist = "delta" it is the exact period between primary and -secondary infections). If gtdist = "normal", it is the mean generation time.} - -\item{sdgt}{if gtdist = "normal", it is the standard deviation of the generation time -distribution.} - -\item{CI}{Model used to compute the confidence interval. Possible choice: "beta".} - -\item{object}{a data.frame with variables "casos" and "SE", ideally from getCases().} -} -\value{ -data.frame with estimated Rt and confidence intervals. +\item{obj, count, gtdist, meangt, sdgt, CI, alpha, a0, b0}{Legacy arguments.} } \description{ -Calculates the effective reproductive number from the growth rate -of cases. Uses formula 4.2 in Wallinga and Lispitch (2007). Confidence interval assume -ratio between two Poissons (see Luis Max documentation). -} -\examples{ -d <- getCases(cities = 3302205, lastday ="2018-03-10") # dengue -# Rt original -rt<-Rtoriginal(obj = d, count = "casos", meangt=3) -plot(rt$Rt, type="l", xlab = "weeks", ylab = "Rt") -lines(rt$lwr,lty=3); lines(rt$upr,lty=3) -abline(h = 1, col = 2) -# Rt delta and normal -rtdelta<-Rt(obj = d, count = "casos", gtdist="delta", meangt=3) -rtnorm<-Rt(obj = d, count = "casos", gtdist="normal", meangt=3, sdgt = 1) -lines(rtdelta$Rt, col = 3) -lines(rtdelta$lwr,lty = 3, col = 3) -lines(rtdelta$upr,lty = 3, col = 3) -lines(rtnorm$Rt, col = 4) -lines(rtnorm$lwr,lty = 3, col = 4) -lines(rtnorm$upr,lty = 3, col = 4) -legend(30,3,c("original","delta","normal"),lty=1, col = c(1,3,4), cex = 0.7) +Legacy Rt estimator } diff --git a/man/SE.Rd b/man/SE.Rd new file mode 100644 index 0000000..b9c257f --- /dev/null +++ b/man/SE.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{SE} +\alias{SE} +\alias{WUdata} +\alias{bairro2APS} +\alias{cliSBCB} +\alias{locs} +\alias{sinan} +\alias{tw} +\title{Example and reference datasets} +\format{ +Objects with structures specific to their historical examples. Use + `utils::data()` and inspect an object with `str()` before use. +} +\source{ +AlertTools historical package data. +} +\description{ +Legacy datasets bundled with AlertTools. `SE` contains the epidemiological +calendar currently used by the date conversion helpers. The remaining +objects are historical examples retained for compatibility and should not +be interpreted as current operational data. +} diff --git a/man/SE2date.Rd b/man/SE2date.Rd index e01b14f..f128ab9 100644 --- a/man/SE2date.Rd +++ b/man/SE2date.Rd @@ -7,7 +7,7 @@ SE2date(se) } \arguments{ -\item{SE}{string vector with dates to be converted, format 201420} +\item{se}{numeric vector with epidemiological weeks, for example 201420.} } \value{ data.frame with SE and first day. @@ -16,6 +16,8 @@ data.frame with SE and first day. Return the first day of the Epidemiological Week } \examples{ -SE2date(se=201812) +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +SE2date(se=202612) SE2date(se = c(202001:202209)) +\dontshow{\}) # examplesIf} } diff --git a/man/adjustIncidence.Rd b/man/adjustIncidence.Rd index 28d1f18..bb7f417 100644 --- a/man/adjustIncidence.Rd +++ b/man/adjustIncidence.Rd @@ -1,68 +1,28 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/adjust_incidence_functions.R +% Please edit documentation in R/api.R \name{adjustIncidence} \alias{adjustIncidence} -\title{Correct incidence data with notification delay (nowcasting).} +\title{Legacy nowcasting interface} \usage{ adjustIncidence( obj, - datas, + datas = NULL, method = "none", - pdig = plnorm((1:20) * 7, 2.5016, 1.1013), + pdig = stats::plnorm((1:20) * 7, 2.5016, 1.1013), Dmax = 10, nyears = 2, - datasource = con, + datasource = NULL, nowSE, safelimit = 5, + seed = NULL, + workers = 1L, + verbose = FALSE, ... ) } \arguments{ -\item{obj}{data.frame with crude weekly cases (not adjusted). This data.frame -comes from the getCases function (if withdivision = FALSE), of getCases followed -by casesinlocality (if dataframe is available per bairro)} - -\item{datas}{data.frame with notification data. Requires: municipio_geocodigo, -dt_sin_pro, dt_digita, dt_notific.} - -\item{method}{"bayesian" or "none". The later just repeats case values} - -\item{pdig}{for the "fixedprob" method. It is a vector of probability of been -typed in the database up to 1, 2, 3, n, weeks after symptoms onset. DEPRECATED.} - -\item{Dmax}{for the "bayesian" method. Maximum number of weeks that is modeled} - -\item{nyears}{for the "bayesian" method. Number of years of data used for fitting the model} - -\item{nowSE}{for the "bayesian" method. Epidemiological week to be considered -for the nowcast. If NA, the maximum SE in obj is used.} - -\item{safelimit}{if median estimate is larger than 'safelimit' times -'sum(tail(cases, n=5))', nowcasting fails.} -} -\value{ -data.frame with median and 95percent -confidence interval for the predicted cases-to-be-notified +\item{obj, datas, method, pdig, Dmax, nyears, datasource, nowSE, safelimit, seed, workers, verbose, ...}{Legacy arguments.} } \description{ -This function estimate the time series of reported cases by adding -the cases that will be reported in the future. -} -\examples{ -muns <- getCidades(uf = "Acre", regional = "Baixo Acre e Purus") -t1 <- Sys.time() -d <- getCases(cities = muns$municipio_geocodigo, dataini = "sinpri") -d <- getCases(cities = 3302700, dataini = "sinpri") -dd <- d[d$cidade == 1200401,] -t1 <- Sys.time() -resfit0<-adjustIncidence(obj=dd, method = "bayesian", nowSE = 202414, -interation = TRUE, datasource = con) -t2 <- Sys.time() -message(paste("total time was", t2-t1)) -# Using argument 'datas' is good to save time with dataset access -t1 <- Sys.time() -load("caselist.RData") # output of getCases -resfit<-adjustIncidence(obj=dd, datas = caselist, method = "bayesian", -nowSE = 202414,datasource = con) -t2 <- Sys.time() +Legacy nowcasting interface } diff --git a/man/alerttools_pipeline.Rd b/man/alerttools_pipeline.Rd new file mode 100644 index 0000000..237545d --- /dev/null +++ b/man/alerttools_pipeline.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/core_pipeline.R +\name{alerttools_pipeline} +\alias{alerttools_pipeline} +\title{Run the pure in-memory AlertTools pipeline} +\usage{ +alerttools_pipeline( + cases, + climate, + parameters, + case_records = NULL, + report_week = max(cases$SE), + nowcasting = c("none", "bayesian"), + workers = 1L, + seed = NULL, + verbose = FALSE +) +} +\arguments{ +\item{cases}{Weekly case data using the `getCases()` domain schema.} + +\item{climate}{Weekly municipal climate data with `SE` and `geocodigo`.} + +\item{parameters}{Alert parameters, one row per municipality and disease.} + +\item{case_records}{Optional individual notification records for Bayesian +nowcasting.} + +\item{report_week}{Epidemiological week through which to compute results.} + +\item{nowcasting}{Either `"none"` or `"bayesian"`.} + +\item{workers}{Positive number of workers. The default is portable and serial.} + +\item{seed}{Optional deterministic seed for stochastic nowcasting.} + +\item{verbose}{Whether orchestration should emit progress messages.} +} +\value{ +An `alerttools_result` object. +} +\description{ +This function performs no database or file access and does not depend on the +current working directory. +} diff --git a/man/applyGenTimeDist.Rd b/man/applyGenTimeDist.Rd index 5767024..298e983 100644 --- a/man/applyGenTimeDist.Rd +++ b/man/applyGenTimeDist.Rd @@ -4,7 +4,7 @@ \alias{applyGenTimeDist} \title{Calculate matrix of generation time distribution for cities in infodengue} \usage{ -applyGenTimeDist(cities, stations, cid10 = "A90", datasource = con, ...) +applyGenTimeDist(cities, stations, cid10 = "A90", datasource, ...) } \arguments{ \item{cities}{: vector of geocodes} @@ -15,9 +15,7 @@ applyGenTimeDist(cities, stations, cid10 = "A90", datasource = con, ...) \item{datasource}{: sql connection} -\item{ini}{: initial date (Date or epidemiological week)} - -\item{end}{: final date (Date or epidemiological week)} +\item{...}{Additional arguments passed to downstream helpers.} } \value{ list of generation time distributions matrices @@ -26,7 +24,9 @@ list of generation time distributions matrices Calculate the generation time for cities or from meteorological stations } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} cid <- getCidades(uf="Rio de Janeiro")$municipio_geocodigo gt <- applyGenTimeDist(stations = c("SBGL","SBJR"), cid10 = "A90") system.time(gt <- applyGenTimeDist(cities = cid, cid10 = "A90")) +\dontshow{\}) # examplesIf} } diff --git a/man/applymem.Rd b/man/applymem.Rd index 9403ecb..28b6c03 100644 --- a/man/applymem.Rd +++ b/man/applymem.Rd @@ -11,53 +11,23 @@ applymem(df.data, l.seasons, typicalcurve = FALSE, ...) and incidence seasons in each column each row gives the incidence in each season, for each municipio_geocodigo, for each week.} -\item{l.seasons}{vector with incidence columns to be used. Additional arguments +\item{l.seasons}{vector with incidence columns to be used. Additional arguments accepted by memmodel function} -\item{i.n.max}{Number of pre-epidemic values used to calculate the threshold.} +\item{typicalcurve}{Whether to retain the typical epidemic curve.} -\item{i.type.curve}{Type of confidence interval to calculate the modelled curve.} - -\item{i.level.threshold}{Level of confidence interval to calculate the threshold.} - -\item{i.level.curve}{Level of confidence interval to calculate the modelled curve.} - -\item{i.data}{Data frame of input data.} - -\item{i.seasons}{Maximum number of seasons to use.} - -\item{i.type.threshold}{Type of confidence interval to calculate the threshold.} - -\item{i.tails.threshold}{Tails for the confidence interval to calculate the threshold.} - -\item{i.type.intensity}{Type of confidence interval to calculate the intensity thresholds.} - -\item{i.level.intensity}{Levels of confidence interval to calculate the intensity thresholds.} - -\item{i.tails.intensity}{Tails for the confidence interval to calculate the threshold.} - -\item{i.type.other}{Type of confidence interval to calculate length, start and percentages.} - -\item{i.level.other}{Level of confidence interval to calculate length, start and percentages.} - -\item{i.method}{Method to calculate the optimal timing of the epidemic.} - -\item{i.param}{Parameter to calculate the optimal timing of the epidemic.} - -\item{i.type.boot}{Type of bootstrap technique.} - -\item{i.iter.boot}{Number of bootstrap iterations.} +\item{...}{Additional arguments passed to `mem::memmodel()`.} } \value{ epithresholds: list with full epimem report for each municipio_geocodigo, keyed by AP's name. dfthresholds: data frame with thresholds for each AP. } \description{ -Function to apply epimem algorithm on df.data and generate full +Function to apply epimem algorithm on df.data and generate full reports as well as a data frame with summary of relevant thresholds (pre, pos, mid, high, veryhigh) } \details{ -internal function, used by info.dengue.apply.mem. Defatul arguments +internal function, used by info.dengue.apply.mem. Defatul arguments passed to memmodel function: } \author{ diff --git a/man/as_alert_history.Rd b/man/as_alert_history.Rd new file mode 100644 index 0000000..bed6c07 --- /dev/null +++ b/man/as_alert_history.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{as_alert_history} +\alias{as_alert_history} +\title{Convert an alert result to the persistence schema} +\usage{ +as_alert_history(result, version_date, start_week = NULL, end_week = NULL) +} +\arguments{ +\item{result}{An `alerttools_result` object.} + +\item{version_date}{Explicit model-version date.} + +\item{start_week, end_week}{Optional inclusive week filter.} +} +\value{ +A data frame keyed by `SE`, `municipio_geocodigo`, and `Localidade_id`. +} +\description{ +Convert an alert result to the persistence schema +} diff --git a/man/as_epiweek.Rd b/man/as_epiweek.Rd new file mode 100644 index 0000000..6f2cf37 --- /dev/null +++ b/man/as_epiweek.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/epiweek.R +\name{as_epiweek} +\alias{as_epiweek} +\title{Convert dates to epidemiological weeks} +\usage{ +as_epiweek(x, format = "\%Y-\%m-\%d") +} +\arguments{ +\item{x}{A vector coercible to `Date`.} + +\item{format}{Format used for character input.} +} +\value{ +An integer vector in `YYYYWW` format. +} +\description{ +Uses the Brazilian Sunday-to-Saturday convention in which epidemiological +week 1 is the week containing 4 January. +} +\examples{ +as_epiweek(as.Date(c("2020-12-27", "2021-01-03"))) +} diff --git a/man/bayesnowcasting.Rd b/man/bayesnowcasting.Rd index 34a95ea..27d6f12 100644 --- a/man/bayesnowcasting.Rd +++ b/man/bayesnowcasting.Rd @@ -4,9 +4,21 @@ \alias{bayesnowcasting} \title{Correct incidence data with notification delay (nowcasting).} \usage{ -bayesnowcasting(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, tweet = F) +bayesnowcasting( + d, + Dmax = 10, + nowSE, + nweeks = 50, + interacao = FALSE, + tweet = FALSE, + seed = NULL, + workers = 1L, + verbose = FALSE +) } \arguments{ +\item{d}{data.frame with individual cases, containing columns municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita} + \item{Dmax}{for the "bayesian" method. Maximum number of weeks that is nowcasted} \item{nowSE}{week of the nowcasting (ex. 202110).} @@ -17,17 +29,23 @@ bayesnowcasting(d, Dmax = 10, nowSE, nweeks = 50, interacao = FALSE, tweet = F) \item{tweet}{FALSE (default). TRUE to include tweet in the model} -\item{obj}{data.frame with individual cases, containing columns municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita} +\item{seed}{Optional seed for posterior and predictive sampling.} + +\item{workers}{Positive number of workers used by INLA.} + +\item{verbose}{Whether to emit progress messages.} } \value{ -data.frame with median and 95percent confidence interval for the +data.frame with median and 95percent confidence interval for the predicted cases-to-be-notified) } \description{ This function estimate the Bayesian nowcast (new version) } \examples{ -dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", -lastday = as.Date("2024-03-23"), datasource=con) # Not run without connection +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", +lastday = as.Date("2024-03-23"), datasource=connection) # Not run without connection resfitcIsT<-bayesnowcasting(dados, nowSE = 202412) +\dontshow{\}) # examplesIf} } diff --git a/man/bestWU.Rd b/man/bestWU.Rd index 4c147c3..35d47c6 100644 --- a/man/bestWU.Rd +++ b/man/bestWU.Rd @@ -20,9 +20,11 @@ Receives a set of meteorological data and return the most complete for a given city.If both are good, the first is returned. } \examples{ -NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") -series1 = getWU(stations = 'SBCP',vars="temp_min", datasource= con) -series2 = getWU(stations = 'SBME',vars="temp_min", datasource= con) +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +series1 = getWU(stations = 'SBCP',vars="temp_min", datasource= connection) +series2 = getWU(stations = 'SBME',vars="temp_min", datasource= connection) res = bestWU(list(series1, series2),var="temp_min") tail(res) +\dontshow{\}) # examplesIf} } diff --git a/man/calc.alerta.Rd b/man/calc.alerta.Rd new file mode 100644 index 0000000..c85a6f6 --- /dev/null +++ b/man/calc.alerta.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/alert_functions.R +\name{calc.alerta} +\alias{calc.alerta} +\title{Calculates the attention levels for one area.} +\usage{ +calc.alerta(x, pars, level = "municipio", ...) +} +\arguments{ +\item{x}{filter variable indicating geocode at municipal, state or other level.} + +\item{pars}{List containing input data, report week, nowcasting mode, parameters, and case records.} + +\item{level}{default is municipio. Other options are: regional, macrorregiao +and uf (not implemented yet)} + +\item{...}{Reserved for compatibility.} +} +\value{ +data.frame with the data with alert level. +} +\description{ +Function to compute the alert levels for one spatial unit, defined by level. +Internal function used by the dengue_pipeline. +} diff --git a/man/calculate_incidence.Rd b/man/calculate_incidence.Rd new file mode 100644 index 0000000..6274334 --- /dev/null +++ b/man/calculate_incidence.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/core_pipeline.R +\name{calculate_incidence} +\alias{calculate_incidence} +\title{Calculate incidence from in-memory vectors} +\usage{ +calculate_incidence(count, population, scale = 1e+05) +} +\arguments{ +\item{count}{Numeric vector of case counts.} + +\item{population}{Numeric vector of positive population values.} + +\item{scale}{Incidence scale, conventionally 100,000 inhabitants.} +} +\value{ +A numeric incidence vector. +} +\description{ +Calculate incidence from in-memory vectors +} diff --git a/man/classify_alerts.Rd b/man/classify_alerts.Rd new file mode 100644 index 0000000..510498a --- /dev/null +++ b/man/classify_alerts.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{classify_alerts} +\alias{classify_alerts} +\title{Classify epidemiological alerts} +\usage{ +classify_alerts(data, rules, missing = FALSE, minimum_history = 8) +} +\arguments{ +\item{data}{In-memory epidemiological indicator data.} + +\item{rules}{Rules returned by `define_alert_rules()`.} + +\item{missing}{Whether missing climate values activate the legacy missing-data rule.} + +\item{minimum_history}{Minimum history used by the classifier.} +} +\value{ +An object of class `alerta`. +} +\description{ +Classify epidemiological alerts +} diff --git a/man/data2SE.Rd b/man/data2SE.Rd index 972c35d..52943b9 100644 --- a/man/data2SE.Rd +++ b/man/data2SE.Rd @@ -15,11 +15,13 @@ data2SE(days, format = "\%d/\%m/\%Y") numeric vector with the epidemiological weeks. } \description{ -Find to which epidemiological week belongs a given day. Uses episem function +Find to which epidemiological week belongs a given day. Uses episem function (formula generated data). } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} data2SE("01-02-2020",format="\%d-\%m-\%Y") data2SE("12-02-2008",format="\%d-\%m-\%Y") data2SE(c("03-04-2013","07-01-2019"),format="\%d-\%m-\%Y") +\dontshow{\}) # examplesIf} } diff --git a/man/daySEday.Rd b/man/daySEday.Rd index 3c7bf91..53ff3f3 100644 --- a/man/daySEday.Rd +++ b/man/daySEday.Rd @@ -8,6 +8,8 @@ daySEday(x, format = "\%Y-\%m-\%d") } \arguments{ \item{x}{numeric vector with epidemiological weeks , format 201945, or date} + +\item{format}{date format used for character input.} } \value{ data.frame with SE and first day. @@ -16,7 +18,9 @@ data.frame with SE and first day. Return the first day of the Epidemiological Week and vice-versa } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} daySEday(x=202612) -daySEday(x = c(202041:202104)) +daySEday(x = c(202541:202604)) daySEday(x = c("2015-12-23", "2015-10-23", "2026-10-16")) +\dontshow{\}) # examplesIf} } diff --git a/man/define_alert_rules.Rd b/man/define_alert_rules.Rd new file mode 100644 index 0000000..4746525 --- /dev/null +++ b/man/define_alert_rules.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{define_alert_rules} +\alias{define_alert_rules} +\title{Define alert rules} +\usage{ +define_alert_rules(rule, values, delays = 3) +} +\arguments{ +\item{rule}{Rule identifier.} + +\item{values}{Named parameter vector.} + +\item{delays}{Number of weeks used by delayed criteria.} +} +\value{ +A validated list of alert criteria. +} +\description{ +Define alert rules +} diff --git a/man/epiYear.Rd b/man/epiYear.Rd index 0055303..3504b07 100644 --- a/man/epiYear.Rd +++ b/man/epiYear.Rd @@ -18,6 +18,8 @@ vector of epidemiological years. Find to which epidemiological year belongs a given epidemiological week. } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} epiYear(se = 201012) epiYear(se = 201012:201522) +\dontshow{\}) # examplesIf} } diff --git a/man/episem.Rd b/man/episem.Rd index 839c7e7..ad7572e 100644 --- a/man/episem.Rd +++ b/man/episem.Rd @@ -7,25 +7,29 @@ episem(x, format = "\%Y-\%m-\%d", separa = "", retorna = "YW") } \arguments{ +\item{x}{date to be converted (class Date)} + +\item{format}{date format used when `x` is not already a `Date`.} + \item{separa}{symbol between year and week} \item{retorna}{What should be return, if epidemiological year and week ('YW'), epi. year only ('Y') or epi. week only ('W'). Default: 'YW'.} - -\item{date}{date to be converted (class Date)} } \value{ -epidemiological week or year. If separa = '', the output is numeric; +epidemiological week or year. If separa = '', the output is numeric; otherwise is a character. } \description{ Find to which epidemiological week belongs a given day } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} episem(x= as.Date("2018-12-31", format="\%Y-\%m-\%d")) episem(x= as.Date("2015-01-01", format="\%Y-\%m-\%d"), separa='-') episem(x= as.Date("2015-01-01", format="\%Y-\%m-\%d"), retorna='Y') +\dontshow{\}) # examplesIf} } \author{ Oswaldo Cruz diff --git a/man/epiweek_seq.Rd b/man/epiweek_seq.Rd new file mode 100644 index 0000000..5e08927 --- /dev/null +++ b/man/epiweek_seq.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/epiweek.R +\name{epiweek_seq} +\alias{epiweek_seq} +\title{Create an inclusive epidemiological-week sequence} +\usage{ +epiweek_seq(from, to) +} +\arguments{ +\item{from}{First epidemiological week in `YYYYWW` format.} + +\item{to}{Last epidemiological week in `YYYYWW` format.} +} +\value{ +An integer vector of epidemiological weeks. +} +\description{ +Create an inclusive epidemiological-week sequence +} +\examples{ +epiweek_seq(202052, 202101) +} diff --git a/man/epiweek_start.Rd b/man/epiweek_start.Rd new file mode 100644 index 0000000..431d517 --- /dev/null +++ b/man/epiweek_start.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/epiweek.R +\name{epiweek_start} +\alias{epiweek_start} +\title{Return the start date of epidemiological weeks} +\usage{ +epiweek_start(x) +} +\arguments{ +\item{x}{Epidemiological weeks in `YYYYWW` format.} +} +\value{ +A `Date` vector containing Sundays. +} +\description{ +Return the start date of epidemiological weeks +} +\examples{ +epiweek_start(c(202052, 202101)) +} diff --git a/man/estimate_rt.Rd b/man/estimate_rt.Rd new file mode 100644 index 0000000..3bcf526 --- /dev/null +++ b/man/estimate_rt.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{estimate_rt} +\alias{estimate_rt} +\title{Estimate the effective reproductive number} +\usage{ +estimate_rt( + data, + count = "casos", + distribution = "normal", + mean_generation_time = 3, + sd_generation_time = 1, + ... +) +} +\arguments{ +\item{data}{In-memory weekly data.} + +\item{count}{Name of the count column.} + +\item{distribution}{Generation-time distribution.} + +\item{mean_generation_time, sd_generation_time}{Generation-time parameters.} + +\item{...}{Additional arguments passed to `Rt()`.} +} +\value{ +`data` with `Rt`, interval, and probability columns. +} +\description{ +Estimate the effective reproductive number +} diff --git a/man/fetch_alert_inputs.Rd b/man/fetch_alert_inputs.Rd new file mode 100644 index 0000000..42664f2 --- /dev/null +++ b/man/fetch_alert_inputs.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{fetch_alert_inputs} +\alias{fetch_alert_inputs} +\title{Fetch all inputs required by the alert pipeline} +\usage{ +fetch_alert_inputs( + conn, + geocodes, + disease = "dengue", + start_week = NULL, + report_week = NULL, + start_date = NULL, + end_date = NULL, + case_date = c("notification", "symptom_onset"), + complete_tail = NA, + climate_vars = c("temp_min", "temp_max", "temp_med", "umid_min", "umid_med", + "umid_max"), + verbose = FALSE +) +} +\arguments{ +\item{conn}{A valid DBI connection.} + +\item{geocodes}{Numeric seven-digit municipality codes.} + +\item{disease}{Disease name (`"dengue"`, `"chikungunya"`, or `"zika"`) or +equivalent CID-10 code.} + +\item{start_week}{First epidemiological week.} + +\item{report_week}{Last epidemiological week included in the report.} + +\item{start_date, end_date}{Explicit inclusive date interval.} + +\item{case_date}{Date used for aggregation.} + +\item{complete_tail}{Value used for weeks beyond the latest report.} + +\item{climate_vars}{Climate columns to fetch.} + +\item{verbose}{Whether to emit progress messages.} +} +\value{ +An experimental `alerttools_inputs` object. +} +\description{ +Exactly one representation of each boundary is sufficient: use weeks, dates, +or both when they refer to the same epidemiological weeks. +} +\section{Lifecycle}{ + +This database orchestration interface is experimental. +} diff --git a/man/fetch_alert_parameters.Rd b/man/fetch_alert_parameters.Rd new file mode 100644 index 0000000..35a36aa --- /dev/null +++ b/man/fetch_alert_parameters.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{fetch_alert_parameters} +\alias{fetch_alert_parameters} +\title{Fetch alert parameters} +\usage{ +fetch_alert_parameters(conn, geocodes, disease = "dengue") +} +\arguments{ +\item{conn}{A valid DBI connection.} + +\item{geocodes}{Numeric seven-digit municipality codes.} + +\item{disease}{Disease name (`"dengue"`, `"chikungunya"`, or `"zika"`) or +equivalent CID-10 code.} +} +\value{ +A data frame with one row per `municipio_geocodigo` and `cid10`, in + requested geocode order. Pipeline columns include `limiar_preseason`, + `limiar_epidemico`, `varcli`, `clicrit`, and `codmodelo`. +} +\description{ +Fetch alert parameters +} diff --git a/man/fetch_case_records.Rd b/man/fetch_case_records.Rd new file mode 100644 index 0000000..b94a1f3 --- /dev/null +++ b/man/fetch_case_records.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{fetch_case_records} +\alias{fetch_case_records} +\title{Fetch individual case records} +\usage{ +fetch_case_records(conn, geocodes, disease = "dengue", start_date, end_date) +} +\arguments{ +\item{conn}{A valid DBI connection.} + +\item{geocodes}{Numeric seven-digit municipality codes.} + +\item{disease}{Disease name (`"dengue"`, `"chikungunya"`, or `"zika"`) or +equivalent CID-10 code.} + +\item{start_date, end_date}{Explicit inclusive date interval.} +} +\value{ +A data frame with individual notification records. It includes + `municipio_geocodigo`, `dt_notific`, `dt_sin_pri`, and `dt_digita`; date + columns use class `Date`. +} +\description{ +Fetch individual case records +} diff --git a/man/fetch_cases.Rd b/man/fetch_cases.Rd new file mode 100644 index 0000000..c0bef4a --- /dev/null +++ b/man/fetch_cases.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{fetch_cases} +\alias{fetch_cases} +\title{Fetch weekly cases} +\usage{ +fetch_cases( + conn, + geocodes, + disease = "dengue", + start_date, + end_date, + case_date = c("notification", "symptom_onset"), + complete_tail = NA, + verbose = FALSE +) +} +\arguments{ +\item{conn}{A valid DBI connection.} + +\item{geocodes}{Numeric seven-digit municipality codes.} + +\item{disease}{Disease name (`"dengue"`, `"chikungunya"`, or `"zika"`) or +equivalent CID-10 code.} + +\item{start_date, end_date}{Explicit inclusive date interval.} + +\item{case_date}{Date used for aggregation.} + +\item{complete_tail}{Value used for weeks beyond the latest report.} + +\item{verbose}{Whether to emit progress messages.} +} +\value{ +A data frame ordered by `cidade` and `SE`, with one row per + `cidade`, `CID10`, and `SE`. Columns are `SE`, `cidade`, `CID10`, `casos`, + `cas_prov`, `cas_lab`, `localidade`, `nome`, and `pop`. +} +\description{ +Fetch weekly cases +} diff --git a/man/fetch_climate.Rd b/man/fetch_climate.Rd new file mode 100644 index 0000000..b30f9d6 --- /dev/null +++ b/man/fetch_climate.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{fetch_climate} +\alias{fetch_climate} +\title{Fetch weekly municipal climate data} +\usage{ +fetch_climate( + conn, + geocodes, + start_date, + end_date, + climate_vars = c("temp_min", "temp_max", "temp_med", "umid_min", "umid_med", + "umid_max") +) +} +\arguments{ +\item{conn}{A valid DBI connection.} + +\item{geocodes}{Numeric seven-digit municipality codes.} + +\item{start_date, end_date}{Explicit inclusive date interval.} + +\item{climate_vars}{Climate columns to fetch.} +} +\value{ +A data frame ordered and uniquely keyed by `geocodigo` and `SE`, + followed by the requested climate columns. +} +\description{ +Fetch weekly municipal climate data +} diff --git a/man/fouralert.Rd b/man/fouralert.Rd index 656ef63..2bad1cb 100644 --- a/man/fouralert.Rd +++ b/man/fouralert.Rd @@ -1,44 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/alert_functions.R +% Please edit documentation in R/api.R \name{fouralert} \alias{fouralert} -\title{Define conditions to issue a four level alert Green-Yellow-Orange-Red.} +\title{Legacy alert classifier} \usage{ fouralert(obj, crit, miss = "last", dy = 4) } \arguments{ -\item{obj}{dataset with data to feed the alert, containing the variables specified in crit.} - -\item{crit}{criteria for the alert colors. See setCriteria()} - -\item{miss}{how missing data is treated. "last" if last value is repeated. -It is currently the only option} - -\item{dy}{if inc > 0, and rt was orange or red at least once in the past -dy weeks -> level yellow. Default: dy=4} -} -\value{ -returns an object of class "alerta" containing four elements: the data, -the alert indices, and the rules used to define the indices. +\item{obj, crit, miss, dy}{Legacy arguments.} } \description{ -Yellow is raised when environmental conditions required for -positive mosquito population growth are detected, green otherwise.Orange -indicates evidence of sustained transmission, red indicates evidence of -an epidemic scenario. -} -\examples{ -# Parameters of the alert model -val = c(varcli ="temp_min", "clicrit"="22","limiar_preseason"="10","limiar_epidemico"="100") -criteria = setCriteria(rule="Af",values=val) -# Get, organize data -cas = getCases(cities = 3200300, cid10 = "A90") \%>\% - Rt(count = "casos",gtdist="normal", meangt=3, sdgt = 1) \%>\% - mutate(inc = casos/pop*100000) -cli = getWU(stations = 'SBGL', vars="temp_min") \%>\% - mutate(temp_min = nafill(temp_min, rule = "arima")) -tw = getTweet(cities = 3200300) -# Calculate alert -ale <- plyr::join_all(list(cas,cli,tw), by="SE") -resf <- fouralert(ale, crit = criteria) +Legacy alert classifier } diff --git a/man/getCases.Rd b/man/getCases.Rd index f523f7b..7fd5ef6 100644 --- a/man/getCases.Rd +++ b/man/getCases.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_timeseries.R +% Please edit documentation in R/api.R \name{getCases} \alias{getCases} -\title{Get Case Data and aggregate per week and area} +\title{Legacy case reader} \usage{ getCases( cities, @@ -12,45 +12,15 @@ getCases( dataini = "notific", completetail = NA, type = "notified", - datasource = con + datasource, + verbose = FALSE ) } \arguments{ -\item{cities}{cities' geocode.} +\item{cities, lastday, firstday, cid10, dataini, completetail, type, datasource}{Legacy arguments.} -\item{lastday}{last day. Default is the last available. Format: "yyyy-mm-dd"} - -\item{firstday}{is the first date of the time series to be produced. Format: "yyyy-mm-dd"} - -\item{cid10}{cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8",} - -\item{dataini}{"notific" if data aggregated by notification date or "sinpri" if data aggregated -if aggregated by date of first symptoms} - -\item{completetail}{if sinan data is older than final_day, fill in the tail with NA (default) or 0.} - -\item{type}{case definition. Default = "notified". Other options: "probable", -"lab_confirmed", "all". All means returning the three counts.} - -\item{datasource}{PostgreSQLConnection to project database.} - -\item{returndata}{TRUE if returns individual data as well.} -} -\value{ -data.frame with the data aggregated per week according to disease onset date. -Notice that the names of the columns and the number of columns will change according to type. -To recover the original function behavior, use the default type. +\item{verbose}{Whether to emit progress messages.} } \description{ -Create weekly time series from case data from server. The source is the SINAN. -} -\examples{ -NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") -d <- getCases(cities = 3106200, dataini = "sinpri", type = "all") # dengue -d <- getCases(cities = 3300936, completetail = 0) # dengue -d <- getCases(cities = 3304557, cid10="A92.0") # chikungunya, until last day available -cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") -d <- getCases(cities = cid$municipio_geocodigo[1:2], -firstday = as.Date("2023-01-01"), dataini = "sinpri") -tail(d) +Legacy case reader } diff --git a/man/getCaseslist.Rd b/man/getCaseslist.Rd index bffed61..0eef6ee 100644 --- a/man/getCaseslist.Rd +++ b/man/getCaseslist.Rd @@ -1,47 +1,20 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_timeseries.R +% Please edit documentation in R/api.R \name{getCaseslist} \alias{getCaseslist} -\title{Get Case Data} +\title{Legacy individual-case reader} \usage{ getCaseslist( cities, lastday = Sys.Date(), firstday = as.Date("2022-01-01"), cid10 = "A90", - datasource = con + datasource ) } \arguments{ -\item{cities}{cities' geocode.} - -\item{lastday}{last day. Default is the last available. Format: "yyyy-mm-dd"} - -\item{firstday}{is the first date of the time series to be produced. Format: "yyyy-mm-dd"} - -\item{cid10}{cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8",} - -\item{datasource}{PostgreSQLConnection to project database.} - -\item{dataini}{"notific" if data aggregated by notification date or "sinpri" if data aggregated -if aggregated by date of first symptoms} - -\item{type}{case definition. Default = "notified". Other options: "probable", -"lab_confirmed", "all". All means returning the three counts.} -} -\value{ -data.frame with the data aggregated per week according to disease onset date. -Notice that the names of the columns and the number of columns will change according to type. -To recover the original function behavior, use the default type. +\item{cities, lastday, firstday, cid10, datasource}{Legacy arguments.} } \description{ -Get case data from server. -} -\examples{ -NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") -d <- getCaseslist(cities = c(4209102, 3304557),firstday = as.Date("2024-01-01")) # dengue -d <- getCaseslist(cities = 3304557, cid10="A92.0") # chikungunya, until last day available -cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") -d <- getCaseslist(cities = 3304557, firstday = as.Date("2023-01-01"),dataini) -tail(d) +Legacy individual-case reader } diff --git a/man/getCidades.Rd b/man/getCidades.Rd index ee0fea3..4c9e5a4 100644 --- a/man/getCidades.Rd +++ b/man/getCidades.Rd @@ -4,7 +4,7 @@ \alias{getCidades} \title{get list of cities.} \usage{ -getCidades(regional, macroregional, uf, datasource = con) +getCidades(regional, macroregional, uf, datasource) } \arguments{ \item{regional}{full name of the regional. Use getRegionais() to obtain the correct spelling.} @@ -22,7 +22,9 @@ vector with names of the cities. consult database to get list of cities for regional, macroregional or uf. } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} getCidades(regional = "Metropolitana I", uf="Rio de Janeiro") getCidades(uf="Acre") -getCidades(uf="Maranhão", macroregional = "NORTE") +getCidades(uf="Maranhao", macroregional = "NORTE") +\dontshow{\}) # examplesIf} } diff --git a/man/getClima.Rd b/man/getClima.Rd index e23c88d..caff671 100644 --- a/man/getClima.Rd +++ b/man/getClima.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_timeseries.R +% Please edit documentation in R/api.R \name{getClima} \alias{getClima} -\title{Get Climate Data} +\title{Legacy climate reader} \usage{ getClima( cities, @@ -11,32 +11,12 @@ getClima( finalday = Sys.Date(), iniSE = 201501, lastSE, - datasource = con + datasource ) } \arguments{ -\item{cities}{list of geocodes.} - -\item{vars}{vector with meteorological variables. Minimum set of vars -"temp_min", "temp_max". Default: all of them} - -\item{finalday}{alternative to lastSE. Default is the last day available. Format = Y-m-d.} - -\item{iniSE}{first epiweek. Default is 012015} - -\item{lastSE}{last epiweek. Optional. Default is the last available} - -\item{datasource}{a valid database connection} -} -\value{ -data.frame with the weekly data (cidade data temp_min tmed tmax umin umed umax pressaomin pressaomed pressaomax) +\item{cities, vars, finalday, iniSE, lastSE, datasource}{Legacy arguments.} } \description{ -Create weekly climate time series from satellite data in server -taking the mean of the daily values. Data source: ERA5. -} -\examples{ -res = getClima(cities = c(3304557), vars=c("temp_min","temp_max") , iniSE = 202201) -res = getClima(cities = c(3304557, 3200300), iniSE = 202403) -tail(res) +Legacy climate reader } diff --git a/man/getPop.Rd b/man/getPop.Rd index ad6086f..49ca272 100644 --- a/man/getPop.Rd +++ b/man/getPop.Rd @@ -11,17 +11,19 @@ getPop(cities, iniY = 2010, endY) \item{iniY}{first year. Default is 2010} -\item{lastY}{last year. Default is the last available} +\item{endY}{last year. Default is the last available} } \value{ tibble with columns geocode, year, pop } \description{ -Get population time series, using the brpop package. +Get population time series, using the brpop package. Currently has estimates from 2000 to 2021 } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} cities <- getCidades(uf = "Paraná")$municipio_geocodigo pop <- getPop(cities, iniY = 2018, endY = 2019) tail(pop) +\dontshow{\}) # examplesIf} } diff --git a/man/getRegionais.Rd b/man/getRegionais.Rd index 380d4e5..6e16e12 100644 --- a/man/getRegionais.Rd +++ b/man/getRegionais.Rd @@ -9,7 +9,7 @@ getRegionais( uf, sortedby = "a", macroreg = FALSE, - datasource = con, + datasource, output = "names" ) } @@ -18,14 +18,14 @@ getRegionais( \item{uf}{full name of the state.} -\item{sortedby}{the options are: 'a' alphabetically, 'id' regional id number (only valid for regional), +\item{sortedby}{the options are: 'a' alphabetically, 'id' regional id number (only valid for regional), if available} \item{macroreg}{TRUE if getRegionais should return macroreg instead of reg. Default: False} \item{datasource}{name of the database} -\item{output}{if "names" returns only a vector with names of regionais or macros. +\item{output}{if "names" returns only a vector with names of regionais or macros. If "complete" , returns municipalities and their regs} } \value{ @@ -35,10 +35,12 @@ vector with names of the regionais. consult database to get list of regionais } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} getRegionais(uf="Rio de Janeiro") head(getRegionais(uf="Rio de Janeiro",output="complete",macroreg = TRUE)) head(getRegionais(uf="Rio de Janeiro",output="complete")) getRegionais(cities = c(3304128,3306107,3300159), uf="Rio de Janeiro") getRegionais(cities = c(3304128,3306107,3300159), uf="Rio de Janeiro", macroreg = TRUE) getRegionais(uf="Rio de Janeiro", sortedby = 'id') +\dontshow{\}) # examplesIf} } diff --git a/man/getTweet.Rd b/man/getTweet.Rd index 13622f4..03e977f 100644 --- a/man/getTweet.Rd +++ b/man/getTweet.Rd @@ -4,29 +4,31 @@ \alias{getTweet} \title{Get Tweeter Data} \usage{ -getTweet(cities, lastday = Sys.Date(), cid10 = "A90", datasource = con) +getTweet(cities, lastday = Sys.Date(), cid10 = "A90", datasource) } \arguments{ \item{cities}{cities's geocode. Use getCidades()} +\item{lastday}{last day. Default is the last available.} + \item{cid10}{default is A90 (dengue). If not dengue, returns NA} \item{datasource}{Use the connection to the Postgresql server for using project data.} - -\item{finalday}{last day. Default is the last available.} } \value{ data.frame with weekly counts of people tweeting on dengue. } \description{ -Create weekly time series from tweeter data from server. The +Create weekly time series from tweeter data from server. The source of this data is the Observatorio da Dengue (UFMG). } \examples{ -NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") tw <- getTweet(cities = c(3302205,3200300), lastday = "2014-03-01") tw <- getTweet(cities = 3304557, finalday = "2016-03-01") cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") -tw <- getTweet(cities = cid$municipio_geocodigo) +tw <- getTweet(cities = cid$municipio_geocodigo) tail(tw) +\dontshow{\}) # examplesIf} } diff --git a/man/getWU.Rd b/man/getWU.Rd index 3b55540..38a77c9 100644 --- a/man/getWU.Rd +++ b/man/getWU.Rd @@ -9,17 +9,19 @@ getWU( vars = "temp_min", finalday = Sys.Date(), iniSE = 201001, - datasource = con + datasource ) } \arguments{ \item{stations}{station code (4 digits).} -\item{vars}{vector with meteorological variables. Available variables: "temp_min" (default), +\item{vars}{vector with meteorological variables. Available variables: "temp_min" (default), "temp_max","temp_med","data_dia","umid_min","umid_med","umid_max","pressao_min","pressao_med","pressao_max"} \item{finalday}{last day. Default is the last available. Format = Y-m-d.} +\item{iniSE}{First epidemiological week to return.} + \item{datasource}{Use "data/WUdata.rda" to use test dataset. Use the connection to the Postgresql server if using project data. See also DenguedbConnect to open the database connection.} } @@ -30,8 +32,10 @@ data.frame with the weekly data (cidade estacao data temp_min tmed tmax umin ume Create weekly time series from meteorological station data in server taking the mean of the daily values. } \examples{ -NOT USE: con <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +# NOT USE: connection <- dbConnect(RSQLite::SQLite(), "../../AlertaDengueAnalise/mydengue.sqlite") res = getWU(stations = c('SBRJ','SBGL'), vars="temp_min", iniSE = 201201) res = getWU(stations = 'SBRJ', vars=c("temp_min", "temp_med")) tail(res) +\dontshow{\}) # examplesIf} } diff --git a/man/getWUstation.Rd b/man/getWUstation.Rd index c366aa7..96a1972 100644 --- a/man/getWUstation.Rd +++ b/man/getWUstation.Rd @@ -4,7 +4,7 @@ \alias{getWUstation} \title{get meteorological stations} \usage{ -getWUstation(cities, datasource = con) +getWUstation(cities, datasource) } \arguments{ \item{cities}{vector with geocodes} @@ -18,7 +18,9 @@ data.frame Get the meteorological stations associated with one or more cities } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} getWUstation(cities = 3304557) cidades <- getCidades(regional = "Sete Lagoas", uf = "Minas Gerais") getWUstation(cities = cidades$municipio_geocodigo) +\dontshow{\}) # examplesIf} } diff --git a/man/getdelaydata.Rd b/man/getdelaydata.Rd index df7492d..e51f5e4 100644 --- a/man/getdelaydata.Rd +++ b/man/getdelaydata.Rd @@ -9,7 +9,7 @@ getdelaydata( nyears = 2, cid10 = "A90", lastday = Sys.Date(), - datasource = con + datasource ) } \arguments{ @@ -30,158 +30,9 @@ list with d = data.frame with data. Gets delay data for one or more cities. Internal function used in the delay fitting using inla. } -\details{ -# bayesnowcasting --------------------------------------------------------------------- -#'@description This function estimate the Bayesian nowcast (new version) -#'@title Correct incidence data with notification delay (nowcasting). -#'@export -#'@param obj data.frame with individual cases, containing columns municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita -#'@param Dmax for the "bayesian" method. Maximum number of weeks that is modeled -#'@param Fim date for the nowcasting (date). Default is today. -#'@return data.frame with median and 95percent confidence interval for the -#'predicted cases-to-be-notified) -#'@examples -#' # bayesian -#'dd <- getdelaydata(cities=3167202, nyears=1, cid10="A90", datasource=con) -#'resfit<-bayesnowcasting(dd) -#'resfit - -bayesnowcasting <- function(d, Dmax = 10, Fim = Sys.Date()){ - - # check input - if(is.null(names(d))) { - message("bayesnowcasting: no data, returning NULL") - return(NULL)} - - if(nrow(d) < 50) { - message("bayesnowcasting: few data, returning NULL") - return(NULL)} - - - #d contains columns - assert_that(all(c("municipio_geocodigo", "dt_notific", "dt_sin_pri", "dt_digita") - %in% names(d)), msg = "bayesnowcasting requires data with columns - municipio_geocodigo, dt_notific, dt_sin_pri, dt_digita") - - d <- d %>% mutate( - dt_notific_epiweek = epiweek(dt_notific), - dt_notific_aux = as.numeric(format(as.Date(dt_notific), "%w")), - dt_notific_week = dt_notific + 6 - dt_notific_aux, - dt_notific_epiyear = epiyear(dt_notific), - dt_digita_epiweek = epiweek(dt_digita), - dt_digita_epiyear = epiyear(dt_digita), - delay_epiweek = ifelse( dt_digita_epiyear == dt_notific_epiyear, - as.numeric(dt_digita_epiweek - dt_notific_epiweek), - as.numeric(dt_digita_epiweek - dt_notific_epiweek) + 52 - ) - ) - - # casos observados por semama - obs <- d %>% - group_by(dt_notific_week) %>% - summarize(casos = n()) - - Inicio <- min(d$dt_notific_week) - # Ultimo dia com notificacao ou digitacao - #Fim <- max(d$dt_digita, d$dt_notific, na.rm = T) - #Fim <- max(d$dt_digita, d$dt_notific, na.rm = T) - #Fim <- Fim + 6 - as.numeric(format(as.Date(Fim), "%w")) # why? - - # contruindo a matriz de atraso - running triang - tibble(Date = c(Inicio,Fim) ) %>% - mutate(Weekday = weekdays(Date) ) - - tbl.dates <- tibble(dt_notific_week = seq(Inicio, Fim, by = 7)) %>% - rowid_to_column(var = "Time") - Today = max(tbl.dates$Time) - - dados.ag <- d %>% - filter( dt_digita <= Fim) %>% - mutate( - delay_epiweek = ifelse(delay_epiweek > Dmax, NA, delay_epiweek) - ) %>% - drop_na(delay_epiweek) %>% - group_by(dt_notific_week, delay_epiweek) %>% - dplyr::summarise( - Casos = n() - ) %>% # View() - # Passando para o formato wide - spread(key = delay_epiweek, value = Casos) %>% # View() - # Adicianoando todas as data, algumas semanas nao houveram casos - full_join( - y = tbl.dates, - by = "dt_notific_week" ) %>% # View() - # Voltando para o formato longo - gather(key = "Delay", value = Casos, -dt_notific_week, -Time) %>% # View() - mutate( - Delay = as.numeric(Delay), - # Preparing the run-off triangle - Casos = ifelse( - test = (Time + Delay) <= Today, - yes = replace_na(Casos, 0), - no = NA) - ) %>% #View() - dplyr::rename( Date = dt_notific_week) %>% #ungroup() %>% - # Sorting by date - dplyr::arrange(Date) - - - dados.ag.full <- d %>% - group_by(dt_notific_week) %>% - dplyr::summarise( - Total = n() - ) %>% # View() - # Adicianoando todas as data, algumas semanas nao houveram casos - right_join( - y = tbl.dates, - by = "dt_notific_week" ) %>% # View() - mutate( - Total = replace_na(Total, 0) - ) %>% # View() - dplyr::rename( Date = dt_notific_week) %>% #ungroup() %>% - # Sorting by date - dplyr::arrange(Date) - -# Model equation -model.dengue <- Casos ~ 1 + - f(Time, model = "rw2", constr = T - #hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) - #hyper = list("prec" = list(prior = half_normal_sd(.1) )) - ) + - f(Delay, model = "rw1", constr = T - # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) - #hyper = list("prec" = list(prior = half_normal_sd(.1) )) - ) + - # Efeito tempo-atraso - f(TimeDelay, model = "iid", constr = T - # hyper = list("prec" = list(prior = "loggamma", param = c(0.001, 0.001) )) - ) - - -output.dengue <- nowcast.INLA( - model.day = model.dengue, - dados.ag = dados.ag %>% - mutate(TimeDelay = paste(Time, Delay)) -) - -pred.dengue <- nowcasting(output.dengue, dados.ag, - Dm = Dmax, Fim = max(dados.ag$Date)) - - -pred.dengue.summy <- pred.dengue %>% group_by(Date) %>% - dplyr::summarise( Mean = mean(Casos, na.rm = TRUE), - Median = median(Casos, na.rm = TRUE), - LI = quantile(Casos, probs = 0.025, na.rm = TRUE), - LS = quantile(Casos, probs = 0.975, na.rm = TRUE) - ) %>% - left_join(obs, by = c("Date" = "dt_notific_week")) - -pred.dengue.summy$SE <- daySEday(pred.dengue.summy$Date)$SE - -pred.dengue.summy -} -} \examples{ -dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +dados <- getdelaydata(cities=3304557, nyears=1, cid10="A90", lastday = as.Date("2023-12-31")) # Not run without connection +\dontshow{\}) # examplesIf} } diff --git a/man/infodengue_apply_mem.Rd b/man/infodengue_apply_mem.Rd index 68deea4..5ab35d4 100644 --- a/man/infodengue_apply_mem.Rd +++ b/man/infodengue_apply_mem.Rd @@ -37,6 +37,8 @@ infodengue_apply_mem( 'no' return data.table without writing in database. 'db' writes data.table to InfoDengue's database using \code{write.parameters} from AlerttTools package.} +\item{database}{DBI connection.} + \item{passwd}{database password for writing output to db if write='db'.} \item{i.n.max}{Number of points by seasons to be used for pre-epidemic and epidemic regions to calculate each threshold. @@ -51,13 +53,15 @@ This value is passed to i.level.threshold parameter in \code{memmodel}, from MEM \item{limiar.epidemico}{Level of confidence interval to calculate high activity during epidemic region. Default: 0.95. This value is passed to i.level.intensity parameter in \code{memmodel}, from MEM package.} +\item{i.type.curve, i.type.threshold, i.type.intensity}{MEM configuration values.} + \item{mincases.pre}{minimum number of cases to launch a preseason alert. Default: 5} +\item{mincases.pos}{minimum number of cases to end a seasonal alert. Default: 5} + \item{mincases.epi}{minimum number of cases to launch an epidemic alert. Default: 10} \item{...}{Optional arguments passed to \code{memmodel}, from MEM package.} - -\item{con}{Connection to PostGreSQL database, using \code{dbConnect} from RPostgreSQL package} } \value{ Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, @@ -82,12 +86,14 @@ to either the 90% quantile or 10, whichever is the greatest. The thresholds are as incidence. The alert model uses incidence. } \examples{ -Generate thresholds for municipalities using the whole history. -Return object instead of writing to data base: +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +# Generate thresholds for municipalities using the whole history. +# Return object instead of writing to data base: mun_list <- c(4212650, 4209102,4216503,4214607,4212502,4218905,4212601,4214805, 4212650,4217006,4212700,4214706,4213104,4200804) -mun_list <- getCidades(uf = "Maranhão", datasource=con)$municipio_geocodigo -thresC <- infodengue_apply_mem(mun_list, cid10 = "A92.0", database=con) -A nice way to visualize the calculated thresholds +mun_list <- getCidades(uf = "Maranhão", datasource=connection)$municipio_geocodigo +thresC <- infodengue_apply_mem(mun_list, cid10 = "A92.0", database=connection) +# A nice way to visualize the calculated thresholds plot(thres) +\dontshow{\}) # examplesIf} } diff --git a/man/infodengue_apply_mem_agreg.Rd b/man/infodengue_apply_mem_agreg.Rd index 5f67a4c..4d719e8 100644 --- a/man/infodengue_apply_mem_agreg.Rd +++ b/man/infodengue_apply_mem_agreg.Rd @@ -2,11 +2,10 @@ % Please edit documentation in R/infodengue_apply_mem.R \name{infodengue_apply_mem_agreg} \alias{infodengue_apply_mem_agreg} -\alias{mem_curve} \title{Function \code{infodengue_apply_mem} uses MEM package to generate activity thresholds. Apply MEM algorithm discarding seasons below local pre-epidemic threshold. For each municipality, pre-epidemic (limiar_preseason) threshold has a minimum set at 5 cases. -If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set +If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set to either the 90% quantile or 10, whichever is the greatest. The thresholds are given both in number of cases or as incidence. The alert model uses incidence.} \usage{ @@ -29,23 +28,6 @@ infodengue_apply_mem_agreg( mincases.epi = 10, ... ) - -mem_curve( - mun_list, - start_year = 2010, - end_year = as.integer(format(Sys.Date(), "\%Y")) - 1, - nome = "x", - database, - passwd = NULL, - i.n.max = 0, - cid10 = "A90", - limiar.preseason = 0.95, - limiar.epidemico = 0.95, - i.type.curve = 2, - i.type.threshold = 2, - i.type.intensity = 2, - ... -) } \arguments{ \item{mun_list}{Vector of municipalities geocode. Default: NULL (i.e., all municipalites)} @@ -54,6 +36,10 @@ mem_curve( \item{end_year}{Historical data final year to consider. Default: previous year from Sys.Date()} +\item{nome}{Name assigned to the aggregation.} + +\item{database}{DBI connection.} + \item{passwd}{database password for writing output to db if write='db'.} \item{i.n.max}{Number of points by seasons to be used for pre-epidemic and epidemic regions to calculate each threshold. @@ -68,68 +54,45 @@ This value is passed to i.level.threshold parameter in \code{memmodel}, from MEM \item{limiar.epidemico}{Level of confidence interval to calculate high activity during epidemic region. Default: 0.95. This value is passed to i.level.intensity parameter in \code{memmodel}, from MEM package.} +\item{i.type.curve, i.type.threshold, i.type.intensity}{MEM configuration values.} + \item{mincases.pre}{minimum number of cases to launch a preseason alert. Default: 5} +\item{mincases.pos}{minimum number of cases to end a seasonal alert. Default: 5} + \item{mincases.epi}{minimum number of cases to launch an epidemic alert. Default: 10} \item{...}{Optional arguments passed to \code{memmodel}, from MEM package.} - -\item{write}{Whether results should be saved into project's database. Default: 'no' -'no' return data.table without writing in database. -'db' writes data.table to InfoDengue's database using \code{write.parameters} from AlerttTools package.} - -\item{con}{Connection to PostGreSQL database, using \code{dbConnect} from RPostgreSQL package} } \value{ -Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, -by simple percentile and the choice used in the infodengue model, by municipality: - \describe{ - \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = - pos-season incidence threshold, inc_epidemico = high incidence threshold, inicio and inicio.ic = estimated begining of the season - duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} - \item{percentiles: threshold values calculated as percentiles (incidence)}{quant_pre = preseason incidence threshold, - quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} - \item{min_threshold_inc:}{pre-defined minimum threshold.} - \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, - limiar_epidemico.} - } - -Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, -by simple percentile and the choice used in the infodengue model, by municipality: +Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, +by simple percentile and the choice used in the infodengue model, by municipality: \describe{ - \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = + \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = pos-season incidence threshold, inc_epidemico = high incidence threshold, inicio and inicio.ic = estimated begining of the season - duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} + duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} \item{percentiles: threshold values calculated as percentiles (incidence)}{quant_pre = preseason incidence threshold, - quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} - \item{min_threshold_inc:}{pre-defined minimum threshold.} - \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, - limiar_epidemico.} + quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} + \item{min_threshold_inc:}{pre-defined minimum threshold.} + \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, + limiar_epidemico.} } } \description{ Function \code{infodengue_apply_mem} uses MEM package to generate activity thresholds. Apply MEM algorithm discarding seasons below local pre-epidemic threshold. For each municipality, pre-epidemic (limiar_preseason) threshold has a minimum set at 5 cases. -If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set -to either the 90% quantile or 10, whichever is the greatest. The thresholds are given both in number of cases or -as incidence. The alert model uses incidence. - -Function \code{infodengue_apply_mem} uses MEM package to generate activity thresholds. -Apply MEM algorithm discarding seasons below local pre-epidemic threshold. -For each municipality, pre-epidemic (limiar_preseason) threshold has a minimum set at 5 cases. -If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set +If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set to either the 90% quantile or 10, whichever is the greatest. The thresholds are given both in number of cases or as incidence. The alert model uses incidence. } \examples{ -Generate thresholds for municipalities using the whole history. -Return object instead of writing to data base: +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +# Generate thresholds for municipalities using the whole history. +# Return object instead of writing to data base: mun_list <- c(4212650, 4209102,4216503,4214607,4212502,4218905,4212601,4214805, 4212650,4217006,4212700,4214706,4213104,4200804) -mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=con) +mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=connection) thres <- infodengue_apply_mem_agreg(mun_list$municipio_geocodigo, cid10 = "A92.0") -mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=con) -thres <- mem_curve(mun_list$municipio_geocodigo, cid10 = "A92.0") -thres <- mem_curve(muns) +\dontshow{\}) # examplesIf} } diff --git a/man/lastepiweek.Rd b/man/lastepiweek.Rd index a64b387..0b0c080 100644 --- a/man/lastepiweek.Rd +++ b/man/lastepiweek.Rd @@ -13,7 +13,9 @@ lastepiweek(ano) Calculate number of year's last epidemiological week using Brazilian standard. } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} lastepiweek(2018) +\dontshow{\}) # examplesIf} } \author{ Marcelo F Gomes diff --git a/man/mem_curve.Rd b/man/mem_curve.Rd new file mode 100644 index 0000000..491ed1c --- /dev/null +++ b/man/mem_curve.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/infodengue_apply_mem.R +\name{mem_curve} +\alias{mem_curve} +\title{Function \code{infodengue_apply_mem} uses MEM package to generate activity thresholds. +Apply MEM algorithm discarding seasons below local pre-epidemic threshold. +For each municipality, pre-epidemic (limiar_preseason) threshold has a minimum set at 5 cases. +If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set +to either the 90% quantile or 10, whichever is the greatest. The thresholds are given both in number of cases or +as incidence. The alert model uses incidence.} +\usage{ +mem_curve( + mun_list, + start_year = 2010, + end_year = as.integer(format(Sys.Date(), "\%Y")) - 1, + nome = "x", + database, + passwd = NULL, + i.n.max = 0, + cid10 = "A90", + limiar.preseason = 0.95, + limiar.epidemico = 0.95, + i.type.curve = 2, + i.type.threshold = 2, + i.type.intensity = 2, + ... +) +} +\arguments{ +\item{mun_list}{Vector of municipalities geocode. Default: NULL (i.e., all municipalites)} + +\item{start_year}{Historical data starting year to consider. Default: 0 (i.e., as old as possible)} + +\item{end_year}{Historical data final year to consider. Default: previous year from Sys.Date()} + +\item{nome}{Name assigned to the aggregation.} + +\item{database}{DBI connection.} + +\item{passwd}{database password for writing output to db if write='db'.} + +\item{i.n.max}{Number of points by seasons to be used for pre-epidemic and epidemic regions to calculate each threshold. +If 0 (default), uses all points in those regions. Else, uses n max values in each region per season. +This value is passed to i.n.max parameter in \code{memmodel}, from MEM package.} + +\item{cid10}{cid 10 code. Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8"} + +\item{limiar.preseason}{Level of confidence interval to calculate pre/post-season thresholds. Default: 0.9. +This value is passed to i.level.threshold parameter in \code{memmodel}, from MEM package.} + +\item{limiar.epidemico}{Level of confidence interval to calculate high activity during epidemic region. Default: 0.95. +This value is passed to i.level.intensity parameter in \code{memmodel}, from MEM package.} + +\item{i.type.curve, i.type.threshold, i.type.intensity}{MEM configuration values.} + +\item{...}{Optional arguments passed to \code{memmodel}, from MEM package.} +} +\value{ +Function \code{info.dengue.apply.mem} will return a list with thresholds calculated by mem, +by simple percentile and the choice used in the infodengue model, by municipality: + \describe{ + \item{mem: threshold values calculated by mem}{municipio_geocodigo = geocode, inc_preseason = preseason incidence threshold, inc_posseason = + pos-season incidence threshold, inc_epidemico = high incidence threshold, inicio and inicio.ic = estimated begining of the season + duracao, duracao.ic = season duration. ano_inicio and ano_fim used for calculation.} + \item{percentiles: threshold values calculated as percentiles (incidence)}{quant_pre = preseason incidence threshold, + quant_pos = posseason incidence threshold, quant_epidemico = epidemic incidence threshold.} + \item{min_threshold_inc:}{pre-defined minimum threshold.} + \item{threshold: values used by Infodengue}{MEM's values if cases > min.cases, percentiles otherwise: limiar_preseason, limiar_posseason, + limiar_epidemico.} + } +} +\description{ +Function \code{infodengue_apply_mem} uses MEM package to generate activity thresholds. +Apply MEM algorithm discarding seasons below local pre-epidemic threshold. +For each municipality, pre-epidemic (limiar_preseason) threshold has a minimum set at 5 cases. +If calculated value falls below that, it is set to 5, with high activity (limiar_epidemico) set +to either the 90% quantile or 10, whichever is the greatest. The thresholds are given both in number of cases or +as incidence. The alert model uses incidence. +} +\examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +mun_list <- getCidades(uf = "Rio de Janeiro", regional = "Metropolitana I", datasource=connection) +thres <- mem_curve(mun_list$municipio_geocodigo, cid10 = "A92.0") +thres <- mem_curve(muns) +\dontshow{\}) # examplesIf} +} diff --git a/man/nafill.Rd b/man/nafill.Rd index 0c40998..61490a7 100644 --- a/man/nafill.Rd +++ b/man/nafill.Rd @@ -15,6 +15,8 @@ linear and extrapolates using arima (calling AlertTools::temp.predict)} \item{maxgap}{maximum number of consecutive NAs to fill. Longer gaps will be left unchanged. Only works for rule = "zero" or "linear"} + +\item{verbose}{Whether to emit information about missing values.} } \value{ vector @@ -23,6 +25,7 @@ vector collection of imputation procedures } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} # Interpolation: v <- c(1,2,3,NA,5,6,NA,NA,9,10,NA,NA) nafill(v, rule = "zero") @@ -31,5 +34,6 @@ nafill(v, rule = "linear") cliSBCB <- getWU(station = "SBCB") summary(cliSBCB) cliSBCB <- getWU(station = "SBCB") \%>\% - mutate(nafill("temp_min", rule = "arima")) + mutate(nafill("temp_min", rule = "arima")) +\dontshow{\}) # examplesIf} } diff --git a/man/new_alert_inputs.Rd b/man/new_alert_inputs.Rd new file mode 100644 index 0000000..74f5d3b --- /dev/null +++ b/man/new_alert_inputs.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{new_alert_inputs} +\alias{new_alert_inputs} +\title{Construct validated inputs for the alert pipeline} +\usage{ +new_alert_inputs( + cases, + climate, + population = NULL, + case_records = NULL, + metadata = list() +) +} +\arguments{ +\item{cases}{Weekly case data frame.} + +\item{climate}{Weekly climate data frame.} + +\item{population}{Optional population data with a geocode and population +column. When years are present, the latest value per municipality is used.} + +\item{case_records}{Optional individual notification records used by +Bayesian nowcasting.} + +\item{metadata}{Named list describing input provenance.} +} +\value{ +An experimental `alerttools_inputs` object. +} +\description{ +`cases` has one row per municipality, disease, and epidemiological week and +must contain `SE`, `cidade`, `CID10`, `casos`, `cas_prov`, `cas_lab`, +`localidade`, and `nome`. It must also contain `pop`, unless `population` is +supplied. `climate` has one row per municipality and week, keyed by +`geocodigo` and `SE`. Rows are ordered by municipality and week. +} +\section{Lifecycle}{ + +This interface is experimental while operational consumers migrate from the +legacy API. +} diff --git a/man/new_alerttools_result.Rd b/man/new_alerttools_result.Rd new file mode 100644 index 0000000..de18a77 --- /dev/null +++ b/man/new_alerttools_result.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/core_pipeline.R +\name{new_alerttools_result} +\alias{new_alerttools_result} +\title{Construct an AlertTools pipeline result} +\usage{ +new_alerttools_result( + data, + alerts, + parameters, + metadata = list(), + diagnostics = list() +) +} +\arguments{ +\item{data}{In-memory epidemiological data frame.} + +\item{alerts}{In-memory alert-index data frame.} + +\item{parameters}{Parameter data frame used by the computation.} + +\item{metadata}{Named list describing the run.} + +\item{diagnostics}{Named list of diagnostic information.} +} +\value{ +An object of class `alerttools_result`. +} +\description{ +Construct an AlertTools pipeline result +} diff --git a/man/nowcast_cases.Rd b/man/nowcast_cases.Rd new file mode 100644 index 0000000..a50893d --- /dev/null +++ b/man/nowcast_cases.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{nowcast_cases} +\alias{nowcast_cases} +\title{Nowcast weekly cases} +\usage{ +nowcast_cases( + data, + case_records = NULL, + method = c("none", "bayesian"), + report_week, + workers = 1L, + seed = NULL, + verbose = FALSE, + ... +) +} +\arguments{ +\item{data}{In-memory weekly case data for one municipality.} + +\item{case_records}{Optional individual notification records.} + +\item{method}{Either `"none"` or `"bayesian"`.} + +\item{report_week}{Explicit report week.} + +\item{workers}{Positive worker count.} + +\item{seed}{Optional deterministic seed.} + +\item{verbose}{Whether to emit progress messages.} + +\item{...}{Additional nowcasting arguments.} +} +\value{ +The weekly data with adjusted-count columns. +} +\description{ +Nowcast weekly cases +} diff --git a/man/pipe_infodengue.Rd b/man/pipe_infodengue.Rd index fc0388d..8bf131f 100644 --- a/man/pipe_infodengue.Rd +++ b/man/pipe_infodengue.Rd @@ -8,14 +8,18 @@ pipe_infodengue( cities, cid10 = "A90", datarelatorio, - finalday = Sys.Date(), + finalday = NULL, iniSE = 201001, nowcasting = "none", narule = NULL, writedb = FALSE, - datasource = con, + datasource, completetail = NA, dataini = "notific", + workers = 1L, + seed = NULL, + verbose = FALSE, + version_date = finalday, firstday = as.Date("2018-01-01") ) } @@ -27,11 +31,14 @@ and all parameters, these will replace the database's parameters.} \item{datarelatorio}{epidemiological week} -\item{finalday}{if provided, uses only disease data reported up to that day} +\item{finalday}{Explicit last reporting date. Required when `datarelatorio` +is not supplied; otherwise it is derived from that epidemiological week.} \item{iniSE}{first date of the disease data. Default = 201501. Minimum = 201001.} -\item{narule}{how to treat missing climate data. Do nothing (default), "zero" fills +\item{nowcasting}{`"bayesian"` for the dynamic model or `"none"` to skip nowcasting.} + +\item{narule}{how to treat missing climate data. Do nothing (default), "zero" fills with zeros, "linear" for linear interpolation, "arima" for inter and extrapolation.} \item{writedb}{TRUE if it should write into the database, default is FALSE.} @@ -42,20 +49,27 @@ with zeros, "linear" for linear interpolation, "arima" for inter and extrapolati \item{dataini}{"notif" (default) or "sinpri"} -\item{firstday}{First date of the notification series passed to getCases(). -Defaults to 2018-01-01.} +\item{workers}{Positive number of workers. Defaults to portable serial execution.} + +\item{seed}{Optional seed for stochastic nowcasting.} + +\item{verbose}{Whether to emit progress messages.} + +\item{version_date}{Explicit model-version date used when writing results.} -\item{"bayesian"}{for the dynamic model, "none" for not doing nowcast (default)} +\item{firstday}{First date of the notification series passed to fetch_cases(). +Defaults to 2018-01-01; supply an earlier date for historical backfills.} } \value{ -data.frame with the week condition and the number of weeks within the +data.frame with the week condition and the number of weeks within the last lag weeks with conditions = TRUE. } \description{ wrap of functions used by Infodengue. } \examples{ -cidades <- getCidades(uf = "Rio de Janeiro",datasource = con) +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +cidades <- getCidades(uf = "Rio de Janeiro",datasource = connection) t1 <- Sys.time() res <- pipe_infodengue(cities = 3304557, cid10 = "A90", nowcasting="bayesian", dataini= "sinpri", completetail = 0, datarelatorio = 202419) @@ -66,4 +80,5 @@ tail(tabela_historico(res)) res <- pipe_infodengue(cities = 4209102 , cid10 = "A90", nowcasting="none", dataini= "sinpri", completetail = 0, datarelatorio = 202408) +\dontshow{\}) # examplesIf} } diff --git a/man/read.cases.Rd b/man/read.cases.Rd index e52061e..07bd2ca 100644 --- a/man/read.cases.Rd +++ b/man/read.cases.Rd @@ -4,7 +4,7 @@ \alias{read.cases} \title{Function to extract case count for covered municipalities} \usage{ -read.cases(start_year, end_year, cid10 = "A90", datasource = con, mun_list) +read.cases(start_year, end_year, cid10 = "A90", datasource, mun_list) } \arguments{ \item{start_year}{first year of the time series} @@ -18,12 +18,14 @@ read.cases(start_year, end_year, cid10 = "A90", datasource = con, mun_list) \item{mun_list}{vector with the municipalities' 7 digit geocodes} } \description{ -Function \code{read.cases} extract notification data from database +Function \code{read.cases} extract notification data from database and aggregate by epiweek. Used by mem. } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} dd <- read.cases(2019, 2020, mun_list = c(4108304, 3300936)) dd <- read.cases(2019, 2020, cid10 = "A92.0", mun_list = c(4108304, 3300936)) +\dontshow{\}) # examplesIf} } \author{ Marcelo F C Gomes diff --git a/man/read.parameters.Rd b/man/read.parameters.Rd index e042f45..0581d99 100644 --- a/man/read.parameters.Rd +++ b/man/read.parameters.Rd @@ -1,31 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utility_tools.R +% Please edit documentation in R/api.R \name{read.parameters} \alias{read.parameters} -\title{Get city-level alert parameters for the infodengue pipeline.} +\title{Legacy alert-parameter reader} \usage{ -read.parameters(cities, cid10 = "A90", datasource = con) +read.parameters(cities, cid10 = "A90", datasource) } \arguments{ -\item{cities}{cities' geocodes. Tip: find them using getCidades().} - -\item{cid10}{Dengue = "A90" (default), Chik = "A92.0", Zika = "A92.8"} - -\item{datasource}{SQL connection to the database} -} -\value{ -dataframe with all parameters +\item{cities, cid10, datasource}{Legacy arguments.} } \description{ -Read the alert parameters for a set of cities from the database, to be used in the infodengue pipeline. -Currently, the parameters are: "limiar_preseason" (pre-season incidence threshold calculated using MEM), -"limiar_posseason" (pos-season incidence threshold), "limiar_epidemico"(epidemic threshold), "varcli" (name of the critical -meteorological variable), "clicrit" (critical value of the meteorological variable), "cid10", -"codmodelo" (name of the heuristic decision model, see serCriteria()). These parameters are specified when the city is initiated -in the pipeline. -} -\examples{ -read.parameters(cities = 3118601, cid10 = "A90") -cid <- getCidades(regional = "Norte",uf = "Rio de Janeiro") -read.parameters(cities = cid$municipio_geocodigo, cid10 = "A90") +Legacy alert-parameter reader } diff --git a/man/run_alert_pipeline.Rd b/man/run_alert_pipeline.Rd new file mode 100644 index 0000000..0326ca6 --- /dev/null +++ b/man/run_alert_pipeline.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{run_alert_pipeline} +\alias{run_alert_pipeline} +\title{Run the alert pipeline} +\usage{ +run_alert_pipeline( + inputs, + parameters, + report_week = NULL, + nowcast = c("none", "bayesian"), + workers = 1L, + seed = NULL, + verbose = FALSE +) +} +\arguments{ +\item{inputs}{An `alerttools_inputs` object.} + +\item{parameters}{Alert parameter data frame, keyed by municipality and disease.} + +\item{report_week}{Explicit report week. Defaults to the value recorded by +`fetch_alert_inputs()`.} + +\item{nowcast}{Either `"none"` or `"bayesian"`.} + +\item{workers}{Positive worker count; defaults to one.} + +\item{seed}{Optional deterministic seed.} + +\item{verbose}{Whether to emit progress messages.} +} +\value{ +An `alerttools_result` object ordered by municipality and week, with + `data`, `alerts`, `parameters`, `metadata`, and `diagnostics` fields. +} +\description{ +This experimental entry point performs computation only. It never reads from +or writes to a database. +} +\section{Lifecycle}{ + +This orchestration interface is experimental. +} diff --git a/man/seqSE.Rd b/man/seqSE.Rd index aea405f..8dddfe1 100644 --- a/man/seqSE.Rd +++ b/man/seqSE.Rd @@ -12,12 +12,14 @@ seqSE(from, to) \item{to}{first week in format 201401} } \value{ -data.frame with the epidemiological weeks and corresponding extreme days. +data.frame with the epidemiological weeks and corresponding extreme days. WARNING: only works from 2010 to 2024. } \description{ Creates a sequence of epidemiological weeks and respective initial and final days } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} seqSE(202442, 202510) +\dontshow{\}) # examplesIf} } diff --git a/man/setCriteria.Rd b/man/setCriteria.Rd index 94f6dd6..f253a5f 100644 --- a/man/setCriteria.Rd +++ b/man/setCriteria.Rd @@ -1,38 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/alert_functions.R +% Please edit documentation in R/api.R \name{setCriteria} \alias{setCriteria} -\title{Define rules to issue a four level alert Green-Yellow-Orange-Red.} +\title{Legacy alert-rule constructor} \usage{ -setCriteria( - rule = NULL, - values = NULL, - delays = list(delayy = c(0, 0), delayo = c(0, 0), delayr = c(0, 0)) -) +setCriteria(rule = NULL, values = NULL, delays = 3) } \arguments{ -\item{rule}{either a built-in rule ("Af", "Aw", "AsAw","Awi","AsAwi") or a list with three elements defining criteria for -transition to yellow (level 2), orange (level 3) and red (level 4). See description.} - -\item{values}{named vector of values for the critical parameters. Use character.} - -\item{delays}{list with three elements, each one is a vector: c(delay to turn on, delay to turn off)} -} -\value{ -list with rules. To be useful, this list must contain variables that match those in the data. +\item{rule, values, delays}{Legacy arguments.} } \description{ -The criteria for transition between colors (alert levels) can be -chosen from existing rules or can be specified by the user. The built in rules are: -Af (minimum temperature defines yellow) and Aw (humidity does), AsAw (temp min and max humidity together). -} -\examples{ -Defining values manually -val <- c("varcli" ="temp_min", "limiar_preseason"="10","limiar_epidemico"="100", "clicrit"="22" -, "clicrit2" = "80", varcli2 = "umid_max") -setCriteria(rule="Af",values=val) -setCriteria(rule="AsAw",values=val) -Using infodengue parameters: -val <- read.parameters(1200401) -setCriteria(rule=val$codmodelo, values=val) +Legacy alert-rule constructor } diff --git a/man/setWUstation.Rd b/man/setWUstation.Rd index 26ad4cf..532e78f 100644 --- a/man/setWUstation.Rd +++ b/man/setWUstation.Rd @@ -4,24 +4,26 @@ \alias{setWUstation} \title{set meteorological stations} \usage{ -setWUstation(st, UF, datasource = con) +setWUstation(st, UF, datasource) } \arguments{ -\item{st}{data.frame containing municipio_geocodigo, primary_station, +\item{st}{data.frame containing municipio_geocodigo, primary_station, secondary_station} \item{UF}{name of the state.Ex. "Rio de Janeiro"} -\item{senha}{for the connection to the project database} +\item{datasource}{connection to the project database} } \description{ -Set primary and secondary meteorological stations associated +Set primary and secondary meteorological stations associated with one or more cities of the same state } \examples{ -NOT RUN +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +# NOT RUN wudata = data.frame(municipio_geocodigo = 3107802, primary_station = "SBIP", secondary_station = "SBGV") setWUstation(wudata, UF = "Minas Gerais") getWUstation(cities =wudata$municipio_geocodigo) +\dontshow{\}) # examplesIf} } diff --git a/man/sevendigitgeocode.Rd b/man/sevendigitgeocode.Rd index b253e74..7eefce5 100644 --- a/man/sevendigitgeocode.Rd +++ b/man/sevendigitgeocode.Rd @@ -2,42 +2,24 @@ % Please edit documentation in R/utility_tools.R \name{sevendigitgeocode} \alias{sevendigitgeocode} -\title{Returns the most recent date present in the database table.} +\title{convert 6 to 7 digits geocodes.} \usage{ sevendigitgeocode(dig) } \arguments{ -\item{tab}{table in the database. Either (sinan, clima_wu, tweet, historico, -historico_mrj).} - -\item{cities}{vector of geocodes.} - -\item{cid10}{relevant for sinan, tweeter or historico. Codes are: dengue "A90", -chik "A92.0", zika "A92.8".} - -\item{stations}{vector with wu stations. Ex. c("SGBL", "SBRL")} - -\item{datasource}{} +\item{dig}{Six- or seven-digit municipality geocode.} } \value{ -vector with two elements: data.max = most recent date in the collection of cities or stations; -se = corresponding epidemiological week. - 7 digits municipality geocode. } \description{ -Useful to check if the database is up-to-date. - -calculates the verification digit of brazilian municipalities. Required +calculates the verification digit of brazilian municipalities. Required to convert 6 digits to 7 digits geocodes. } \examples{ -cidades <- getCidades(regional = "Sete Lagoas", uf = "Minas Gerais") -lastDBdate(tab = "tweet", cities = cidades$municipio_geocodigo, cid10 = "A90") -lastDBdate(tab = "sinan", cities = cidades$municipio_geocodigo, cid10 = "A92.8") -lastDBdate(tab = "clima_wu", stations = "SBAF", datasource=con) -lastDBdate(tab = "clima_wu", cities = cidades$municipio_geocodigo, datasource=con) +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} sevendigitgeocode(330455) sevendigitgeocode(3304557) sevendigitgeocode(261153) +\dontshow{\}) # examplesIf} } diff --git a/man/tabela_historico.Rd b/man/tabela_historico.Rd index cc17831..523ff4d 100644 --- a/man/tabela_historico.Rd +++ b/man/tabela_historico.Rd @@ -1,40 +1,22 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/alert_functions.R +% Please edit documentation in R/api.R \name{tabela_historico} \alias{tabela_historico} -\title{Convert the alert object into a data.frame and calculate indicators} +\title{Legacy history converter} \usage{ -tabela_historico(obj, iniSE, lastSE, type = "all", versao = Sys.Date()) +tabela_historico( + obj, + iniSE, + lastSE, + type = "all", + versao, + parameters = if (inherits(obj, "alerttools_result")) obj$parameters else attr(obj, + "parameters") +) } \arguments{ -\item{obj}{object created by the pipeline.} - -\item{type}{"notified", if it should return total counts, disregarding the -final classification. For compatibility reasons.} - -\item{versao}{Default is current's date} - -\item{ini_se}{first week of the table. Default is the first date in obj.} - -\item{last_se}{last week of the table. Default is the last date in obj. To do.} -} -\value{ -data.frame with the data to be written. +\item{obj, iniSE, lastSE, type, versao, parameters}{Legacy arguments.} } \description{ -Function to organize the alert results for easy reading and inserting -in the database. Also computes receptivity, transmission and incidence levels. -} -\examples{ -# Several cities at once: -cidades <- getCidades(uf = "Mato Grosso", datasource = con) -res <- pipe_infodengue(cities = cidades$municipio_geocodigo[1:3], cid10 = "A90", -finalday= "2018-01-10") -restab <- tabela_historico_comp(res, iniSE = 202301, type = "all") -tail(restab) -# One city: -res <- pipe_infodengue(cities = 3304557, cid10 = "A90", -finalday= "2015-01-10") -restab <- tabela_historico(res) -tail(restab) +Legacy history converter } diff --git a/man/tabela_historico_intra.Rd b/man/tabela_historico_intra.Rd index 5d4de0c..b8ceb31 100644 --- a/man/tabela_historico_intra.Rd +++ b/man/tabela_historico_intra.Rd @@ -4,29 +4,40 @@ \alias{tabela_historico_intra} \title{Convert the alert object into a data.frame and calculate indicators for cities with subdivisions} \usage{ -tabela_historico_intra(obj, iniSE, lastSE, versao = Sys.Date()) +tabela_historico_intra( + obj, + iniSE, + lastSE, + versao, + parameters = attr(obj, "parameters") +) } \arguments{ \item{obj}{object created by the pipeline.} -\item{versao}{Default is current's date} +\item{iniSE}{first week of the table. Default is the first date in obj.} -\item{ini_se}{first week of the table. Default is the first date in obj.} +\item{lastSE}{last week of the table. Default is the last date in obj.} -\item{last_se}{last week of the table. Default is the last date in obj. To do.} +\item{versao}{Explicit model-version date.} + +\item{parameters}{Parameter data frame. It is never read implicitly from a database.} } \value{ data.frame with the data to be written. } \description{ -Function to organize the alert results for easy reading and inserting +Function to organize the alert results for easy reading and inserting in the database. Specific for municipalities with subdivisions. } \examples{ -NOT RUN without connection +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +# NOT RUN without connection # Rio de Janeiro -alerio <- pipe_infodengue_intra(city = 3304557, datarelatorio=202105, +alerio <- pipe_infodengue_intra(city = 3304557, datarelatorio=202105, delaymethod="bayesian", cid10 = "A90", dataini = "sinpri") -restab <- tabela_historico_intra(alerio, iniSE = 201801) +restab <- tabela_historico_intra(alerio, iniSE = 201801, + versao = as.Date("2026-09-04")) tail(restab) +\dontshow{\}) # examplesIf} } diff --git a/man/temp.predict.Rd b/man/temp.predict.Rd index fcd6a9a..16a9d87 100644 --- a/man/temp.predict.Rd +++ b/man/temp.predict.Rd @@ -8,6 +8,8 @@ temp.predict(v, plotar = FALSE) } \arguments{ \item{v}{vector with temperature data.} + +\item{plotar}{Whether to plot observed and predicted values.} } \value{ vector with replaced NA. @@ -16,6 +18,8 @@ vector with replaced NA. function for extrapolating temperature using arima } \examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} head(cliSBCB) temp.predict(v=cli[,3], plotar = T) +\dontshow{\}) # examplesIf} } diff --git a/man/upsert_alert_parameters.Rd b/man/upsert_alert_parameters.Rd new file mode 100644 index 0000000..c3086dd --- /dev/null +++ b/man/upsert_alert_parameters.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{upsert_alert_parameters} +\alias{upsert_alert_parameters} +\title{Upsert alert parameters} +\usage{ +upsert_alert_parameters( + conn, + parameters, + conflict = c("update", "error", "ignore") +) +} +\arguments{ +\item{conn}{A valid DBI connection.} + +\item{parameters}{Parameter data frame keyed by `municipio_geocodigo` and `cid10`.} + +\item{conflict}{Conflict policy: `"update"`, `"error"`, or `"ignore"`.} +} +\value{ +The persisted parameter rows. +} +\description{ +Upsert alert parameters +} diff --git a/man/write_alert_results.Rd b/man/write_alert_results.Rd new file mode 100644 index 0000000..30fad60 --- /dev/null +++ b/man/write_alert_results.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/api.R +\name{write_alert_results} +\alias{write_alert_results} +\title{Write alert results explicitly} +\usage{ +write_alert_results( + conn, + result, + version_date = NULL, + conflict = c("update", "error", "ignore"), + start_week = NULL, + end_week = NULL, + verbose = FALSE +) +} +\arguments{ +\item{conn}{A valid DBI connection.} + +\item{result}{An `alerttools_result` object or an alert-history data frame.} + +\item{version_date}{Explicit model-version date, required when `result` is an +`alerttools_result`.} + +\item{conflict}{Conflict policy: `"update"`, `"error"`, or `"ignore"`.} + +\item{start_week, end_week}{Optional inclusive week filter.} + +\item{verbose}{Whether to emit a persistence message.} +} +\value{ +`result`, invisibly. +} +\description{ +Write alert results explicitly +} diff --git a/man/write_alerta.Rd b/man/write_alerta.Rd index b5e9a65..25029ee 100644 --- a/man/write_alerta.Rd +++ b/man/write_alerta.Rd @@ -1,40 +1,20 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/alert_functions.R +% Please edit documentation in R/api.R \name{write_alerta} \alias{write_alerta} -\title{Write historico_alerta into the database.} +\title{Legacy alert-result writer} \usage{ -write_alerta(d, writetofile = FALSE, datasource = con, arq = "output.sql") +write_alerta( + d, + writetofile = FALSE, + datasource, + arq = "output.sql", + conflict = c("update", "error", "ignore") +) } \arguments{ -\item{d}{object created by tabela_historico()} - -\item{writetofile}{TRUE if an sql object will be the output; FALSE if not.} - -\item{datasource}{posgreSQL conn to project's database} - -\item{arq}{file name to store sql object} -} -\value{ -the same data.frame from the input +\item{d, writetofile, datasource, arq, conflict}{Legacy arguments.} } \description{ -Function to write the pipeline results into the database. -Receives the object created by the function historico.alerta. If writetofile == TRUE, -it saves the sql command in a text file. If FALSE, it will write directly in the database -using the connection. -} -\examples{ -# Parameters for the model -cidades <- getCidades(regional = "Norte",uf = "Rio de Janeiro",datasource = con) -res <- pipe_infodengue(cities = cidades$municipio_geocodigo[1], cid10 = "A90", -datarelatorio = 202407, iniSE = 202301, nowcasting="none") -restab <- tabela_historico(res) -res2 <- pipe_infodengue(cities = cidades$municipio_geocodigo[1], cid10 = "A90", -datarelatorio = 202406, iniSE = 202301, nowcasting="none") -restab2 <- tabela_historico(res2) -# NOT RUN -t1 <- Sys.time() -write_alerta(restab[1:10,], writetofile = TRUE) -t2 <- Sys.time() - t1 +Legacy alert-result writer } diff --git a/man/write_parameters.Rd b/man/write_parameters.Rd index 13b4195..c0ca07f 100644 --- a/man/write_parameters.Rd +++ b/man/write_parameters.Rd @@ -1,26 +1,21 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utility_tools.R +% Please edit documentation in R/api.R \name{write_parameters} \alias{write_parameters} -\title{City's parameterization.} +\title{Legacy alert-parameter writer} \usage{ -write_parameters(city, cid10, params, overwrite = FALSE, datasource = con) +write_parameters( + city, + cid10, + params, + overwrite = FALSE, + datasource, + conflict = c("ignore", "update", "error") +) } \arguments{ -\item{params}{vector of the names of the params to be inserted in the table. Limiar is given as incidence. -It can be a subset of the default.} -} -\value{ -the new line in the parameters table +\item{city, cid10, params, overwrite, datasource, conflict}{Legacy arguments.} } \description{ -Write the alert parameters for each city into the database, to be used in the update.alert. -Currently, the parameters are: "limiar_preseason", "limiar_posseason", -"limiar_epidemico,"varcli", "varcli2", "clicrit", "clicrit2" , "cid10", "codmodelo". -City must be already in the regionais table. -} -\examples{ -pars = data.frame(municipio_geocodigo = 3506003,limiar_preseason = 4.50243, limiar_posseason = 3.962566, -limiar_epidemico = 67.72364, varcli = "temp_min", clicrit = 22, cid10 = "A90", codmodelo = "Af") -res = write_parameters(params$municipio_geocodigo, params$cid10, params = pars) +Legacy alert-parameter writer } diff --git a/tests/testthat.R b/tests/testthat.R index a5214a5..99cc8fa 100755 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,5 +1 @@ -library(testthat) -library(AlertTools) - -test_check("AlertTools") - +testthat::test_check("AlertTools") diff --git a/tests/testthat/fixtures/cases.csv b/tests/testthat/fixtures/cases.csv new file mode 100644 index 0000000..dea0461 --- /dev/null +++ b/tests/testthat/fixtures/cases.csv @@ -0,0 +1,9 @@ +SE,cidade,CID10,casos,cas_prov,cas_lab,localidade,nome,pop +202052,3304557,A90,0,0,0,0,Municipio Fixture,10000 +202053,3304557,A90,1,1,0,0,Municipio Fixture,10000 +202101,3304557,A90,2,2,1,0,Municipio Fixture,10000 +202102,3304557,A90,5,4,2,0,Municipio Fixture,10000 +202103,3304557,A90,12,10,5,0,Municipio Fixture,10000 +202104,3304557,A90,15,13,6,0,Municipio Fixture,10000 +202105,3304557,A90,4,4,1,0,Municipio Fixture,10000 +202106,3304557,A90,1,1,0,0,Municipio Fixture,10000 diff --git a/tests/testthat/fixtures/climate.csv b/tests/testthat/fixtures/climate.csv new file mode 100644 index 0000000..51a4ab7 --- /dev/null +++ b/tests/testthat/fixtures/climate.csv @@ -0,0 +1,9 @@ +SE,geocodigo,temp_min,temp_med,temp_max,umid_min,umid_med,umid_max +202052,3304557,20,24,28,45,60,75 +202053,3304557,23,25,29,46,61,76 +202101,3304557,23,26,30,48,63,78 +202102,3304557,23,26,31,50,65,80 +202103,3304557,23,27,32,52,67,82 +202104,3304557,20,25,30,49,64,79 +202105,3304557,19,24,29,47,62,77 +202106,3304557,19,23,28,45,60,75 diff --git a/tests/testthat/fixtures/expected-alerts.csv b/tests/testthat/fixtures/expected-alerts.csv new file mode 100644 index 0000000..7af45cf --- /dev/null +++ b/tests/testthat/fixtures/expected-alerts.csv @@ -0,0 +1,9 @@ +cytrue,nytrue,cotrue,notrue,crtrue,nrtrue,level +0,NA,0,NA,0,NA,1 +1,NA,0,0,0,0,1 +1,2,1,1,0,0,1 +1,3,1,2,0,0,3 +1,3,1,2,1,1,3 +0,2,0,1,1,2,3 +0,1,0,0,0,1,4 +0,0,0,0,0,0,1 diff --git a/tests/testthat/fixtures/expected-epiweeks.csv b/tests/testthat/fixtures/expected-epiweeks.csv new file mode 100644 index 0000000..b88b9a3 --- /dev/null +++ b/tests/testthat/fixtures/expected-epiweeks.csv @@ -0,0 +1,6 @@ +date,SE,start_date +2020-12-26,202052,2020-12-20 +2020-12-27,202053,2020-12-27 +2021-01-02,202053,2020-12-27 +2021-01-03,202101,2021-01-03 +2021-01-09,202101,2021-01-03 diff --git a/tests/testthat/fixtures/expected-fetch-cases.csv b/tests/testthat/fixtures/expected-fetch-cases.csv new file mode 100644 index 0000000..c59ac92 --- /dev/null +++ b/tests/testthat/fixtures/expected-fetch-cases.csv @@ -0,0 +1,4 @@ +SE,cidade,CID10,casos,cas_prov,cas_lab,localidade,nome,pop +202052,3304557,A90,1,0,0,0,Municipio Fixture,10000 +202053,3304557,A90,1,1,1,0,Municipio Fixture,10000 +202101,3304557,A90,2,1,1,0,Municipio Fixture,10000 diff --git a/tests/testthat/fixtures/expected-rt.csv b/tests/testthat/fixtures/expected-rt.csv new file mode 100644 index 0000000..aa1f8db --- /dev/null +++ b/tests/testthat/fixtures/expected-rt.csv @@ -0,0 +1,11 @@ +SE,casos,Rt,lwr,upr,p1 +202001,1,NA,NA,NA,NA +202002,2,NA,NA,NA,NA +202003,3,NA,NA,NA,NA +202004,5,NA,NA,NA,NA +202005,8,NA,NA,NA,NA +202006,13,2.3763017417791850,0.7846539700581793,4.437045346654189,0.96573017458078791 +202007,8,0.9816059989016321,0.3691594147440740,2.133607841607980,0.48473073512426557 +202008,5,0.5202233933481075,0.2000011088728710,1.351957376986673,0.10499128600486651 +202009,3,0.3674905317955246,0.1322992446836378,1.204438393585692,0.05033724605285084 +202010,2,0.3634789257030839,0.1160572454170437,1.439920841761891,0.08275363510283706 diff --git a/tests/testthat/fixtures/notifications.csv b/tests/testthat/fixtures/notifications.csv new file mode 100644 index 0000000..03a4bef --- /dev/null +++ b/tests/testthat/fixtures/notifications.csv @@ -0,0 +1,5 @@ +municipio_geocodigo,cid10_codigo,dt_notific,dt_sin_pri,dt_digita,ano_notif,se_notif,classi_fin,criterio +3304557,A90,2020-12-22,2020-12-20,2020-12-23,2020,52,5,2 +3304557,A90,2020-12-28,2020-12-27,2020-12-29,2020,53,1,1 +3304557,A90,2021-01-04,2021-01-03,2021-01-05,2021,1,2,1 +3304557,A90,2021-01-05,2021-01-04,2021-01-06,2021,1,5,2 diff --git a/tests/testthat/fixtures/parameters.csv b/tests/testthat/fixtures/parameters.csv new file mode 100644 index 0000000..0648075 --- /dev/null +++ b/tests/testthat/fixtures/parameters.csv @@ -0,0 +1,2 @@ +municipio_geocodigo,limiar_preseason,limiar_posseason,limiar_epidemico,varcli,clicrit,varcli2,clicrit2,cid10,codmodelo +3304557,10,5,100,temp_min,22,NA,NA,A90,Af diff --git a/tests/testthat/fixtures/population.csv b/tests/testthat/fixtures/population.csv new file mode 100644 index 0000000..e6d8093 --- /dev/null +++ b/tests/testthat/fixtures/population.csv @@ -0,0 +1,3 @@ +geocode,year,pop +3304557,2020,10000 +3304557,2021,10000 diff --git a/tests/testthat/helper-database.R b/tests/testthat/helper-database.R new file mode 100644 index 0000000..19cdffb --- /dev/null +++ b/tests/testthat/helper-database.R @@ -0,0 +1,155 @@ +notification_fixture <- function() { + data <- read_fixture("notifications.csv", stringsAsFactors = FALSE) + date_columns <- c("dt_notific", "dt_sin_pri", "dt_digita") + data[date_columns] <- lapply(data[date_columns], as.Date) + data +} + +municipality_fixture <- function() { + data.frame( + nome = "Municipio Fixture", + populacao = 10000, + geocodigo = 3304557, + regional = "Regional Fixture", + id_regional = 7, + macroregional = "Macro Fixture", + macroregional_id = 70, + uf = "Rio de Janeiro", + stringsAsFactors = FALSE + ) +} + +parameter_fixture <- function() { + data <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + data$codigo_estacao_wu <- "TEST" + data$estacao_wu_sec <- "ALT1" + data +} + +station_climate_fixture <- function() { + data.frame( + Estacao_wu_estacao_id = rep("TEST", 4), + data_dia = as.Date(c("2020-12-20", "2020-12-21", "2020-12-27", "2020-12-28")), + temp_min = c(20, 22, 24, 26), + temp_med = c(24, 25, 26, 27), + stringsAsFactors = FALSE + ) +} + +municipal_climate_fixture <- function() { + data.frame( + geocode = rep(3304557, 4), + date = as.Date(c("2020-12-20", "2020-12-21", "2020-12-27", "2020-12-28")), + temp_min = c(20, 22, 24, 26), temp_max = c(28, 30, 32, 34), + temp_med = c(24, 26, 28, 30), umid_min = c(40, 42, 44, 46), + umid_med = c(60, 62, 64, 66), umid_max = c(80, 82, 84, 86), + precip_tot = c(0, 2, 4, 6), precip_max = c(0, 2, 4, 6) + ) +} + +tweet_fixture <- function() { + data.frame( + Municipio_geocodigo = c(3304557, 3304557), + data_dia = as.Date(c("2020-12-20", "2020-12-27")), + numero = c(2, 3) + ) +} + +sqlite_fixture_connection <- function(test_env = parent.frame()) { + testthat::skip_if_not_installed("RSQLite") + connection <- DBI::dbConnect(RSQLite::SQLite(), ":memory:") + withr::defer(DBI::dbDisconnect(connection), envir = test_env) + + notifications <- notification_fixture() + date_columns <- c("dt_notific", "dt_sin_pri", "dt_digita") + notifications[date_columns] <- lapply( + notifications[date_columns], + function(value) as.numeric(value) + ) + + DBI::dbWriteTable(connection, "Notificacao", notifications) + DBI::dbWriteTable(connection, "Municipio", municipality_fixture()) + DBI::dbWriteTable(connection, "parameters", parameter_fixture()) + DBI::dbExecute( + connection, + "CREATE UNIQUE INDEX parameters_key ON parameters (municipio_geocodigo, cid10)" + ) + + station_climate <- station_climate_fixture() + station_climate$data_dia <- as.numeric(station_climate$data_dia) + DBI::dbWriteTable(connection, "wu", station_climate) + + municipal_climate <- municipal_climate_fixture() + municipal_climate$date <- as.numeric(municipal_climate$date) + DBI::dbWriteTable(connection, "copernicus_bra", municipal_climate) + + tweets <- tweet_fixture() + tweets$data_dia <- as.numeric(tweets$data_dia) + DBI::dbWriteTable(connection, "tweet", tweets) + + DBI::dbWriteTable(connection, "regional_saude", data.frame( + id = 1, nome_regional = "Regional Fixture", municipio_geocodigo = 3304557, + codigo_estacao_wu = "TEST", estacao_wu_sec = "ALT1" + )) + connection +} + +create_alert_history_table <- function(connection) { + DBI::dbExecute(connection, paste( + "CREATE TABLE Historico_alerta (", + '"SE" INTEGER, "data_iniSE" TEXT, casos_est REAL, casos_est_min REAL,', + 'casos_est_max REAL, casos REAL, casprov REAL, municipio_geocodigo INTEGER,', + 'p_rt1 REAL, p_inc100k REAL, "Localidade_id" INTEGER, nivel INTEGER, id TEXT,', + 'versao_modelo TEXT, municipio_nome TEXT, tweet REAL, "Rt" REAL, pop REAL,', + 'tempmin REAL, tempmed REAL, tempmax REAL, umidmin REAL, umidmed REAL,', + 'umidmax REAL, receptivo INTEGER, transmissao INTEGER, nivel_inc INTEGER,', + 'UNIQUE ("SE", municipio_geocodigo, "Localidade_id"))' + )) +} + +postgres_fixture_connection <- function(test_env = parent.frame()) { + testthat::skip_if_not( + identical(Sys.getenv("ALERTTOOLS_TEST_POSTGRES"), "true"), + "set ALERTTOOLS_TEST_POSTGRES=true only for an ephemeral test database" + ) + testthat::skip_if_not_installed("RPostgres") + + connection <- DBI::dbConnect( + RPostgres::Postgres(), + dbname = Sys.getenv("PGDATABASE", "alerttools_test"), + host = Sys.getenv("PGHOST", "127.0.0.1"), + port = as.integer(Sys.getenv("PGPORT", "5432")), + user = Sys.getenv("PGUSER", "postgres"), + password = Sys.getenv("PGPASSWORD", "postgres") + ) + withr::defer(DBI::dbDisconnect(connection), envir = test_env) + + database_name <- DBI::dbGetInfo(connection)$dbname + if (!identical(database_name, "alerttools_test")) { + stop("PostgreSQL integration tests require the dedicated alerttools_test database.") + } + + DBI::dbExecute(connection, 'DROP SCHEMA IF EXISTS "Municipio" CASCADE') + DBI::dbExecute(connection, 'DROP SCHEMA IF EXISTS "Dengue_global" CASCADE') + DBI::dbExecute(connection, 'CREATE SCHEMA "Municipio"') + DBI::dbExecute(connection, 'CREATE SCHEMA "Dengue_global"') + withr::defer( + { + DBI::dbExecute(connection, 'DROP SCHEMA IF EXISTS "Municipio" CASCADE') + DBI::dbExecute(connection, 'DROP SCHEMA IF EXISTS "Dengue_global" CASCADE') + }, + envir = test_env + ) + + DBI::dbWriteTable( + connection, + DBI::Id(schema = "Municipio", table = "Notificacao"), + notification_fixture() + ) + DBI::dbWriteTable( + connection, + DBI::Id(schema = "Dengue_global", table = "Municipio"), + municipality_fixture() + ) + connection +} diff --git a/tests/testthat/helper-fixtures.R b/tests/testthat/helper-fixtures.R new file mode 100644 index 0000000..46eb8de --- /dev/null +++ b/tests/testthat/helper-fixtures.R @@ -0,0 +1,31 @@ +.fixture_directory <- normalizePath(testthat::test_path("fixtures"), mustWork = TRUE) + +fixture_path <- function(name) { + file.path(.fixture_directory, name) +} + +read_fixture <- function(name, ...) { + utils::read.csv(fixture_path(name), na.strings = "NA", ...) +} + +expect_cases_contract <- function(observed, expected) { + testthat::expect_s3_class(observed, "data.frame") + testthat::expect_named( + observed, + c("SE", "cidade", "CID10", "casos", "cas_prov", "cas_lab", + "localidade", "nome", "pop") + ) + testthat::expect_equal(nrow(observed), nrow(expected)) + testthat::expect_false(anyDuplicated(observed[c("SE", "cidade", "CID10")]) > 0) + testthat::expect_true(all(vapply( + observed[c("SE", "cidade", "casos", "cas_prov", "cas_lab", "localidade", "pop")], + is.numeric, + logical(1) + ))) + testthat::expect_type(observed$CID10, "character") + testthat::expect_type(observed$nome, "character") + testthat::expect_false(anyNA(observed[c("SE", "cidade", "CID10", "casos", + "cas_prov", "cas_lab", "localidade")])) + testthat::expect_equal(observed$SE, sort(observed$SE)) + testthat::expect_equal(lapply(observed, unname), lapply(expected, unname)) +} diff --git a/tests/testthat/test-alert-rules.R b/tests/testthat/test-alert-rules.R new file mode 100644 index 0000000..7b379fe --- /dev/null +++ b/tests/testthat/test-alert-rules.R @@ -0,0 +1,46 @@ +test_that("setCriteria validates inputs and returns the legacy structure", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + values <- c( + varcli = "temp_min", clicrit = "22", + limiar_preseason = "10", limiar_epidemico = "100" + ) + + expect_error(setCriteria(rule = "XX"), "setcriteria: rule unknown.") + expect_error(setCriteria(), "if rule is null, values must be provided") + + criteria <- setCriteria(rule = "Af", values = values) + expect_named(criteria, c("crity", "crito", "critr")) + expect_equal(vapply(criteria, class, character(1)), + c(crity = "character", crito = "character", critr = "character")) + expect_equal(lengths(criteria), c(crity = 3L, crito = 3L, critr = 3L)) +}) + +test_that("alert rules preserve output structure and delayed levels", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + expected <- read_fixture("expected-alerts.csv") + + input <- merge(cases, climate, by.x = c("SE", "cidade"), + by.y = c("SE", "geocodigo"), sort = FALSE) + input <- input[match(cases$SE, input$SE), ] + input$inc <- input$casos / input$pop * 100000 + input$p1 <- c(0, 0.5, 0.96, 0.97, 0.98, 0.9, 0.4, 0.2) + + values <- c( + varcli = parameters$varcli, + clicrit = as.character(parameters$clicrit), + limiar_preseason = as.character(parameters$limiar_preseason), + limiar_epidemico = as.character(parameters$limiar_epidemico) + ) + criteria <- setCriteria(rule = parameters$codmodelo, values = values) + observed <- fouralert(input, crit = criteria) + + expect_s3_class(observed, "alerta") + expect_named(observed, c("data", "indices", "crit", "n")) + expect_equal(nrow(observed$indices), nrow(input)) + expect_equal(observed$indices, expected) + expect_equal(observed$n, 4) + expect_equal(observed$crit, criteria) +}) diff --git a/tests/testthat/test-api.R b/tests/testthat/test-api.R new file mode 100644 index 0000000..1bb9ccc --- /dev/null +++ b/tests/testthat/test-api.R @@ -0,0 +1,223 @@ +test_that("new_alert_inputs validates, normalizes, and orders public schemas", { + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + population <- unique(data.frame( + municipio_geocodigo = cases$cidade, populacao = cases$pop, year = 2025 + )) + cases$pop <- NULL + inputs <- new_alert_inputs( + cases[sample(nrow(cases)), ], climate[sample(nrow(climate)), ], population, + metadata = list(source = "fixture") + ) + + expect_s3_class(inputs, "alerttools_inputs") + expect_named(inputs, c("cases", "climate", "population", "case_records", "metadata")) + expect_equal(inputs$cases$SE, sort(inputs$cases$SE)) + expect_equal(inputs$climate$SE, sort(inputs$climate$SE)) + expect_true(all(inputs$cases$pop == 10000)) + expect_output(printed <- print(inputs), "", fixed = TRUE) + expect_identical(printed, inputs) + + duplicate <- rbind(cases, cases[1, ]) + duplicate$pop <- 10000 + expect_error(new_alert_inputs(duplicate, climate), "keys.*unique") + expect_error(new_alert_inputs(cases, climate), "positive population") +}) + +test_that("run_alert_pipeline is equivalent to the approved pure pipeline", { + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + inputs <- new_alert_inputs(cases, climate, metadata = list(report_week = 202106)) + + expected <- alerttools_pipeline( + cases, climate, parameters, report_week = 202106, + nowcasting = "none", workers = 1, seed = 42 + ) + observed <- run_alert_pipeline( + inputs, parameters, nowcast = "none", workers = 1, seed = 42 + ) + expect_identical(observed, expected) + expect_error(run_alert_pipeline(list(), parameters), "new_alert_inputs") +}) + +test_that("database API fetches a complete, explicitly bounded input bundle", { + connection <- sqlite_fixture_connection(environment()) + inputs <- fetch_alert_inputs( + conn = connection, geocodes = 3304557, disease = "dengue", + start_week = 202052, report_week = 202101 + ) + parameters <- fetch_alert_parameters(connection, 3304557, "A90") + + expect_s3_class(inputs, "alerttools_inputs") + expect_equal(inputs$metadata$start_date, as.Date("2020-12-20")) + expect_equal(inputs$metadata$end_date, as.Date("2021-01-09")) + expect_equal(inputs$metadata$disease, "A90") + expect_equal(nrow(inputs$case_records), 4) + expect_equal(parameters$municipio_geocodigo, 3304557) + expect_equal(parameters$cid10, "A90") + expect_error( + fetch_alert_inputs(connection, 3304557, start_week = 202052), + "report_week.*end_date" + ) + expect_error( + fetch_alert_inputs(connection, 3304557, start_week = 202052, + report_week = 202101, end_date = as.Date("2021-01-10")), + "different weeks" + ) +}) + +test_that("new persistence API writes results and parameters explicitly", { + connection <- sqlite_fixture_connection(environment()) + create_alert_history_table(connection) + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + result <- run_alert_pipeline( + new_alert_inputs(cases, climate), parameters, + report_week = 202106, nowcast = "none" + ) + + expect_invisible(write_alert_results( + connection, result, version_date = as.Date("2026-09-04"), conflict = "update" + )) + expect_equal(DBI::dbGetQuery(connection, "SELECT COUNT(*) AS n FROM Historico_alerta")$n, 8) + expect_error(write_alert_results(connection, result), "version_date") + + withr::local_options(list(lifecycle_verbosity = "warning")) + history <- as_alert_history(result, as.Date("2026-09-04")) + expect_warning( + write_alerta(history, datasource = connection, conflict = "update"), + "write_alert_results" + ) + + changed <- transform(parameter_fixture(), limiar_preseason = 23) + persisted <- upsert_alert_parameters(connection, changed, conflict = "update") + expect_equal(persisted$limiar_preseason, 23) +}) + +test_that("legacy wrappers warn and preserve argument and result adapters", { + withr::local_options(list(lifecycle_verbosity = "warning")) + connection <- sqlite_fixture_connection(environment()) + + modern_cases <- fetch_cases( + connection, 3304557, "dengue", + as.Date("2020-12-20"), as.Date("2021-01-09") + ) + expect_warning( + legacy_cases <- getCases( + cities = 3304557, cid10 = "A90", firstday = as.Date("2020-12-20"), + lastday = as.Date("2021-01-09"), dataini = "notific", datasource = connection + ), + "fetch_cases" + ) + expect_identical(legacy_cases, modern_cases) + expect_warning( + legacy_records <- getCaseslist( + 3304557, firstday = as.Date("2020-12-20"), + lastday = as.Date("2021-01-09"), datasource = connection + ), + "fetch_case_records" + ) + expect_identical( + legacy_records, + fetch_case_records(connection, 3304557, start_date = as.Date("2020-12-20"), + end_date = as.Date("2021-01-09")) + ) + expect_warning( + legacy_climate <- getClima( + 3304557, vars = c("temp_min", "temp_max"), iniSE = 202052, + finalday = as.Date("2021-01-02"), datasource = connection + ), + "fetch_climate" + ) + expect_identical( + legacy_climate, + fetch_climate(connection, 3304557, as.Date("2020-12-20"), + as.Date("2021-01-02"), c("temp_min", "temp_max")) + ) + + modern_parameters <- fetch_alert_parameters(connection, 3304557, "dengue") + expect_warning( + legacy_parameters <- read.parameters(3304557, cid10 = "A90", datasource = connection), + "fetch_alert_parameters" + ) + expect_identical(legacy_parameters, modern_parameters) + expect_warning( + write_parameters(3304557, "A90", modern_parameters, overwrite = TRUE, + datasource = connection), + "upsert_alert_parameters" + ) + expect_warning( + expect_error( + pipe_infodengue(3304557, datarelatorio = 202101, datasource = NULL), + "valid DBI connection" + ), + "run_alert_pipeline" + ) +}) + +test_that("snake_case computational aliases preserve baseline results", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + cases <- read_fixture("cases.csv") + criteria_values <- structure( + as.character(read_fixture("parameters.csv", stringsAsFactors = FALSE)[1, ]), + names = names(read_fixture("parameters.csv", stringsAsFactors = FALSE)) + ) + expect_identical( + estimate_rt(cases, count = "casos", distribution = "normal", + mean_generation_time = 3, sd_generation_time = 1), + Rt(cases, count = "casos", gtdist = "normal", meangt = 3, sdgt = 1) + ) + expect_identical( + nowcast_cases(cases, method = "none", report_week = 202106), + adjustIncidence(cases, method = "none", nowSE = 202106) + ) + rules <- define_alert_rules("Af", criteria_values) + expect_identical(rules, setCriteria("Af", criteria_values)) +}) + +test_that("legacy computational wrappers identify replacements and remain equivalent", { + withr::local_options(list(lifecycle_verbosity = "warning")) + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + + modern_rt <- estimate_rt(cases, count = "casos", distribution = "normal", + mean_generation_time = 3, sd_generation_time = 1) + expect_warning( + legacy_rt <- Rt(cases, count = "casos", gtdist = "normal", meangt = 3, sdgt = 1), + "estimate_rt" + ) + expect_identical(legacy_rt, modern_rt) + + modern_nowcast <- nowcast_cases(cases, method = "none", report_week = 202106) + expect_warning( + legacy_nowcast <- adjustIncidence(cases, method = "none", nowSE = 202106), + "nowcast_cases" + ) + expect_identical(legacy_nowcast, modern_nowcast) + + values <- structure(as.character(parameters[1, ]), names = names(parameters)) + modern_rules <- define_alert_rules("Af", values) + expect_warning(legacy_rules <- setCriteria("Af", values), "define_alert_rules") + expect_identical(legacy_rules, modern_rules) + + result <- run_alert_pipeline( + new_alert_inputs(cases, climate), parameters, + report_week = 202106, nowcast = "none" + ) + modern_alert <- classify_alerts(result$data, modern_rules, + missing = "last", minimum_history = 4) + expect_warning( + legacy_alert <- fouralert(result$data, modern_rules, miss = "last", dy = 4), + "classify_alerts" + ) + expect_identical(legacy_alert, modern_alert) + modern_history <- as_alert_history(result, as.Date("2026-09-04")) + expect_warning( + legacy_history <- tabela_historico(result, versao = as.Date("2026-09-04")), + "as_alert_history" + ) + expect_identical(legacy_history, modern_history) +}) diff --git a/tests/testthat/test-core-pipeline.R b/tests/testthat/test-core-pipeline.R new file mode 100644 index 0000000..ef24404 --- /dev/null +++ b/tests/testthat/test-core-pipeline.R @@ -0,0 +1,127 @@ +test_that("pure pipeline runs deterministically from in-memory fixtures", { + withr::local_dir(withr::local_tempdir()) + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + before <- list.files(all.files = TRUE) + + first <- alerttools_pipeline( + cases, climate, parameters, + report_week = 202106, nowcasting = "none", workers = 1, seed = 42 + ) + second <- alerttools_pipeline( + cases, climate, parameters, + report_week = 202106, nowcasting = "none", workers = 1, seed = 42 + ) + + expect_s3_class(first, "alerttools_result") + expect_named(first, c("data", "alerts", "parameters", "metadata", "diagnostics")) + expect_identical(first, second) + expect_equal(list.files(all.files = TRUE), before) + expect_equal(nrow(first$data), nrow(cases)) + expect_equal(nrow(first$alerts), nrow(cases)) + expect_equal(first$metadata$workers, 1L) + expect_true(first$metadata$deterministic) + expect_equal(first$diagnostics$missing_climate, 0) +}) + +test_that("alerttools_result methods expose a stable result contract", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + result <- alerttools_pipeline(cases, climate, parameters, report_week = 202106) + + expect_output(printed <- print(result), "", fixed = TRUE) + expect_identical(printed, result) + overview <- summary(result) + expect_named(overview, c("rows", "municipalities", "alert_levels", "metadata", "diagnostics")) + expect_equal(overview$rows, 8) + expect_equal(sum(overview$alert_levels), 8) + flattened <- as.data.frame(result) + expect_s3_class(flattened, "data.frame") + expect_equal(nrow(flattened), 8) + expect_true(all(c("SE", "cidade", "Rt", "level") %in% names(flattened))) + + history <- tabela_historico(result, versao = as.Date("2026-09-04")) + expect_s3_class(history, "data.frame") + expect_equal(nrow(history), 8) + expect_true(all(c("data_iniSE", "municipio_geocodigo", "nivel_inc") %in% names(history))) + expect_error(tabela_historico(result), "explicit.*versao") +}) + +test_that("alerttools_result constructor handles empty and invalid inputs", { + empty <- new_alerttools_result( + data.frame(), data.frame(), data.frame(), + metadata = list(source = "fixture"), diagnostics = list(rows = 0L) + ) + expect_s3_class(empty, "alerttools_result") + expect_equal(nrow(as.data.frame(empty)), 0) + + expect_error( + new_alerttools_result(data.frame(x = 1), data.frame(), data.frame(), + metadata = list(x = 1), diagnostics = list(x = 1)), + "same number of rows" + ) + expect_error( + new_alerttools_result(data.frame(), data.frame(), data.frame(), + metadata = list(), diagnostics = unname(list(1))), + "diagnostics.*named list" + ) + duplicate_names <- structure(data.frame(x = 1, y = 2), names = c("x", "x")) + expect_error( + new_alerttools_result(duplicate_names, data.frame(level = 1), data.frame()), + "duplicate column names" + ) +}) + +test_that("incidence is a pure validated calculation", { + expect_equal(calculate_incidence(c(0, 10, NA), c(1000, 2000, 3000)), + c(0, 500, NA)) + expect_error(calculate_incidence(-1, 1000), "negative") + expect_error(calculate_incidence(1, 0), "positive") + expect_error(calculate_incidence(1:2, 1000), "equal length") +}) + +test_that("pure pipeline validates schemas, workers and nowcasting inputs", { + cases <- read_fixture("cases.csv") + climate <- read_fixture("climate.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + + expect_error(alerttools_pipeline(cases[-1], climate, parameters), + "cases.*missing columns") + expect_error(alerttools_pipeline(cases, climate[-1], parameters), + "climate.*missing columns") + expect_error(alerttools_pipeline(cases, climate, parameters, workers = 0), + "positive integer") + expect_error(alerttools_pipeline(cases, climate, parameters, + nowcasting = "bayesian"), + "requires in-memory.*case_records") +}) + +test_that("seed scoping does not mutate caller random state", { + set.seed(123) + before <- .Random.seed + value <- AlertTools:::.with_seed(999, stats::runif(3)) + expect_length(value, 3) + expect_identical(.Random.seed, before) +}) + +test_that("portable worker controls are validated", { + expect_error(GenTimeDist(rep(25, 60), workers = 0), "positive integer") + expect_error(GenTimeDist(c(25, NA), smooth = "raw"), "finite numeric") + expect_error(GenTimeDist(rep(25, 60), smooth = "other"), "sinusoidal.*raw") + serial <- GenTimeDist(rep(25, 60), smooth = "raw", workers = 1) + expect_s3_class(serial, "generationtime") + expect_equal(dim(serial), c(11, 60)) +}) + +test_that("computational entry points contain no database or file access", { + functions <- list(alerttools_pipeline, adjustIncidence, bayesnowcasting, + Rt, setCriteria, fouralert, GenTimeDist, + AlertTools:::applymem) + forbidden <- "DBI::|dbGetQuery|dbExecute|read\\.|writeLines|save\\(|load\\(|setwd\\(" + bodies <- vapply(functions, function(fun) paste(deparse(body(fun)), collapse = "\n"), + character(1)) + expect_false(any(grepl(forbidden, bodies))) +}) diff --git a/tests/testthat/test-data-repository.R b/tests/testthat/test-data-repository.R new file mode 100644 index 0000000..61bae8e --- /dev/null +++ b/tests/testthat/test-data-repository.R @@ -0,0 +1,214 @@ +test_that("repository-backed readers expose stable domain schemas", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + + cities <- getCidades(uf = "Rio de Janeiro", datasource = connection) + expect_named(cities, c("municipio_geocodigo", "cidade", "regional", "regional_id", + "macroregional", "macroregional_id", "uf")) + expect_equal(cities$municipio_geocodigo, 3304557) + expect_equal(getRegionais(uf = "Rio de Janeiro", datasource = connection), + "Regional Fixture") + expect_equal(getRegionais(uf = "Rio de Janeiro", macroreg = TRUE, + datasource = connection), "Macro Fixture") + + parameters <- read.parameters(3304557, datasource = connection) + expect_equal(nrow(parameters), 1) + expect_equal(parameters$codmodelo, "Af") + expect_named(getWUstation(3304557, datasource = connection), + c("municipio_geocodigo", "codigo_estacao_wu", "estacao_wu_sec")) + regional_link <- AlertTools:::.repo_regional_health(connection, 3304557) + expect_named(regional_link, c("id", "nome_regional", "municipio_geocodigo", + "codigo_estacao_wu", "estacao_wu_sec")) +}) + +test_that("bound values prevent SQL injection through repository filters", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + + expect_error( + getCidades(uf = "Rio de Janeiro' OR 1=1 --", datasource = connection), + "found no city" + ) + expect_error( + read.parameters(cities = c(3304557, NA_real_), datasource = connection) + ) + expect_equal(DBI::dbGetQuery(connection, "SELECT COUNT(*) AS n FROM Municipio")$n, 1) +}) + +test_that("case-record readers share date and disease normalization", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + + records <- getCaseslist( + 3304557, firstday = as.Date("2020-12-20"), lastday = as.Date("2021-01-09"), + datasource = connection + ) + expect_equal(nrow(records), 4) + expect_true(all(vapply(records[c("dt_notific", "dt_sin_pri", "dt_digita")], + inherits, logical(1), what = "Date"))) + + delays <- getdelaydata(3304557, nyears = 1, lastday = as.Date("2021-01-09"), + datasource = connection) + expect_named(delays, c("municipio_geocodigo", "dt_notific", "dt_sin_pri", "dt_digita")) + expect_equal(nrow(delays), 4) + + weekly <- read.cases(2020, 2021, mun_list = 3304557, datasource = connection) + expect_named(weekly, c("municipio_geocodigo", "SE", "casos")) + expect_equal(sum(weekly$casos), 4) + expect_false(anyDuplicated(weekly[c("municipio_geocodigo", "SE")]) > 0) +}) + +test_that("climate and tweet repositories filter dates and preserve ordering", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + + climate <- getClima( + 3304557, vars = c("temp_min", "temp_max", "temp_med", "umid_min", + "umid_med", "umid_max"), + iniSE = 202052, finalday = as.Date("2021-01-02"), datasource = connection + ) + expect_named(climate, c("geocodigo", "SE", "temp_min", "temp_max", "temp_med", + "umid_min", "umid_med", "umid_max")) + expect_equal(climate$SE, c(202052, 202053)) + expect_equal(climate$temp_min, c(21, 25)) + + station <- getWU("TEST", vars = c("temp_min", "temp_med"), iniSE = 202052, + finalday = as.Date("2021-01-02"), datasource = connection) + expect_equal(station$SE, c(202052, 202053)) + expect_equal(station$temp_min, c(21, 25)) + + tweets <- getTweet(3304557, lastday = as.Date("2020-12-27"), datasource = connection) + selected <- tweets[tweets$SE %in% c(202052, 202053), ] + expect_equal(selected$tweet, c(2, 3)) +}) + +test_that("parameter writes implement explicit conflict policies", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + original <- parameter_fixture() + + ignored <- write_parameters(3304557, "A90", transform(original, limiar_preseason = 20), + datasource = connection, conflict = "ignore") + expect_equal(ignored$limiar_preseason, 10) + + updated <- write_parameters(3304557, "A90", transform(original, limiar_preseason = 20), + datasource = connection, conflict = "update") + expect_equal(updated$limiar_preseason, 20) + + expect_error( + write_parameters(3304557, "A90", original, datasource = connection, conflict = "error"), + "UNIQUE constraint failed" + ) + expect_equal(read.parameters(3304557, datasource = connection)$limiar_preseason, 20) +}) + +test_that("batch write rolls back every row after a conflict", { + connection <- sqlite_fixture_connection(environment()) + rows <- rbind( + transform(parameter_fixture(), municipio_geocodigo = 3550308, limiar_preseason = 30), + transform(parameter_fixture(), municipio_geocodigo = 3304557, limiar_preseason = 40) + ) + + expect_error( + AlertTools:::.repo_write_rows( + connection, "parameters", rows, + key = c("municipio_geocodigo", "cid10"), conflict = "error" + ), + "UNIQUE constraint failed" + ) + observed <- DBI::dbGetQuery(connection, "SELECT * FROM parameters ORDER BY municipio_geocodigo") + expect_equal(nrow(observed), 1) + expect_equal(observed$limiar_preseason, 10) +}) + +test_that("station association updates are batched and transactional", { + connection <- sqlite_fixture_connection(environment()) + update <- data.frame( + municipio_geocodigo = 3304557, + primary_station = "NEW1", + secondary_station = "NEW2" + ) + + expect_invisible(setWUstation(update, UF = "Rio de Janeiro", datasource = connection)) + observed <- getWUstation(3304557, datasource = connection) + expect_equal(observed$codigo_estacao_wu, "NEW1") + expect_equal(observed$estacao_wu_sec, "NEW2") +}) + +test_that("alert history writes are batched, idempotent and conflict-aware", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + DBI::dbExecute(connection, paste( + "CREATE TABLE Historico_alerta (", + '"SE" INTEGER, "data_iniSE" TEXT, casos_est REAL, casos_est_min REAL,', + 'casos_est_max REAL, casos REAL, casprov REAL, municipio_geocodigo INTEGER,', + 'p_rt1 REAL, p_inc100k REAL, "Localidade_id" INTEGER, nivel INTEGER, id TEXT,', + 'versao_modelo TEXT, municipio_nome TEXT, tweet REAL, "Rt" REAL, pop REAL,', + 'tempmin REAL, tempmed REAL, tempmax REAL, umidmin REAL, umidmed REAL,', + 'umidmax REAL, receptivo INTEGER, transmissao INTEGER, nivel_inc INTEGER,', + 'UNIQUE ("SE", municipio_geocodigo, "Localidade_id"))' + )) + history <- data.frame( + SE = c(202052, 202053), data_iniSE = as.Date(c("2020-12-20", "2020-12-27")), + CID10 = "A90", casos_est = c(1, 2), casos_est_min = c(1, 2), + casos_est_max = c(1, 2), casos = c(1, 2), casprov = c(1, 2), + municipio_geocodigo = 3304557, p_rt1 = c(0.1, 0.2), p_inc100k = c(10, 20), + Localidade_id = 0, nivel = c(1, 2), id = c("a", "b"), + versao_modelo = "2026-09-04", municipio_nome = "Municipio Fixture", + Rt = c(0.8, 1.2), pop = 10000, tweet = c(2, 3), receptivo = c(0, 1), + transmissao = c(0, 1), nivel_inc = c(0, 1), temp_min = c(20, 24), + temp_med = c(24, 28), temp_max = c(28, 32), umid_min = c(40, 44), + umid_med = c(60, 64), umid_max = c(80, 84) + ) + + expect_invisible(write_alerta(history, datasource = connection, conflict = "update")) + expect_equal(DBI::dbGetQuery(connection, "SELECT COUNT(*) AS n FROM Historico_alerta")$n, 2) + + changed <- transform(history, casos_est = casos_est + 10) + expect_invisible(write_alerta(changed, datasource = connection, conflict = "update")) + observed <- DBI::dbGetQuery(connection, + 'SELECT casos_est FROM Historico_alerta ORDER BY "SE"') + expect_equal(observed$casos_est, c(11, 12)) + expect_error(write_alerta(history, datasource = connection, conflict = "error"), + "UNIQUE constraint failed") + expect_equal(DBI::dbGetQuery(connection, "SELECT COUNT(*) AS n FROM Historico_alerta")$n, 2) +}) + +test_that("SQL file export quotes literals instead of interpolating user values", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + path <- withr::local_tempfile(fileext = ".sql") + history <- data.frame( + SE = 202052, data_iniSE = as.Date("2020-12-20"), CID10 = "A90", + casos_est = 1, casos_est_min = 1, casos_est_max = 1, casos = 1, casprov = 1, + municipio_geocodigo = 3304557, p_rt1 = 0.1, p_inc100k = 10, + Localidade_id = 0, nivel = 1, id = "a", versao_modelo = "2026-09-04", + municipio_nome = "D'Angelo); DROP TABLE x; --", Rt = 0.8, pop = 10000, + tweet = 2, receptivo = 0, transmissao = 0, nivel_inc = 0, + temp_min = 20, temp_med = 24, temp_max = 28, + umid_min = 40, umid_med = 60, umid_max = 80 + ) + + expect_invisible(write_alerta(history, writetofile = TRUE, arq = path)) + sql <- paste(readLines(path, warn = FALSE), collapse = "\n") + expect_match(sql, "D''Angelo", fixed = TRUE) + expect_match(sql, "INSERT INTO \"Municipio\".\"Historico_alerta\"", fixed = TRUE) +}) + +test_that("database functions never fall back to a global con object", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + assign("con", connection, envir = .GlobalEnv) + withr::defer(rm("con", envir = .GlobalEnv), envir = environment()) + + database_functions <- list(getCases, getCaseslist, getClima, getWU, getTweet, + getCidades, getRegionais, read.parameters, + write_parameters, getWUstation, setWUstation, + read.cases, getdelaydata, pipe_infodengue, + write_alerta, applyGenTimeDist) + expect_true(all(vapply(database_functions, function(fun) { + identical(formals(fun)$datasource, quote(expr = )) + }, logical(1)))) + expect_error(getCases(3304557), + "valid DBI connection|datasource.*missing|argument.*datasource", + ignore.case = TRUE) +}) diff --git a/tests/testthat/test-documentation-examples.R b/tests/testthat/test-documentation-examples.R new file mode 100644 index 0000000..8fcb33e --- /dev/null +++ b/tests/testthat/test-documentation-examples.R @@ -0,0 +1,22 @@ +test_that("published in-memory example runs in a clean environment", { + example_file <- system.file( + "examples", "in-memory-pipeline.R", package = "AlertTools" + ) + expect_true(nzchar(example_file)) + example_env <- new.env(parent = globalenv()) + expect_silent(sys.source(example_file, envir = example_env)) + expect_s3_class(example_env$inputs, "alerttools_inputs") + expect_s3_class(example_env$result, "alerttools_result") +}) + +test_that("published SQLite example runs without credentials or production", { + skip_if_not_installed("RSQLite") + example_file <- system.file( + "examples", "sqlite-pipeline.R", package = "AlertTools" + ) + expect_true(nzchar(example_file)) + example_env <- new.env(parent = globalenv()) + expect_silent(sys.source(example_file, envir = example_env)) + expect_s3_class(example_env$inputs, "alerttools_inputs") + expect_s3_class(example_env$result, "alerttools_result") +}) diff --git a/tests/testthat/test-epiweek.R b/tests/testthat/test-epiweek.R new file mode 100644 index 0000000..ff822a4 --- /dev/null +++ b/tests/testthat/test-epiweek.R @@ -0,0 +1,105 @@ +test_that("calendar behavior is preserved across epidemiological year boundary", { + expected <- read_fixture("expected-epiweeks.csv", colClasses = "character") + dates <- as.Date(expected$date) + weeks <- as.numeric(expected$SE) + + expect_equal(vapply(dates, episem, numeric(1)), weeks) + expect_equal(data2SE(expected$date, format = "%Y-%m-%d"), weeks) + + starts <- SE2date(unique(weeks)) + expected_starts <- expected[!duplicated(weeks), c("SE", "start_date")] + expect_equal(starts$SE, as.numeric(expected_starts$SE)) + expect_equal(as.character(starts$ini), expected_starts$start_date) + expect_equal(seqSE(202052, 202101)$SE, c(202052, 202053, 202101)) +}) + +test_that("epidemiological calendar functions preserve types and boundaries", { + expect_equal(epiYear(202010)$eyear, 2019) + expect_equal(epiYear(202041)$eyear, 2020) + expect_equal(epiYear(202030, cut = 31)$eyear, 2019) + expect_equal(epiYear(202031, cut = 31)$eyear, 2020) + + converted <- data2SE(c("03-04-2013", "07-01-2019", "01-03-1998"), + format = "%d-%m-%Y") + expect_type(converted, "double") + expect_true(all(nchar(as.character(converted)) == 6)) + expect_equal(data2SE("03-01-1998", format = "%d-%m-%Y"), 199753) + + expect_equal(episem(as.Date("2015-01-01")), 201453) + expect_equal(episem(as.Date("2015-01-01"), separa = "-"), "2014-53") + expect_equal(episem(as.Date("2015-01-01"), retorna = "Y"), 2014) + expect_equal(episem(as.Date("2015-01-01"), retorna = "W"), 53) + expect_true(is.na(episem(NA))) + expect_equal(episem(as.Date("2017-01-01")), 201701) + expect_equal(episem(as.Date("2016-01-01")), 201552) + expect_equal(vapply(2020:2022, lastepiweek, numeric(1)), c(53, 52, 52)) +}) + +test_that("date conversion results retain their tabular contract", { + starts <- SE2date(c(202001, 202002)) + expect_s3_class(starts, "data.frame") + expect_named(starts, c("SE", "ini")) + expect_equal(nrow(starts), 2) + expect_equal(starts$SE, c(202001, 202002)) + expect_equal(as.character(starts$ini[1]), "2019-12-29") + + days <- daySEday(c("2015-12-23", "2015-10-23", "2022-10-16")) + expect_named(days, c("SE", "ini")) + expect_equal(nrow(days), 3) + expect_equal(days$SE[1], 201551) + expect_equal(as.character(days$ini[1]), "2015-12-23") + expect_equal(as.character(daySEday(202001)$ini), "2019-12-29") +}) + +test_that("algorithmic calendar is equivalent to the legacy SE table", { + legacy <- AlertTools:::SE + valid <- as.integer(format(legacy$Inicio, "%w")) == 0L & + as.numeric(legacy$Termino - legacy$Inicio) == 6 + expect_true(all(valid)) + expect_equal(as.numeric(as_epiweek(legacy$Inicio[valid])), legacy$SE[valid]) + expect_equal(epiweek_start(legacy$SE[valid]), legacy$Inicio[valid]) + expect_equal(epiweek_start(legacy$SE[valid]) + 6L, legacy$Termino[valid]) + expect_equal(epiweek_start(201815), as.Date("2018-04-08")) +}) + +test_that("algorithmic calendar has no fixed annual boundary", { + weeks <- epiweek_seq(190052, 210101) + starts <- epiweek_start(weeks) + + expect_gt(length(weeks), 10000) + expect_equal(as.numeric(diff(starts)), rep(7, length(starts) - 1L)) + expect_equal(as_epiweek(starts), weeks) + expect_equal(as_epiweek(starts + 6L), weeks) + future <- as.Date("2150-07-14") + future_start <- epiweek_start(as_epiweek(future)) + expect_true(future_start <= future && future <= future_start + 6L) +}) + +test_that("epidemiological week validation rejects impossible values", { + expect_error(epiweek_start(202054), "Invalid epidemiological week") + expect_error(epiweek_seq(202101, 202053), "must not be after") + expect_error(epiweek_start(202101.5), "finite integers") + expect_true(is.na(as_epiweek(as.Date(NA)))) + expect_true(is.na(epiweek_start(NA_real_))) +}) + + +test_that("SE 201815 and its neighbors have consistent bundled boundaries", { + period <- seqSE(201814, 201816) + expect_equal(period$SE, c(201814, 201815, 201816)) + expect_equal(period$Inicio, as.Date(c("2018-04-01", "2018-04-08", "2018-04-15"))) + expect_equal(period$Termino, as.Date(c("2018-04-07", "2018-04-14", "2018-04-21"))) + expect_equal(SE2date(201815)$ini, as.Date("2018-04-08")) + + calendar <- get("SE", envir = asNamespace("AlertTools")) + calendar <- calendar[order(calendar$SE), ] + expect_equal(anyDuplicated(calendar$SE), 0L) + expect_true(all(as.integer(calendar$Termino - calendar$Inicio) == 6L)) + expect_equal(calendar$Inicio[-1], head(calendar$Termino, -1) + 1) + expect_equal(vapply(calendar$Inicio, episem, numeric(1)), calendar$SE) + expect_equal(vapply(calendar$Termino, episem, numeric(1)), calendar$SE) + + packaged <- new.env(parent = emptyenv()) + utils::data("SE", package = "AlertTools", envir = packaged) + expect_identical(packaged$SE, get("SE", envir = asNamespace("AlertTools"))) +}) diff --git a/tests/testthat/test-fetch-cases.R b/tests/testthat/test-fetch-cases.R new file mode 100644 index 0000000..aeab2e8 --- /dev/null +++ b/tests/testthat/test-fetch-cases.R @@ -0,0 +1,56 @@ +test_that("getCases has a deterministic SQLite integration contract", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + withr::local_dir(withr::local_tempdir()) + connection <- sqlite_fixture_connection(environment()) + expected <- read_fixture("expected-fetch-cases.csv", stringsAsFactors = FALSE) + + observed <- getCases( + cities = 3304557, + firstday = as.Date("2020-12-20"), + lastday = as.Date("2021-01-09"), + cid10 = "A90", + dataini = "notific", + datasource = connection + ) + + expect_cases_contract(observed, expected) + expect_false(file.exists("caselist.RData")) + expect_s3_class(attr(observed, "case_records"), "data.frame") + expect_equal(nrow(attr(observed, "case_records")), 4) +}) + +test_that("getCases reproduces its contract on ephemeral PostgreSQL", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + withr::local_dir(withr::local_tempdir()) + connection <- postgres_fixture_connection(environment()) + expected <- read_fixture("expected-fetch-cases.csv", stringsAsFactors = FALSE) + + observed <- getCases( + cities = 3304557, + firstday = as.Date("2020-12-20"), + lastday = as.Date("2021-01-09"), + cid10 = "A90", + dataini = "notific", + datasource = connection + ) + + expect_cases_contract(observed, expected) +}) + +test_that("getCases rejects invalid user input before querying", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + connection <- sqlite_fixture_connection(environment()) + + expect_error( + getCases(cities = "3304557", datasource = connection), + "cities should be a vector of numeric geocodes" + ) + expect_error( + getCases(cities = 3304557, dataini = "invalid", datasource = connection), + "dataini should" + ) + expect_error( + getCases(cities = 3304557, cid10 = "B00", datasource = connection), + "Unknown CID-10" + ) +}) diff --git a/tests/testthat/test-fixture-contracts.R b/tests/testthat/test-fixture-contracts.R new file mode 100644 index 0000000..8719adf --- /dev/null +++ b/tests/testthat/test-fixture-contracts.R @@ -0,0 +1,21 @@ +test_that("synthetic fixtures preserve tabular schemas and keys", { + cases <- read_fixture("cases.csv", stringsAsFactors = FALSE) + climate <- read_fixture("climate.csv") + population <- read_fixture("population.csv") + parameters <- read_fixture("parameters.csv", stringsAsFactors = FALSE) + + expect_named(cases, c("SE", "cidade", "CID10", "casos", "cas_prov", "cas_lab", + "localidade", "nome", "pop")) + expect_named(climate, c("SE", "geocodigo", "temp_min", "temp_med", "temp_max", + "umid_min", "umid_med", "umid_max")) + expect_named(population, c("geocode", "year", "pop")) + expect_named(parameters, c("municipio_geocodigo", "limiar_preseason", + "limiar_posseason", "limiar_epidemico", "varcli", + "clicrit", "varcli2", "clicrit2", "cid10", "codmodelo")) + expect_true(all(cases$nome == "Municipio Fixture")) + expect_true(all(cases$CID10 == "A90")) + expect_false(anyDuplicated(cases[c("SE", "cidade", "CID10")]) > 0) + expect_false(anyDuplicated(climate[c("SE", "geocodigo")]) > 0) + expect_false(anyDuplicated(population[c("geocode", "year")]) > 0) + expect_false(anyDuplicated(parameters[c("municipio_geocodigo", "cid10")]) > 0) +}) diff --git a/tests/testthat/test-optional-models.R b/tests/testthat/test-optional-models.R new file mode 100644 index 0000000..927d00d --- /dev/null +++ b/tests/testthat/test-optional-models.R @@ -0,0 +1,11 @@ +test_that("MEM integration is available when its optional dependency is installed", { + skip_if_not_installed("mem") + expect_true(requireNamespace("mem", quietly = TRUE)) + expect_true(is.function(mem::memmodel)) +}) + +test_that("INLA integration is available when its optional dependency is installed", { + skip_if_not_installed("INLA") + expect_true(requireNamespace("INLA", quietly = TRUE)) + expect_true(is.function(INLA::inla)) +}) diff --git a/tests/testthat/test-pipe-infodengue-firstday.R b/tests/testthat/test-pipe-infodengue-firstday.R index bdec6a8..014479e 100644 --- a/tests/testthat/test-pipe-infodengue-firstday.R +++ b/tests/testthat/test-pipe-infodengue-firstday.R @@ -1,41 +1,51 @@ -test_that("pipe_infodengue keeps the source default and forwards an override", { +test_that("pipe_infodengue preserves firstday defaults and historical overrides", { + withr::local_options(list(lifecycle_verbosity = "quiet")) expect_identical(eval(formals(pipe_infodengue)$firstday), as.Date("2018-01-01")) - + connection <- sqlite_fixture_connection(environment()) calls <- list() + climate_starts <- list() local_mocked_bindings( - read.parameters = function(cities, cid10) { - data.frame(municipio_geocodigo = cities) + fetch_alert_parameters = function(conn, geocodes, disease) { + data.frame(municipio_geocodigo = geocodes) + }, + fetch_climate = function(conn, geocodes, climate_vars, start_date, end_date) { + climate_starts[[length(climate_starts) + 1L]] <<- start_date + data.frame() }, - getClima = function(...) data.frame(), - getCases = function(cities, lastday, firstday, cid10, type, - dataini, completetail) { + fetch_cases = function(conn, geocodes, disease, start_date, end_date, + case_date, complete_tail, verbose) { calls[[length(calls) + 1L]] <<- list( - cities = cities, lastday = lastday, firstday = firstday, - cid10 = cid10, type = type, dataini = dataini, - completetail = completetail + conn = conn, geocodes = geocodes, disease = disease, + start_date = start_date, end_date = end_date, case_date = case_date, + complete_tail = complete_tail ) - stop("captured getCases call") + stop("captured fetch_cases call") }, .package = "AlertTools" ) report_end <- as.Date("2026-08-01") - expect_error(pipe_infodengue(2201919, finalday = report_end), - "captured getCases call") - expect_identical(calls[[1L]]$firstday, as.Date("2018-01-01")) - expect_identical(calls[[1L]]$lastday, report_end) + expect_error(pipe_infodengue(2201919, finalday = report_end, + datasource = connection), "captured fetch_cases call") + expect_identical(calls[[1L]]$start_date, as.Date("2018-01-01")) + expect_identical(calls[[1L]]$end_date, report_end) + expect_identical(calls[[1L]]$conn, connection) historical_start <- as.Date("2010-01-03") expect_error(pipe_infodengue(2201919, finalday = report_end, - firstday = historical_start), - "captured getCases call") - expect_identical(calls[[2L]]$firstday, historical_start) - expect_identical(calls[[2L]]$cid10, "A90") - expect_identical(calls[[2L]]$type, "all") + datasource = connection, firstday = historical_start), + "captured fetch_cases call") + expect_identical(calls[[2L]]$start_date, historical_start) + expect_identical(calls[[2L]]$geocodes, 2201919) + expect_identical(calls[[2L]]$disease, "A90") + expect_identical(calls[[2L]]$case_date, "notification") - # The original positional arguments still end at dataini. + # Preserve the positional arguments of both master and the release candidate. expect_error(pipe_infodengue(2201919, "A90", 202630, report_end, - 201001, "none", NULL, FALSE, NULL, NA, - "notific"), "captured getCases call") - expect_identical(calls[[3L]]$firstday, as.Date("2018-01-01")) + 201001, "none", NULL, FALSE, connection, NA, + "notific", 1L, NULL, FALSE, report_end), + "captured fetch_cases call") + expect_identical(calls[[3L]]$start_date, as.Date("2018-01-01")) + expect_identical(calls[[3L]]$end_date, epiweek_start(202630) + 6L) + expect_identical(climate_starts, rep(list(epiweek_start(201001)), 3L)) }) diff --git a/tests/testthat/test-remove-tweet-historical-alerts.R b/tests/testthat/test-remove-tweet-historical-alerts.R index 1fe2488..fa8266b 100644 --- a/tests/testthat/test-remove-tweet-historical-alerts.R +++ b/tests/testthat/test-remove-tweet-historical-alerts.R @@ -1,11 +1,3 @@ -library(assertthat) -library(dplyr) -library(purrr) -library(stringr) - -source(testthat::test_path("..", "..", "R", "utility_tools.R")) -source(testthat::test_path("..", "..", "R", "alert_functions.R")) - historical_alert_input <- function(include_tweet = TRUE) { data <- data.frame( cidade = 3304557, @@ -41,26 +33,22 @@ historical_alert_input <- function(include_tweet = TRUE) { } test_that("tabela_historico excludes legacy tweet input", { - alert_environment <- environment(tabela_historico) - original_read_parameters <- get("read.parameters", envir = alert_environment) - original_SE2date <- get("SE2date", envir = alert_environment) - assign("read.parameters", function(...) { - data.frame( - municipio_geocodigo = 3304557, - limiar_preseason = 5, - limiar_epidemico = 15 - ) - }, envir = alert_environment) - on.exit(assign("read.parameters", original_read_parameters, - envir = alert_environment), add = TRUE) - assign("SE2date", function(se) { - data.frame(SE = se, ini = as.Date("2024-01-01")) - }, envir = alert_environment) - on.exit(assign("SE2date", original_SE2date, envir = alert_environment), - add = TRUE) - - with_tweet <- tabela_historico(historical_alert_input(TRUE)) - without_tweet <- tabela_historico(historical_alert_input(FALSE)) + withr::local_options(list(lifecycle_verbosity = "quiet")) + parameters <- data.frame( + municipio_geocodigo = 3304557, + limiar_preseason = 5, + limiar_epidemico = 15 + ) + with_tweet <- tabela_historico( + historical_alert_input(TRUE), + versao = as.Date("2024-01-01"), + parameters = parameters + ) + without_tweet <- tabela_historico( + historical_alert_input(FALSE), + versao = as.Date("2024-01-01"), + parameters = parameters + ) expect_false("tweet" %in% names(with_tweet)) expect_false("tweet" %in% names(without_tweet)) @@ -100,6 +88,7 @@ historical_alert_row <- function(cid10) { } test_that("write_alerta SQL omits tweet for every disease table", { + withr::local_options(list(lifecycle_verbosity = "quiet")) expected_tables <- c( A90 = "Historico_alerta", "A92.0" = "Historico_alerta_chik", diff --git a/tests/testthat/test-rt.R b/tests/testthat/test-rt.R new file mode 100644 index 0000000..0eb634a --- /dev/null +++ b/tests/testthat/test-rt.R @@ -0,0 +1,20 @@ +test_that("Rt numerical regression baseline is preserved", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + expected <- read_fixture("expected-rt.csv") + observed <- Rt( + expected[c("SE", "casos")], + count = "casos", + gtdist = "normal", + meangt = 3, + sdgt = 1 + ) + + expect_named(observed, names(expected)) + expect_equal(nrow(observed), nrow(expected)) + expect_equal(observed$SE, expected$SE) + expect_equal(observed$casos, expected$casos) + expect_equal(observed$Rt, expected$Rt, tolerance = 1e-7) + expect_equal(observed$lwr, expected$lwr, tolerance = 1e-7) + expect_equal(observed$upr, expected$upr, tolerance = 1e-7) + expect_equal(observed$p1, expected$p1, tolerance = 1e-7) +}) diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R new file mode 100644 index 0000000..8ffe98d --- /dev/null +++ b/tests/testthat/test-utilities.R @@ -0,0 +1,39 @@ +test_that("municipal geocode conversion preserves regular and exceptional cases", { + expect_equal(sevendigitgeocode(330455), 3304557) + expect_equal(sevendigitgeocode(355030), 3550308) + expect_equal(sevendigitgeocode(3304557), 3304557) + expect_equal(sevendigitgeocode(261153), 2611533) + expect_equal(sevendigitgeocode(220191), 2201919) + expect_error(sevendigitgeocode(123), + "this funtion receives 6 digits geocodes only", fixed = TRUE) +}) + +test_that("missing values are filled by the selected deterministic rule", { + values <- c(1, 2, NA, 4, 5) + expect_equal(nafill(values, rule = "zero"), c(1, 2, 0, 4, 5)) + expect_equal(nafill(values, rule = "linear"), c(1, 2, 3, 4, 5)) +}) + +test_that("temperature extrapolation preserves length and removes tail gaps", { + values <- sin(seq(0, 10, length.out = 100)) + 20 + values[91:100] <- NA + + expect_message(observed <- temp.predict(values), "temperature predicted 10 steps ahead") + expect_length(observed, 100) + expect_false(anyNA(observed)) +}) + +test_that("database functions validate absent connections and malformed input", { + withr::local_options(list(lifecycle_verbosity = "quiet")) + expect_error(getRegionais(uf = "Rio de Janeiro", datasource = NULL)) + expect_error(getRegionais(), "getRegionais: please specify uf") + expect_error(getCidades(uf = "Rio de Janeiro", datasource = NULL)) + expect_error(getCidades(), "getCidades: specify uf's full name") + expect_error(read.parameters(cities = 330455, datasource = NULL)) + expect_error(write_parameters(city = 3304557, cid10 = "A90", params = list()), + "params should be a data.frame") + expect_error(write_parameters(city = 3304557, cid10 = "A90", + params = data.frame(), datasource = NULL)) + expect_error(getWUstation(cities = 3304557, datasource = NULL)) + expect_error(setWUstation(st = data.frame(), UF = "Rio de Janeiro", datasource = NULL)) +}) diff --git a/tests/testthat/test_alertfunctions.R b/tests/testthat/test_alertfunctions.R deleted file mode 100755 index 8ea0b29..0000000 --- a/tests/testthat/test_alertfunctions.R +++ /dev/null @@ -1,79 +0,0 @@ -## Testing the alert_functions #### - -setwd("../..") - -# cities for testing -geoc = c(3302403, 3205200) - -# -# Testing setcriteria -------------------------- -# -# common use -val = c(varcli ="temp_min", "clicrit"="22","limiar_preseason"="10","limiar_epidemico"="100") -criteria = setCriteria(rule="Af",values=val) - -test_that("setcriteria: produces required input error messages", { - expect_error(setCriteria(rule="XX"),"setcriteria: rule unknown.") - expect_error(setCriteria(), "if rule is null, values must be provided") -}) - -test_that("setcriteria: produce required output",{ - expect_named(criteria, c("crity", "crito", "critr")) - classes <- sapply(criteria,class) - expect_equal(classes, c(crity = "character", crito = "character", critr = "character")) - expect_equal(sapply(criteria,length), c(crity =3, crito =3, critr =3)) -}) - - -# -# Testing the fouralert function ------------------ -# - - -cas = getCases(cities = geoc[1], cid10 = "A90", datasource=con) %>% - Rt(count = "casos",gtdist="normal", meangt=3, sdgt = 1) %>% - mutate(inc = casos/pop*100000) -cli = getWU(stations = 'SBGL', vars=c("temp_min"), datasource=con) %>% - mutate(temp_min = nafill(temp_min, rule = "arima")) -ale <- plyr::join_all(list(cas,cli),by="SE") -resf <- fouralert(ale, crit = criteria) - -#test_that("fouralert: produces required input error messages", { - #expect_error(fouralert(cities = "Rio"),"cities should be a vector of numeric geocodes") - #expect_error(getCases(cities=222222), "one or more cities not found") -#}) - -test_that("fouralert: produces the required output", { - expect_named(resf, c("data", "indices", "crit", "n")) - expect_equal(sapply(resf,class), c(data = "data.frame", indices = "data.frame", - crit = "list", n = "numeric")) - expect_equal(class(resf),"alerta") -}) - -#critgy <- c("temp_min > 22 | tweet > 80", 3, 3) -#alerta <- twoalert(d0, cy = critgy) - -#test_that("twoalert has the minimum set of items.", { -# expect_true(all(c("data", "indices", "rules","n") %in% names(alerta))) -#}) - -# Testing pipe_infodengue_intra REFAZER ---------------------- - -# common use -# params <- c(varcli ="temp_min", clicrit=22, limiar_epidemico=100, limiar_preseason = 14.15) -# criter <- setCriteria(rule="Af", values = params) -# alerio <- pipe_infodengue_intra(crit = criter, se=201304, delaymethod="fixedprob") -# -# test_that("alertrio: produces the required output", { -# expect_named(alerio, c("APS 1", "APS 2.1", "APS 2.2")) -# expect_named(alerio[[1]], c("data", "indices", "crit", "n")) -# expect_named(alerio[[1]]$data, c("localidadeid","SE","casos","localidade","populacao", -# "cidade","nome","CID10","tcasesICmin","tcasesmed", -# "tcasesICmax","pdig","Rt","lwr","upr","p1","inc", -# "estacao","temp_min","tweet")) -# expect_named(alerio[[1]]$indices, c("cytrue","nytrue","cotrue","notrue","crtrue", -# "nrtrue","level")) -# expect_equal(class(alerio[[1]]), "alerta") -# }) - - diff --git a/tests/testthat/test_timeseriespipeline.R b/tests/testthat/test_timeseriespipeline.R deleted file mode 100755 index 774b935..0000000 --- a/tests/testthat/test_timeseriespipeline.R +++ /dev/null @@ -1,160 +0,0 @@ -setwd("../..") -require(assertthat) -require(tidyverse) - -## testando conexão com o banco -#con <-DenguedbConnect() # -#test_that("sql connection exists", { -# expect_equal(class(con)[1], "PostgreSQLConnection") -#}) - -geoc = c(3304557, 3205200) # cidade para teste - -# ===================================== -## Testing function getCases ========== -#====================================== -# args:cities, lastday = Sys.Date(), cid10 = "A90", dataini = "notific", -#datasource=con - -# common use -dC0 = getCases(cities = geoc, firstday = as.Date("2023-01-01"), - dataini = "sinpri", datasource=con) - -test_that("getCases: produces required input error messages", { - expect_error(getCases(cities = "Rio"),"cities should be a vector of numeric geocodes") - #expect_error(getCases(cities=222222), "one or more cities not found") - #expect_error_getCases(cities = c(3302403, 999999), "one or more cities not found") - #expect_error(getCases(cities = 3302403, cid10 = "A99"),"cid10 unknown") - #expect_error(getCases(cities = 3302403, cid10 = "dengue"),"cid10 should be a code, p.e. A92") - #expect_error(getCases(cities = 3302403, lastday = "20-12-2019"),"check lastday's format") - #expect_error(getCases(cities = 3302403, lastday = "1980-12-01"),"lastday should be 2010-01-01 or more recent") - #expect_error(getCases(cities = 3302403, dataini = "abc"),"check dataini argument, it seems incorrect") -}) - - -#test_that("getcases: produce required warnings",{ - #expect_message(getCases(cities = 3302403, lastday = "2050-12-31"),"this date is greater than the lastday, returning the most recent data available") -#}) - -#test_that("getcases: produce required output",{ -# classes <- sapply(dC0,class) -# expect_equal(sapply(dC0,class), c("SE"="numeric","cidade"="numeric", -# "CID10"="character","casos"="numeric", -# "localidade"="numeric","nome"="character", -# "pop"="numeric")) -# expect_equal(sum(sapply(dC0, anyNA)),0) # no NAs - -#}) - -## - -## ===================================== -# Testing getWU function =============== -# ===================================== -# args: vars = "temp_min", finalday = Sys.Date(), datasource=con -sta <- c('SBAF','SBRJ') -wuvars <- c("temp_min","temp_max","temp_med","umid_min","umid_med","umid_max", - "pressao_min","pressao_med","pressao_max") - -dW01 = getWU(stations = sta, vars = wuvars, datasource=con) #default var is temp_min - -test_that("getWU: produces required input error messages", { - #expect_error(getWU(stations = 'SBGL', lastday = "20-12-2019"),"check lastday's format") - #expect_error(getWU(stations = 'SBGL', lastday = "1980-12-01"),"lastday should be 2010-01-01 or more recent") -}) - -test_that("output of getWU has the required columns.", { - expect_named(dW01, c("estacao","SE", wuvars),ignore.order = TRUE) - expect_equal(sapply(dW01,class), c("estacao"="character",SE="numeric", - "temp_min"="numeric","temp_med"="numeric","temp_max"="numeric", - "umid_min"="numeric","umid_med"="numeric","umid_max"="numeric", - "pressao_min"="numeric","pressao_med"="numeric","pressao_max"="numeric")) - expect_equal(sum(sapply(dW01[,c("estacao","SE")], anyNA)),0) # no NAs -}) - -### ===================================== -# Testing the adjustIncidence function -### ===================================== - -# check consistency between data used in getCases and nowcasting functions -# both must use similar filters -require(INLA) - -dC0a <- dC0 %>% filter(cidade == geoc[1]) -dC2 <- adjustIncidence(dC0a, method = "bayesian", nyears = 1, nowSE = max(dC0a$SE)) -# args: obj, method = "", pdig = plnorm((1:20)*7, 2.5016, 1.1013), -# Dmax=12, nyears = 3, datasource = con, lastSE=NA - -test_that("adjustIncidence: produce required output",{ - required_output = c("casos","tcasesICmin","tcasesmed","tcasesICmax") - # bayesian - expect_true(all(required_output %in% names(dC2))) -}) - -test_that("adjustIncidence: tcasesmed >= casos",{ - expect_true(all(dC2$tcasesmed >= dC2$casos, na.rm = TRUE)) -}) - -# Testing the internal bayesian adjust incidence functions -### ===================================== -#q0 <- getdelaydata(cities=geoc, years=2016:2017, datasource=con) -#q1 <- getdelaydata(cities=330455, years=2017, datasource=con) - -#res0 = delaycalc(q0) -#test_that("delayCalc: runnoff matrix contains all valid cases", { -# expect_true(sum(res0$delay.tbl$Notifications) == nrow(q0)) -#}) - -# incluir teste se a sequencia de semanas epidemiologicas esta correta - -#out0<-fitDelay.inla(res0) -#delay <- prob.inc(out0, plotar = F) - -#test_that("prob.inc: returns a matrix", { -# expect_true(class(delay) == "matrix") -#}) - -#test_that("prob.inc: returns a non-empty matrix", { -# expect_true(all(is.na(delay)) == FALSE) -#}) - - -### ===================== -# Testing Rt functions -### ===================== -# Rt com dist normal sem temp dep -# args: count = "casos", gtdist, meangt, sdgt, CI = "beta", alpha = .95, a0 = 2 , b0 = 3 -# different ways to run it -dC00 <- dC0 %>% - Rt(., count = "casos", gtdist="normal", meangt=3, sdgt = 1) -dC10<-dC1 %>% - Rt(., count = "tcasesmed", gtdist="normal", meangt=3, sdgt = 1) - -test_that("output of Rt has the required columns.", { - expect_true(all(c("SE", "casos", "Rt", "lwr", "upr") %in% names(dC00))) - expect_true(all(c("SE", "casos", "Rt", "lwr", "upr") %in% names(dC10))) -}) - -test_that("Rt: produce valid estimates",{ - # casos - expect_true(min(dC00$Rt, na.rm=TRUE) >= 0) - expect_true(min(dC00$lwr, na.rm=TRUE) >= 0) - expect_true(min(dC00$upr, na.rm=TRUE) >= 0) - # casosest - expect_true(min(dC10$Rt, na.rm=TRUE) >= 0) - expect_true(min(dC10$lwr, na.rm=TRUE) >= 0) - expect_true(min(dC10$upr, na.rm=TRUE) >= 0) -}) - -# ---------------------- -# Testing getTweet function -# ---------------------- -#dT01 = getTweet(city = geoc, lastday = Sys.Date(), datasource = con) - -#test_that("output of getTweet has the required columns.", { -# expect_true(all(c("cidade", "SE", "tweet") %in% names(dT01))) -#}) - - - - diff --git a/tests/testthat/test_utilityfunctions.R b/tests/testthat/test_utilityfunctions.R deleted file mode 100644 index f8a88ab..0000000 --- a/tests/testthat/test_utilityfunctions.R +++ /dev/null @@ -1,182 +0,0 @@ -library(assertthat) -library(tidyverse) - -####================================================ -# Testing functions episem, data2SE, SE2date, seqSE. epiyear -####================================================ - -# epiYear -test_that("epiYear correctly identifies epidemiological years", { - # Default cut = 41 - expect_equal(epiYear(202010)$eyear, 2019) # Before cut - expect_equal(epiYear(202041)$eyear, 2020) # At cut - expect_equal(epiYear(202045)$eyear, 2020) # After cut - - # Custom cut - expect_equal(epiYear(202030, cut = 31)$eyear, 2019) - expect_equal(epiYear(202031, cut = 31)$eyear, 2020) -}) - -# data2SE -out1 <- data2SE(c("03-04-2013","07-01-2019","01-03-1998"),format="%d-%m-%Y") - -test_that("data2SE output should be numeric", { - expect_type(out1, "double") -}) - -test_that("data2SE output should have 6 digits when converted to numeric", { - expect_true(all(nchar(as.character(out1)) == 6)) -}) - -test_that("data2SE for 01-03-1998 should reflect epiweek 53 of 1997", { - # 1998-03-01 is a Sunday. - # episem("1998-03-01") -> let's see - expect_equal(data2SE("03-01-1998", format="%d-%m-%Y"), 199753) -}) - -# SE2date -test_that("SE2date output structure and values", { - # SE2date relies on the 'SE' object being present (usually from sysdata.rda) - # We assume it is loaded via devtools::load_all() - out_se2d <- SE2date(se = c(202001, 202002)) - expect_equal(dim(out_se2d), c(2, 2)) - expect_equal(out_se2d$SE[1], 202001) - # Week 1 of 2020 started on 2019-12-29 - expect_equal(as.character(out_se2d$ini[1]), "2019-12-29") -}) - -# daySEday -test_that("daySEday output structure and values", { - out_dsd <- daySEday(x = c("2015-12-23", "2015-10-23", "2022-10-16")) - expect_equal(dim(out_dsd), c(3, 2)) - expect_equal(out_dsd$SE[1], 201551) - expect_equal(as.character(out_dsd$ini[1]), "2015-12-23") - - # Testing with numeric input - out_dsd_num <- daySEday(x = 202001) - expect_equal(as.character(out_dsd_num$ini[1]), "2019-12-29") -}) - -# episem -test_that("episem output types and formats", { - # numeric output - out_num <- episem(x= as.Date("2015-01-01", format="%Y-%m-%d"), separa = '') - expect_type(out_num, "double") - expect_equal(out_num, 201453) - - # character output - out_char <- episem(x= as.Date("2015-01-01", format="%Y-%m-%d"), separa = '-') - expect_type(out_char, "character") - expect_equal(out_char, "2014-53") - - # year only - expect_equal(episem(x= as.Date("2015-01-01", format="%Y-%m-%d"), retorna = "Y"), 2014) - - # week only - expect_equal(episem(x= as.Date("2015-01-01", format="%Y-%m-%d"), retorna = "W"), 53) - - # edge cases - expect_true(is.na(episem(NA))) - expect_equal(episem(as.Date("2017-01-01")), 201701) # Jan 1st 2017 was Sunday - expect_equal(episem(as.Date("2016-01-01")), 201552) # Jan 1st 2016 was Friday -}) - -# lastepiweek -test_that("lastepiweek identifies the correct last week", { - expect_equal(lastepiweek(2020), 53) - expect_equal(lastepiweek(2021), 52) - expect_equal(lastepiweek(2022), 52) -}) - -# seqSE -test_that("seqSE generates correct sequence", { - sq <- seqSE(202001, 202003) - expect_equal(nrow(sq), 3) - expect_equal(sq$SE, c(202001, 202002, 202003)) -}) - -test_that("SE 201815 has the correct epidemiological boundaries", { - period <- seqSE(201814, 201816) - - expect_equal(period$SE, c(201814, 201815, 201816)) - expect_equal(period$Inicio, as.Date(c("2018-04-01", "2018-04-08", "2018-04-15"))) - expect_equal(period$Termino, as.Date(c("2018-04-07", "2018-04-14", "2018-04-21"))) - expect_equal(SE2date(201815)$ini, as.Date("2018-04-08")) -}) - -test_that("bundled SE calendar has continuous seven-day weeks", { - calendar <- get("SE", envir = asNamespace("AlertTools")) - calendar <- calendar[order(calendar$SE), ] - - expect_equal(anyDuplicated(calendar$SE), 0L) - expect_true(all(as.integer(calendar$Termino - calendar$Inicio) == 6L)) - expect_equal(calendar$Inicio[-1], head(calendar$Termino, -1) + 1) - expect_equal(vapply(calendar$Inicio, episem, numeric(1)), calendar$SE) - expect_equal(vapply(calendar$Termino, episem, numeric(1)), calendar$SE) -}) - -# sevendigitgeocode -test_that("sevendigitgeocode works for regular and special cases", { - # Regular cases - expect_equal(sevendigitgeocode(330455), 3304557) - expect_equal(sevendigitgeocode(355030), 3550308) # São Paulo - - # Already 7 digits - expect_equal(sevendigitgeocode(3304557), 3304557) - - # Pathological cases - expect_equal(sevendigitgeocode(261153), 2611533) # Recife - expect_equal(sevendigitgeocode(220191), 2201919) - - # Errors - expect_error(sevendigitgeocode(123), "this funtion receives 6 digits geocodes only") -}) - -# nafill -test_that("nafill works correctly", { - v <- c(1, 2, NA, 4, 5) - expect_equal(nafill(v, rule = "zero"), c(1, 2, 0, 4, 5)) - expect_equal(nafill(v, rule = "linear"), c(1, 2, 3, 4, 5)) -}) - -# temp.predict -test_that("temp.predict extrapolates values", { - # Create a seasonal-like series with NAs at the end - v <- sin(seq(0, 10, length.out = 100)) + 20 - v_with_nas <- v - v_with_nas[91:100] <- NA - - # Mocking message to avoid output clutter - expect_message(out <- temp.predict(v_with_nas), "temperature predicted 10 steps ahead") - expect_equal(length(out), 100) - expect_false(any(is.na(out))) -}) - -####================================== -# getRegional e getCidades (Database dependent) ---- -####================================== - -test_that("Database functions handle missing connection or bad inputs", { - # Since we don't have a real DB connection, we verify they fail as expected - # getRegionais - expect_error(getRegionais(uf = "Rio de Janeiro", datasource = NULL)) - expect_error(getRegionais(), "getRegionais: please specify uf") - - # getCidades - expect_error(getCidades(uf = "Rio de Janeiro", datasource = NULL)) - expect_error(getCidades(), "getCidades: specify uf's full name") - - # read.parameters - # Should fail because it tries to convert cities to 7 digits then query - expect_error(read.parameters(cities = 330455, datasource = NULL)) - - # write_parameters - expect_error(write_parameters(city = 3304557, cid10 = "A90", params = list()), "params should be a data.frame") - expect_error(write_parameters(city = 3304557, cid10 = "A90", params = data.frame(), datasource = NULL)) - - # getWUstation - expect_error(getWUstation(cities = 3304557, datasource = NULL)) - - # setWUstation - expect_error(setWUstation(st = data.frame(), UF = "Rio de Janeiro", datasource = NULL)) -}) diff --git a/tools/check-migration-readiness.R b/tools/check-migration-readiness.R new file mode 100644 index 0000000..9b00d9c --- /dev/null +++ b/tools/check-migration-readiness.R @@ -0,0 +1,126 @@ +args <- commandArgs(trailingOnly = TRUE) +for_removal <- "--for-removal" %in% args + +registry_path <- file.path("docs", "refactoring", "consumer-registry.csv") +policy_path <- file.path("docs", "refactoring", "transition-policy.dcf") + +if (!file.exists(registry_path) || !file.exists(policy_path)) { + stop("Run this script from the AlertTools repository root.", call. = FALSE) +} + +registry <- utils::read.csv( + registry_path, + stringsAsFactors = FALSE, + check.names = FALSE, + na.strings = "" +) +policy <- as.list(read.dcf(policy_path)[1, ]) + +legacy_api <- c( + "getCases", "getCaseslist", "getClima", "read.parameters", + "pipe_infodengue", "Rt", "adjustIncidence", "setCriteria", "fouralert", + "tabela_historico", "write_alerta", "write_parameters" +) + +r_files <- list.files("R", pattern = "\\.[Rr]$", full.names = TRUE) +internal_legacy_calls <- character() +for (r_file in r_files) { + lines <- readLines(r_file, warn = FALSE) + for (line_number in seq_along(lines)) { + line <- lines[[line_number]] + if (grepl("^\\s*#", line) || grepl("\\.deprecate_api\\(", line)) { + next + } + code_line <- sub("\\s+#.*$", "", line) + for (api in legacy_api) { + call_pattern <- paste0("\\b", gsub("\\.", "\\\\.", api), "\\s*\\(") + definition_pattern <- paste0( + "^\\s*", gsub("\\.", "\\\\.", api), "\\s*<-\\s*function\\b" + ) + if (grepl(call_pattern, code_line) && !grepl(definition_pattern, code_line)) { + internal_legacy_calls <- c( + internal_legacy_calls, + paste0(r_file, ":", line_number, ": ", trimws(line)) + ) + } + } + } +} + +if (length(internal_legacy_calls)) { + stop( + "Legacy API calls reintroduced in package code:\n", + paste(unique(internal_legacy_calls), collapse = "\n"), + call. = FALSE + ) +} + +required_columns <- c( + "consumer_id", "repository", "path", "legacy_api", "criticality", + "owner", "status", "last_checked", "evidence", "blocker", "rollback" +) +missing_columns <- setdiff(required_columns, names(registry)) +if (length(missing_columns)) { + stop( + "Consumer registry is missing columns: ", + paste(missing_columns, collapse = ", "), + call. = FALSE + ) +} + +allowed_status <- c("discovered", "planned", "migrating", "validated", "retired") +invalid_status <- setdiff(unique(registry$status), allowed_status) +if (length(invalid_status)) { + stop("Invalid consumer status: ", paste(invalid_status, collapse = ", "), call. = FALSE) +} + +allowed_criticality <- c("critical", "high", "medium", "low") +invalid_criticality <- setdiff(unique(registry$criticality), allowed_criticality) +if (length(invalid_criticality)) { + stop( + "Invalid consumer criticality: ", + paste(invalid_criticality, collapse = ", "), + call. = FALSE + ) +} + +if (anyDuplicated(registry$consumer_id)) { + stop("Consumer IDs must be unique.", call. = FALSE) +} + +if (any(!nzchar(registry$rollback))) { + stop("Every consumer must have a rollback plan.", call. = FALSE) +} + +blocking <- registry[ + registry$criticality %in% c("critical", "high") & + !registry$status %in% c("validated", "retired"), + , + drop = FALSE +] + +cat("Migration inventory:", nrow(registry), "consumers\n") +cat("Internal operational legacy calls: 0\n") +cat("Critical/high consumers pending:", nrow(blocking), "\n") +cat("Transition policy:", policy$Status, "\n") + +if (nrow(blocking)) { + cat("Pending IDs:", paste(blocking$consumer_id, collapse = ", "), "\n") +} + +if (for_removal) { + policy_approved <- identical(unname(policy$Status), "approved") + if (!policy_approved || nrow(blocking)) { + stop( + "Legacy API removal is blocked: approve the support policy and validate ", + "or retire every critical/high consumer.", + call. = FALSE + ) + } + cat("Legacy API removal gate: READY\n") +} else { + cat("Registry integrity: OK\n") + if (nrow(blocking)) { + cat("Legacy API removal gate: BLOCKED (expected during transition)\n") + } +} diff --git a/tools/style.R b/tools/style.R new file mode 100644 index 0000000..f5bc992 --- /dev/null +++ b/tools/style.R @@ -0,0 +1,27 @@ +if (!requireNamespace("styler", quietly = TRUE)) { + stop("Install the suggested package 'styler' before running this script.") +} + +files <- c( + "R/api.R", + "R/core_pipeline.R", + "R/data_repository.R", + "R/epiweek.R", + "tests/testthat/test-api.R", + "tests/testthat/test-core-pipeline.R", + "tests/testthat/test-data-repository.R", + "tests/testthat/test-epiweek.R" +) + +missing_files <- files[!file.exists(files)] +if (length(missing_files)) { + stop("Run tools/style.R from the package root. Missing: ", + paste(missing_files, collapse = ", ")) +} + +styler::style_file(files, strict = TRUE) + +message( + "Review and commit style-only changes separately from functional changes, ", + "then rerun devtools::test() and devtools::check()." +) diff --git a/vignettes/database-pipeline.Rmd b/vignettes/database-pipeline.Rmd new file mode 100644 index 0000000..beb3576 --- /dev/null +++ b/vignettes/database-pipeline.Rmd @@ -0,0 +1,76 @@ +--- +title: "Pipeline com uma conexão DBI" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Pipeline com uma conexão DBI} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>") +has_sqlite <- requireNamespace("RSQLite", quietly = TRUE) +``` + +A API de banco separa três operações: buscar, calcular e escrever. A conexão +DBI é sempre explícita. Este documento usa SQLite em memória; não acessa +produção e não exige credenciais. + +## Demonstração autocontida + +O script incluído no pacote cria tabelas sintéticas temporárias, usa +`fetch_alert_inputs()` e `fetch_alert_parameters()` e fecha a conexão após o +cálculo. + +```{r sqlite-example, eval=has_sqlite} +example_file <- system.file( + "examples", "sqlite-pipeline.R", + package = "AlertTools" +) +if (!nzchar(example_file)) { + example_file <- file.path("..", "inst", "examples", "sqlite-pipeline.R") +} +sys.source(example_file, envir = environment()) +result +``` + +```{r sqlite-missing, eval=!has_sqlite, echo=FALSE, results='asis'} +cat("Instale `RSQLite` para executar a demonstração autocontida.\n") +``` + +## PostgreSQL operacional + +Em produção, construa a conexão fora do pacote e obtenha segredos pelo +mecanismo adotado pela organização. O exemplo abaixo é propositalmente não +executado e não contém valores sensíveis. + +```{r postgres, eval=FALSE} +conn <- DBI::dbConnect( + RPostgres::Postgres(), + dbname = Sys.getenv("INFODENGUE_DB"), + host = Sys.getenv("INFODENGUE_DB_HOST"), + user = Sys.getenv("INFODENGUE_DB_USER"), + password = Sys.getenv("INFODENGUE_DB_PASSWORD") +) +on.exit(DBI::dbDisconnect(conn), add = TRUE) + +inputs <- fetch_alert_inputs( + conn = conn, + geocodes = 3304557, + disease = "dengue", + start_week = 202501, + report_week = 202512 +) +parameters <- fetch_alert_parameters(conn, 3304557, "dengue") +result <- run_alert_pipeline(inputs, parameters, nowcast = "none") + +write_alert_results( + conn, + result, + version_date = as.Date("2026-09-05"), + conflict = "update" +) +``` + +Use uma conexão de teste descartável para integração. Nunca execute a suíte +contra o banco operacional. diff --git a/vignettes/in-memory-pipeline.Rmd b/vignettes/in-memory-pipeline.Rmd new file mode 100644 index 0000000..f2266d2 --- /dev/null +++ b/vignettes/in-memory-pipeline.Rmd @@ -0,0 +1,67 @@ +--- +title: "Pipeline reproduzível sem banco" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Pipeline reproduzível sem banco} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>") +``` + +Esta vignette executa o núcleo do AlertTools somente com objetos em memória. +Não há conexão, arquivo temporário, credencial ou estado global. + +## Exemplo completo + +O pacote distribui um script sintético executável. Ele cria doze semanas de +casos e clima, constrói `alerttools_inputs` e executa o pipeline sem nowcasting. + +```{r run-example} +example_file <- system.file( + "examples", "in-memory-pipeline.R", + package = "AlertTools" +) +if (!nzchar(example_file)) { + example_file <- file.path("..", "inst", "examples", "in-memory-pipeline.R") +} +sys.source(example_file, envir = environment()) +``` + +As entradas possuem um contrato explícito e o resultado contém cálculo, +alertas, parâmetros, metadados e diagnósticos. + +```{r inspect} +inputs +result +summary(result) +head(as.data.frame(result)) +``` + +## Substituindo pelos seus dados + +`cases` deve ser unicamente identificado por `cidade`, `CID10` e `SE`. +`climate` usa a chave `geocodigo`, `SE`. Se `cases` não contiver `pop`, forneça +uma tabela de população separada. + +```{r custom-inputs, eval=FALSE} +inputs <- new_alert_inputs( + cases = my_weekly_cases, + climate = my_weekly_climate, + population = my_population, + metadata = list(source = "estudo reproduzível") +) + +result <- run_alert_pipeline( + inputs, + parameters = my_alert_parameters, + report_week = 202512, + nowcast = "none", + workers = 1 +) +``` + +Para nowcasting bayesiano, inclua `case_records`, defina `seed` e instale INLA. +O modo `none` é determinístico sem configuração adicional. diff --git a/vignettes/migrating-to-snake-case.Rmd b/vignettes/migrating-to-snake-case.Rmd new file mode 100644 index 0000000..1120459 --- /dev/null +++ b/vignettes/migrating-to-snake-case.Rmd @@ -0,0 +1,84 @@ +--- +title: "Migração para a API snake_case" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Migração para a API snake_case} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>") +``` + +A API legada continua disponível, mas os wrappers depreciados indicam sua +substituição. Migre primeiro a leitura, depois o cálculo e por fim a escrita. + +| API legada | API nova | +|---|---| +| `getCases()` | `fetch_cases()` | +| `getCaseslist()` | `fetch_case_records()` | +| `getClima()` | `fetch_climate()` | +| `read.parameters()` | `fetch_alert_parameters()` | +| `pipe_infodengue()` | `fetch_alert_inputs()` + `run_alert_pipeline()` | +| `Rt()` | `estimate_rt()` | +| `adjustIncidence()` | `nowcast_cases()` | +| `setCriteria()` | `define_alert_rules()` | +| `fouralert()` | `classify_alerts()` | +| `tabela_historico()` | `as_alert_history()` | +| `write_alerta()` | `write_alert_results()` | +| `write_parameters()` | `upsert_alert_parameters()` | + +## Mudanças de vocabulário + +- `datasource` torna-se `conn`; +- `cities` torna-se `geocodes`; +- `cid10` torna-se `disease` e aceita nomes de domínio; +- `firstday` e `lastday` tornam-se `start_date` e `end_date`; +- `iniSE` e `datarelatorio` tornam-se `start_week` e `report_week`; +- `nowcasting` torna-se `nowcast`. + +## Separação do pipeline + +```{r migration-example, eval=FALSE} +# Legado: leitura, cálculo e escrita podiam partir de uma única chamada. +old_result <- pipe_infodengue( + cities = 3304557, + cid10 = "A90", + datarelatorio = 202512, + iniSE = 202501, + datasource = conn +) + +# Novo: efeitos externos ficam visíveis no código. +inputs <- fetch_alert_inputs( + conn, 3304557, "dengue", + start_week = 202501, + report_week = 202512 +) +parameters <- fetch_alert_parameters(conn, 3304557, "dengue") +result <- run_alert_pipeline(inputs, parameters, nowcast = "none") +write_alert_results(conn, result, version_date = as.Date("2026-09-05")) +``` + +Consulte também a tabela detalhada em +`docs/refactoring/api-migration.md`. Interfaces legadas somente serão removidas +após a janela de suporte e a migração dos consumidores críticos. + +## Validar um consumidor + +Migre um consumidor por vez e preserve sua versão anterior como rollback. A +validação precisa comparar schema, cardinalidade, Rt, intervalos, casos +estimados e níveis de alerta, incluindo viradas de ano e semana 53. Durante os +testes, torne todos os avisos de depreciação visíveis: + +```{r lifecycle-monitoring, eval=FALSE} +options(lifecycle_verbosity = "warning") +``` + +O repositório mantém um inventário de consumidores conhecidos e um gate que +impede remoções enquanto existirem sistemas críticos pendentes. A sequência +proposta inicia warnings formais na versão 1.3.0, usa a linha 1.4.x para a +transição e torna a 2.0.0 apenas elegível — não automaticamente autorizada — +para remoções. A duração temporal da janela ainda depende de aprovação dos +mantenedores.