In mrc-ide/naomi: Naomi Model for Subnational HIV Estimates

print_fr <- FALSE
print_en <- FALSE
print_pt <- FALSE
if (params$lang == "fr") {
  print_fr <- TRUE
  title <- "Naomi rapport de synthèse"
} else if (params$lang == "pt") {
  print_pt <- TRUE
  title <- "Naomi relatório de síntese"
} else {
  print_en <- TRUE
  title <- "Naomi comparison report"
}

---

title: r title

#Set limit for scientific notation
options(scipen=10000000)

outputs <- params$outputs

# Read files if hintr rds provided
if(tolower(tools::file_ext(params$outputs)) %in% c("rds", "qs")) {

  model_object <- read_hintr_output(outputs)
  outputs <- model_object$output_package
  inputs <- readr::read_csv(model_object$info$inputs.csv, show_col_types = FALSE)
  options <- yaml::read_yaml(text = model_object$info$options.yml)
  packages <- readr::read_csv(model_object$info$packages.csv, show_col_types = FALSE)
  version <- packages[packages$name == "naomi", ]$version
  outputs$version <- version

  calibration_files <- names(model_object$info)
  if("calibration_options.yml" %in% calibration_files) {
    calibration_options <- yaml::read_yaml(text = model_object$info$calibration_options.yml)
  } else {
    # In the event there is no calibration options, add in defaults:
    calibration_options <- tibble::tribble( ~option, ~value,
                                    "spectrum_population_calibration", "none",
                                    "spectrum_plhiv_calibration_level","subnational",
                                    "spectrum_plhiv_calibration_strat","sex_age_group",
                                    "spectrum_artnum_calibration_level","national",
                                    "spectrum_artnum_calibration_strat","age_coarse",
                                    "spectrum_aware_calibration_level","national",
                                    "spectrum_aware_calibration_strat","age_coarse",
                                    "spectrum_infections_calibration_level","none",
                                    "spectrum_infections_calibration_strat","age_coarse",
                                    "calibrate_method","logistic")
  }
}

# Read files if zipped output package provided
if(grepl("\\.zip$", params$outputs)) {
  output_zip <- params$outputs
  outputs <- naomi::read_output_package(output_zip)
  inputs <- unz(output_zip, "info/inputs.csv")
  inputs <- utils::read.csv(inputs)
  options <- unz(output_zip, "info/options.yml")
  options <- yaml::read_yaml(options)

  packages <- unz(output_zip, "info/packages.csv")
  packages <- readr::read_csv(packages, show_col_types = FALSE)
  version <- packages[packages$name == "naomi", ]$version
  outputs$version <- version



  if("calibration_options" %in% names(outputs$fit)) {
    calibration_options <- outputs$fit$calibration_options
  } else {
    calibration_options <- options[grep("calibration", names(options))]
  }
}

# Grab inputs and model options from model output zip file
# # concatenating strings where more than one option may be selected
report_date <- format(Sys.Date(), "%d-%m-%Y")
t1 <- options$calendar_quarter_t1
t2 <- options$calendar_quarter_t2
iso <- options$area_scope
quarter_t1 <- outputs$meta_period[outputs$meta_period$calendar_quarter == t1,]$quarter_label
quarter_t2 <- outputs$meta_period[outputs$meta_period$calendar_quarter == t2,]$quarter_label
level <- as.integer(options$area_level)
spectrum_file <- paste0(inputs[inputs$role == "pjnz",]$filename)


# Identify area_level_label for model estimates
area_level_map <- outputs$meta_area %>%
  sf::st_drop_geometry() %>%
  dplyr::group_by(area_level, area_level_label) %>%
  dplyr::summarise(.groups = "drop")

area_level_label <- area_level_map$area_level_label[area_level_map$area_level == level]

country <- paste0(outputs$meta_area$area_name[outputs$meta_area$area_id == iso],
                  sep = "", collapse = "")

# Determine if and when programme data has been included 
if (is.null(options$include_art_t1) || options$include_art_t1 == "") {
  options$include_art_t1 <- NA
}
if (is.null(options$include_art_t2) || options$include_art_t2 == "") {
  options$include_art_t2 <- NA
}

if (is.null(quarter_t1) || quarter_t1 == "") {
  quarter_t1 <- NA
}
if (is.null(quarter_t2) || quarter_t2 == "") {
  quarter_t2 <- NA
}

if (is.null(options[["artattend"]]) || options[["artattend"]] == "") {
  options[["artattend"]] <- NA
}
if (is.null(options[["artattend_t2"]]) || options[["artattend_t2"]] == "") {
  options[["artattend_t2"]] <- NA
}

include <- tibble::tibble(
  art = c(options$include_art_t1, options$include_art_t2),
  art_year = c(quarter_t1, quarter_t2),
  art_attend = c(options$artattend, options$artattend_t2)
)

# Select years where programme data is included
collapse_and <- " and "
if (print_fr) {
  collapse_and <- " et "
} else if (print_pt) {
  collapse_and <- " e "
}

# ART data included
if("true" %in% include$art) {
  df <- include %>% dplyr::filter(art == "true")
  art_year <- paste0(df$art_year, sep = "", collapse = collapse_and)
} else {
  art_year <- NA
}

# ART attendance reallocation is implemented
if("true" %in% include$art_attend ) {
  df <- include %>% dplyr::filter(art_attend == "true")
  art_attend <- paste0(df$art_year, sep = "", collapse = collapse_and)
} else {
  art_attend <- NA
}

# ANC ART programme data included
anc_art_options = c(options$anc_art_coverage_year1, options$anc_art_coverage_year2)
anc_art_options <- anc_art_options[!vlapply(anc_art_options, is_empty)]

if(length(anc_art_options)) {
  anc_art <- paste0(anc_art_options, sep = "", collapse = collapse_and)
} else {
  anc_art <- NA
}

# ANC prev programme data
anc_prev_options = c(options$anc_prevalence_year1, options$anc_prevalence_year2)
anc_prev_options <- anc_art_options[!vlapply(anc_art_options, is_empty)]

if(length(anc_prev_options)) {
  anc_prev <- paste0(anc_prev_options, sep = "", collapse = collapse_and)
} else {
  anc_prev <- NA
}

if (print_en) {
  cat(paste0("## ", country, " Subnational HIV Estimates \n"))
  cat(paste0("Naomi estimates for **", quarter_t2, "** (report generated ", report_date, ")"))
}

if (print_fr) {
  cat(paste0("## ", country, " Estimativas subnacionais do VIH \n"))
  cat(paste0("Les estimations de Naomi pour **", quarter_t2, "** (rapport généré ", report_date, ")"))
}

if (print_pt) {
  cat(paste0("## ", country, " Estimativas subnacionais do VIH \n"))
  cat(paste0("Estimativas Naomi para **", quarter_t2, "** (relatório gerado ", report_date, ")"))
}

::: {#translate lang="en"}

Methods

Naomi is a small-area estimation model for estimating HIV prevalence and PLHIV, ART coverage, and new HIV infections at district level by sex and five-year age group. The model combines district-level data about multiple outcomes from several sources in a Bayesian statistical model to produce robust indicators of subnational HIV burden.

:::

::: {#translate lang="fr"}

Méthodes

Naomi est un modèle d'estimation à petite échelle permettant d'estimer la prévalence du VIH et des PVVIH, la couverture TARV et les nouvelles infections par le VIH au niveau du district par sexe et par groupe d'âge de cinq ans. Le modèle combine des données au niveau du district sur des résultats multiples provenant de plusieurs sources dans un modèle statistique bayésien pour produire des indicateurs robustes de la charge du VIH au niveau sous-national.

:::

::: {#translate lang="pt"}

Métodos

Naomi{target="_blank"} é um modelo de estimativa de pequena área para estimar a prevalência de VIH e o número de PVVIH, cobertura de TARV e novas infeções por VIH a nível distrital por género e grupo etário de cinco anos. O modelo combina dados de nível distrital sobre resultados múltiplos de várias fontes num modelo estatístico Bayesiano para produzir indicadores robustos da carga subnacional do VIH.

:::

if (print_en) {
  cat("### Comparison of Naomi model estimates to data inputs \n")
  cat("\n### Household Survey \n")
}

if (print_fr) {
  cat("### Comparaison des estimations du modèle Naomi avec les entrées de données\n")
  cat("\n### Données d’enquête auprès des ménages \n")
}

if (print_pt) {
  cat("### Comparação das estimativas do modelo Naomi com os dados introduzidos \n")
  cat("\n### Dados do inquérito aos agregados familiares \n")
}

::: {#translate lang="en"}

Cross-sectional estimates for HIV prevalence, ART coverage, and HIV incidence are produced at the mid-point of the most recent nationally representative household survey. For HIV prevalence, the model is calibrated to survey data about HIV prevalence by subnational level, sex, and five-year age group from the most recent population-based survey (for example Population HIV Impact Assessment survey or Demographic and Health Survey).

:::

if (print_en) {
  cat("This report compares Naomi estimates for ", quarter_t2, "to the following population-based survey(s): \n")
  cat("\n### Household Survey \n")
}

if (print_fr) {
  cat("Ce rapport compare les estimations de Naomi pour ", quarter_t2, "à l'enquête de population suivante(s): \n")
  cat("\n### Données d’enquête auprès des ménages \n")
}

if (print_pt) {
  cat("Este relatório compara as estimativas da Naomi para o ", quarter_t2, "com os seguinte(s) inquéritos baseados na população: \n")
  cat("\n### Dados do inquérito aos agregados familiares \n")
}

survey_prev <- paste0(options$survey_prevalence, collapse = ", ")
survey_art <- paste0(options$survey_art_coverage, collapse = ", ")
survey_recent <- paste0(options$survey_recently_infected, collapse = ", ")

text <- tibble::tibble(prefix = c(t_("PREVALENCE_SURVEY_PREFIX"),
                                  t_("ART_SURVEY_PREFIX")),
                        source = c(survey_prev,
                                   survey_art)) %>%
  dplyr::filter(source != "")
cat(paste0("* ", text$prefix, " _", text$source, "_"), sep = "\n")

::: {#translate lang="en"} We anticipate that the Naomi estimates will be closely aligned with the survey estimates at a national level. Some variation is expected between model estimates and survey estimates at lower Admin levels where survey estimates may be sparse for certain age and sex groups. :::

::: {#translate lang="fr"} Nous prévoyons que les estimations de Naomi seront étroitement alignées avec les estimations de l'enquête au niveau national. Une certaine variation est attendue entre les estimations du modèle et les estimations de l'enquête aux niveaux administratifs inférieurs où les estimations de l'enquête peuvent être rares pour certains groupes d'âge et de sexe. :::

::: {#translate lang="pt"} Esperamos que as estimativas de Naomi estejam estreitamente alinhadas com as estimativas de pesquisas em nível nacional. Espera-se alguma variação entre as estimativas do modelo e as estimativas da pesquisa em níveis administrativos mais baixos, onde as estimativas da pesquisa podem ser esparsas para alguns grupos de idade e sexo. :::

if (print_en) {cat("\n### Geographic distribution \n")}
if (print_fr) {cat("\n### Répartition géographique \n")}
if (print_pt) {cat("\n### Distribuição geográfica \n")}

data <- outputs$inputs_outputs
calendar_quarter1 <- options$calendar_quarter_t1
calendar_quarter2 <- options$calendar_quarter_t2

plots <- list()
class <- c()
#  Barplot prevalence
if (identical(options$use_survey_aggregate, "false")) {
  ## We do not create prevalence aggregate plot if use_survey_aggregate is true
  ## See Guinea-Bissau issue 2022/2023 #36
  fig1 <- bar_plotly(data,
                     ind = "prevalence",
                     quarter = calendar_quarter1)
  plots <- c(plots, list(htmltools::div(fig1)))
  class <- c(class, "prevalence-barchart")
}


if (!is_empty(options$survey_art_coverage)) {
  ## If no survey ART don't include the plot

  ## Fix for 2022/20223 CMR issue #41
  filtered_data <- data %>%
    dplyr::filter(indicator == "art_coverage",
                  calendar_quarter == calendar_quarter1)
  if (nrow(filtered_data) > 0) {
    fig2 <- bar_plotly(data,
                       ind = "art_coverage",
                       quarter = calendar_quarter1)
    plots <- c(plots, list(htmltools::div(fig2)))
    class <- c(class, "art-barchart")
  }
} 
htmltools::div(plots,
               style = "display: flex; flex-direction: column",
               class = paste(class, collapse = " "))

survey_prev1 <- options$survey_prevalence[1]
survey_prev2 <- options$survey_prevalence[2]

plots <- list()
class <- c()
prev_plots <- NULL
if (identical(options$use_survey_aggregate, "false")) {
  ## We do not create prevalence aggregate plot if use_survey_aggregate is true
  ## See Guinea-Bissau issue 2022/2023 #36

  #  Scatter plot survey prevalence
  fig1 <- scatter_plotly(data,
                         ind = "prevalence",
                         quarter = calendar_quarter1,
                         input_data = survey_prev1,
                         input_data_type = "survey")
  plots <- c(plots, list(htmltools::div(fig1, style = "width: 50%")))
  class <- c(class, "prevalence-scatter1")

  if (!is_empty(survey_prev2)) { 

    # Multiple prevalence surveys
    fig1B <-  scatter_plotly(data,
                             ind = "prevalence",
                             quarter = calendar_quarter1,
                             input_data = survey_prev2,
                             input_data_type = "survey")
    plots <- c(list(htmltools::div(fig1B, style = "width: 50%;")), plots)
    class <- c(class, "prevalence-scatter1B")
  }

  prev_plots <- htmltools::div(
    plots,
    style = "display: flex",
    class = paste(class, collapse = " "))
}


art_plot <- NULL 
if (!is_empty(options$survey_art_coverage)) {

  # ART coverage plot
  ## Fix for 2022/20223 CMR issue #41
  if (nrow(filtered_data) > 0) {
    fig2 <-  scatter_plotly(data,
                            ind = "art_coverage",
                            quarter = calendar_quarter1,
                            input_data = survey_art,
                            input_data_type = "survey")
    art_plot <- htmltools::div(fig2, 
                               style = "width: 50%", 
                               class = "art-scatter")
  }
}
htmltools::div(
  style = "display: flex; flex-direction: column",
  prev_plots,
  art_plot
)

if (print_en) {cat("\n### Age distribution \n")}
if (print_fr) {cat("\n### Répartition par âge \n")}
if (print_pt) {cat("\n### Distribuição etária \n")}

plots <- list()
class <- c()
if (identical(options$use_survey_aggregate, "false")) {
  ## We do not create prevalence aggregate plot if use_survey_aggregate is true
  ## See Guinea-Bissau issue 2022/2023 #36

  # Age bar plots
  fig1 <- age_bar_plotly(data,
                         ind = "prevalence",
                         quarter = calendar_quarter1)

  plots <- c(plots, list(htmltools::div(fig1)))
  class <- c(class, "prevalence-plotly")
}


if (!is_empty(options$survey_art_coverage)) {
  ## If no survey ART don't include the plot

  ## Fix for 2022/20223 CMR issue #41
  if (nrow(filtered_data) > 0) {
    fig2 <- age_bar_plotly(data,
                           ind = "art_coverage",
                           quarter = calendar_quarter1)
    plots <- c(plots, list(htmltools::div(fig2)))
    class <- c(class, "art-plotly")
  }
}

htmltools::div(plots,
               style = "display: flex; flex-direction: column",
               class = paste(class, collapse = " "))

::: {#translate lang="en"} Static images of individual plots can be downloaded by hovering on the right hand corner :::

::: {#translate lang="fr"} Les images des graphiques individuels peuvent être téléchargées en survolant le coin droit :::

::: {#translate lang="pt"} Imagens de gráficos individuais podem ser baixadas passando o mouse no canto direito :::

programme_data <- c(art_year, anc_prev, anc_art)

if (sum(is.na(programme_data)) <3 ) {

   cat(paste0("\n### Routinely collected programme data: \n", sep = "\n"))

   cat(paste0("For the HIV prevalence and ART coverage components of the model, ART service delivery numbers inform subnational estimates for the number of PLHIV. Since the Household survey sample size in each district is relatively small, routinely reported data about HIV prevalence among pregnant women attending their first antenatal care visit, extracted from the national health information system, are used to improve estimates of the spatial pattern of HIV. \n", sep = "\n"))


   cat(paste0("\nThis report compares Naomi estimates to: \n", sep = "\n"))

  text2 <- tibble::tibble(prefix = c("National programme data on numbers on ART for ",
                                  "National programme data on ANC HIV prevalence for ",
                                  "National programme data on ANC ART coverage for "
                                  ),
                       source = c(art_year,
                                  anc_prev,
                                  anc_art)) %>% tidyr::drop_na()

  cat(paste0("\n ",cat(paste0("* ", text2$prefix, "_", text2$source, "_"), sep = "\n")))

 cat(paste0("The plots below compare ANC programme to age and sex matched estimates of the general population produced by Naomi. While these data should be positively correlated, we expect higher HIV prevalence and ART coverage in all females ages 15-49 relative to women attending antenatal services.", sep = "\n"))

}

programme_data <- c(art_year, anc_prev, anc_art)

if (sum(is.na(programme_data)) <3 ) {

  cat(paste0("\n### Données du programme opérationnel: \n", sep = "\n"))

  cat(paste0("Pour les composantes de prévalence du VIH et de couverture du TAR du modèle, les chiffres de prestation de services de TAR informent les estimations infranationales du nombre de PVVIH. Étant donné que la taille de l'échantillon de l'enquête auprès des ménages dans chaque district est relativement petite, les données régulièrement déclarées sur la prévalence du VIH chez les femmes enceintes assistant à leur première consultation prénatale, extraites du système national d'information sur la santé, sont utilisées pour améliorer les estimations de la répartition spatiale du VIH. \n", sep = "\n"))

  cat(paste0("\nCe rapport compare les estimations de Naomi à: \n", sep = "\n"))

  text2 <- tibble::tibble(prefix = c("Données national sur la couverture TARV pour ",
                                  "Données national sur la prévalence du VIH parmi CPN pour ",
                                  "Données national sur la couverture du TARV parmi CPN pour "
                                  ),
                       source = c(art_year,
                                  anc_prev,
                                  anc_art)) %>% tidyr::drop_na()

  cat(paste0("\n ",cat(paste0("* ", text2$prefix, "_", text2$source, "_"), sep = "\n")))

  cat(paste0("Les graphiques ci-dessous comparent le programme de soins prénatals aux estimations appariées selon l'âge et le sexe de la population générale produites par Naomi. Bien que ces données devraient être positivement corrélées, nous prévoyons une prévalence du VIH et une couverture du TAR plus élevées chez toutes les femmes âgées de 15 à 49 ans par rapport aux femmes fréquentant les services prénatals.", sep = "\n"))

}

programme_data <- c(art_year, anc_prev, anc_art)

if (sum(is.na(programme_data)) <3 ) {

  cat(paste0("\n### Dados do programa operacional: \n", sep = "\n"))

  cat(paste0("Para os componentes de prevalência do VIH e cobertura de TARV do modelo, os números de prestação de serviços de TARV informam as estimativas subnacionais para o número de PVVIH. Uma vez que o tamanho da amostra do inquérito domiciliar em cada distrito é relativamente pequeno, os dados relatados rotineiramente sobre a prevalência do HIV entre mulheres grávidas na primeira consulta pré-natal, extraídos do sistema nacional de informações de saúde, são usados para melhorar as estimativas do padrão espacial do VIH. \n", sep = "\n"))

  cat(paste0("\nEste relatório compara as estimativas da Naomi com: \n", sep = "\n"))

  text2 <- tibble::tibble(prefix = c("Dados do programa nacional sobre a cobertura de TARV para ",
                                  "Dados do programa nacional sobre a prevalência de VIH na CPN para ",
                                  "Dados do programa nacional sobre a cobertura de TARV na CPN para "
                                  ),
                       source = c(art_year,
                                  anc_prev,
                                  anc_art)) %>% tidyr::drop_na()

  cat(paste0("\n ",cat(paste0("* ", text2$prefix, "_", text2$source, "_"), sep = "\n")))

  cat(paste0("Os gráficos abaixo comparam o programa CPN com as estimativas combinadas de idade e sexo da população geral produzidas por Naomi. Embora esses dados devam estar positivamente correlacionados, esperamos maior prevalência de HIV e cobertura de TARV em todas as mulheres de 15 a 49 anos em relação às mulheres que frequentam serviços pré-natais", sep = "\n"))

}

#-------------------------------------------------------------------------------
# ANC data: interactive scatter plot
#-------------------------------------------------------------------------------
anc_t1 <- outputs$fit$data_options$anc_prev_year_t1
anc_t2 <- outputs$fit$data_options$anc_prev_year_t2

# Quick fix to prevent ANC plots from rendering if ANC T1 is not in the same year
# as model T1
# TO DO: Refactor align_inputs_outputs script to align based on data inclusion 
# vs. matching on years

if (!is.null(anc_t1) && anc_t1 != naomi:::calendar_quarter_to_year(calendar_quarter1)){
  anc_t1 <- NULL
}

has_anc <- !is_empty(anc_t1) && !is_empty(anc_t2)

if (has_anc) {
  #  Scatter plot ANC prevalence
  fig1 <-  scatter_plotly(data,
                          ind = "anc_prevalence_age_matched",
                          quarter = calendar_quarter1,
                          input_data = paste0("ANC ", anc_t1) ,
                          input_data_type = "ANC programme",
                          sex_disag = "female")

  fig2 <-  scatter_plotly(data,
                          ind = "anc_prevalence_age_matched",
                          quarter = calendar_quarter2,
                          input_data = paste0("ANC ", anc_t2) ,
                          input_data_type = "ANC programme",
                          sex_disag = "female")


  # Scatter plot ANC ART coverage

  fig3 <-  scatter_plotly(data,
                          ind = "anc_art_coverage_age_matched",
                          quarter = calendar_quarter1,
                          input_data = paste0("ANC ", anc_t2),
                          input_data_type = "ANC programme",
                          sex_disag = "female")

  fig4 <-  scatter_plotly(data,
                          ind = "anc_art_coverage_age_matched",
                          quarter = calendar_quarter2,
                          input_data = paste0("ANC ", anc_t2),
                          input_data_type = "ANC programme",
                          sex_disag = "female")


  prev_plots <-   htmltools::div(
    style = "display: flex;",
    htmltools::div(fig1, style = "width: 50%;"),
    htmltools::div(fig2, style = "width: 50%;")
  )

  art_plots <-   htmltools::div(
    style = "display: flex;",
    htmltools::div(fig3, style = "width: 50%;"),
    htmltools::div(fig4, style = "width: 50%;")
  )

  htmltools::div(
    style = "display: flex; flex-direction: column",
    prev_plots,
    art_plots
  )
}

::: {#translate lang="en"} Version

The Naomi model is supported by UNAIDS and developed and maintained by the MRC Centre for Global Infectious Disease Analysis at Imperial College London. The model receives technical guidance from the UNAIDS Reference Group on Estimates, Modelling, and Projections. The model was first used in 2020 and continues to be developed responsive to new data and HIV strategic information needs. :::

::: {#translate lang="fr"} Version

Le modèle Naomi est soutenu par l'ONUSIDA et développé et maintenu par le MRC Centre for Global Infectious Disease Analysis à l'Imperial College London. Le modèle reçoit des conseils techniques du Groupe de référence de l'ONUSIDA sur les estimations, la modélisation et les projections. Le modèle a été utilisé pour la première fois en 2020 et continue d'être développé en fonction des nouvelles données et des besoins en informations stratégiques sur le VIH. :::

::: {#translate lang="pt"} Versão

O modelo Naomi é apoiado pela UNAIDS e desenvolvido e mantido pelo [MRC Centre for Global Infectious Disease Analysis] (https://www.imperial.ac.uk/mrc-global-infectious-disease-analysis) no Imperial College London. O modelo recebe orientação técnica do UNAIDS Reference Group on Estimates, Modelling, and Projections. O modelo foi usado pela primeira vez em 2020 e continua a ser desenvolvido em resposta a novos dados e necessidades de informação estratégica sobre o VIH. :::

mrc-ide/naomi documentation built on April 10, 2024, 2:13 p.m.