diff --git a/.Rbuildignore b/.Rbuildignore index e262b35..cb1ea78 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -3,5 +3,5 @@ ^\.github$ ^LICENSE\.md$ ^quarto\.qmd$ -^quarto\.qmd$ ^README\.qmd$ +^CITATION\.cff$ diff --git a/CITATION.cff b/CITATION.cff new file mode 100644 index 0000000..b3f436e --- /dev/null +++ b/CITATION.cff @@ -0,0 +1,430 @@ +# ------------------------------------------------ +# CITATION.cff file created with {cffr} R package +# See also: https://docs.ropensci.org/cffr/ +# ------------------------------------------------ + +cff-version: 1.2.0 +message: 'To cite package "mwanaApp" in publications use:' +type: software +license: GPL-3.0-or-later +title: 'mwanaApp: mwana GUI' +version: 0.2.2 +abstract: A seamless graphical interface to the mwana R package for data wrangling, + plausibility checks, and prevalence estimation of wasting. +authors: +- family-names: Zaba + given-names: Tomás + email: tomas.zaba@outlook.com + orcid: https://orcid.org/0000-0002-7079-3574 +preferred-citation: + type: manual + title: 'mwanaApp: A seamless graphical interface to the mwana R package for data + wrangling, plausibility checks, and prevalence estimation of wasting' + authors: + - name: Tomás Zaba + year: '2026' + notes: R package version 0.2.2 + url: https://github.com/mphimo/mwanaApp +repository-code: https://github.com/mphimo/mwanaApp +url: https://mphimo.github.io/mwanaApp/ +contact: +- family-names: Zaba + given-names: Tomás + email: tomas.zaba@outlook.com + orcid: https://orcid.org/0000-0002-7079-3574 +keywords: +- acute-malnutrition +- anthropometry +- wasting +references: +- type: software + title: dplyr + abstract: 'dplyr: A Grammar of Data Manipulation' + notes: Imports + url: https://dplyr.tidyverse.org + repository: https://CRAN.R-project.org/package=dplyr + authors: + - family-names: Wickham + given-names: Hadley + email: hadley@posit.co + orcid: https://orcid.org/0000-0003-4757-117X + - family-names: François + given-names: Romain + orcid: https://orcid.org/0000-0002-2444-4226 + - family-names: Henry + given-names: Lionel + - family-names: Müller + given-names: Kirill + orcid: https://orcid.org/0000-0002-1416-3412 + - family-names: Vaughan + given-names: Davis + email: davis@posit.co + orcid: https://orcid.org/0000-0003-4777-038X + year: '2026' + doi: 10.32614/CRAN.package.dplyr + version: '>= 1.1.4' +- type: software + title: mwana + abstract: 'mwana: An Efficient Workflow for Plausibility Checks and Prevalence Analysis + of Wasting in R' + notes: Imports + url: https://mphimo.github.io/mwana/ + repository: https://CRAN.R-project.org/package=mwana + authors: + - family-names: Zaba + given-names: Tomás + email: tomas.zaba@outlook.com + orcid: https://orcid.org/0000-0002-7079-3574 + - family-names: Guevarra + given-names: Ernest + orcid: https://orcid.org/0000-0002-4887-4415 + - family-names: Myatt + given-names: Mark + year: '2026' + doi: 10.32614/CRAN.package.mwana + version: '>= 0.2.5' +- type: software + title: rlang + abstract: 'rlang: Functions for Base Types and Core R and ''Tidyverse'' Features' + notes: Imports + url: https://rlang.r-lib.org + repository: https://CRAN.R-project.org/package=rlang + authors: + - family-names: Henry + given-names: Lionel + email: lionel@posit.co + - family-names: Wickham + given-names: Hadley + email: hadley@posit.co + year: '2026' + doi: 10.32614/CRAN.package.rlang +- type: software + title: shiny + abstract: 'shiny: Web Application Framework for R' + notes: Imports + url: https://shiny.posit.co/ + repository: https://CRAN.R-project.org/package=shiny + authors: + - family-names: Chang + given-names: Winston + email: winston@posit.co + orcid: https://orcid.org/0000-0002-1576-2126 + - family-names: Cheng + given-names: Joe + email: joe@posit.co + - family-names: Allaire + given-names: JJ + email: jj@posit.co + - family-names: Sievert + given-names: Carson + email: carson@posit.co + orcid: https://orcid.org/0000-0002-4958-2844 + - family-names: Schloerke + given-names: Barret + email: barret@posit.co + orcid: https://orcid.org/0000-0001-9986-114X + - family-names: Aden-Buie + given-names: Garrick + email: garrick@adenbuie.com + orcid: https://orcid.org/0000-0002-7111-0077 + - family-names: Xie + given-names: Yihui + email: yihui@posit.co + - family-names: Allen + given-names: Jeff + - family-names: McPherson + given-names: Jonathan + email: jonathan@posit.co + - family-names: Dipert + given-names: Alan + - family-names: Borges + given-names: Barbara + year: '2026' + doi: 10.32614/CRAN.package.shiny + version: '>= 1.11.1' +- type: software + title: shinycssloaders + abstract: 'shinycssloaders: Add Loading Animations to a ''shiny'' Output While It''s + Recalculating' + notes: Imports + url: https://daattali.com/shiny/shinycssloaders-demo/ + repository: https://CRAN.R-project.org/package=shinycssloaders + authors: + - family-names: Attali + given-names: Dean + email: daattali@gmail.com + orcid: https://orcid.org/0000-0002-5645-3493 + - family-names: Sali + given-names: Andras + email: andras.sali@alphacruncher.hu + year: '2026' + doi: 10.32614/CRAN.package.shinycssloaders + version: '>= 1.1.0' +- type: software + title: bslib + abstract: 'bslib: Custom ''Bootstrap'' ''Sass'' Themes for ''shiny'' and ''rmarkdown''' + notes: Imports + url: https://rstudio.github.io/bslib/ + repository: https://CRAN.R-project.org/package=bslib + authors: + - family-names: Sievert + given-names: Carson + email: carson@posit.co + orcid: https://orcid.org/0000-0002-4958-2844 + - family-names: Cheng + given-names: Joe + email: joe@posit.co + - family-names: Aden-Buie + given-names: Garrick + email: garrick@posit.co + orcid: https://orcid.org/0000-0002-7111-0077 + year: '2026' + doi: 10.32614/CRAN.package.bslib + version: '>= 0.9.0' +- type: software + title: openxlsx + abstract: 'openxlsx: Read, Write and Edit xlsx Files' + notes: Imports + url: https://ycphs.github.io/openxlsx/index.html + repository: https://CRAN.R-project.org/package=openxlsx + authors: + - family-names: Schauberger + given-names: Philipp + email: philipp@schauberger.co.at + - family-names: Walker + given-names: Alexander + email: Alexander.Walker1989@gmail.com + year: '2026' + doi: 10.32614/CRAN.package.openxlsx + version: '>= 4.2.8.1' +- type: software + title: DT + abstract: 'DT: A Wrapper of the JavaScript Library ''DataTables''' + notes: Imports + url: https://github.com/rstudio/DT + repository: https://CRAN.R-project.org/package=DT + authors: + - family-names: Xie + given-names: Yihui + - family-names: Cheng + given-names: Joe + email: joe@posit.co + - family-names: Tan + given-names: Xianying + - family-names: Aden-Buie + given-names: Garrick + email: garrick@posit.co + orcid: https://orcid.org/0000-0002-7111-0077 + year: '2026' + doi: 10.32614/CRAN.package.DT +- type: software + title: htmltools + abstract: 'htmltools: Tools for HTML' + notes: Imports + url: https://rstudio.github.io/htmltools/ + repository: https://CRAN.R-project.org/package=htmltools + authors: + - family-names: Cheng + given-names: Joe + email: joe@posit.co + - family-names: Sievert + given-names: Carson + email: carson@posit.co + orcid: https://orcid.org/0000-0002-4958-2844 + - family-names: Schloerke + given-names: Barret + email: barret@posit.co + orcid: https://orcid.org/0000-0001-9986-114X + - family-names: Chang + given-names: Winston + email: winston@posit.co + orcid: https://orcid.org/0000-0002-1576-2126 + - family-names: Xie + given-names: Yihui + email: yihui@posit.co + - family-names: Allen + given-names: Jeff + year: '2026' + doi: 10.32614/CRAN.package.htmltools + version: '>= 0.5.8.1' +- type: software + title: scales + abstract: 'scales: Scale Functions for Visualization' + notes: Imports + url: https://scales.r-lib.org + repository: https://CRAN.R-project.org/package=scales + authors: + - family-names: Wickham + given-names: Hadley + email: hadley@posit.co + - family-names: Pedersen + given-names: Thomas Lin + email: thomas.pedersen@posit.co + orcid: https://orcid.org/0000-0002-5147-4711 + - family-names: Seidel + given-names: Dana + year: '2026' + doi: 10.32614/CRAN.package.scales + version: '>= 1.4.0' +- type: software + title: covr + abstract: 'covr: Test Coverage for Packages' + notes: Suggests + url: https://covr.r-lib.org + repository: https://CRAN.R-project.org/package=covr + authors: + - family-names: Hester + given-names: Jim + email: james.f.hester@gmail.com + year: '2026' + doi: 10.32614/CRAN.package.covr + version: '>= 3.6.4' +- type: software + title: knitr + abstract: 'knitr: A General-Purpose Package for Dynamic Report Generation in R' + notes: Suggests + url: https://yihui.org/knitr/ + repository: https://CRAN.R-project.org/package=knitr + authors: + - family-names: Xie + given-names: Yihui + email: xie@yihui.name + orcid: https://orcid.org/0000-0003-0645-5666 + year: '2026' + doi: 10.32614/CRAN.package.knitr + version: '>= 1.50' +- type: software + title: rmarkdown + abstract: 'rmarkdown: Dynamic Documents for R' + notes: Suggests + url: https://pkgs.rstudio.com/rmarkdown/ + repository: https://CRAN.R-project.org/package=rmarkdown + authors: + - family-names: Allaire + given-names: JJ + email: jj@posit.co + - family-names: Xie + given-names: Yihui + email: xie@yihui.name + orcid: https://orcid.org/0000-0003-0645-5666 + - family-names: Dervieux + given-names: Christophe + email: cderv@posit.co + orcid: https://orcid.org/0000-0003-4474-2498 + - family-names: McPherson + given-names: Jonathan + email: jonathan@posit.co + - family-names: Luraschi + given-names: Javier + - family-names: Ushey + given-names: Kevin + email: kevin@posit.co + - family-names: Atkins + given-names: Aron + email: aron@posit.co + - family-names: Wickham + given-names: Hadley + email: hadley@posit.co + - family-names: Cheng + given-names: Joe + email: joe@posit.co + - family-names: Chang + given-names: Winston + email: winston@posit.co + - family-names: Iannone + given-names: Richard + email: rich@posit.co + orcid: https://orcid.org/0000-0003-3925-190X + year: '2026' + doi: 10.32614/CRAN.package.rmarkdown + version: '>= 2.30' +- type: software + title: quarto + abstract: 'quarto: R Interface to ''Quarto'' Markdown Publishing System' + notes: Suggests + url: https://quarto-dev.github.io/quarto-r/ + repository: https://CRAN.R-project.org/package=quarto + authors: + - family-names: Allaire + given-names: JJ + email: jj@posit.co + orcid: https://orcid.org/0000-0003-0174-9868 + - family-names: Dervieux + given-names: Christophe + email: cderv@posit.co + orcid: https://orcid.org/0000-0003-4474-2498 + year: '2026' + doi: 10.32614/CRAN.package.quarto + version: '>= 1.4.4' +- type: software + title: spelling + abstract: 'spelling: Tools for Spell Checking in R' + notes: Suggests + url: https://ropensci.r-universe.dev/spelling + repository: https://CRAN.R-project.org/package=spelling + authors: + - family-names: Ooms + given-names: Jeroen + email: jeroenooms@gmail.com + orcid: https://orcid.org/0000-0002-4035-0289 + - family-names: Hester + given-names: Jim + email: james.hester@rstudio.com + year: '2026' + doi: 10.32614/CRAN.package.spelling + version: '>= 2.3.1' +- type: software + title: testthat + abstract: 'testthat: Unit Testing for R' + notes: Suggests + url: https://testthat.r-lib.org + repository: https://CRAN.R-project.org/package=testthat + authors: + - family-names: Wickham + given-names: Hadley + email: hadley@posit.co + year: '2026' + doi: 10.32614/CRAN.package.testthat + version: '>= 3.0.0' +- type: software + title: shinytest2 + abstract: 'shinytest2: Testing for Shiny Applications' + notes: Suggests + url: https://rstudio.github.io/shinytest2/ + repository: https://CRAN.R-project.org/package=shinytest2 + authors: + - family-names: Schloerke + given-names: Barret + email: barret@posit.co + orcid: https://orcid.org/0000-0001-9986-114X + year: '2026' + doi: 10.32614/CRAN.package.shinytest2 + version: '>= 0.4.1' +- type: software + title: stringr + abstract: 'stringr: Simple, Consistent Wrappers for Common String Operations' + notes: Suggests + url: https://stringr.tidyverse.org + repository: https://CRAN.R-project.org/package=stringr + authors: + - family-names: Wickham + given-names: Hadley + email: hadley@posit.co + year: '2026' + doi: 10.32614/CRAN.package.stringr + version: '>= 1.6.0' +- type: software + title: 'R: A Language and Environment for Statistical Computing' + notes: Depends + url: https://www.R-project.org/ + authors: + - name: R Core Team + website: https://ror.org/02zz1nj61 + institution: + name: R Foundation for Statistical Computing + website: https://ror.org/05qewa988 + address: Vienna, Austria + year: '2026' + doi: 10.32614/R.manuals + version: '>= 4.1.0' + diff --git a/DESCRIPTION b/DESCRIPTION index 0f4bb1e..4cfe995 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: mwanaApp -Title: mwana GUI -Version: 0.2.1 +Title: Graphical User Interface to 'mwana' +Version: 0.2.2 Authors@R: person(given = "Tomás", family = "Zaba", @@ -8,19 +8,17 @@ Authors@R: email = "tomas.zaba@outlook.com", comment = c(ORCID = "0000-0002-7079-3574") ) -Description: A seamless graphical interface to the mwana R package for data +Description: A graphical interface to the 'mwana' R package for data wrangling, plausibility checks, and prevalence estimation of wasting. License: GPL (>= 3) Encoding: UTF-8 -LazyData: true Language: en-GB Roxygen: list(markdown = TRUE) -RoxygenNote: 8.0.0 -URL: https://github.com/mphimo/mwanaApp, https://mphimo.github.io/mwanaApp/ +URL: https://github.com/mphimo/mwanaApp BugReports: https://github.com/mphimo/mwanaApp/issues Imports: dplyr (>= 1.1.4), - mwana (>= 0.2.3), + mwana (>= 0.2.5), rlang, shiny (>= 1.11.1), shinycssloaders (>= 1.1.0), @@ -38,8 +36,7 @@ Suggests: testthat (>= 3.0.0), shinytest2 (>= 0.4.1), stringr (>= 1.6.0) -Remotes: - mphimo/mwana Config/testthat/edition: 3 Depends: R (>= 4.1.0) +Config/roxygen2/version: 8.1.0 diff --git a/NEWS.md b/NEWS.md index f26b870..49b400d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,16 @@ +# mwanaApp 0.2.2 + +### Bug fixes + ++ Removed the survey weights input field from the prevalence module's UI when +the selected data source is "screening" or "sentinel" (it is now shown only +for the "survey" source) (#45). + +### General updates ++ Revised user-guide documentation to enhance clarity on type and format of the +input variables to the app. ++ Updated hyperlinks to open in a new browser tab. + # mwanaApp 0.2.1 ### Bug fixes diff --git a/R/_disable_autoload.r b/R/_disable_autoload.r new file mode 100644 index 0000000..e69de29 diff --git a/R/module-helpers-prevalence.R b/R/module-helpers-prevalence.R index 631e21e..bf7fb71 100644 --- a/R/module-helpers-prevalence.R +++ b/R/module-helpers-prevalence.R @@ -5,39 +5,49 @@ #' #' #' Display input variables dynamically, according to UI for screening -#' -#' -#' @param vars,source,indicator_surv,has_age Input variables collected +#' +#' +#' @param vars,source,indicator_surv,has_age Input variables collected #' from the UI and required to pass to `{mwana}` prevalence functions. -#' +#' #' @param ns A placeholder for Shiny module namespace. #' #' @keywords internal #' #' mod_prevalence_display_input_variables <- function( - vars, source, indicator_surv, has_age, ns) { + vars, + source, + indicator_surv, + has_age, + ns +) { ### Base list input vars ---- inputs <- list( shiny::selectInput( inputId = ns("area1"), label = shiny::tagList( - htmltools::tags$span("Area 1", + htmltools::tags$span( + "Area 1", style = "font-size: 14px; font-weight: bold;" ), htmltools::tags$div( - style = "font-size: 0.85em; color: #6c7574;", "(Primary area)" + style = "font-size: 0.85em; color: #6c7574;", + "(Primary area)" ) ), choices = c("", vars) ), - shiny::selectInput(ns("area2"), + shiny::selectInput( + ns("area2"), label = shiny::tagList( - htmltools::tags$span("Area 2", + htmltools::tags$span( + "Area 2", style = "font-size: 14px; font-weight: bold;" ), htmltools::tags$div( - style = "font-size: 0.85em; color: #6c7574;", "(Sub-area)" + style = "font-size: 0.85em; color: #6c7574;", + "(Sub-area)" ) ), choices = c("", vars) @@ -45,111 +55,133 @@ mod_prevalence_display_input_variables <- function( shiny::selectInput( inputId = ns("area3"), label = shiny::tagList( - htmltools::tags$span("Area 3", + htmltools::tags$span( + "Area 3", style = "font-size: 14px; font-weight: bold;" ), htmltools::tags$div( - style = "font-size: 0.85em; color: #6c7574;", "Sub-area)" + style = "font-size: 0.85em; color: #6c7574;", + "Sub-area)" ) ), choices = c("", vars) - ), - shiny::selectInput( - inputId = ns("wts"), - label = shiny::tagList( - htmltools::tags$span("Survey weights", - style = "font-size: 14px; font-weight: bold;" - ), - htmltools::tags$div( - style = "font-size: 0.85em; color: #6c7574;", - "Final survey weights for weighted analysis" - ) - ), - choices = c("", vars) - ) + ) ) #### Conditional inputs depending on source of data ---- if (source == "survey") { - inputs <- c(inputs, list( - if (isTRUE(indicator_surv == "muac")) { - #### Display age ---- - shiny::tagList( + inputs <- c( + ##### Display grouping variables ---- + inputs, + + list( + ##### Display input variable for survey weights ---- + shiny::selectInput( + inputId = ns("wts"), + label = shiny::tagList( + htmltools::tags$span( + "Survey weights", + style = "font-size: 14px; font-weight: bold;" + ), + htmltools::tags$div( + style = "font-size: 0.85em; color: #6c7574;", + "Final survey weights for weighted analysis" + ) + ), + choices = c("", vars) + ), + + if (isTRUE(indicator_surv == "muac")) { + #### Display age ---- + shiny::tagList( + shiny::selectInput( + inputId = ns("muac"), + label = shiny::tagList( + htmltools::tags$span( + "MUAC", + style = "font-size: 14px; font-weight: bold;" + ), + htmltools::tags$span("*", style = "color: red;") + ), + choices = c("", vars) + ), + shiny::selectInput( + inputId = ns("age"), + label = shiny::tagList( + htmltools::tags$span( + "Age (months)", + style = "font-size: 14px; font-weight: bold;" + ), + htmltools::tags$span("*", style = "color: red;") + ), + choices = c("", vars) + ) + ) + } + ) + ) + } + + if (source == "screening") { + inputs <- c( + inputs, + list( + shiny::selectInput( + inputId = ns("muac"), + label = shiny::tagList( + htmltools::tags$span( + "MUAC", + style = "font-size: 14px; font-weight: bold;" + ), + htmltools::tags$span("*", style = "color: red;") + ), + choices = c("", vars) + ), + if (isTRUE(has_age == "yes")) { shiny::selectInput( - inputId = ns("muac"), + inputId = ns("age"), label = shiny::tagList( - htmltools::tags$span("MUAC", + htmltools::tags$span( + "Age (months)", style = "font-size: 14px; font-weight: bold;" ), htmltools::tags$span("*", style = "color: red;") ), choices = c("", vars) - ), + ) + } else { shiny::selectInput( - inputId = ns("age"), + inputId = ns("age_cat"), label = shiny::tagList( - htmltools::tags$span("Age (months)", + htmltools::tags$span( + "Age categories (6-23 and 24-59)", style = "font-size: 14px; font-weight: bold;" ), htmltools::tags$span("*", style = "color: red;") ), choices = c("", vars) ) - ) - } - )) + } + ) + ) } - if (source == "screening") { - inputs <- c(inputs, list( + # Always add oedema at the end + inputs_vars <- c( + inputs, + list( shiny::selectInput( - inputId = ns("muac"), + inputId = ns("oedema"), label = shiny::tagList( - htmltools::tags$span("MUAC", + htmltools::tags$span( + "Oedema", style = "font-size: 14px; font-weight: bold;" - ), - htmltools::tags$span("*", style = "color: red;") + ) ), choices = c("", vars) - ), - if (isTRUE(has_age == "yes")) { - shiny::selectInput( - inputId = ns("age"), - label = shiny::tagList( - htmltools::tags$span("Age (months)", - style = "font-size: 14px; font-weight: bold;" - ), - htmltools::tags$span("*", style = "color: red;") - ), - choices = c("", vars) - ) - } else { - shiny::selectInput( - inputId = ns("age_cat"), - label = shiny::tagList( - htmltools::tags$span("Age categories (6-23 and 24-59)", - style = "font-size: 14px; font-weight: bold;" - ), - htmltools::tags$span("*", style = "color: red;") - ), - choices = c("", vars) - ) - } - )) - } - - # Always add oedema at the end - inputs_vars <- c(inputs, list( - shiny::selectInput( - inputId = ns("oedema"), - label = shiny::tagList( - htmltools::tags$span("Oedema", - style = "font-size: 14px; font-weight: bold;" - ) - ), - choices = c("", vars) + ) ) - )) + ) inputs_vars } @@ -160,27 +192,42 @@ mod_prevalence_display_input_variables <- function( #' #' Invoke mwana's prevalence functions from within module server according to #' user specifications in the UI -#' -#' @param df,wts,oedema,area1,area2,area3 Input variables collected from the UI +#' +#' @param df,wts,oedema,area1,area2,area3 Input variables collected from the UI #' and required to pass to mwana::mw_estimate_prevalence_wfhz(). -#' +#' #' @returns A summary tibble for the descriptive statistics about wasting. #' #' @keywords internal #' #' mod_prevalence_call_wfhz_prev_estimator <- function( - df, wts = NULL, oedema = NULL, - area1, area2, area3) { + df, + wts = NULL, + oedema = NULL, + area1, + area2, + area3 +) { ## Build the grouping variables dynamically ---- dots <- list() - if (!is.null(area1) && nzchar(area1)) dots <- c(dots, list(rlang::sym(area1))) - if (!is.null(area2) && nzchar(area2)) dots <- c(dots, list(rlang::sym(area2))) - if (!is.null(area3) && nzchar(area3)) dots <- c(dots, list(rlang::sym(area3))) + if (!is.null(area1) && nzchar(area1)) { + dots <- c(dots, list(rlang::sym(area1))) + } + if (!is.null(area2) && nzchar(area2)) { + dots <- c(dots, list(rlang::sym(area2))) + } + if (!is.null(area3) && nzchar(area3)) { + dots <- c(dots, list(rlang::sym(area3))) + } ## Determine wt and oedema arguments - only convert to symbol if valid ---- wt_arg <- if (!is.null(wts) && nzchar(wts)) rlang::sym(wts) else NULL - oedema_arg <- if (!is.null(oedema) && nzchar(oedema)) rlang::sym(oedema) else NULL + oedema_arg <- if (!is.null(oedema) && nzchar(oedema)) { + rlang::sym(oedema) + } else { + NULL + } ## Call the function once with dynamic arguments ---- mwana::mw_estimate_prevalence_wfhz( @@ -198,23 +245,36 @@ mod_prevalence_call_wfhz_prev_estimator <- function( #' Invoke mwana's prevalence functions from within module server according to #' user specifications in the UI #' -#' @param df,age,muac,wts,oedema,area1,area2,area3 Input variables collected +#' @param df,age,muac,wts,oedema,area1,area2,area3 Input variables collected #' from the UI and required to pass to mwana::mw_estimate_prevalence_muac(). -#' -#' @returns A summary tibble for the descriptive statistics about wasting based +#' +#' @returns A summary tibble for the descriptive statistics about wasting based #' on MUAC, with confidence intervals. -#' +#' #' @keywords internal #' #' mod_prevalence_call_muac_prev_estimator <- function( - df, age, muac, wts = NULL, oedema = NULL, - area1, area2, area3) { + df, + age, + muac, + wts = NULL, + oedema = NULL, + area1, + area2, + area3 +) { # Build the grouping variables dynamically ---- dots <- list() - if (nzchar(area1)) dots <- c(dots, list(rlang::sym(area1))) - if (nzchar(area2)) dots <- c(dots, list(rlang::sym(area2))) - if (nzchar(area3)) dots <- c(dots, list(rlang::sym(area3))) + if (nzchar(area1)) { + dots <- c(dots, list(rlang::sym(area1))) + } + if (nzchar(area2)) { + dots <- c(dots, list(rlang::sym(area2))) + } + if (nzchar(area3)) { + dots <- c(dots, list(rlang::sym(area3))) + } # Determine wt and oedema arguments ---- wt_arg <- if (nzchar(wts)) rlang::sym(wts) else NULL @@ -242,17 +302,32 @@ mod_prevalence_call_muac_prev_estimator <- function( #' #' mod_prevalence_call_combined_prev_estimator <- function( - df, wts = NULL, oedema = NULL, - area1, area2, area3) { + df, + wts = NULL, + oedema = NULL, + area1, + area2, + area3 +) { ## Build the grouping variables dynamically ---- dots <- list() - if (!is.null(area1) && nzchar(area1)) dots <- c(dots, list(rlang::sym(area1))) - if (!is.null(area2) && nzchar(area2)) dots <- c(dots, list(rlang::sym(area2))) - if (!is.null(area3) && nzchar(area3)) dots <- c(dots, list(rlang::sym(area3))) + if (!is.null(area1) && nzchar(area1)) { + dots <- c(dots, list(rlang::sym(area1))) + } + if (!is.null(area2) && nzchar(area2)) { + dots <- c(dots, list(rlang::sym(area2))) + } + if (!is.null(area3) && nzchar(area3)) { + dots <- c(dots, list(rlang::sym(area3))) + } ## Determine wt and oedema arguments - only convert to symbol if valid ---- wt_arg <- if (!is.null(wts) && nzchar(wts)) rlang::sym(wts) else NULL - oedema_arg <- if (!is.null(oedema) && nzchar(oedema)) rlang::sym(oedema) else NULL + oedema_arg <- if (!is.null(oedema) && nzchar(oedema)) { + rlang::sym(oedema) + } else { + NULL + } ## Call the function once with dynamic arguments ---- mwana::mw_estimate_prevalence_combined( @@ -269,23 +344,37 @@ mod_prevalence_call_combined_prev_estimator <- function( #' #' Invoke mwana's prevalence functions from within module server according to #' user specifications in the UI -#' -#' @param df,age,muac,oedema,area1,area2,area3 Input variables collected -#' from the UI and required to pass to mwana::mw_estimate_prevalence_screening(). +#' +#' @param df,age,muac,oedema,area1,area2,area3 Input variables collected +#' from the UI and required to pass to mwana::mw_estimate_prevalence_screening(). # -#' @returns A summary tibble for the descriptive statistics about wasting based +#' @returns A summary tibble for the descriptive statistics about wasting based #' on MUAC, with no confidence intervals. #' #' @keywords internal #' #' mod_prevalence_call_prev_estimator_screening <- function( - df, age, muac, oedema = NULL, - area1, area2, area3) { + df, + age, + muac, + oedema = NULL, + area1, + area2, + area3 +) { dots <- list() - if (nzchar(area1)) dots <- c(dots, list(rlang::sym(area1))) else NULL - if (nzchar(area2)) dots <- c(dots, list(rlang::sym(area2))) - if (nzchar(area3)) dots <- c(dots, list(rlang::sym(area3))) + if (nzchar(area1)) { + dots <- c(dots, list(rlang::sym(area1))) + } else { + NULL + } + if (nzchar(area2)) { + dots <- c(dots, list(rlang::sym(area2))) + } + if (nzchar(area3)) { + dots <- c(dots, list(rlang::sym(area3))) + } df <- dplyr::mutate(df, muac = !!rlang::sym(muac) * 10) @@ -317,21 +406,35 @@ mod_prevalence_call_prev_estimator_screening <- function( #' Invoke mwana's prevalence functions from within module server according to #' user specifications in the UI #' -#' @param df,age_cat,muac,oedema,area1,area2,area3 Input variables collected +#' @param df,age_cat,muac,oedema,area1,area2,area3 Input variables collected #' from the UI and required to pass to mwana::mw_estimate_prevalence_screening2() -#' -#' @returns A summary tibble for the descriptive statistics about wasting based +#' +#' @returns A summary tibble for the descriptive statistics about wasting based #' on MUAC, with no confidence intervals. #' #' @keywords internal #' mod_prevalence_call_prev_estimator_screening2 <- function( - df, age_cat, muac, oedema = NULL, - area1, area2, area3) { + df, + age_cat, + muac, + oedema = NULL, + area1, + area2, + area3 +) { dots <- list() - if (nzchar(area1)) dots <- c(dots, list(rlang::sym(area1))) else NULL - if (nzchar(area2)) dots <- c(dots, list(rlang::sym(area2))) - if (nzchar(area3)) dots <- c(dots, list(rlang::sym(area3))) + if (nzchar(area1)) { + dots <- c(dots, list(rlang::sym(area1))) + } else { + NULL + } + if (nzchar(area2)) { + dots <- c(dots, list(rlang::sym(area2))) + } + if (nzchar(area3)) { + dots <- c(dots, list(rlang::sym(area3))) + } # Create the call - pass oedema as NULL or as a symbol if (nzchar(oedema)) { @@ -358,25 +461,28 @@ mod_prevalence_call_prev_estimator_screening2 <- function( #' #' #' Neat prevalence output from survey -#' +#' #' @param df data.frame containing the prevalence results. #' @param .type A choice from which the prevalence is derived. -#' -#' @returns A tibble object of the same length and width as df, with column +#' +#' @returns A tibble object of the same length and width as df, with column #' names and values formatted for clarity and readability. -#' +#' #' @keywords internal #' #' mod_prevalence_neat_output_survey <- function( - df, - .type = c("wfhz", "muac", "combined")) { + df, + .type = c("wfhz", "muac", "combined") +) { df <- dplyr::mutate( .data = df, dplyr::across( .cols = dplyr::ends_with(c("am_p", "am_p_low", "am_p_upp")), .fns = scales::label_percent( - accuracy = 0.1, suffix = "%", decimal.mark = "." + accuracy = 0.1, + suffix = "%", + decimal.mark = "." ) ) ) @@ -429,12 +535,12 @@ mod_prevalence_neat_output_survey <- function( #' -#' +#' #' Neat prevalence output from survey -#' +#' #' @param df data.frame containing the prevalence results. -#' -#' @returns A tibble object of the same length and width as df, with column +#' +#' @returns A tibble object of the same length and width as df, with column #' names and values formatted for clarity and readability. #' #' @keywords internal diff --git a/R/module-prevalence.R b/R/module-prevalence.R index 6b066ff..120ff5c 100644 --- a/R/module-prevalence.R +++ b/R/module-prevalence.R @@ -24,7 +24,8 @@ module_ui_prevalence <- function(id) { style = "background-color: #f9fdfb;", style = "width: 350px;", bslib::card_header( - htmltools::tags$span("Define Analysis Parameters", + htmltools::tags$span( + "Define Analysis Parameters", style = "font-size: 15px; font-weight: bold;" ) ), @@ -32,12 +33,13 @@ module_ui_prevalence <- function(id) { #### Select the source of data for prevalence analysis ---- shiny::radioButtons( inputId = ns("source"), - label = htmltools::tags$span("Select Data Source", + label = htmltools::tags$span( + "Select Data Source", style = "font-size: 14px; font-weight: bold;" ), choices = list( "Survey" = "survey", - "Screening" = "screening" + "Screening & Sentinel Site" = "screening" ), selected = "survey", inline = TRUE @@ -65,7 +67,8 @@ module_ui_prevalence <- function(id) { bslib::card( style = "background-color: #f9fdfb;", bslib::card_header( - htmltools::tags$span("Prevalence Analysis Results", + htmltools::tags$span( + "Prevalence Analysis Results", style = "font-size: 15px; font-weight: bold;" ) ), @@ -79,10 +82,12 @@ module_ui_prevalence <- function(id) { image.height = "50px", color = "#004225", caption = htmltools::tags$div( - htmltools::tags$h6(htmltools::tags$span("Estimating prevalence", + htmltools::tags$h6(htmltools::tags$span( + "Estimating prevalence", style = "font-size: 12px;" )), - htmltools::tags$h6(htmltools::tags$span("Please wait...", + htmltools::tags$h6(htmltools::tags$span( + "Please wait...", style = "font-size: 12px;" )) ) @@ -97,7 +102,6 @@ module_ui_prevalence <- function(id) { ## ---- Module: Server --------------------------------------------------------- - #' #' #' Module server for prevalence analysis @@ -118,13 +122,15 @@ module_server_prevalence <- function(id, data) { ### Render the method through which GAM should be estimated ---- output$amnby <- shiny::renderUI({ #### Display method options ---- - switch(input$source, + switch( + input$source, ##### Options for survey data ---- "survey" = { shiny::radioButtons( inputId = ns("amn_method_survey"), - label = htmltools::tags$span("Acute malnutrition based on:", + label = htmltools::tags$span( + "Acute malnutrition based on:", style = "font-size: 14px; font-weight: bold;" ), choices = list( @@ -141,7 +147,8 @@ module_server_prevalence <- function(id, data) { "screening" = { shiny::radioButtons( inputId = ns("has_age"), - label = htmltools::tags$span("Is age in months available?", + label = htmltools::tags$span( + "Is age in months available?", style = "font-size: 14px; font-weight: bold;" ), choices = list("Yes" = "yes", "No" = "no"), @@ -159,7 +166,11 @@ module_server_prevalence <- function(id, data) { #### Display variables ---- mod_prevalence_display_input_variables( - vars, input$source, input$amn_method_survey, input$has_age, ns + vars, + input$source, + input$amn_method_survey, + input$has_age, + ns ) }) @@ -196,7 +207,8 @@ module_server_prevalence <- function(id, data) { tryCatch( { p <- if (input$source == "survey") { - switch(input$amn_method_survey, + switch( + input$amn_method_survey, "wfhz" = { mod_prevalence_call_wfhz_prev_estimator( df = data(), @@ -205,11 +217,14 @@ module_server_prevalence <- function(id, data) { area1 = input$area1, area2 = input$area2, area3 = input$area3 - ) |> mod_prevalence_neat_output_survey(.type = "wfhz") + ) |> + mod_prevalence_neat_output_survey(.type = "wfhz") }, "muac" = { data() |> - dplyr::mutate(muac = mwana::recode_muac(!!rlang::sym(input$muac), "mm")) |> + dplyr::mutate( + muac = mwana::recode_muac(!!rlang::sym(input$muac), "mm") + ) |> mod_prevalence_call_muac_prev_estimator( age = input$age, muac = input$muac, @@ -223,7 +238,9 @@ module_server_prevalence <- function(id, data) { }, "combined" = { data() |> - dplyr::mutate(muac = mwana::recode_muac(.data$muac, "mm")) |> + dplyr::mutate( + muac = mwana::recode_muac(.data$muac, "mm") + ) |> mod_prevalence_call_combined_prev_estimator( wts = input$wts, oedema = input$oedema, @@ -235,7 +252,8 @@ module_server_prevalence <- function(id, data) { } ) } else { - switch(input$has_age, + switch( + input$has_age, "yes" = { shiny::req(input$muac, input$age) mod_prevalence_call_prev_estimator_screening( @@ -271,7 +289,8 @@ module_server_prevalence <- function(id, data) { }, error = function(e) { shiny::showNotification( - ui = paste("Error while estimating:", e$message), type = "error" + ui = paste("Error while estimating:", e$message), + type = "error" ) } ) @@ -294,16 +313,20 @@ module_server_prevalence <- function(id, data) { ), caption = if (nrow(prevalence$estimated) > 20) { paste( - "Showing first 20 rows of", format(nrow(prevalence$estimated), big.mark = "."), + "Showing first 20 rows of", + format(nrow(prevalence$estimated), big.mark = "."), "total rows" ) } else { paste("Showing all", nrow(prevalence$estimated), "rows") } - ) |> DT::formatStyle(columns = colnames(prevalence$estimated), fontSize = "13px") + ) |> + DT::formatStyle( + columns = colnames(prevalence$estimated), + fontSize = "13px" + ) }) - #### Download button to download table of detected clusters in .xlsx ---- ##### Output into the UI ---- output$download_prevalence <- shiny::renderUI({ @@ -320,23 +343,47 @@ module_server_prevalence <- function(id, data) { ) }) - ##### Downloadable results by clicking on the download button ---- output$download_results <- shiny::downloadHandler( filename = function() { if (input$source == "survey") { if (input$amn_method_survey == "wfhz") { - paste0("mwana-amn-prevalence-survey-wfhz_", Sys.Date(), ".xlsx", sep = "") + paste0( + "mwana-amn-prevalence-survey-wfhz_", + Sys.Date(), + ".xlsx", + sep = "" + ) } else if (input$amn_method_survey == "muac") { - paste0("mwana-amn-prevalence-survey-muac_", Sys.Date(), ".xlsx", sep = "") + paste0( + "mwana-amn-prevalence-survey-muac_", + Sys.Date(), + ".xlsx", + sep = "" + ) } else { - paste0("mwana-amn-prevalence-survey-combined_", Sys.Date(), ".xlsx", sep = "") + paste0( + "mwana-amn-prevalence-survey-combined_", + Sys.Date(), + ".xlsx", + sep = "" + ) } } else { if (input$has_age == "yes") { - paste0("mwana-amn-prevalence-screening-age-avail_", Sys.Date(), ".xlsx", sep = "") + paste0( + "mwana-amn-prevalence-screening-age-avail_", + Sys.Date(), + ".xlsx", + sep = "" + ) } else { - paste0("mwana-amn-prevalence-screening-age-notavail_", Sys.Date(), ".xlsx", sep = "") + paste0( + "mwana-amn-prevalence-screening-age-notavail_", + Sys.Date(), + ".xlsx", + sep = "" + ) } } }, @@ -345,10 +392,16 @@ module_server_prevalence <- function(id, data) { tryCatch( { openxlsx::write.xlsx(prevalence$estimated, file) - shiny::showNotification("File downloaded successfully!", type = "message") + shiny::showNotification( + "File downloaded successfully!", + type = "message" + ) }, error = function(e) { - shiny::showNotification(paste("Error creating file:", e$message), type = "error") + shiny::showNotification( + paste("Error creating file:", e$message), + type = "error" + ) } ) } diff --git a/README.md b/README.md index 29d41c6..347f438 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ -# mwanaApp: A seamless graphical interface to the mwana R package for data wrangling, plausibility checks, and prevalence estimation +# mwanaApp: A graphical interface to the `mwana` R package for data wrangling, plausibility checks, and prevalence estimation of wasting @@ -33,7 +33,7 @@ The App can be installed from GitHub: ``` r # First install remotes package with: install.package("remotes") -# The install mwana package from GitHub with: +# The install mwana package from GitHub with: remotes::install_github(repo = "mphimo/mwanaApp", dependencies = TRUE) ``` @@ -54,7 +54,7 @@ citation("mwanaApp") Tomás Zaba (2026). _mwanaApp: A seamless graphical interface to the mwana R package for data wrangling, plausibility checks, and - prevalence estimation of wasting_. R package version 0.2.1, + prevalence estimation of wasting_. R package version 0.2.2, . A BibTeX entry for LaTeX users is @@ -63,6 +63,6 @@ citation("mwanaApp") title = {mwanaApp: A seamless graphical interface to the mwana R package for data wrangling, plausibility checks, and prevalence estimation of wasting}, author = {{Tomás Zaba}}, year = {2026}, - note = {R package version 0.2.1}, + note = {R package version 0.2.2}, url = {https://github.com/mphimo/mwanaApp}, } diff --git a/README.qmd b/README.qmd index cae4050..c083c8b 100644 --- a/README.qmd +++ b/README.qmd @@ -2,7 +2,7 @@ format: gfm --- -# mwanaApp: A seamless graphical interface to the mwana R package for data wrangling, plausibility checks, and prevalence estimation +# mwanaApp: A graphical interface to the `mwana` R package for data wrangling, plausibility checks, and prevalence estimation of wasting [![R-CMD-check](https://github.com/mphimo/mwanaApp/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/mphimo/mwanaApp/actions/workflows/R-CMD-check.yaml) @@ -32,7 +32,7 @@ The App can be installed from GitHub: #| eval: false # First install remotes package with: install.package("remotes") -# The install mwana package from GitHub with: +# The install mwana package from GitHub with: remotes::install_github(repo = "mphimo/mwanaApp", dependencies = TRUE) ``` diff --git a/inst/CITATION b/inst/CITATION index ccf4fdb..de66d16 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -4,6 +4,6 @@ bibentry( title = "mwanaApp: A seamless graphical interface to the mwana R package for data wrangling, plausibility checks, and prevalence estimation of wasting", author = person("Tomás Zaba"), year = 2026, - note = "R package version 0.2.1", + note = "R package version 0.2.2", url = "https://github.com/mphimo/mwanaApp" ) diff --git a/inst/app/ui.R b/inst/app/ui.R index 23e0352..81e24a8 100644 --- a/inst/app/ui.R +++ b/inst/app/ui.R @@ -18,35 +18,41 @@ library(rlang) ui <- tagList( ### Link up with custom .css file ---- tags$head( - tags$link(rel = "stylesheet", type = "text/css", href = "custom.css") # external stylesheet + tags$meta(charset = "UTF-8"), + tags$meta(name = "description", content = "mwana App"), + tags$title("mwana App"), + tags$link(rel = "stylesheet", type = "text/css", href = "custom.css"), # external stylesheet + tags$link(rel = "icon", href = "logo.png"), ), page_navbar( title = tags$div( - style = "display: flex; align-items: center; justify-content: space-between; width: 100%;", + class = "page-navbar", ### Left side: app name and logo ---- tags$div( - style = "display: flex; align-items: center;", - tags$span("mwana", - style = "margin-right: 10px; font-family: Arial, sans-serif; font-size: 50px;" + class = "brand", + tags$span( + class = "brand-span", + "mwana", ), tags$a( href = "https://mphimo.github.io/mwana/", + target = "_blank", tags$span( - tags$img(src = "logo.png", height = "40px"), - style = "margin-right: 20px;" + tags$img(src = "logo.png"), ) ) ), ### Right side: app version ---- - tags$span(paste0( - "App v", utils::packageVersion("mwanaApp"), - " | Eng: mwana v", utils::packageVersion("mwana") - ), - id = "app-version", - style = "font-size: 12.5px; color: rgba(255, 255, 255, 0.4); - position: fixed; top: 40px; right: 20px;" + tags$span( + class = "app-version", + paste0( + "App v", + utils::packageVersion("mwanaApp"), + " | Eng: mwana v", + utils::packageVersion("mwana") + ) ) ), @@ -59,7 +65,7 @@ ui <- tagList( ### Left sidebar for contents ---- layout_sidebar( sidebar = tags$div( - style = "padding: 1rem;", + class = "table-contents", tags$h4("Contents"), tags$h6(tags$a(href = "#sec1", "Welcome")), tags$h6(tags$a(href = "#sec2", "Data Upload")), @@ -84,16 +90,17 @@ ui <- tagList( ##### Left side: title + subtitle stacked ---- tags$div( style = "display: flex; flex-direction: column;", - tags$h3( - style = "marging: 0; font-weight: bold;", - "A seamless graphical interface to the mwana R package for data + tags$h3( + style = "marging: 0; font-weight: bold;", + "A seamless graphical interface to the mwana R package for data wrangling, plausibility checks, and prevalence estimation of wasting" - ) - ), + ) + ), ##### Right side: logo ---- tags$a( href = "https://mphimo.github.io/mwana/", + target = "_blank", tags$img( src = "logo.png", height = "160px", @@ -102,123 +109,162 @@ ui <- tagList( ) ) ) - ), + ), - #### Welcome message ---- - tags$div( - id = "sec1", - style = "text-align: justify;", - tags$hr(), - tags$p( - " + #### Welcome message ---- + tags$div( + id = "sec1", + style = "text-align: justify;", + tags$hr(), + tags$p( + " This app is a lightweight, field-ready application thoughtful designed to seamlessly streamline plausibility checks - and wasting prevalence estimation of child anthropometric data, + and wasting prevalence estimation of child anthropometric data by automating key steps of the R package ", - tags$a( - href = "https://mphimo.github.io/mwana/", - tags$code("mwana") - ), "for non-R users." + tags$a( + href = "https://mphimo.github.io/mwana/", + target = "_blank", + tags$code("mwana") ), - tags$p( - "The app is divided in five easy-to-navigate tabs, apart from + "for non-R users." + ), + tags$p( + "The app is divided into five easy-to-navigate tabs, apart from the Home - where you at right now.", - tags$ol( - tags$li(tags$b("Data Upload")), - tags$li(tags$b("Data Wrangling")), - tags$li(tags$b("Plausibility Check")), - tags$li(tags$b("Prevalence Analysis")), - tags$li(tags$b("IPC Check")) - ) - ), - tags$hr(), + tags$ol( + tags$li(tags$b("Data Upload")), + tags$li(tags$b("Data Wrangling")), + tags$li(tags$b("Plausibility Check")), + tags$li(tags$b("Prevalence Analysis")), + tags$li(tags$b("IPC Check")) + ) + ), + tags$hr(), - ##### Briefly describe each tab ---- - tags$div( - id = "sec2", - style = "text-align: justify;", + ##### Briefly describe each tab ---- + tags$div( + id = "sec2", + style = "text-align: justify;", - ###### Data Upload tab ---- - tags$p(tags$b("Data Upload")), - tags$p( - " + ###### Data Upload tab ---- + tags$p(tags$b("Data Upload")), + tags$p( + " This is where the workflow begins. Upload the dataset saved in a comma-separated-value format (.csv); this is the only accepted format. Click on the 'Browse' button to locate the file to be uploaded from your computer; it is as simple as that. - Once uploaded, the first 20 rows will be priviewed on the right side. + Once uploaded, the first 20 rows will be priviewed on the right side of the tab. " - ), - tags$ul( - tags$li( - tags$b("Data requirements"), - tags$p( - " + ), + tags$ul( + tags$li( + tags$b("Data requirements"), + tags$p( + " The data to be uploaded must have been tidy up in accordance - to the below-described app's", tags$b("input file"), "and", - tags$b("input variable"), "requirements: + to the below-described app ", + tags$b("input file"), + "and", + tags$b("input variable"), + "requirements: " - ), - tags$ul( - tags$li( - tags$b("Input file requirements"), - tags$ul( - tags$li( - tags$b("File naming:"), "the file name must use + ), + tags$ul( + tags$li( + tags$b("Input file requirements"), + tags$ul( + tags$li( + tags$b("File naming:"), + "the file name must use underscore ( _ ) to separate words. Hyphen ( - ) or - simple spaces will lead to errors along the uploading + simple spaces could lead to errors along the uploading process. Consider the following naming example:", - tags$em("my_file_to_upload.csv") - ) + tags$em("my_file_to_upload.csv") ) - ), - tags$br(), - tags$li( - tags$b("Input variable requirements"), - tags$ul( - tags$li( - tags$b("Age:"), "values must be in months. The variable name + ) + ), + tags$br(), + tags$li( + tags$b("Input variable requirements"), + tags$ul( + tags$li( + tags$b("Date of data collection:"), + "this is an optional variable. If provided, it is + used to calculate the child’s age in months. + The date format should be DD/MM/YYYY (e.g., 16/07/2023). + Variable names may follow any format. For longer names, + separate words with an underscore (e.g., survey_date)." + ), + tags$li( + tags$b("Date of birth:"), + "this is an optional variable. If provided, it is + used to calculate the child’s age in months. + The date format should be DD/MM/YYYY (e.g., 16/07/2023). + Variable names may follow any format. For longer names, + separate words with an underscore (e.g., birth_date). + " + ), + tags$li( + tags$b("Age:"), + "values must be in months. The variable name must be written in lowercase ('age')." - ), - tags$li( - tags$b("Sex:"), "values must be given in 'm' for boys and 'f' + ), + tags$li( + tags$b("Sex:"), + "values must be given in 'm' for boys and 'f' for girls." - ), - tags$li( - tags$b("MUAC:"), "values must be in millimetres. Ensure there + ), + tags$li( + tags$b("Weight"), + "child's weight in kilograms. The variable name must + be written in lowercase ('weight')." + ), + tags$li( + tags$b("Height"), + "child's height in centimetres. The variable name must + be written in lowercase ('height')." + ), + tags$li( + tags$b("MUAC:"), + "values must be in millimetres. Ensure there are no strange numbers, such as '130.1'. The presence - of decimal places will raise error in the data wrangling - tab and hault the app." - ), - tags$li( - tags$b("Oedema:"), "values must be given in 'y' for yes, - and 'n' for no." - ) + of decimal places will raise an error in the data wrangling + tab and hault the app. The variable name + must be written in lowercase ('muac')." + ), + tags$li( + tags$b("Oedema:"), + "values must be given in 'y' for yes, + and 'n' for no. Variable names may follow any format. + For longer names, separate words with an underscore." ) ) ) ) ) - ), - tags$hr(), + ) + ), + tags$hr(), - ###### Data Wrangling tab ---- - tags$div( - id = "sec3", - style = "text-align: justify;", - tags$p(tags$b("Data Wrangling")), - tags$p( - " + ###### Data Wrangling tab ---- + tags$div( + id = "sec3", + style = "text-align: justify;", + tags$p(tags$b("Data Wrangling")), + tags$p( + " Wrangle the dataset for downstream workflow. For this, different wrangling methods are given. Upon completion, this tab's output becomes available in subsequent tabs; therefore, the wrangling method selected herein should match the intended analysis. " - ), - tags$p( - " + ), + tags$p( + " Under the hood, the wrangling process consists in calculating age in months and excluding all records that fall under six months and over 59.99 months. Then, it computes z-scores - if @@ -226,19 +272,27 @@ ui <- tagList( based on the SMART flagging criteria - for z-scores. For MUAC, when age in months is not available, values under 100 and over 200 millimetres are considered as outliers. At the the end, two new - columns get added into the dataset:", tags$code("wfhz"), "and", - tags$code("flag_wfhz"), "for weight-for-heigh z-scores and flagged + columns get added into the dataset:", + tags$code("wfhz"), + "and", + tags$code("flag_wfhz"), + "for weight-for-heigh z-scores and flagged records, respectively. Moreover, when working with MUAC and when - age is available, the following columns get added:", tags$code("mfaz"), - "and", tags$code("flag_mfaz"), "for MUAC-for-age z-scores and flagged + age is available, the following columns get added:", + tags$code("mfaz"), + "and", + tags$code("flag_mfaz"), + "for MUAC-for-age z-scores and flagged records, respectively. Finally, when age is not available, only one - column gets added:", tags$code("flag_muac"), "which indicates + column gets added:", + tags$code("flag_muac"), + "which indicates the flagged records based on the above-mentioned criterion. " - ), - tags$p( - " + ), + tags$p( + " Once the wrangling process is completed, a preview of the output is displayed on the right side of the tab, wherein the first 20 rows are shown. You can get a full view of the entire dataset by @@ -246,17 +300,17 @@ ui <- tagList( thereafter look for the file in the 'downloads' folder on your computer. " - ) - ), - tags$hr(), + ) + ), + tags$hr(), - ###### Plausibility Check tab ---- - tags$div( - id = "sec4", - style = "text-align: justify;", - tags$p(tags$b("Plausibility Check")), - tags$p( - "As above-described, this tab depends on the previous tab. + ###### Plausibility Check tab ---- + tags$div( + id = "sec4", + style = "text-align: justify;", + tags$p(tags$b("Plausibility Check")), + tags$p( + "As above described, this tab depends on the previous tab. Select the same method as in the data wrangling. Thereafter, supply the input fields with the corresponding variables from the dataset. For this, a dropdown list of the variable @@ -265,36 +319,43 @@ ui <- tagList( The app lets you get the plausibility checks results grouped by different categories - up to a maximum of three. For this, - supply the grouping variables to", tags$code("Area 1"), - tags$code("Area 2"), "and", tags$code("Area 3") - ), - tags$p(tags$em( - "For example: In your dataset, there are the following + supply the grouping variables to", + tags$code("Area 1"), + tags$code("Area 2"), + "and", + tags$code("Area 3") + ), + tags$p(tags$em( + "For example: In your dataset, there are the following indentifying variables: 'state', 'county', and 'team'. You wish to get the plausibility check results grouped by province, then by county and then you also wish to check the results by survey teams that worked in each county and provinces. You can achieve this simply by supplying 'province' to", - tags$code("Area 1"), "'county' to", tags$code("Area 2"), - "and 'team' to", tags$code("Area 3"), "." - )), - tags$p( - " + tags$code("Area 1"), + "'county' to", + tags$code("Area 2"), + "and 'team' to", + tags$code("Area 3"), + "." + )), + tags$p( + " Upon completion, you can download the results into Excel by clicking on the 'Download Results' button found at the bottom-right side of the tab. " - ) - ), - tags$hr(), + ) + ), + tags$hr(), - ###### Prevalence Analysis tab ---- - tags$div( - id = "sec5", - style = "text-align: justify;", - tags$p(tags$b("Prevalence Analysis")), - tags$p( - " + ###### Prevalence Analysis tab ---- + tags$div( + id = "sec5", + style = "text-align: justify;", + tags$p(tags$b("Prevalence Analysis")), + tags$p( + " As afore-mentioned, this tab depends on the data wrangling. The app lets you estimate prevalence derived from survey and screening. Therefore, the first step is to select the @@ -304,77 +365,92 @@ ui <- tagList( or resort to a fallback - when 'No' is selected. In the latter case, you must have a variable called", - tags$code("age_cat"), ".", "This should have the following + tags$code("age_cat"), + ".", + "This should have the following categories: '6-23' for each record wherein age is between 6 and 23 months, and '24-59' for when age is between 24 and 59 monts. - This must be done before uploading the data.", "The", - tags$code("age_cat"), "variable is supplied to the ", - tags$code("Age categories (6-23 and 24-59)"), "input field. + This must be done before uploading the data.", + "The", + tags$code("age_cat"), + "variable is supplied to the ", + tags$code("Age categories (6-23 and 24-59)"), + "input field. This ensures that MUAC-based prevalence gets age-weighted - whenever there is excess of children in the 6-23' category.", "Read more", - tags$a("here", href = "https://mphimo.github.io/mwana/dev/reference/age_ratio.html"), - "and", tags$a("here", href = "https://mphimo.github.io/mwana/dev/articles/prevalence.html#sec-prevalence-muac"), - "." + whenever there is excess of children in the 6-23' category.", + "Read more", + tags$a( + "here", + href = "https://mphimo.github.io/mwana/reference/age_ratio.html", + target = "_blank", ), - tags$p( - " + "and", + tags$a( + "here", + href = "https://mphimo.github.io/mwana/articles/prevalence.html#sec-prevalence-muac", + target = "_blank", + ), + "." + ), + tags$p( + " Thereafter, the next step is to select the method to define acute malnutrition. Then, supply the input variables as required. " - ), - tags$p( - " + ), + tags$p( + " You can also group the analysis by different groups, as explained in the plausibility check section. Follow the same guide provided therein. " - ) - ), - tags$hr(), + ) + ), + tags$hr(), - ###### IPC Check tab ---- - tags$div( - id = "sec6", - style = "text-align: justify;", - tags$p(tags$b("IPC Check")), - tags$p( - " + ###### IPC Check tab ---- + tags$div( + id = "sec6", + style = "text-align: justify;", + tags$p(tags$b("IPC Check")), + tags$p( + " This lets you check whether the IPC Acute Malnutrition evidence requirements for outcome data have been met or not. It checks against survey, screening and sentinel sites data source-related requirements, in accordance with the IPC protocols. " - ), - tags$p( - " + ), + tags$p( + " This tab depends on the 'Upload Data' tab; this means that you can check the requirements even before the wrangling the data. " - ) - ), - tags$hr(), - tags$div( - id = "sec7", - style = "text-align: justify;", - tags$p(tags$b("Authorship")), - tags$p( - "This app was developed and is maintained by Tomás Zaba." - ) - ), - tags$hr(), - tags$div( - id = "sec8", - style = "text-align: justify;", - tags$p(tags$b("License")), - tags$p( - "This app is licensed under the GPL (>=3) license." - ) + ) + ), + tags$hr(), + tags$div( + id = "sec7", + style = "text-align: justify;", + tags$p(tags$b("Authorship")), + tags$p( + "This app was developed and is maintained by Tomás Zaba." + ) + ), + tags$hr(), + tags$div( + id = "sec8", + style = "text-align: justify;", + tags$p(tags$b("License")), + tags$p( + "This app is licensed under the GPL (>=3) license." ) ) ) ) ) + ) ), ## ---- Tab 2: Data Upload --------------------------------------------------- @@ -412,4 +488,4 @@ ui <- tagList( mwanaApp:::module_ui_ipccheck(id = "ipc_check") ) ) -) \ No newline at end of file +) diff --git a/inst/app/www/custom.css b/inst/app/www/custom.css index 75f7a22..8d0574e 100644 --- a/inst/app/www/custom.css +++ b/inst/app/www/custom.css @@ -1,30 +1,116 @@ -/* Global background */ +/* Import Roboto Font from Google Fonts */ + +@import url("https://fonts.googleapis.com/css2?family=Roboto:ital,wght@0,100..900;1,100..900&display=swap"); + + +/* ---- Global background --------------------------------------------------- */ + + body { - color: rgb(68, 68, 68); background-color: #f9fdfb; - font-family: system-ui, "Segoe UI", Roboto, "Helvetica Neue", - "Noto Sans", "Liberation Sans", Arial, sans-serif, "Apple Color Emoji", - "Segoe UI Emoji", "Segoe UI Symbol", "Noto Color Emoji"; + color: rgb(68, 68, 68); +} + +p, +li, +h6, +h4, +h3, +b, +h6, +span { + font-family: Roboto, Arial, sans-serif, "Helvetica Neue"; +} + + +/* ---- Navigation bar ------------------------------------------------------ */ + + +/* Navbar container */ +nav, +nav .container-fluid { + background-color: #004225; + margin-top: -1rem; + height: 90px; + width: 100vw; + border: none; + margin: 0; + padding: 0; +} + +/* Brand (name and logo) */ + +.page-navbar { + align-items: center; + display: flex; + justify-content: space-between; + width: 100%; + padding-right: 30px; + height: 50px; + color: rgba(255, 255, 255, 0.7); +} + +/* Brand name */ + +.brand, +.brand-span { + margin-right: 10px; + margin-top: 12px; + font-family: Roboto, Arial, Helvetica, sans-serif; + font-size: 50px; + display: flex; + align-items: center; + color: rgba(255, 255, 255, 0.7); +} + +/* Logo */ + +a span { + margin-right: 20px; +} + +a span img { + height: 40px; + margin-right: 20px; + margin-left: 0px; + margin-top: 12px; } +/* Tab list elements */ -/* Navbar brand text */ -.navbar-brand span { - box-sizing: border-box; +.nav-link { color: rgba(255, 255, 255, 0.7); - color-scheme: dark; - cursor: auto; - display: inline; - font-size: 21.25px; - font-weight: 400; height: auto; - line-height: 31.875px; - text-align: start; - text-underline-offset: 3px; - text-wrap-mode: nowrap; - white-space-collapse: collapse; - width: auto; + font-family: Roboto; + font-size: 15px; +} + +/* Emphasise active tab */ + +.navbar-nav .nav-link.active { + color: rgba(255, 255, 255, 0.7); +} + +/* Target tab lists on hover */ + +.nav-link:hover { + color: rgba(209, 197, 226, 0.8); +} + +/* App version */ + +.app-version { + font-size: 12.5px; + color: rgba(255, 255, 255, 0.3); + position: fixed; + top: 60px; + right: 20px; + font-family: Roboto, Arial, Helvetica, sans-serif; } + +/* ---- Progress bar -------------------------------------------------------- */ + + /* Data upload progress bar */ span.btn.btn-default.btn-file { fill: #004225 !important; @@ -37,60 +123,24 @@ span.btn.btn-default.btn-file { background-color: #004225 !important; } -/* Navbar container */ -.navbar { - background-color: #004225 !important; - --bs-navbar-active-color: rgb(209, 197, 226, 0.8); /* active tab */ - /* --bs-nav-link-color: rgba(255, 255, 255, 0.7); */ - color: rgba(255, 255, 255, 0.7); - border-bottom: 2px solid #13b955; - align-items: center; - box-sizing: border-box; - color-scheme: light; - column-gap: 0px; - flex-direction: column; - display: flex; - flex-wrap: nowrap; - font-size: 17px; - font-weight: 400; height: 83.78125px; - justify-content: flex-start; - line-height: 25.5px; - padding-bottom: 20.4px; - padding-left: 17px; - padding-right: 17px; - padding-top: 20.4px; - position: relative; - text-align: start; - width: 1920px; -} -/* Highlight colour on hover */ -.navbar-nav { - --bs-nav-link-color: rgba(255, 255, 255, 0.7); - --bs-nav-link-hover-color: rgba(209, 197, 226, 0.8); -} +/* ---- Radio Buttons ------------------------------------------------------- */ -/* Panel headers or section titles */ -h1, h2, h3 { - color:rgb(68, 68, 68); -} -/* Set table of content's font-size to 15px */ -h6 { - font-size: 15px; -} - -/* Radio button labels */ -#wrangle_data-wrangle, #ipc_check-ipccheck, #plausible-method, -#prevalence-amn_method_survey, #prevalence-amn_method_screening, +/* Radio button labels */ +#wrangle_data-wrangle, +#ipc_check-ipccheck, +#plausible-method, +#prevalence-amn_method_survey, +#prevalence-amn_method_screening, #prevalence-source label { font-size: 14px; } /* Buttons */ .btn-primary { - background-color: #004225 !important; - border-color: #004225 !important; + background-color: #004225 !important; + border-color: #004225 !important; } .btn-primary:hover { @@ -99,21 +149,24 @@ h6 { } /* Radio buttons */ -.form-check-input:checked, -.shiny-input-container .checkbox input:checked, -.shiny-input-container .checkbox-inline input:checked, -.shiny-input-container .radio input:checked, +.form-check-input:checked, +.shiny-input-container .checkbox input:checked, +.shiny-input-container .checkbox-inline input:checked, +.shiny-input-container .radio input:checked, .shiny-input-container .radio-inline input:checked { - background-color:#004225; - border-color:#004225 + background-color: #004225; + border-color: #004225 } -/* Pagination */ -.page-link.active, -.active > .page-link { - z-index: 3; - color: var(--bs-pagination-active-color); - background-color:#004225; - border-color:#004225; -} +/* ---- Pagination ---------------------------------------------------------- */ + +/* Pagination of table under view data */ + +.page-link.active, +.active>.page-link { + z-index: 3; + color: var(--bs-pagination-active-color); + background-color: #004225; + border-color: #004225; +} \ No newline at end of file diff --git a/man/mwanaApp-package.Rd b/man/mwanaApp-package.Rd index 180f19b..9461e24 100644 --- a/man/mwanaApp-package.Rd +++ b/man/mwanaApp-package.Rd @@ -4,15 +4,14 @@ \name{mwanaApp-package} \alias{mwanaApp} \alias{mwanaApp-package} -\title{mwanaApp: mwana GUI} +\title{mwanaApp: Graphical User Interface to 'mwana'} \description{ -A seamless graphical interface to the mwana R package for data wrangling, plausibility checks, and prevalence estimation. +A graphical interface to the 'mwana' R package for data wrangling, plausibility checks, and prevalence estimation of wasting. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/mphimo/mwanaApp} - \item \url{https://mphimo.github.io/mwanaApp/} \item Report bugs at \url{https://github.com/mphimo/mwanaApp/issues} } diff --git a/tests/testthat/fixtures/anthro-03.csv b/tests/testthat/fixtures/anthro-03.csv new file mode 100644 index 0000000..2b2ce17 --- /dev/null +++ b/tests/testthat/fixtures/anthro-03.csv @@ -0,0 +1,45 @@ +survey_area,survdate,cluster,team,id,hh,sex,birthdat,age,months,weight,height,oedema +District A,03/04/2026,2,2,,2,m,04/07/2023,,32.99,16.4,94.3,n +District A,03/04/2026,2,2,,2,f,01/05/2025,,11.07,9.7,76.2,n +District A,03/04/2026,2,2,,6,m,03/08/2023,,32,13.3,95.6,n +District A,03/04/2026,2,2,,5,m,22/08/2025,,7.36,8.2,65,n +District A,03/04/2026,2,2,,10,f,02/04/2023,,36.04,13.1,97.4,n +District A,03/04/2026,2,2,,10,f,20/05/2024,,22.44,9.4,81.5,n +District A,03/04/2026,2,2,,14,f,10/04/2025,,11.76,8.4,75.7,n +District A,03/04/2026,3,3,,5,m,23/11/2023,,28.32,11.1,85,n +District A,03/04/2026,3,3,,5,m,17/03/2025,,12.55,7.7,69.7,n +District A,03/04/2026,4,4,,2,f,02/08/2022,,44.02,11.7,97.1,n +District A,03/04/2026,4,4,,2,f,10/06/2024,,21.75,9.2,80,n +District A,03/04/2026,4,4,,4,m,20/09/2025,,6.41,5.6,64.4,n +District A,03/04/2026,4,4,,8,f,09/06/2024,,21.78,9.1,76.6,n +District A,04/04/2026,6,2,,9,f,21/09/2025,,6.41,6.5,65.7,n +District A,04/04/2026,4,4,,2,f,09/02/2025,,13.77,6.4,63,n +District A,05/04/2026,9,1,,1,m,02/09/2025,,7.06,7.2,67,n +District A,05/04/2026,9,1,,2,m,06/05/2025,,10.97,6.9,67,n +District A,05/04/2026,12,4,,2,m,05/05/2025,,11.01,7.4,72.5,n +District A,05/04/2026,12,4,,14,f,11/08/2025,,7.79,5.8,65,n +District A,05/04/2026,12,4,,16,m,09/03/2025,,12.88,5.5,65,n +District A,05/04/2026,12,4,,19,m,07/03/2025,,12.94,5.9,65.3,n +District A,06/04/2026,14,2,,5,f,10/09/2025,,6.83,6.5,64,n +District A,06/04/2026,14,2,,14,f,22/03/2025,,12.48,5,65.2,n +District A,06/04/2026,16,4,,2,m,07/02/2025,,13.9,10.1,73.5,n +District A,06/04/2026,16,4,,6,f,10/04/2025,,11.86,9.1,78.5,n +District A,06/04/2026,16,4,,10,f,03/12/2022,,40.08,13.8,90,n +District A,06/04/2026,16,4,,10,f,03/05/2025,,11.1,7.3,77.2,n +District A,06/04/2026,16,4,,14,m,06/08/2025,,7.98,8,70,n +District A,07/04/2026,20,4,,2,f,10/07/2025,,8.9,6.1,65.7,n +District A,07/04/2026,20,4,,6,f,05/02/2025,,14,6.9,65.9,n +District A,07/04/2026,20,4,,14,f,10/07/2025,,8.9,5.6,65.5,n +District A,08/04/2026,24,4,,2,f,12/07/2025,,8.87,7.3,70.4,n +District A,08/04/2026,24,4,,8,f,10/09/2025,,6.9,7.5,68.4,n +District A,08/04/2026,24,4,,10,m,04/08/2025,,8.11,6.7,66.6,n +District A,08/04/2026,24,4,,12,m,06/07/2025,,9.07,5.6,65.1,n +District A,09/04/2026,28,4,,4,f,07/04/2025,,12.06,7.8,74.5,n +District A,09/04/2026,28,4,,9,f,12/07/2025,,8.9,5.3,66.3,n +District A,09/04/2026,28,4,,16,m,10/06/2025,,9.95,6.5,69,n +District A,09/04/2026,28,4,,17,m,13/09/2025,,6.83,4.9,60.1,n +District A,10/04/2026,29,1,,5,f,04/08/2025,,8.18,6.3,64.4,n +District A,10/04/2026,32,4,,2,m,04/04/2025,,12.19,7.3,70.5,n +District A,10/04/2026,32,4,,8,f,08/04/2025,,12.06,5.3,66.5,n +District A,10/04/2026,32,4,,14,m,11/06/2025,,9.95,6.7,69.5,n +District A,11/04/2026,33,1,,17,f,27/08/2025,,7.46,6,63.6,n \ No newline at end of file diff --git a/tests/testthat/test-module-data-upload.R b/tests/testthat/test-module-data-upload.R index 60b0ad1..3092892 100644 --- a/tests/testthat/test-module-data-upload.R +++ b/tests/testthat/test-module-data-upload.R @@ -2,16 +2,12 @@ # Test Suite: Module Data Upload # ============================================================================== - ## ---- Module: Data Upload ---------------------------------------------------- - -### Skip test on windows ---- -# if (identical(Sys.getenv("CI"), "true") && Sys.info()[["sysname"]] == "Windows") { -# skip("Skipping shinytest2 integration tests on Windows CI to reduce runtime") -# } - testthat::test_that("Data upload tab works as expected", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + ### Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"), @@ -46,23 +42,41 @@ testthat::test_that("Data upload tab works as expected", { ) ### Test checks ---- - testthat::expect_gte(object = column_names$input$`upload_data-upload`$size, 130756) - testthat::expect_equal(object = column_names$input$`upload_data-upload`$type, "text/csv") + testthat::expect_gte( + object = column_names$input$`upload_data-upload`$size, + 130756 + ) + testthat::expect_equal( + object = column_names$input$`upload_data-upload`$type, + "text/csv" + ) testthat::expect_true(object = column_names$output$`upload_data-fileUploaded`) - testthat::expect_true(app$get_js("$('#upload_data-uploadedDataTable').length > 0")) + testthat::expect_true(app$get_js( + "$('#upload_data-uploadedDataTable').length > 0" + )) expect_equal( - object = app$get_js(" + object = app$get_js( + " $('#upload_data-uploadedDataTable thead th').map(function() { return $(this).text(); }).get(); - ")[1:10] |> as.character(), + " + )[1:10] |> + as.character(), expected = c( - "province", "strata", "cluster", "sex", "age", "weight", "height", - "oedema", "muac", "wtfactor" + "province", + "strata", + "cluster", + "sex", + "age", + "weight", + "height", + "oedema", + "muac", + "wtfactor" ) ) #### Stop the app ---- app$stop() }) - diff --git a/tests/testthat/test-module-ipc-check.R b/tests/testthat/test-module-ipc-check.R index 372af80..7a4dfab 100644 --- a/tests/testthat/test-module-ipc-check.R +++ b/tests/testthat/test-module-ipc-check.R @@ -2,214 +2,206 @@ # Test Suite: Module IPC Check # ============================================================================== - ## ---- IPC check on survey data ----------------------------------------------- - -### Skip test on windows ---- -# if (identical(Sys.getenv("CI"), "true") && Sys.info()[["sysname"]] == "Windows") { -# skip("Skipping shinytest2 integration tests on Windows CI to reduce runtime") -# } - -testthat::test_that( - "IPC check's server module behaves as expected on survey data", - { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - load_timeout = 120000, - wait = TRUE - ) - - ### Let the app load ---- - app$wait_for_idle(timeout = 40000) - - ### Click on the Data uploading navbar ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - ### Upload data ---- - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the Data uploading navbar ---- - app$click(selector = "a[data-value='IPC Check']") - app$wait_for_idle(timeout = 40000) - - #### Set IPC Check for survey data ---- - app$set_inputs(`ipc_check-ipccheck` = "survey", wait_ = FALSE) - app$wait_for_idle(timeout = 40000) - - #### Now set parameters for survey ---- - app$set_inputs(`ipc_check-area1` = "province", wait_ = FALSE) - app$set_inputs(`ipc_check-area2` = "strata", wait_ = FALSE) - app$set_inputs(`ipc_check-psu` = "cluster", wait_ = FALSE) - - #### Run check ---- - app$click(input = "ipc_check-apply_check") - app$wait_for_value(output = "ipc_check-checked", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#ipc_check-checked thead th').map(function() { +testthat::test_that("IPC check's server module behaves as expected on survey data", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + load_timeout = 120000, + wait = TRUE + ) + + ### Let the app load ---- + app$wait_for_idle(timeout = 40000) + + ### Click on the Data uploading navbar ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + ### Upload data ---- + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the Data uploading navbar ---- + app$click(selector = "a[data-value='IPC Check']") + app$wait_for_idle(timeout = 40000) + + #### Set IPC Check for survey data ---- + app$set_inputs(`ipc_check-ipccheck` = "survey", wait_ = FALSE) + app$wait_for_idle(timeout = 40000) + + #### Now set parameters for survey ---- + app$set_inputs(`ipc_check-area1` = "province", wait_ = FALSE) + app$set_inputs(`ipc_check-area2` = "strata", wait_ = FALSE) + app$set_inputs(`ipc_check-psu` = "cluster", wait_ = FALSE) + + #### Run check ---- + app$click(input = "ipc_check-apply_check") + app$wait_for_value(output = "ipc_check-checked", timeout = 40000) + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#ipc_check-checked thead th').map(function() { return $(this).text();}).get();" - js_values <- "$('#ipc_check-checked tbody tr').map(function() + js_values <- "$('#ipc_check-checked tbody tr').map(function() {return $(this).text();}).get();" - ### Test check ---- - testthat::expect_true(app$get_js("$('#ipc_check-checked').length > 0")) - testthat::expect_equal(as.character(app$get_js(js_cols)[1:5]), + ### Test check ---- + testthat::expect_true(app$get_js("$('#ipc_check-checked').length > 0")) + testthat::expect_equal( + as.character(app$get_js(js_cols)[1:5]), c("province", "strata", "n_clusters", "n_obs", "meet_ipc") - ) - testthat::expect_equal(app$get_js(js_values)[[1]], "NampulaRural60472yes") - testthat::expect_equal(app$get_js(js_values)[[3]], "ZambeziaRural51368yes") - } -) + ) + testthat::expect_equal(app$get_js(js_values)[[1]], "NampulaRural60472yes") + testthat::expect_equal(app$get_js(js_values)[[3]], "ZambeziaRural51368yes") +}) ## ---- IPC Check on screening data -------------------------------------------- - -### Skip test on windows ---- -# if (identical(Sys.getenv("CI"), "true") && Sys.info()[["sysname"]] == "Windows") { -# skip("Skipping shinytest2 integration tests on Windows CI to reduce runtime") -# } - -testthat::test_that( - "IPC check's server module behaves as expected on screening data", - { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - load_timeout = 120000, - wait = TRUE - ) - - ### Let the app load ---- - app$wait_for_idle(timeout = 40000) - - ### Click on the Data uploading navbar ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - ### Upload data ---- - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - #### Set IPC Check for screening data ---- - app$set_inputs(`ipc_check-ipccheck` = "screening", wait_ = TRUE, timeout_ = 10000) - app$wait_for_idle(timeout = 40000) - - ### Click on the Data uploading navbar ---- - app$click(selector = "a[data-value='IPC Check']") - app$wait_for_idle(timeout = 40000) - - #### Now set parameters for survey ---- - app$set_inputs(`ipc_check-area1` = "province", wait_ = FALSE) - app$set_inputs(`ipc_check-area2` = "strata", wait_ = FALSE) - app$set_inputs(`ipc_check-sites` = "cluster", wait_ = FALSE) - - #### Run check ---- - app$click(input = "ipc_check-apply_check") - app$wait_for_value(output = "ipc_check-checked", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#ipc_check-checked thead th').map(function() { +testthat::test_that("IPC check's server module behaves as expected on screening data", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + load_timeout = 120000, + wait = TRUE + ) + + ### Let the app load ---- + app$wait_for_idle(timeout = 40000) + + ### Click on the Data uploading navbar ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + ### Upload data ---- + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + #### Set IPC Check for screening data ---- + app$set_inputs( + `ipc_check-ipccheck` = "screening", + wait_ = TRUE, + timeout_ = 10000 + ) + app$wait_for_idle(timeout = 40000) + + ### Click on the Data uploading navbar ---- + app$click(selector = "a[data-value='IPC Check']") + app$wait_for_idle(timeout = 40000) + + #### Now set parameters for survey ---- + app$set_inputs(`ipc_check-area1` = "province", wait_ = FALSE) + app$set_inputs(`ipc_check-area2` = "strata", wait_ = FALSE) + app$set_inputs(`ipc_check-sites` = "cluster", wait_ = FALSE) + + #### Run check ---- + app$click(input = "ipc_check-apply_check") + app$wait_for_value(output = "ipc_check-checked", timeout = 40000) + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#ipc_check-checked thead th').map(function() { return $(this).text();}).get();" - js_values <- "$('#ipc_check-checked tbody tr').map(function() + js_values <- "$('#ipc_check-checked tbody tr').map(function() {return $(this).text();}).get();" - ### Test ---- - testthat::expect_true(app$get_js("$('#ipc_check-checked').length > 0")) - testthat::expect_equal(as.character(app$get_js(js_cols)[1:5]), + ### Test ---- + testthat::expect_true(app$get_js("$('#ipc_check-checked').length > 0")) + testthat::expect_equal( + as.character(app$get_js(js_cols)[1:5]), c("province", "strata", "n_clusters", "n_obs", "meet_ipc") - ) - testthat::expect_equal(app$get_js(js_values)[[1]], "NampulaRural60472no") - testthat::expect_equal(app$get_js(js_values)[[3]], "ZambeziaRural51368no") - } -) + ) + testthat::expect_equal(app$get_js(js_values)[[1]], "NampulaRural60472no") + testthat::expect_equal(app$get_js(js_values)[[3]], "ZambeziaRural51368no") +}) ## ---- IPC Check on sentinel site data ---------------------------------------- - -### Skip test on windows ---- -# if (identical(Sys.getenv("CI"), "true") && Sys.info()[["sysname"]] == "Windows") { -# skip("Skipping shinytest2 integration tests on Windows CI to reduce runtime") -# } - -testthat::test_that( - "IPC check's server module behaves as expected on sentinel site data", - { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - load_timeout = 120000, - wait = TRUE - ) - - ### Let the app load ---- - app$wait_for_idle(timeout = 40000) - - ### Click on the Data uploading navbar ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - ### Upload data ---- - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the IPC Check nav bar ---- - app$click(selector = "a[data-value='IPC Check']") - - #### Set IPC Check for screening data ---- - app$set_inputs(`ipc_check-ipccheck` = "sentinel", wait_ = TRUE, timeout_ = 10000) - app$wait_for_idle(timeout = 40000) - - #### Now set parameters for survey ---- - app$set_inputs(`ipc_check-area1` = "province", wait_ = FALSE) - app$set_inputs(`ipc_check-area2` = "strata", wait_ = FALSE) - app$set_inputs(`ipc_check-ssites` = "cluster", wait_ = FALSE) - - #### Run check ---- - app$click(input = "ipc_check-apply_check") - app$wait_for_value(output = "ipc_check-checked", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#ipc_check-checked thead th').map(function() { +testthat::test_that("IPC check's server module behaves as expected on sentinel site data", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + load_timeout = 120000, + wait = TRUE + ) + + ### Let the app load ---- + app$wait_for_idle(timeout = 40000) + + ### Click on the Data uploading navbar ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + ### Upload data ---- + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the IPC Check nav bar ---- + app$click(selector = "a[data-value='IPC Check']") + + #### Set IPC Check for screening data ---- + app$set_inputs( + `ipc_check-ipccheck` = "sentinel", + wait_ = TRUE, + timeout_ = 10000 + ) + app$wait_for_idle(timeout = 40000) + + #### Now set parameters for survey ---- + app$set_inputs(`ipc_check-area1` = "province", wait_ = FALSE) + app$set_inputs(`ipc_check-area2` = "strata", wait_ = FALSE) + app$set_inputs(`ipc_check-ssites` = "cluster", wait_ = FALSE) + + #### Run check ---- + app$click(input = "ipc_check-apply_check") + app$wait_for_value(output = "ipc_check-checked", timeout = 40000) + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#ipc_check-checked thead th').map(function() { return $(this).text();}).get();" - js_values <- "$('#ipc_check-checked tbody tr').map(function() + js_values <- "$('#ipc_check-checked tbody tr').map(function() {return $(this).text();}).get();" - ### Test ---- - testthat::expect_true(app$get_js("$('#ipc_check-checked').length > 0")) - testthat::expect_equal(as.character(app$get_js(js_cols)[1:5]), + ### Test ---- + testthat::expect_true(app$get_js("$('#ipc_check-checked').length > 0")) + testthat::expect_equal( + as.character(app$get_js(js_cols)[1:5]), c("province", "strata", "n_clusters", "n_obs", "meet_ipc") - ) - testthat::expect_equal(app$get_js(js_values)[[1]], "NampulaRural60472yes") - testthat::expect_equal(app$get_js(js_values)[[3]], "ZambeziaRural51368yes") - } -) + ) + testthat::expect_equal(app$get_js(js_values)[[1]], "NampulaRural60472yes") + testthat::expect_equal(app$get_js(js_values)[[3]], "ZambeziaRural51368yes") +}) diff --git a/tests/testthat/test-module-plausibility-check.R b/tests/testthat/test-module-plausibility-check.R index 76fdd16..1c05d09 100644 --- a/tests/testthat/test-module-plausibility-check.R +++ b/tests/testthat/test-module-plausibility-check.R @@ -2,309 +2,341 @@ # Test Suite: Module Plausibility Check # ============================================================================== - ## ---- Plausibility Check on WFHZ data ---------------------------------------- - -### Skip test on windows ---- -# if (identical(Sys.getenv("CI"), "true") && Sys.info()[["sysname"]] == "Windows") { -# skip("Skipping shinytest2 integration tests on Windows CI to reduce runtime") -# } - -testthat::test_that( - desc = "Plausibility check module works well for WFHZ data", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - load_timeout = 120000, - wait = TRUE - ) - - ### Let the app load ---- - app$wait_for_idle(timeout = 40000) - - ### Click on data upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - #### Find the data to upload ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method ---- - app$set_inputs(`wrangle_data-wrangle` = "wfhz", wait_ = FALSE) - - ### Select input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-age` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) - app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) - - ### Click wrangle button ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Plausibility Check tab ---- - app$click(selector = "a[data-value='Plausibility Check']") - app$wait_for_idle(timeout = 40000) - - ### Select method for plausibility check ---- - app$set_inputs(`plausible-method` = "wfhz", wait_ = FALSE) - - ### Select input variables ---- - app$set_inputs(`plausible-area1` = "province", wait_ = FALSE) - app$set_inputs(`plausible-area2` = "strata", wait_ = FALSE) - app$set_inputs(`plausible-area3` = "sex", wait_ = FALSE) - app$set_inputs(`plausible-sex` = "sex", wait_ = FALSE) - app$set_inputs(`plausible-age` = "age", wait_ = FALSE) - app$set_inputs(`plausible-weight` = "weight", wait_ = FALSE) - app$set_inputs(`plausible-height` = "height", wait_ = FALSE) - app$set_inputs(`plausible-flags` = "flag_wfhz", wait_ = FALSE) - - ### Click on check plausibility button ---- - app$click(input = "plausible-check") - app$wait_for_value(output = "plausible-checked", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#plausible-checked thead th').map(function() { +testthat::test_that(desc = "Plausibility check module works well for WFHZ data", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + load_timeout = 120000, + wait = TRUE + ) + + ### Let the app load ---- + app$wait_for_idle(timeout = 40000) + + ### Click on data upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Find the data to upload ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method ---- + app$set_inputs(`wrangle_data-wrangle` = "wfhz", wait_ = FALSE) + + ### Select input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-age` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) + app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) + + ### Click wrangle button ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Plausibility Check tab ---- + app$click(selector = "a[data-value='Plausibility Check']") + app$wait_for_idle(timeout = 40000) + + ### Select method for plausibility check ---- + app$set_inputs(`plausible-method` = "wfhz", wait_ = FALSE) + + ### Select input variables ---- + app$set_inputs(`plausible-area1` = "province", wait_ = FALSE) + app$set_inputs(`plausible-area2` = "strata", wait_ = FALSE) + app$set_inputs(`plausible-area3` = "sex", wait_ = FALSE) + app$set_inputs(`plausible-sex` = "sex", wait_ = FALSE) + app$set_inputs(`plausible-age` = "age", wait_ = FALSE) + app$set_inputs(`plausible-weight` = "weight", wait_ = FALSE) + app$set_inputs(`plausible-height` = "height", wait_ = FALSE) + app$set_inputs(`plausible-flags` = "flag_wfhz", wait_ = FALSE) + + ### Click on check plausibility button ---- + app$click(input = "plausible-check") + app$wait_for_value(output = "plausible-checked", timeout = 40000) + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#plausible-checked thead th').map(function() { return $(this).text();}).get();" - - js_values <- "$('#plausible-checked tbody tr').map(function() + + js_values <- "$('#plausible-checked tbody tr').map(function() {return $(this).text();}).get();" - ### Capture Zambezia-urban plausibility check results ---- - plausibility_results <- - "ZambeziaRural23681.4%Excellent<0.001Problematic0.882Excellent9Good7Excellent0.92Excellent0.1Excellent0.2Excellent12Good" - - ### Test check ----- - testthat::expect_equal(as.character(app$get_js(js_cols)[1:22]), - expected = c( - "Province", "Strata", "Sex", "Total children", "Flagged data (%)", - "Class. of flagged data", "Sex ratio (p)", "Class. of sex ratio", - "Age ratio (p)", "Class. of age ratio", "DPS weight (#)", "Class. DPS weight", - "DPS height (#)", "Class. DPS height", "Standard Dev* (#)", - "Class. of standard dev", "Skewness* (#)", "Class. of skewness", - "Kurtosis* (#)", "Class. of kurtosis", "Overall score", "Overall quality" - ) + ### Capture Zambezia-urban plausibility check results ---- + plausibility_results <- + "ZambeziaRural23681.4%Excellent<0.001Problematic0.882Excellent9Good7Excellent0.92Excellent0.1Excellent0.2Excellent12Good" + + ### Test check ----- + testthat::expect_equal( + as.character(app$get_js(js_cols)[1:22]), + expected = c( + "Province", + "Strata", + "Sex", + "Total children", + "Flagged data (%)", + "Class. of flagged data", + "Sex ratio (p)", + "Class. of sex ratio", + "Age ratio (p)", + "Class. of age ratio", + "DPS weight (#)", + "Class. DPS weight", + "DPS height (#)", + "Class. DPS height", + "Standard Dev* (#)", + "Class. of standard dev", + "Skewness* (#)", + "Class. of skewness", + "Kurtosis* (#)", + "Class. of kurtosis", + "Overall score", + "Overall quality" ) - testthat::expect_equal(app$get_js(js_values)[[3]], plausibility_results) - ### Stop the app ---- - app$stop() - } -) + ) + testthat::expect_equal(app$get_js(js_values)[[3]], plausibility_results) + ### Stop the app ---- + app$stop() +}) ## ---- Plausibility Check on MFAZ data ---------------------------------------- - -### Skip test on windows ---- -# if (identical(Sys.getenv("CI"), "true") && Sys.info()[["sysname"]] == "Windows") { -# skip("Skipping shinytest2 integration tests on Windows CI to reduce runtime") -# } - -testthat::test_that( - desc = "Plausibility check module works well for MFAZ data", - code = { - # Initialise app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - load_timeout = 120000, - wait = TRUE - ) - - ### Let the app load ---- - app$wait_for_idle(timeout = 40000) - - ### Click on the Data uploading navbar ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method ---- - app$set_inputs(`wrangle_data-wrangle` = "mfaz", wait_ = TRUE, timeout_ = 15000) - app$wait_for_idle(timeout = 40000) - - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) - - ### Click wrangle button ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Plausibility Check tab ---- - app$click(selector = "a[data-value='Plausibility Check']") - app$wait_for_idle(timeout = 40000) - - ### Select method for plausibility check ---- - app$set_inputs(`plausible-method` = "mfaz", wait_ = TRUE, timeout_ = 15000) - - ### Select input variables ---- - app$set_inputs(`plausible-area1` = "province", wait_ = FALSE) - app$set_inputs(`plausible-area2` = "strata", wait_ = FALSE) - app$set_inputs(`plausible-area3` = "sex", wait_ = FALSE) - app$set_inputs(`plausible-sex` = "sex", wait_ = FALSE) - app$set_inputs(`plausible-age` = "age", wait_ = FALSE) - app$set_inputs(`plausible-muac` = "muac", wait_ = FALSE) - app$set_inputs(`plausible-flags` = "flag_mfaz", wait_ = FALSE) - - ### Click on check plausibility button ---- - app$click(input = "plausible-check") - app$wait_for_value(output = "plausible-checked", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#plausible-checked thead th').map(function() { +testthat::test_that(desc = "Plausibility check module works well for MFAZ data", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + # Initialise app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + load_timeout = 120000, + wait = TRUE + ) + + ### Let the app load ---- + app$wait_for_idle(timeout = 40000) + + ### Click on the Data uploading navbar ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method ---- + app$set_inputs( + `wrangle_data-wrangle` = "mfaz", + wait_ = TRUE, + timeout_ = 15000 + ) + app$wait_for_idle(timeout = 40000) + + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) + + ### Click wrangle button ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Plausibility Check tab ---- + app$click(selector = "a[data-value='Plausibility Check']") + app$wait_for_idle(timeout = 40000) + + ### Select method for plausibility check ---- + app$set_inputs(`plausible-method` = "mfaz", wait_ = TRUE, timeout_ = 15000) + + ### Select input variables ---- + app$set_inputs(`plausible-area1` = "province", wait_ = FALSE) + app$set_inputs(`plausible-area2` = "strata", wait_ = FALSE) + app$set_inputs(`plausible-area3` = "sex", wait_ = FALSE) + app$set_inputs(`plausible-sex` = "sex", wait_ = FALSE) + app$set_inputs(`plausible-age` = "age", wait_ = FALSE) + app$set_inputs(`plausible-muac` = "muac", wait_ = FALSE) + app$set_inputs(`plausible-flags` = "flag_mfaz", wait_ = FALSE) + + ### Click on check plausibility button ---- + app$click(input = "plausible-check") + app$wait_for_value(output = "plausible-checked", timeout = 40000) + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#plausible-checked thead th').map(function() { return $(this).text();}).get();" - js_values <- "$('#plausible-checked tbody tr').map(function() + js_values <- "$('#plausible-checked tbody tr').map(function() {return $(this).text();}).get();" - ### Capture Nampula-urban plausibility check results ---- - plausibility_results <- - "NampulaUrban26141.3%Good<0.001Problematic0.241Excellent10Good0.96Excellent-0.36Excellent0.27Good18Acceptable" - - ### Test check ---- - testthat::expect_equal(as.character(app$get_js(js_cols)[1:20]), - expected = c( - "Province", "Strata", "Sex", "Total children", "Flagged data (%)", - "Class. of flagged data", "Sex ratio (p)", "Class. of sex ratio", - "Age ratio (p)", "Class. of age ratio", "DPS (#)", - "Class. of DPS", "Standard Dev* (#)", "Class. of standard dev", - "Skewness* (#)", "Class. of skewness", "Kurtosis* (#)", - "Class. of kurtosis", "Overall score", "Overall quality" - ) + ### Capture Nampula-urban plausibility check results ---- + plausibility_results <- + "NampulaUrban26141.3%Good<0.001Problematic0.241Excellent10Good0.96Excellent-0.36Excellent0.27Good18Acceptable" + + ### Test check ---- + testthat::expect_equal( + as.character(app$get_js(js_cols)[1:20]), + expected = c( + "Province", + "Strata", + "Sex", + "Total children", + "Flagged data (%)", + "Class. of flagged data", + "Sex ratio (p)", + "Class. of sex ratio", + "Age ratio (p)", + "Class. of age ratio", + "DPS (#)", + "Class. of DPS", + "Standard Dev* (#)", + "Class. of standard dev", + "Skewness* (#)", + "Class. of skewness", + "Kurtosis* (#)", + "Class. of kurtosis", + "Overall score", + "Overall quality" ) - testthat::expect_equal(app$get_js(js_values)[[2]], plausibility_results) - ### Stop the app ---- - app$stop() - } -) + ) + testthat::expect_equal(app$get_js(js_values)[[2]], plausibility_results) + ### Stop the app ---- + app$stop() +}) ## ---- Plausibility Check on raw MUAC data ------------------------------------ +testthat::test_that(desc = "Plausibility check module works well for MUAC data", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + load_timeout = 120000, + wait = TRUE + ) + + ### Let the app load ---- + app$wait_for_idle(timeout = 40000) + + ### Click on data upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Find the data to upload ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method ---- + app$set_inputs( + `wrangle_data-wrangle` = "muac", + wait_ = TRUE, + timeout_ = 15000 + ) + app$wait_for_idle(timeout = 40000) + + ### Select input variables ---- + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) + + ### Click wrangle button ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Plausibility Check tab ---- + app$click(selector = "a[data-value='Plausibility Check']") + app$wait_for_idle(timeout = 40000) + + ### Select method for plausibility check ---- + app$set_inputs(`plausible-method` = "muac", wait_ = TRUE, timeout_ = 15000) + app$wait_for_idle(timeout = 40000) + + ### Select input variables ---- + app$set_inputs(`plausible-area1` = "province", wait_ = FALSE) + app$set_inputs(`plausible-area2` = "strata", wait_ = FALSE) + app$set_inputs(`plausible-area3` = "sex", wait_ = FALSE) + app$set_inputs(`plausible-sex` = "sex", wait_ = FALSE) + app$set_inputs(`plausible-muac` = "muac", wait_ = FALSE) + app$set_inputs(`plausible-flags` = "flag_muac", wait_ = FALSE) + + ### Click on check plausibility button + app$click(input = "plausible-check") + app$wait_for_value(output = "plausible-checked", timeout = 40000) + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#plausible-checked thead th').map(function() { + return $(this).text();}).get();" + js_values <- "$('#plausible-checked tbody tr').map(function() + {return $(this).text();}).get();" -### Skip test on windows ---- -# if (identical(Sys.getenv("CI"), "true") && Sys.info()[["sysname"]] == "Windows") { -# skip("Skipping shinytest2 integration tests on Windows CI to reduce runtime") -# } - -testthat::test_that( - desc = "Plausibility check module works well for MUAC data", - code = { - - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - load_timeout = 120000, - wait = TRUE - ) - - ### Let the app load ---- - app$wait_for_idle(timeout = 40000) - - ### Click on data upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - #### Find the data to upload ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE + ### Capture Zambezia-urban plausibility check results ---- + plausibility_results <- + "ZambeziaUrban28130.1%Excellent<0.001Problematic5Excellent13.48Acceptable" + + ### Test check ----- + testthat::expect_equal( + as.character(app$get_js(js_cols)[1:12]), + expected = c( + "Province", + "Strata", + "Sex", + "Total children", + "Flagged data (%)", + "Class. of flagged data", + "Sex ratio (p)", + "Class. of sex ratio", + "DPS(#)", + "Class. of DPS", + "Standard Dev* (#)", + "Class. of standard dev" ) + ) - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method ---- - app$set_inputs(`wrangle_data-wrangle` = "muac", wait_ = TRUE, timeout_ = 15000) - app$wait_for_idle(timeout = 40000) - - ### Select input variables ---- - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) - - ### Click wrangle button ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Plausibility Check tab ---- - app$click(selector = "a[data-value='Plausibility Check']") - app$wait_for_idle(timeout = 40000) - - ### Select method for plausibility check ---- - app$set_inputs(`plausible-method` = "muac", wait_ = TRUE, timeout_ = 15000) - app$wait_for_idle(timeout = 40000) - - ### Select input variables ---- - app$set_inputs(`plausible-area1` = "province", wait_ = FALSE) - app$set_inputs(`plausible-area2` = "strata", wait_ = FALSE) - app$set_inputs(`plausible-area3` = "sex", wait_ = FALSE) - app$set_inputs(`plausible-sex` = "sex", wait_ = FALSE) - app$set_inputs(`plausible-muac` = "muac", wait_ = FALSE) - app$set_inputs(`plausible-flags` = "flag_muac", wait_ = FALSE) - - ### Click on check plausibility button - app$click(input = "plausible-check") - app$wait_for_value(output = "plausible-checked", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#plausible-checked thead th').map(function() { - return $(this).text();}).get();" - js_values <- "$('#plausible-checked tbody tr').map(function() - {return $(this).text();}).get();" + testthat::expect_equal(app$get_js(js_values)[[4]], plausibility_results) - ### Capture Zambezia-urban plausibility check results ---- - plausibility_results <- - "ZambeziaUrban28130.1%Excellent<0.001Problematic5Excellent13.48Acceptable" - - ### Test check ----- - testthat::expect_equal(as.character(app$get_js(js_cols)[1:12]), - expected = c( - "Province", "Strata", "Sex", "Total children", "Flagged data (%)", - "Class. of flagged data", "Sex ratio (p)", "Class. of sex ratio", "DPS(#)", - "Class. of DPS", "Standard Dev* (#)", "Class. of standard dev")) - - testthat::expect_equal(app$get_js(js_values)[[4]], plausibility_results) - - ### Stop the app ---- - app$stop() - } -) + ### Stop the app ---- + app$stop() +}) diff --git a/tests/testthat/test-module-prevalence.R b/tests/testthat/test-module-prevalence.R index a618553..6133d3c 100644 --- a/tests/testthat/test-module-prevalence.R +++ b/tests/testthat/test-module-prevalence.R @@ -2,789 +2,897 @@ # Test Suite: Module Prevalence # ============================================================================== - ## ---- Survey data ------------------------------------------------------------ - ### WFHZ weighted prevalence ---- -testthat::test_that( - desc = "Module works well to estimate weighted-WFHZ prevalence from survey", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE - ) - - ### Wait the app to idle ---- - app$wait_for_idle(timeout = 40000) - - ### Click in the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - data["sex"] <- ifelse(data$sex == 1, "m", "f") - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ## App defaults to WFHZ ---- - ### Input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) - app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) - - ### Click wrangle button and wait the app to idle ---- - app$click(input = "wrangle_data-apply_wrangle") - Sys.sleep(3) - - ### Click on the Prevalence tab and wait the app to idle ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) - - ### Select source of data ---- - app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) - - ### Select the method ---- - app$set_inputs(`prevalence-amn_method_survey` = "wfhz", wait_ = FALSE) - app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) - app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var - app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) - app$set_inputs(`prevalence-wts` = "wtfactor", wait_ = FALSE) - app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) - - ### Click on Estime Prevalence button ---- - app$click(input = "prevalence-estimate") - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() +testthat::test_that(desc = "Module works well to estimate weighted-WFHZ prevalence from survey", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + ### Wait the app to idle ---- + app$wait_for_idle(timeout = 40000) + + ### Click in the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + data["sex"] <- ifelse(data$sex == 1, "m", "f") + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ## App defaults to WFHZ ---- + ### Input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) + app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) + + ### Click wrangle button and wait the app to idle ---- + app$click(input = "wrangle_data-apply_wrangle") + Sys.sleep(3) + + ### Click on the Prevalence tab and wait the app to idle ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) + + ### Select source of data ---- + app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) + + ### Select the method ---- + app$set_inputs(`prevalence-amn_method_survey` = "wfhz", wait_ = FALSE) + app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) + app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var + app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) + app$set_inputs(`prevalence-wts` = "wtfactor", wait_ = FALSE) + app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) + + ### Click on Estime Prevalence button ---- + app$click(input = "prevalence-estimate") + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() {return $(this).text();}).get();" - js_values <- "$('#prevalence-results tbody tr').map(function() + js_values <- "$('#prevalence-results tbody tr').map(function() {return $(this).text();}).get();" - ### Capture prevalence results of Nampula Province, Rural Strata ---- - glued_results <- app$get_js(js_values)[[3]] - weighted_pop <- sub("1", "", stringr::str_extract(glued_results, "\\d{7}(?:)")) - gam_prev <- stringr::str_extract(glued_results, "\\d\\.\\d") - - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) - testthat::expect_equal(as.numeric(weighted_pop), 292611) - testthat::expect_equal(as.numeric(gam_prev), 6.1) + ### Capture prevalence results of Nampula Province, Rural Strata ---- + glued_results <- app$get_js(js_values)[[3]] + weighted_pop <- sub( + "1", + "", + stringr::str_extract(glued_results, "\\d{7}(?:)") + ) + gam_prev <- stringr::str_extract(glued_results, "\\d\\.\\d") + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) + testthat::expect_equal(as.numeric(weighted_pop), 292611) + testthat::expect_equal(as.numeric(gam_prev), 6.1) + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-survey-wfhz_", + Sys.Date(), + ".xlsx", + sep = "" + ) + ) - ### Stop the app ---- - app$stop() - } -) + ### Stop the app ---- + app$stop() +}) ### WFHZ unweighted prevalence ---- -testthat::test_that( - desc = "Module works well to estimate unweighted-WFHZ prevalence from survey", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE - ) - - ### Wait the app to idle ---- - app$wait_for_idle(timeout = 40000) +testthat::test_that(desc = "Module works well to estimate unweighted-WFHZ prevalence from survey", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + ### Wait the app to idle ---- + app$wait_for_idle(timeout = 40000) + + ### Click in the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + data["sex"] <- ifelse(data$sex == 1, "m", "f") + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ## App defaults to WFHZ ---- + ### Input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) + app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) + + ### Click wrangle button and wait the app to idle ---- + app$click(input = "wrangle_data-apply_wrangle") + Sys.sleep(3) + + ### Click on the Prevalence tab and wait the app to idle ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) + + ### Select source of data ---- + app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) + + ### Select the method ---- + app$set_inputs(`prevalence-amn_method_survey` = "wfhz", wait_ = FALSE) + app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) + app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var + app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) + app$set_inputs(`prevalence-wts` = "", wait_ = FALSE) + app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) + + ### Click on Estime Prevalence button ---- + app$click(input = "prevalence-estimate") + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() + {return $(this).text();}).get();" - ### Click in the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) + js_values <- "$('#prevalence-results tbody tr').map(function() + {return $(this).text();}).get();" - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE + ### Capture prevalence results of Nampula Province, Rural Strata ---- + glued_results <- app$get_js(js_values)[[3]] + pop <- sub("1", "", stringr::str_extract(glued_results, "\\d{4}")) + gam_prev <- stringr::str_extract(glued_results, "\\d{1}\\.\\d") + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) + testthat::expect_equal(as.numeric(pop), 280) + testthat::expect_equal(as.numeric(gam_prev), 6.1) + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-survey-wfhz_", + Sys.Date(), + ".xlsx", + sep = "" ) - data["sex"] <- ifelse(data$sex == 1, "m", "f") - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ## App defaults to WFHZ ---- - ### Input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) - app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) - - ### Click wrangle button and wait the app to idle ---- - app$click(input = "wrangle_data-apply_wrangle") - Sys.sleep(3) + ) - ### Click on the Prevalence tab and wait the app to idle ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) + ### Stop the app ---- + app$stop() +}) - ### Select source of data ---- - app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) - ### Select the method ---- - app$set_inputs(`prevalence-amn_method_survey` = "wfhz", wait_ = FALSE) - app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) - app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var - app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) - app$set_inputs(`prevalence-wts` = "", wait_ = FALSE) - app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) - - ### Click on Estime Prevalence button ---- - app$click(input = "prevalence-estimate") - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() +### MUAC weighted prevalence ---- +testthat::test_that(desc = "Module works well to estimate weighted-MUAC prevalence from survey", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + ### Wait the app to idle ---- + app$wait_for_idle(timeout = 40000) + + ### Click in the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + data["sex"] <- ifelse(data$sex == 1, "m", "f") + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method and wait the app till idles ---- + app$set_inputs(`wrangle_data-wrangle` = "mfaz", wait_ = TRUE) + app$wait_for_idle(timeout = 40000) + + ### Input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) + + ### Click wrangle button and wait the app to idle ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Prevalence tab and wait the app to idle ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) + + ### Select source of data ---- + app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) + + ### Select the method ---- + app$set_inputs(`prevalence-amn_method_survey` = "muac", wait_ = TRUE) + app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) + app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var + app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) + app$set_inputs(`prevalence-muac` = "muac", wait_ = FALSE) + app$set_inputs(`prevalence-age` = "age", wait_ = FALSE) + app$set_inputs(`prevalence-wts` = "wtfactor", wait_ = FALSE) + app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) + + ### Click on Estime Prevalence button ---- + app$click(input = "prevalence-estimate") + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() {return $(this).text();}).get();" - js_values <- "$('#prevalence-results tbody tr').map(function() + js_values <- "$('#prevalence-results tbody tr').map(function() {return $(this).text();}).get();" - ### Capture prevalence results of Nampula Province, Rural Strata ---- - glued_results <- app$get_js(js_values)[[3]] - pop <- sub("1", "", stringr::str_extract(glued_results, "\\d{4}")) - gam_prev <- stringr::str_extract(glued_results, "\\d{1}\\.\\d") + ### Get a JS expression ---- + js_result <- app$get_js(js_values) - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) - testthat::expect_equal(as.numeric(pop), 280) - testthat::expect_equal(as.numeric(gam_prev), 6.1) - - ### Stop the app ---- - app$stop() + ### Wait/validate that we have at least 3 values + if (length(js_result) < 4) { + #### Add a small delay and retry + Sys.sleep(3) + js_result <- app$get_js(js_values) } -) - - -### MUAC weighted prevalence ---- -testthat::test_that( - desc = "Module works well to estimate weighted-MUAC prevalence from survey", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE + ### Capture prevalence results of Zambezia Province, Rural Strata ---- + prev <- stringr::str_extract_all(js_result[[3]], "\\d\\.\\d")[[1]] + weighted_pop <- sub( + "1", + "", + stringr::str_extract(js_result[[3]], "\\d{7}(?:)") + ) + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) + testthat::expect_equal(as.numeric(prev[2]), 7.7) # GAM + testthat::expect_equal(as.numeric(weighted_pop), 307395) + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-survey-muac_", + Sys.Date(), + ".xlsx", + sep = "" ) + ) - ### Wait the app to idle ---- - app$wait_for_idle(timeout = 40000) + ### Stop the app ---- + app$stop() +}) - ### Click in the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - data["sex"] <- ifelse(data$sex == 1, "m", "f") - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method and wait the app till idles ---- - app$set_inputs(`wrangle_data-wrangle` = "mfaz", wait_ = TRUE) - app$wait_for_idle(timeout = 40000) - - ### Input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) - - ### Click wrangle button and wait the app to idle ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Prevalence tab and wait the app to idle ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) - - ### Select source of data ---- - app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) - - ### Select the method ---- - app$set_inputs(`prevalence-amn_method_survey` = "muac", wait_ = TRUE) - app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) - app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var - app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) - app$set_inputs(`prevalence-muac` = "muac", wait_ = FALSE) - app$set_inputs(`prevalence-age` = "age", wait_ = FALSE) - app$set_inputs(`prevalence-wts` = "wtfactor", wait_ = FALSE) - app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) - - ### Click on Estime Prevalence button ---- - app$click(input = "prevalence-estimate") - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() +### MUAC unweighted prevalence ---- +testthat::test_that(desc = "Module works well to estimate unweighted-MUAC prevalence from survey", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + ### Wait the app to idle ---- + app$wait_for_idle(timeout = 40000) + + ### Click in the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + data["sex"] <- ifelse(data$sex == 1, "m", "f") + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method and wait the app till idles ---- + app$set_inputs(`wrangle_data-wrangle` = "mfaz", wait_ = TRUE) + app$wait_for_idle(timeout = 40000) + + ### Input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) + + ### Click wrangle button and wait the app to idle ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Prevalence tab and wait the app to idle ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) + + ### Select source of data ---- + app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) + + ### Select the method ---- + app$set_inputs(`prevalence-amn_method_survey` = "muac", wait_ = TRUE) + app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) + app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var + app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) + app$set_inputs(`prevalence-muac` = "muac", wait_ = FALSE) + app$set_inputs(`prevalence-age` = "age", wait_ = FALSE) + app$set_inputs(`prevalence-wts` = "", wait_ = FALSE) + app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) + + ### Click on Estime Prevalence button ---- + app$click(input = "prevalence-estimate") + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() {return $(this).text();}).get();" - js_values <- "$('#prevalence-results tbody tr').map(function() + js_values <- "$('#prevalence-results tbody tr').map(function() {return $(this).text();}).get();" - ### Get a JS expression ---- - js_result <- app$get_js(js_values) + ### Get a JS expression ---- + js_result <- app$get_js(js_values) - ### Wait/validate that we have at least 3 values - if (length(js_result) < 4) { - #### Add a small delay and retry - Sys.sleep(3) - js_result <- app$get_js(js_values) - } - ### Capture prevalence results of Zambezia Province, Rural Strata ---- - prev <- stringr::str_extract_all(js_result[[3]], "\\d\\.\\d")[[1]] - weighted_pop <- sub("1", "", stringr::str_extract(js_result[[3]], "\\d{7}(?:)")) - - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) - testthat::expect_equal(as.numeric(prev[2]), 7.7) # GAM - testthat::expect_equal(as.numeric(weighted_pop), 307395) - - ### Stop the app ---- - app$stop() + ### Wait/validate that we have at least 3 values + if (length(js_result) < 4) { + #### Add a small delay and retry + Sys.sleep(3) + js_result <- app$get_js(js_values) } -) - - -### MUAC unweighted prevalence ---- -testthat::test_that( - desc = "Module works well to estimate unweighted-MUAC prevalence from survey", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE + ### Capture prevalence results of Zambezia Province, Rural Strata ---- + pop <- sub("1", "", stringr::str_extract(js_result[[3]], "\\d{4}")) + prev <- stringr::str_extract(js_result[[3]], "\\d{1}\\.\\d") + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) + testthat::expect_equal(as.numeric(prev), 8.0) # GAM + testthat::expect_equal(as.numeric(pop), 300) + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-survey-muac_", + Sys.Date(), + ".xlsx", + sep = "" ) + ) - ### Wait the app to idle ---- - app$wait_for_idle(timeout = 40000) + ### Stop the app ---- + app$stop() +}) - ### Click in the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - data["sex"] <- ifelse(data$sex == 1, "m", "f") - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method and wait the app till idles ---- - app$set_inputs(`wrangle_data-wrangle` = "mfaz", wait_ = TRUE) - app$wait_for_idle(timeout = 40000) - - ### Input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) - - ### Click wrangle button and wait the app to idle ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Prevalence tab and wait the app to idle ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) - - ### Select source of data ---- - app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) - - ### Select the method ---- - app$set_inputs(`prevalence-amn_method_survey` = "muac", wait_ = TRUE) - app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) - app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var - app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) - app$set_inputs(`prevalence-muac` = "muac", wait_ = FALSE) - app$set_inputs(`prevalence-age` = "age", wait_ = FALSE) - app$set_inputs(`prevalence-wts` = "", wait_ = FALSE) - app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) - - ### Click on Estime Prevalence button ---- - app$click(input = "prevalence-estimate") - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() +### Combined weighted prevalence ---- +testthat::test_that(desc = "Module works well to estimate weighted-combined prevalence from survey", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + ### Wait the app to idle ---- + app$wait_for_idle(timeout = 40000) + + ### Click in the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + data["sex"] <- ifelse(data$sex == 1, "m", "f") + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method and wait the app till idles ---- + app$set_inputs(`wrangle_data-wrangle` = "combined", wait_ = TRUE) + app$wait_for_idle(timeout = 40000) + + ### Input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) + app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) + app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) + + ### Click wrangle button and wait the app to idle ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Prevalence tab and wait the app to idle ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) + + ### Select source of data ---- + app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) + + ### Select the method ---- + app$set_inputs(`prevalence-amn_method_survey` = "combined", wait_ = TRUE) + app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) + app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var + app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) + app$set_inputs(`prevalence-wts` = "wtfactor", wait_ = FALSE) + app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) + + ### Click on Estime Prevalence button ---- + app$click(input = "prevalence-estimate") + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() {return $(this).text();}).get();" - js_values <- "$('#prevalence-results tbody tr').map(function() + js_values <- "$('#prevalence-results tbody tr').map(function() {return $(this).text();}).get();" - ### Get a JS expression ---- - js_result <- app$get_js(js_values) - - ### Wait/validate that we have at least 3 values - if (length(js_result) < 4) { - #### Add a small delay and retry - Sys.sleep(3) - js_result <- app$get_js(js_values) - } - ### Capture prevalence results of Zambezia Province, Rural Strata ---- - pop <- sub("1", "", stringr::str_extract(js_result[[3]], "\\d{4}")) - prev <- stringr::str_extract(js_result[[3]], "\\d{1}\\.\\d") - - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) - testthat::expect_equal(as.numeric(prev), 8.0) # GAM - testthat::expect_equal(as.numeric(pop), 300) - - ### Stop the app ---- - app$stop() - } -) - - - -### Combined weighted prevalence ---- -testthat::test_that( - desc = "Module works well to estimate weighted-combined prevalence from survey", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE + ### Capture prevalence results of Nampula Province, Urban Strata ---- + glued_results <- app$get_js(js_values)[[3]] + prev <- stringr::str_extract_all(glued_results, "\\d{2}\\.\\d")[[1]] + weighted_pop <- sub( + "1", + "", + stringr::str_extract(glued_results, "\\d{7}(?:)") + ) + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) + testthat::expect_equal(as.numeric(prev[2]), 10.8) # GAM + testthat::expect_equal(as.numeric(weighted_pop), 288534) + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-survey-combined_", + Sys.Date(), + ".xlsx", + sep = "" ) + ) - ### Wait the app to idle ---- - app$wait_for_idle(timeout = 40000) + ### Stop the app ---- + app$stop() +}) - ### Click in the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - data["sex"] <- ifelse(data$sex == 1, "m", "f") - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method and wait the app till idles ---- - app$set_inputs(`wrangle_data-wrangle` = "combined", wait_ = TRUE) - app$wait_for_idle(timeout = 40000) - - ### Input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) - app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) - app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) - - ### Click wrangle button and wait the app to idle ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Prevalence tab and wait the app to idle ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) - - ### Select source of data ---- - app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) - - ### Select the method ---- - app$set_inputs(`prevalence-amn_method_survey` = "combined", wait_ = TRUE) - app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) - app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var - app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) - app$set_inputs(`prevalence-wts` = "wtfactor", wait_ = FALSE) - app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) - - ### Click on Estime Prevalence button ---- - app$click(input = "prevalence-estimate") - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() +### Combined unweighted prevalence ---- +testthat::test_that(desc = "Module works well to estimate unweighted-combined prevalence from survey", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + ### Wait the app to idle ---- + app$wait_for_idle(timeout = 40000) + + ### Click in the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-01.csv"), + check.names = FALSE + ) + data["sex"] <- ifelse(data$sex == 1, "m", "f") + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method and wait the app till idles ---- + app$set_inputs(`wrangle_data-wrangle` = "combined", wait_ = TRUE) + app$wait_for_idle(timeout = 40000) + + ### Input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) + app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) + app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) + + ### Click wrangle button and wait the app to idle ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Prevalence tab and wait the app to idle ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) + + ### Select source of data ---- + app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) + + ### Select the method ---- + app$set_inputs(`prevalence-amn_method_survey` = "combined", wait_ = TRUE) + app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) + app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var + app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) + app$set_inputs(`prevalence-wts` = "", wait_ = FALSE) + app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) + + ### Click on Estime Prevalence button ---- + app$click(input = "prevalence-estimate") + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() {return $(this).text();}).get();" - js_values <- "$('#prevalence-results tbody tr').map(function() + js_values <- "$('#prevalence-results tbody tr').map(function() {return $(this).text();}).get();" - ### Capture prevalence results of Nampula Province, Urban Strata ---- - glued_results <- app$get_js(js_values)[[3]] - prev <- stringr::str_extract_all(glued_results, "\\d{2}\\.\\d")[[1]] - weighted_pop <- sub("1", "", stringr::str_extract(glued_results, "\\d{7}(?:)")) - - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) - testthat::expect_equal(as.numeric(prev[2]), 10.8) # GAM - testthat::expect_equal(as.numeric(weighted_pop), 288534) - - ### Stop the app ---- - app$stop() - } -) - - -### Combined unweighted prevalence ---- -testthat::test_that( - desc = "Module works well to estimate unweighted-combined prevalence from survey", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE + ### Capture prevalence results of Nampula Province, Urban Strata ---- + glued_results <- app$get_js(js_values)[[3]] + pop <- sub("1", "", stringr::str_extract(glued_results, "\\d{4}")) + prev <- stringr::str_extract(glued_results, "\\d{2}\\.\\d") + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) + testthat::expect_equal(as.numeric(prev), 10.5) # GAM + testthat::expect_equal(as.numeric(pop), 276) + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-survey-combined_", + Sys.Date(), + ".xlsx", + sep = "" ) + ) - ### Wait the app to idle ---- - app$wait_for_idle(timeout = 40000) + ### Stop the app ---- + app$stop() +}) - ### Click in the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) +## ---- Screening data --------------------------------------------------------- - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-01.csv"), - check.names = FALSE - ) - data["sex"] <- ifelse(data$sex == 1, "m", "f") - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method and wait the app till idles ---- - app$set_inputs(`wrangle_data-wrangle` = "combined", wait_ = TRUE) - app$wait_for_idle(timeout = 40000) - - ### Input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-weight` = "weight", wait_ = FALSE) - app$set_inputs(`wrangle_data-height` = "height", wait_ = FALSE) - app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) - - ### Click wrangle button and wait the app to idle ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Prevalence tab and wait the app to idle ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) - - ### Select source of data ---- - app$set_inputs(`prevalence-source` = "survey", wait_ = FALSE) - - ### Select the method ---- - app$set_inputs(`prevalence-amn_method_survey` = "combined", wait_ = TRUE) - app$set_inputs(`prevalence-area1` = "province", wait_ = FALSE) - app$set_inputs(`prevalence-area2` = "strata", wait_ = FALSE) ## Assume sex as grouping var - app$set_inputs(`prevalence-area3` = "sex", wait_ = FALSE) - app$set_inputs(`prevalence-wts` = "", wait_ = FALSE) - app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) - - ### Click on Estime Prevalence button ---- - app$click(input = "prevalence-estimate") - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() +### When age is available ---- +testthat::test_that(desc = "Module works well to estimate prevalence from screening", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + ### Initialise mwana app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + ### Wait the app to idle ---- + app$wait_for_idle(timeout = 40000) + + ### Click in the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-02.csv"), + check.names = FALSE + ) + ### Make age categories ---- + data <- data |> + transform(oedema = dplyr::recode_values(oedema, "n " ~ "n")) + + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) + + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) + + ### Click on the data wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling']") + app$wait_for_idle(timeout = 40000) + + ### Select data wrangling method and wait the app till idles ---- + app$set_inputs(`wrangle_data-wrangle` = "mfaz", wait_ = TRUE) + app$wait_for_idle(timeout = 40000) + + ### Input variables ---- + app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) + app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) + app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) + app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) + + ### Click wrangle button and wait the app to idle ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) + + ### Click on the Prevalence tab and wait the app to idle ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) + + ### Select source of data ---- + app$set_inputs( + `prevalence-source` = "screening", + wait_ = TRUE, + timeout_ = 40000 + ) + + ### Select the method ---- + app$set_inputs(`prevalence-has_age` = "yes", wait_ = TRUE, timeout_ = 40000) + app$set_inputs(`prevalence-area1` = "analysis_unit", wait_ = FALSE) + app$set_inputs(`prevalence-area2` = "sex", wait_ = FALSE) ## Assume sex as grouping var + app$set_inputs(`prevalence-area3` = "", wait_ = FALSE) + app$set_inputs(`prevalence-muac` = "muac", wait_ = FALSE) + app$set_inputs(`prevalence-age` = "age", wait_ = FALSE) + + ### Click on Estime Prevalence button ---- + app$click(input = "prevalence-estimate") + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") + + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() {return $(this).text();}).get();" - js_values <- "$('#prevalence-results tbody tr').map(function() + js_values <- "$('#prevalence-results tbody tr').map(function() {return $(this).text();}).get();" - ### Capture prevalence results of Nampula Province, Urban Strata ---- - glued_results <- app$get_js(js_values)[[3]] - pop <- sub("1", "", stringr::str_extract(glued_results, "\\d{4}")) - prev <- stringr::str_extract(glued_results, "\\d{2}\\.\\d") - - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:19]), 19) - testthat::expect_equal(as.numeric(prev), 10.5) # GAM - testthat::expect_equal(as.numeric(pop), 276) - - ### Stop the app ---- - app$stop() - } -) - -## ---- Screening data --------------------------------------------------------- - - -### When age is available ---- -testthat::test_that( - desc = "Module works well to estimate prevalence from screening", - code = { - ### Initialise mwana app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE + ### Capture results ---- + glued_results_unit_a <- app$get_js(js_values)[[1]] + glued_results_unit_b <- app$get_js(js_values)[[2]] + + N_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d{3}$")[[1]] + N_unit_b <- stringr::str_extract_all(glued_results_unit_b, "\\d{4}$")[[1]] + + #### Prevalences ---- + prev_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d\\.\\d")[[ + 1 + ]] + prev_unit_b <- stringr::str_extract(glued_results_unit_b, "\\d{2}\\.\\d")[[1]] + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:9]), 9) + testthat::expect_equal(as.numeric(N_unit_a), 608) + testthat::expect_equal(as.numeric(N_unit_b), 1359) + testthat::expect_equal(as.numeric(prev_unit_a)[1], 6.4) # GAM + testthat::expect_equal(as.numeric(prev_unit_a)[2], 1.2) # SAM + testthat::expect_equal(as.numeric(prev_unit_a)[3], 5.3) # MAM + testthat::expect_equal(as.numeric(prev_unit_b), 12.4) # Age-weighted GAM + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-screening-age-avail_", + Sys.Date(), + ".xlsx", + sep = "" ) + ) - ### Wait the app to idle ---- - app$wait_for_idle(timeout = 40000) + ### Stop the app ---- + app$stop() +}) - ### Click in the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") - app$wait_for_idle(timeout = 40000) - - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-02.csv"), - check.names = FALSE +### When age is given in categories ---- +testthat::test_that(desc = "Prevalence tab works as expected when age is given in categories", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + + #### Initialise app ---- + app <- shinytest2::AppDriver$new( + app_dir = testthat::test_path("fixtures"), + timeout = 120000, + wait = TRUE + ) + + #### Wait app to idle ---- + app$wait_for_idle(timeout = 40000) + + #### Click on the Data Upload tab ---- + app$click(selector = "a[data-value='Data Upload']") + + app$wait_for_idle(timeout = 40000) + + #### Read data ---- + data <- read.csv( + file = testthat::test_path("fixtures", "anthro-02.csv"), + check.names = FALSE + ) + + ### Make age categories ---- + data <- data |> + transform( + age_cat = ifelse(age < 24, "6-23", "24-59"), + oedema = dplyr::recode_values(oedema, "n " ~ "n") ) - ### Make age categories ---- - data <- data |> - transform(oedema = dplyr::recode_values(oedema, "n " ~ "n")) - - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on the data wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling']") - app$wait_for_idle(timeout = 40000) - - ### Select data wrangling method and wait the app till idles ---- - app$set_inputs(`wrangle_data-wrangle` = "mfaz", wait_ = TRUE) - app$wait_for_idle(timeout = 40000) - - ### Input variables ---- - app$set_inputs(`wrangle_data-dos` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-dob` = "", wait_ = FALSE) - app$set_inputs(`wrangle_data-age` = "age", wait_ = FALSE) - app$set_inputs(`wrangle_data-sex` = "sex", wait_ = FALSE) - app$set_inputs(`wrangle_data-muac` = "muac", wait_ = FALSE) - - ### Click wrangle button and wait the app to idle ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - ### Click on the Prevalence tab and wait the app to idle ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) - - ### Select source of data ---- - app$set_inputs(`prevalence-source` = "screening", wait_ = TRUE) - - ### Select the method ---- - app$set_inputs(`prevalence-has_age` = "yes", wait_ = TRUE) - app$set_inputs(`prevalence-area1` = "analysis_unit", wait_ = FALSE) - app$set_inputs(`prevalence-area2` = "sex", wait_ = FALSE) ## Assume sex as grouping var - app$set_inputs(`prevalence-area3` = "", wait_ = FALSE) - app$set_inputs(`prevalence-muac` = "muac", wait_ = FALSE) - app$set_inputs(`prevalence-age` = "age", wait = FALSE) - app$set_inputs(`prevalence-oedema` = "oedema", wait_ = FALSE) - - ### Click on Estime Prevalence button ---- - app$click(input = "prevalence-estimate") - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() - {return $(this).text();}).get();" - - js_values <- "$('#prevalence-results tbody tr').map(function() - {return $(this).text();}).get();" - ### Capture results ---- - glued_results_unit_a <- app$get_js(js_values)[[1]] - glued_results_unit_b <- app$get_js(js_values)[[2]] + tempfile <- tempfile(fileext = ".csv") + write.csv(data, tempfile, row.names = FALSE) - N_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d{3}$")[[1]] - N_unit_b <- stringr::str_extract_all(glued_results_unit_b, "\\d{4}$")[[1]] + #### Upload onto the app ---- + app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - #### Prevalences ---- - prev_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d\\.\\d")[[1]] - prev_unit_b <- stringr::str_extract(glued_results_unit_b, "\\d{2}\\.\\d")[[1]] + ### Click on Data Wrangling tab ---- + app$click(selector = "a[data-value='Data Wrangling'") + app$wait_for_idle(timeout = 40000) + #### Select data wrangling method ---- + app$set_inputs("wrangle_data-wrangle" = "muac") + app$wait_for_idle(timeout = 40000) - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:9]), 9) - testthat::expect_equal(as.numeric(N_unit_a), 608) - testthat::expect_equal(as.numeric(N_unit_b), 1359) - testthat::expect_equal(as.numeric(prev_unit_a)[1], 6.4) # GAM - testthat::expect_equal(as.numeric(prev_unit_a)[2], 1.2) # SAM - testthat::expect_equal(as.numeric(prev_unit_a)[3], 5.3) # MAM - testthat::expect_equal(as.numeric(prev_unit_b), 12.4) # Age-weighted GAM + #### Select variables ---- + app$set_inputs("wrangle_data-sex" = "sex", wait_ = FALSE) + app$set_inputs("wrangle_data-muac" = "muac", wait_ = FALSE) - ### Stop the app ---- - app$stop() - } -) + #### Click on wrangle button ---- + app$click(input = "wrangle_data-apply_wrangle") + app$wait_for_idle(timeout = 40000) -### When age is given in categories ---- -testthat::test_that( - desc = "Prevalence tab works as expected when age is given in categories", - code = { - #### Initialise app ---- - app <- shinytest2::AppDriver$new( - app_dir = testthat::test_path("fixtures"), - timeout = 120000, - wait = TRUE - ) + #### Click on Prevalence tab ---- + app$click(selector = "a[data-value='Prevalence Analysis']") + app$wait_for_idle(timeout = 40000) - #### Wait app to idle ---- - app$wait_for_idle(timeout = 40000) + #### Select source of data ---- + app$set_inputs("prevalence-source" = "screening", wait_ = FALSE) + app$wait_for_idle(timeout = 40000) - #### Click on the Data Upload tab ---- - app$click(selector = "a[data-value='Data Upload']") + #### Select if age is available ---- + app$set_inputs("prevalence-has_age" = "no", wait_ = TRUE) - app$wait_for_idle(timeout = 40000) + #### Select variables ---- + app$set_inputs("prevalence-area1" = "analysis_unit", wait_ = FALSE) + app$set_inputs("prevalence-area2" = "sex", wait_ = FALSE) + app$set_inputs("prevalence-area3" = "", wait_ = FALSE) + app$set_inputs("prevalence-muac" = "muac", wait_ = FALSE) + app$set_inputs("prevalence-age_cat" = "age_cat", wait_ = FALSE) - #### Read data ---- - data <- read.csv( - file = testthat::test_path("fixtures", "anthro-02.csv"), - check.names = FALSE - ) + #### Click on Estimate Prevalence button ---- + app$click(input = "prevalence-estimate") + #### Wait until output has been rendered ---- + app$wait_for_value(output = "prevalence-results", timeout = 40000) + #### Donwload results ---- + app$wait_for_idle(timeout = 40000) + results <- app$get_download(output = "prevalence-download_results") - ### Make age categories ---- - data <- data |> - transform( - age_cat = ifelse(age < 24, "6-23", "24-59"), - oedema = dplyr::recode_values(oedema, "n " ~ "n") - ) - - tempfile <- tempfile(fileext = ".csv") - write.csv(data, tempfile, row.names = FALSE) - - #### Upload onto the app ---- - app$upload_file(`upload_data-upload` = tempfile, wait_ = TRUE) - - ### Click on Data Wrangling tab ---- - app$click(selector = "a[data-value='Data Wrangling'") - app$wait_for_idle(timeout = 40000) - - #### Select data wrangling method ---- - app$set_inputs("wrangle_data-wrangle" = "muac") - app$wait_for_idle(timeout = 40000) - - #### Select variables ---- - app$set_inputs("wrangle_data-sex" = "sex", wait_ = FALSE) - app$set_inputs("wrangle_data-muac" = "muac", wait_ = FALSE) - - #### Click on wrangle button ---- - app$click(input = "wrangle_data-apply_wrangle") - app$wait_for_idle(timeout = 40000) - - #### Click on Prevalence tab ---- - app$click(selector = "a[data-value='Prevalence Analysis']") - app$wait_for_idle(timeout = 40000) - - #### Select source of data ---- - app$set_inputs("prevalence-source" = "screening", wait_ = FALSE) - app$wait_for_idle(timeout = 40000) - - #### Select if age is available ---- - app$set_inputs("prevalence-has_age" = "no", wait_ = TRUE) - - #### Select variables ---- - app$set_inputs("prevalence-area1" = "analysis_unit", wait_ = FALSE) - app$set_inputs("prevalence-area2" = "sex", wait_ = FALSE) - app$set_inputs("prevalence-area3" = "", wait_ = FALSE) - app$set_inputs("prevalence-muac" = "muac", wait_ = FALSE) - app$set_inputs("prevalence-age_cat" = "age_cat", wait_ = FALSE) - app$set_inputs("prevalence-oedema" = "oedema", wait_ = FALSE) - - #### Click on Estimate Prevalence button ---- - app$click(input = "prevalence-estimate") - #### Wait until output has been rendered ---- - app$wait_for_value(output = "prevalence-results", timeout = 40000) - - ### Capture JavaScript expressions to return results's cols and values ---- - js_cols <- "$('#prevalence-results thead th').map(function() + ### Capture JavaScript expressions to return results's cols and values ---- + js_cols <- "$('#prevalence-results thead th').map(function() {return $(this).text();}).get();" - js_values <- "$('#prevalence-results tbody tr').map(function() + js_values <- "$('#prevalence-results tbody tr').map(function() {return $(this).text();}).get();" - ### Capture prevalence ---- - glued_results_unit_a <- app$get_js(js_values)[[1]] - glued_results_unit_b <- app$get_js(js_values)[[2]] - - N_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d{3}$")[[1]] - N_unit_b <- stringr::str_extract_all(glued_results_unit_b, "\\d{4}$")[[1]] - - #### Prevalences ---- - prev_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d\\.\\d")[[1]] - prev_unit_b <- stringr::str_extract(glued_results_unit_b, "\\d{2}\\.\\d")[[1]] - - - ### Test check ---- - testthat::expect_equal(length(app$get_js(js_cols)[1:9]), 9) - testthat::expect_equal(as.numeric(N_unit_a), 612) - testthat::expect_equal(as.numeric(N_unit_b), 1365) - testthat::expect_equal(as.numeric(prev_unit_a)[1], 6.4) # GAM - testthat::expect_equal(as.numeric(prev_unit_a)[2], 1.1) # SAM - testthat::expect_equal(as.numeric(prev_unit_a)[3], 5.2) # MAM - testthat::expect_equal(as.numeric(prev_unit_b), 12.6) # Age-weighted GAM + ### Capture prevalence ---- + glued_results_unit_a <- app$get_js(js_values)[[1]] + glued_results_unit_b <- app$get_js(js_values)[[2]] + + N_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d{3}$")[[1]] + N_unit_b <- stringr::str_extract_all(glued_results_unit_b, "\\d{4}$")[[1]] + + #### Prevalences ---- + prev_unit_a <- stringr::str_extract_all(glued_results_unit_a, "\\d\\.\\d")[[ + 1 + ]] + prev_unit_b <- stringr::str_extract(glued_results_unit_b, "\\d{2}\\.\\d")[[1]] + + ### Test check ---- + testthat::expect_equal(length(app$get_js(js_cols)[1:9]), 9) + testthat::expect_equal(as.numeric(N_unit_a), 612) + testthat::expect_equal(as.numeric(N_unit_b), 1365) + testthat::expect_equal(as.numeric(prev_unit_a)[1], 6.4) # GAM + testthat::expect_equal(as.numeric(prev_unit_a)[2], 1.1) # SAM + testthat::expect_equal(as.numeric(prev_unit_a)[3], 5.2) # MAM + testthat::expect_equal(as.numeric(prev_unit_b), 12.6) # Age-weighted GAM + testthat::expect_equal( + object = basename(results), + paste0( + "mwana-amn-prevalence-screening-age-notavail_", + Sys.Date(), + ".xlsx", + sep = "" + ) + ) - ### Stop the app ---- - app$stop() - } -) + ### Stop the app ---- + app$stop() +}) diff --git a/tests/testthat/test-module-wrangling.R b/tests/testthat/test-module-wrangling.R index ab3afe2..f4ecf42 100644 --- a/tests/testthat/test-module-wrangling.R +++ b/tests/testthat/test-module-wrangling.R @@ -7,6 +7,9 @@ testthat::test_that(desc = "Server data wrangling works as expected for WFHZ", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + ## Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"), @@ -68,6 +71,9 @@ testthat::test_that(desc = "Server data wrangling works as expected for WFHZ", { ### When user supplies dos and dob for age wrangling ---- testthat::test_that(desc = "Server data wrangling wrangles age correctly in WFHZ", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + ## Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"), @@ -142,6 +148,9 @@ testthat::test_that(desc = "Server data wrangling wrangles age correctly in WFHZ testthat::test_that(desc = "Server data wrangling works as expected for MFAZ", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + ## Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"), @@ -204,6 +213,9 @@ testthat::test_that(desc = "Server data wrangling works as expected for MFAZ", { ### When user supplies dos and dob for age wrangling ---- testthat::test_that(desc = "Server data wrangling wrangles age correctly in MFAZ", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + ## Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"), @@ -279,6 +291,9 @@ testthat::test_that(desc = "Server data wrangling wrangles age correctly in MFAZ testthat::test_that( desc = "Server data wrangling works as expected for raw MUAC values", code = { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + #### Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"), @@ -345,6 +360,9 @@ testthat::test_that( testthat::test_that( desc = "Server data wrangling works as expected for combined wrangling", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + ## Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"), @@ -402,6 +420,9 @@ testthat::test_that( ### When user supplies dos and dob for age wrangling ---- testthat::test_that(desc = "Server data wrangling wrangles age correctly in combined data wrangling", { + ### Skip test on CRAN ---- + testthat::skip_on_cran() + ## Initialise app ---- app <- shinytest2::AppDriver$new( app_dir = testthat::test_path("fixtures"),