R/fpemreporting.R

In FPRgroup/FPEMcountry: fpemlocal

#' Convert data frame to JSON string
#'
#' @param df `data.frame` Data frame to be converted
#' @return `character` JSON string
#' @export
to_json <- function(df) {
  df %>%
    setNames(snakecase::to_lower_camel_case(names(.))) %>%
    jsonlite::toJSON(null = "null",
                     na = "null",
                     pretty = TRUE)
}



#' Expand contraceptive use data to include derived values.
#'
#' @param contraceptive_use `data.frame` Contraceptive use data.
#' @param simplify_logicals `logical` Convert Y/N to TRUE/FALSE.
#' @return `data.frame` Expanded contraceptive use data..
expand_contraceptive_use <- function(contraceptive_use, simplify_logicals = TRUE) {
  contraceptive_use_all <- dplyr::coalesce(
    contraceptive_use$contraceptive_use_all,
    contraceptive_use$contraceptive_use_modern + contraceptive_use$contraceptive_use_traditional
  )

  ratio_modern_all <- contraceptive_use$contraceptive_use_modern / contraceptive_use_all

  unmet_need_modern <- dplyr::coalesce(
    as.numeric(contraceptive_use$unmet_need_modern),
    contraceptive_use$contraceptive_use_traditional + contraceptive_use$unmet_need_any
  )

  demand <- contraceptive_use_all + contraceptive_use$unmet_need_any
  demand_modern <- contraceptive_use$contraceptive_use_modern + unmet_need_modern

  demand_satisfied <- contraceptive_use_all / demand
  demand_satisfied_modern <- contraceptive_use$contraceptive_use_modern / demand_modern

  non_use <- 1 - contraceptive_use_all

  contraceptive_use$contraceptive_use_all <- contraceptive_use_all
  contraceptive_use$unmet_need_modern <- unmet_need_modern

  contraceptive_use %<>%
    tibble::add_column(ratio_modern_all, .after = "contraceptive_use_all") %>%
    tibble::add_column(
      demand,
      demand_modern,
      demand_satisfied,
      demand_satisfied_modern,
      non_use,
      .after = "unmet_need_any"
    )

  if (simplify_logicals) {
    contraceptive_use$is_in_union <- contraceptive_use$is_in_union == "Y"
    contraceptive_use$is_pertaining_to_methods_used_since_last_pregnancy <-
      contraceptive_use$is_pertaining_to_methods_used_since_last_pregnancy == "Y"
    contraceptive_use$has_geographical_region_bias <-
      contraceptive_use$has_geographical_region_bias == "Y"
    contraceptive_use$has_non_pregnant_and_other_positive_biases <-
      contraceptive_use$has_non_pregnant_and_other_positive_biases == "Y"
    contraceptive_use$has_traditional_method_bias <-
      contraceptive_use$has_traditional_method_bias == "Y"
    contraceptive_use$has_absence_of_probing_questions_bias <-
      contraceptive_use$has_absence_of_probing_questions_bias == "Y"
  }

  contraceptive_use
}

transform_posterior_samples <- function(posterior_samples, indicator, transformer, years) {
  dimensions <- dim(posterior_samples)

  iterations <- dimensions[1] * dimensions[2]
  period_years <- dimensions[3]

  posterior_samples %>%
    transform_yearly(transformer) %>%
    drop() %>%
    tibble::as_tibble() %>%
    setNames(years) %>%
    tidyr::gather(key = "year") %>%
    dplyr::mutate(year = as.integer(year)) %>%
    tibble::add_column(indicator, .before = "value") %>%
    tibble::add_column(iteration = rep(1:iterations, period_years), .before = "year")
}

#' Get posterior samples for all indicators
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by indicator and year
#' @export
get_posterior_samples_for_all_indicators <- function(posterior_samples, years) {
  mcmc_proportion_dimensions <- dim(posterior_samples)

  if (length(mcmc_proportion_dimensions) != 4) {
    stop("MCMC proportions matrix must have four dimensions")
  }

  if (mcmc_proportion_dimensions[4] != 3) {
    stop("MCMC proportions must be modern, traditional and unmet")
  }

  dplyr::bind_rows(
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "contraceptive_use_modern",
      transformer = modern_cpr,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "contraceptive_use_traditional",
      transformer = traditional_cpr,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "unmet_need_any",
      transformer = unmet_p,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "contraceptive_use_all",
      transformer = total_cpr,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "demand",
      transformer = demand,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "demand_for_modern_methods",
      transformer = demand_modern,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "no_need",
      transformer = no_need,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "unmet_need_modern",
      transformer = unmet_modern,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "non_use",
      transformer = non_use,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "demand_satisfied",
      transformer = demand_satisfied,
      years = years
    ),
    transform_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = "demand_satisfied_modern",
      transformer = demand_satisfied_modern,
      years = years
    )
  )
}

transform_proportions <- function(posterior_samples, transformer) {
  posterior_samples %>%
    transform_yearly(transformer) %>%
    array_summarise() %>%
    drop() %>%
    tibble::as_tibble()
}

#' Get proportions
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @param transformer `function` Computes the desired result
#' @return `data.frame` Values by year and percentile
get_proportions <- function(posterior_samples, first_year, transformer) {
  mcmc_proportion_dimensions <- dim(posterior_samples)

  if (length(mcmc_proportion_dimensions) != 4) {
    stop("MCMC proportions matrix must have four dimensions")
  }

  if (mcmc_proportion_dimensions[4] != 3) {
    stop("MCMC proportions must be modern, traditional and unmet")
  }

  years <- as.integer(first_year + 0:(mcmc_proportion_dimensions[3] - 1))

  transform_proportions(
    posterior_samples = posterior_samples,
    transformer = transformer
  ) %>%
    tibble::add_column(year = years, .before = 1) %>%
    tidyr::gather(key = "percentile", value = "value", -year)
}





#' get_contraceptive_use_any
#'
#' `total_cpr = modern_cpr + traditional_cpr`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
#'
get_contraceptive_use_any <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = total_cpr
  )
}

#' Get modern CPR
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_contraceptive_use_modern <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = modern_cpr
  )
}

#' Get traditional CPR
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_contraceptive_use_traditional <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = traditional_cpr
  )
}

#' Get non-use
#'
#' `non_use = 1 - total_cpr`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_non_use <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = non_use
  )
}

#' Get unmet need
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_unmet_need_any <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = unmet_p
  )
}

#' Get unmet need for modern methods
#'
#' `unmet_modern = traditional_cpr + unmet`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_unmet_need_modern <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = unmet_modern
  )
}

#' Get total demand
#'
#' `demand = total_cpr + unmet`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_demand <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = demand
  )
}

#' Get demand for modern methods
#'
#' `demand = modern_cpr + unmet_modern`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_demand_modern <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = demand_modern
  )
}

#' Get demand satisfied
#'
#' `demand = total_cpr / demand`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_demand_satisfied <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = demand_satisfied
  )
}

#' Get demand satisfied with a modern method
#'
#' `demand_satisfied_modern = modern_cpr / demand`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_demand_satisfied_modern <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = demand_satisfied_modern
  )
}

#' Get no need
#'
#' `no_need = 1 - demand`
#'
#' @inheritParams calc_fp
#' @param first_year `integer` Earliest year represented in the data
#' @return `data.frame` Values by year and percentile
get_no_need <- function(posterior_samples, first_year) {
  get_proportions(
    posterior_samples = posterior_samples,
    first_year = first_year,
    transformer = no_need
  )
}


#' Get estimated population counts
#'
#' @param proportions `data.frame` Proportions, as returned from [get_proportions()]
#' @param annual_country_population_counts `data.frame`
#' Contains "mid_year" and "population_count" columns for group (e.g. married and 15-49) in one country.
#' There must be a single population count per country.
#' @return `data.frame` Values by year and percentile
get_estimated_counts <- function(proportions, annual_country_population_counts) {
  proportions %>%
    dplyr::inner_join(annual_country_population_counts, by = c("year" = "mid_year")) %>%
    dplyr::mutate(result_population_count = population_count * value) %>%
    dplyr::select(year, percentile, population_count = result_population_count)
}

select_posterior_samples <- function(posterior_samples, indicator, year) {
  posterior_samples[, , year, indicator]
}

select_relative_posterior_samples <- function(posterior_samples, indicator, year, relative_to_year = NULL) {
  samples <- posterior_samples[, , year, indicator]

  if (!is.null(relative_to_year)) {
    samples <- samples - posterior_samples[, , relative_to_year, indicator]
  }

  samples
}

#' Get posterior probability from proportion or population
#'
#' @inheritParams calc_fp
#' @param population_count `integer` Number of individuals in the sample population (1 to calculate from proportion)
#' @param indicator `integer` Indicator index (1 = modern, 2 = traditional, 3 = unmet)
#' @param year `integer` Year index
#' @param above `logical` If FALSE then it's below
#' @param cutoff `numeric` Cutoff proportion or population
#' @return `numeric` Posterior probability
get_posterior_probability_from_cutoff_target <- function(
  posterior_samples,
  population_count_year = 1,
  population_count_relative_to_year = 1,
  indicator,
  year,
  relative_to_year = NULL,
  above,
  cutoff) {
  samples <- select_posterior_samples(
    posterior_samples = posterior_samples,
    indicator = indicator,
    year = year
  )

  population_samples <- samples * population_count_year

  if (!is.null(relative_to_year)) {
    relative_to_samples <- select_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = indicator,
      year = relative_to_year
    )

    relative_to_population_samples <- relative_to_samples * population_count_relative_to_year

    population_samples <- population_samples - relative_to_population_samples
  }

  (1 - above) + ifelse(above, 1, -1) * mean(population_samples > cutoff)
}

#' Get proportion or population from posterior probability
#'
#' @inheritParams calc_fp
#' @param population_count `integer` Number of individuals in the sample population (1 to calculate proportion)
#' @param indicator `integer` Indicator index (1 = modern, 2 = traditional, 3 = unmet)
#' @param year `integer` Year index
#' @param greater_than `logical` If FALSE then it's less than
#' @param probability `numeric` Posterior probability
#' @return `numeric` Proportion or population
get_target_from_posterior_probability <- function(
  posterior_samples,
  population_count_year = 1,
  population_count_relative_to_year = 1,
  indicator,
  year,
  relative_to_year = NULL,
  greater_than,
  probability) {
  samples <- select_posterior_samples(
    posterior_samples = posterior_samples,
    indicator = indicator,
    year = year
  )

  population_samples <- samples * population_count_year

  if (!is.null(relative_to_year)) {
    relative_to_samples <- select_posterior_samples(
      posterior_samples = posterior_samples,
      indicator = indicator,
      year = relative_to_year
    )

    relative_to_population_samples <- relative_to_samples * population_count_relative_to_year

    population_samples <- population_samples - relative_to_population_samples
  }

  population_quantile <- quantile(population_samples, probs = 1 - probability, type = 8)

  (1 - greater_than) + ifelse(greater_than, 1, -1) * unname(population_quantile)
}

#' Get progress for indicator
#'
#' @inheritParams calc_fp
#' @param from_year_population_count `integer`
#' Number of individuals in the sample population for "from" year (1 to calculate proportion)
#' @param to_year_population_count `integer`
#' Number of individuals in the sample population for "to" year (1 to calculate proportion)
#' @param indicator `integer` Indicator index (1 = modern, 2 = traditional, 3 = unmet)
#' @param from_year `integer` First year
#' @param to_year `integer` Last year
#' @return `numeric` Median and 2.5%/97.5% quantiles of change
get_progress <- function(
  posterior_samples,
  from_year_population_count = 1,
  to_year_population_count = 1,
  indicator,
  from_year,
  to_year,
  absolute = FALSE) {
  from_year_posterior_samples <- select_posterior_samples(
    posterior_samples = posterior_samples,
    indicator = indicator,
    year = from_year
  )

  to_year_posterior_samples <- select_posterior_samples(
    posterior_samples = posterior_samples,
    indicator = indicator,
    year = to_year
  )

  from_year_values <- from_year_posterior_samples * from_year_population_count
  to_year_values <- to_year_posterior_samples * to_year_population_count

  change <- to_year_values - from_year_values

  if (absolute) {
    values <- change
  } else {
    values <- change / from_year_values
  }

  quantile(values, probs = c(0.025, 0.5, 0.975), type = 8)
}