diff --git a/DESCRIPTION b/DESCRIPTION index 5d89616..ca1c74a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,7 +12,7 @@ License: file LICENSE LazyLoad: yes LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Depends: R (>= 4.1), ggplot2 diff --git a/NAMESPACE b/NAMESPACE index 8958af9..306e786 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -36,7 +36,6 @@ export(lt_flexible_chunk) export(lt_plot) export(lt_summary) export(lt_summary_chunk) -export(movepop) export(odap_opag) export(plot_compare_rates) export(plot_histogram) @@ -109,6 +108,7 @@ importFrom(dplyr,last) importFrom(dplyr,left_join) importFrom(dplyr,mutate) importFrom(dplyr,n) +importFrom(dplyr,pick) importFrom(dplyr,pull) importFrom(dplyr,reframe) importFrom(dplyr,rename) diff --git a/R/input_diagnostics.R b/R/input_diagnostics.R index ee882cd..7cc4a0b 100644 --- a/R/input_diagnostics.R +++ b/R/input_diagnostics.R @@ -2,11 +2,15 @@ #' @description Check the age heaping for 5 or 1 year data. #' @param data data.frame. User file from the read_data command with the minimum data on `Exposures`, `Death` and `Age`. Data can be both in 5 and 1 year age intervals #' @param y character.Variable name for which the heaping should be checked `Deaths` or `Exposures`. -#' @return A data.frame with 2 columns `method` - the method used for age heaping evaluation and `result` - the resulting heaping measure +#' @return A data.frame with 3 columns `method` - the method used for age heaping evaluation, `result` - the resulting heaping measure, and `.id` - user specified groups identifier (if missing is set to "all") +#' @importFrom tibble tibble +#' @importFrom tidyr unnest pivot_longer +#' @importFrom tidyselect all_of #' @importFrom stringr str_detect -#' @importFrom dplyr bind_rows left_join join_by +#' @importFrom dplyr bind_rows left_join select group_nest mutate pull group_by #' @importFrom rlang .data -#' @importFrom DemoTools check_heaping_roughness check_heaping_bachi check_heaping_myers check_heaping_sawtooth +#' @importFrom purrr map map2 +#' @importFrom DemoTools is_single check_heaping_roughness check_heaping_bachi check_heaping_myers check_heaping_sawtooth #' @export #' @examples #' \dontrun{ @@ -154,8 +158,8 @@ check_heaping_general <- function(data, y) { Value = pull(.x, !!sym(y)), Age = .x$Age, ageMin = 30)), - "res" = map2(.x = roughness, - .y = sawtooth, ~ + "res" = map2(.x = .data$roughness, + .y = .data$sawtooth, ~ bind_rows( classify( x = .x, diff --git a/R/odap.R b/R/odap.R index b28553f..26fd8ea 100644 --- a/R/odap.R +++ b/R/odap.R @@ -16,7 +16,7 @@ #' @param year Numeric vector of years to filter by (default \code{1971}). #' @param sex Character scalar indicating sex to filter by, e.g., \code{"M"} or \code{"F"} (default \code{"M"}). #' @param i18n Optional internationalization object for translating plot labels and titles (default \code{NULL}). -#' @importFrom dplyr filter arrange across select mutate group_by reframe ungroup full_join group_nest +#' @importFrom dplyr filter arrange across select mutate group_by reframe ungroup full_join group_nest pick #' @importFrom tibble as_tibble #' @importFrom DemoTools lt_single_mx OPAG groupAges #' @importFrom tidyr pivot_longer @@ -159,7 +159,7 @@ odap_opag <- function(data_in = NULL, conditional_filter("country_code", country_code) %>% conditional_filter("name", name) %>% conditional_filter("year", year) %>% - conditional_filter("sex", sex) %>% + conditional_filter("sex", sex) %>% select(any_of(c("name", "country_code", "sex", "year", "age", "nlx"))) # Rename nlx back to nLx for consistency with downstream code if("nlx" %in% names(nLx)) { @@ -184,36 +184,38 @@ odap_opag <- function(data_in = NULL, } + # add env solution suppressPackageStartupMessages(library(latest_wpp, character.only = TRUE)) - data("mx1dt", package = latest_wpp) + + env <- new.env() + data("mx1dt", package = latest_wpp, envir = env) - nLx <- mx1dt %>% + nLx <- env$mx1dt %>% as_tibble() %>% - select(-.data$mxB) %>% + select(-c("mxB")) %>% conditional_filter("country_code", country_code) %>% conditional_filter("name", name) %>% conditional_filter("year", year) %>% pivot_longer( - cols = c(.data$mxM, .data$mxF), - names_to = "sex", + cols = c("mxM", "mxF"), + names_to = "sex", values_to = "mx" ) %>% mutate(sex = substr(.data$sex, 3, 3)) %>% conditional_filter("sex", sex) - group_vars <- intersect(c("name","country_code","sex","year"), names(nLx)) - - nLx <- nLx %>% - group_by(across(all_of(intersect(c("name", "country_code", "sex", "year"), names(.))))) %>% + nLx <- nLx %>% + group_by(across(any_of(c("name", "country_code", "sex", "year")))) %>% reframe( - lt_single_mx(nMx = .data$mx, Age = .data$age), .groups = "drop") %>% - select(.data$name, - .data$country_code, - .data$sex, - .data$year, - age = .data$Age, - .data$AgeInt, - .data$nLx) + lt_single_mx(nMx = .data$mx, + Age = .data$age), .groups = "drop") %>% + select("name", + "country_code", + "sex", + "year", + "age" = "Age", + "AgeInt", + "nLx") # # nLx <- nLx %>% # as_tibble() %>% @@ -237,7 +239,7 @@ odap_opag <- function(data_in = NULL, conditional_filter("country_code", country_code) %>% conditional_filter("name", name) %>% conditional_filter("year", year) %>% - conditional_filter("sex", sex) %>% + conditional_filter("sex", sex) %>% select(any_of(c("name", "country_code", "sex", "year", "age", "AgeInt", "nLx"))) } @@ -261,7 +263,7 @@ odap_opag <- function(data_in = NULL, nLx <- nLx %>% - group_by(across(all_of(intersect(c("name", "country_code", "sex", "year"), names(.))))) %>% + group_by(across(any_of(c("name", "country_code", "sex", "year")))) %>% reframe({ dat <- pick(everything()) age_vals <- seq(0, max(dat$age), by = age_spacing) @@ -269,9 +271,7 @@ odap_opag <- function(data_in = NULL, tibble(age = age_vals, nLx = nLx_vals) }) - } else { } - # ---------------------------------------------------------------------------- # # Part 3: Now we have user data and reference data and we can use the OPAG function @@ -359,21 +359,23 @@ odap_opag <- function(data_in = NULL, Pop_vals <- .x$pop nLx_vals <- .x$nLx OPAG( - Pop = Pop_vals, - Age_Pop = Age_vals, - nLx = nLx_vals, - Age_nLx = Age_vals, - Age_fit = Age_fit, - AgeInt_fit = AgeInt_fit, + Pop = Pop_vals, + Age_Pop = Age_vals, + nLx = nLx_vals, + Age_nLx = Age_vals, + Age_fit = Age_fit, + AgeInt_fit = AgeInt_fit, Redistribute_from = Redistribute_from, - OAnew = OAnew, - method = method + OAnew = OAnew, + method = method ) }), plots = map2(.data$data, .data$results, function(.x, .y) { - old <- tibble(pop = .x$pop, age = .x$age) %>% + old <- tibble(pop = .x$pop, + age = .x$age) %>% filter(.data$age > Redistribute_from) - new <- tibble(pop = .y$Pop_out, age = .y$Age_out) %>% + new <- tibble(pop = .y$Pop_out, + age = .y$Age_out) %>% filter(.data$age > Redistribute_from) # Note: translated text variables (title_text, age_text, etc.) @@ -383,21 +385,21 @@ odap_opag <- function(data_in = NULL, # Rename columns to translated versions for hover tooltips (following lifetable pattern) names(old)[names(old) == "age"] <- age_text names(old)[names(old) == "pop"] <- pop_text - old[[type_text]] <- original_text + old[[type_text]] <- original_text names(new)[names(new) == "age"] <- age_text names(new)[names(new) == "pop"] <- pop_text - new[[type_text]] <- redistributed_text + new[[type_text]] <- redistributed_text # Create named vector for colors using translated keys - color_values <- c("black", "red") + color_values <- c("black", "red") names(color_values) <- c(original_text, redistributed_text) # Build plot using .data[[]] for runtime evaluation (NOT !!sym()) ggplot() + geom_point(data = old, aes(x = .data[[age_text]], y = .data[[pop_text]], color = .data[[type_text]]), size = 2) + - geom_line(data = new, aes(x = .data[[age_text]], y = .data[[pop_text]], color = .data[[type_text]]), linewidth = 1) + + geom_line( data = new, aes(x = .data[[age_text]], y = .data[[pop_text]], color = .data[[type_text]]), linewidth = 1) + scale_color_manual(name = type_text, values = color_values) + labs(x = age_text, y = pop_text, title = title_text) + theme_minimal(base_size = 14) + diff --git a/man/check_heaping_general.Rd b/man/check_heaping_general.Rd index b67b4ec..adaaa2a 100644 --- a/man/check_heaping_general.Rd +++ b/man/check_heaping_general.Rd @@ -12,7 +12,7 @@ check_heaping_general(data, y) \item{y}{character.Variable name for which the heaping should be checked \code{Deaths} or \code{Exposures}.} } \value{ -A data.frame with 2 columns \code{method} - the method used for age heaping evaluation and \code{result} - the resulting heaping measure +A data.frame with 3 columns \code{method} - the method used for age heaping evaluation, \code{result} - the resulting heaping measure, and \code{.id} - user specified groups identifier (if missing is set to "all") } \description{ Check the age heaping for 5 or 1 year data. diff --git a/man/movepop.Rd b/man/movepop.Rd deleted file mode 100644 index 51f8dee..0000000 --- a/man/movepop.Rd +++ /dev/null @@ -1,100 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/movepop.R -\name{movepop} -\alias{movepop} -\title{Project Population Between Two Dates Using Age-Specific Rates} -\usage{ -movepop( - initial_date, - desired_date, - male_pop, - female_pop, - male_mx, - female_mx, - asfr, - annual_net_migrants = 0, - age_groups = NULL, - age_format = "auto" -) -} -\arguments{ -\item{initial_date}{Numeric or Date. The starting year/date of the population.} - -\item{desired_date}{Numeric or Date. The year/date to which the population is projected.} - -\item{male_pop}{Numeric vector of male population counts by age.} - -\item{female_pop}{Numeric vector of female population counts by age.} - -\item{male_mx}{Numeric vector of male mortality rates by age.} - -\item{female_mx}{Numeric vector of female mortality rates by age.} - -\item{asfr}{Numeric vector of age-specific fertility rates corresponding to female ages.} - -\item{annual_net_migrants}{Numeric scalar for annual net migration to include in growth (default 0).} - -\item{age_groups}{Optional character vector of age group labels. If \code{NULL}, default labels are assigned.} - -\item{age_format}{Character specifying age structure: \code{"single_year"}, \code{"five_year"}, or \code{"auto"} (default \code{"auto"}). When \code{"auto"}, the function infers format from the length of population vectors.} -} -\value{ -A list with three elements: -\describe{ -\item{\code{initial_summaries}}{A tibble summarising total births, deaths, crude rates, growth rate, total population, and adjustment factor.} -\item{\code{projected_summaries}}{A tibble summarising projected total population by sex and overall sex ratio.} -\item{\code{data}}{A tibble with age-specific populations, ASFR, births, deaths, projected populations by sex, both-sexes totals, and sex ratios.} -} -} -\description{ -The \code{movepop()} function projects a population from an initial date to a desired date -using age-specific fertility (ASFR) and mortality rates. It supports single-year or -five-year age group formats and optionally accounts for net migration. -The function produces both projected population by age and sex and summary statistics. -} -\details{ -\itemize{ -\item The function ensures that population and mortality vectors have equal lengths. -\item If \code{age_format} is \code{"auto"}, lengths of 18 imply \code{"five_year"} and lengths ≥101 imply \code{"single_year"}. -\item Age groups are automatically generated if not provided, and ASFR values are aligned starting at the age group \code{"15"} (or equivalent). -\item Projected populations are computed using exponential growth based on crude birth rate, crude death rate, and net migration rate. -\item The function returns both age-specific projected populations and summary statistics. -} -} -\examples{ -\dontrun{ -male_pop <- c(48875, 164390, 173551, 130297, 101143, 73615, 60594, 55175, - 49530, 46562, 39028, 27837, 22110, 18066, 15340, 13318, -#' 12002, 6424) - -female_pop <- c(47105, 159546, 168760, 119437, 92080, 70515, 58801, 53381, - 46757, 41164, 33811, 24121, 19315, 16319, 14058, 12302, - 11047, 5922) - -male_mx <- c(0.12427, 0.01639, 0.00274, 0.00167, 0.00251, 0.00380, 0.00382, - 0.00442, 0.00506, 0.00663, 0.00872, 0.01240, 0.01783, 0.02700, - 0.04126, 0.06785, 0.11287, 0.21015) - -female_mx <- c(0.11050, 0.01577, 0.00254, 0.00159, 0.00232, 0.00304, 0.00344, - 0.00370, 0.00418, 0.00492, 0.00592, 0.00831, 0.01182, 0.01942, - 0.03221, 0.05669, 0.09771, 0.19385) - -asfr <- c(0.199, 0.478, 0.418, 0.321, 0.163, 0.071, 0.028) - -res <- movepop( -initial_date = 1973.58, -desired_date = 1973.50, -male_pop = male_pop, -female_pop = female_pop, -male_mx = male_mx, -female_mx = female_mx, -asfr = asfr, -annual_net_migrants = -50000, -age_format = "five_year" - -res$initial_summaries -res$projected_summaries -head(res$data) -} - -}