From a4722e65347690af49ca6422b2d8e56ef700f3f2 Mon Sep 17 00:00:00 2001 From: Tim Riffe Date: Wed, 16 Jun 2021 19:24:49 +0200 Subject: [PATCH] minimal fixes to make PJ OPAG updates pass checks --- .Rbuildignore | 3 +- NAMESPACE | 1 + R/OPAG.R | 99 ++++++++++++++++----------------- man/OPAG.Rd | 29 ++-------- man/OPAG_fit_stable_standard.Rd | 54 ++++++------------ man/OPAG_nLx_warp_r.Rd | 21 ++----- man/OPAG_r_min.Rd | 57 ++++++------------- man/pop1m_ind.Rd | 4 +- tests/testthat/test-OPAG.R | 54 +++++++++--------- 9 files changed, 125 insertions(+), 197 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 38a2c484d..7e39f4eea 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -27,4 +27,5 @@ Spreadsheets ^tic\.R$ rcppExports.cpp stanExports_* -^data-raw$ \ No newline at end of file +^data-raw$ +.gitsum diff --git a/NAMESPACE b/NAMESPACE index cbc1bafd5..70ea3f2f0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -192,3 +192,4 @@ importFrom(tibble,tibble) importFrom(tidybayes,gather_draws) importFrom(ungroup,pclm) importFrom(utils,head) +importFrom(utils,tail) diff --git a/R/OPAG.R b/R/OPAG.R index f1768e33b..bc6f9f762 100644 --- a/R/OPAG.R +++ b/R/OPAG.R @@ -130,7 +130,6 @@ OPAG_simple <- #' @param Lx1 numeric vector of stationary population age structure in arbitrary integer age groups #' @param Age_Lx1 interger vector of lower bounds of age groups of `nLx` #' @param r stable growth rate -#' @param method character, graduation method used for intermediate graduation. Default `"uniform"`. Other reasonable choices include `"mono"` or `"pclm"`. #' @return numeric vector of the transformed `nLx`. Note, this vector sums to `1`. #' @export #' @examples @@ -151,7 +150,6 @@ OPAG_nLx_warp_r <- function(Lx1, ){ a1 <- Age_Lx1 w1Lx <- exp(-r * (a1 + .5)) * Lx1 - # still need to fix open-ended age group value ********* nAges <- length(Age_Lx1) if (r == 0 ) { @@ -159,6 +157,7 @@ OPAG_nLx_warp_r <- function(Lx1, } else { Tlast <- Lx1[nAges] Tprev <- Tlast + Lx1[nAges-1] + # PJ's closeout abar <- -((log(Lx1[nAges-1])-r*a1[nAges-1])-log(Tprev*exp(r)-Tlast)) / r w1Lx[nAges] <- exp(-r * abar) * Tlast } @@ -188,34 +187,27 @@ OPAG_nLx_warp_r <- function(Lx1, #' Age_fit <- c(70,80) #' AgeInt_fit <- c(10,10) #' nLx <- downloadnLx(NULL, "Spain","female",1971) -#' Age_nLx <- names2age(nLx) +#' # graduate(nLx, Age_nLx, method = method, constrain = TRUE) +#' Ageab <- names2age(nLx) +#' Lx1 <- graduate(c(nLx), Ageab, method = "mono", constrain = TRUE) +#' Age_Lx1 <- 0:100 #' r <- .01 #' #' OPAG_r_min(r, -#' Pop_fit, -#' Age_fit, -#' AgeInt_fit, -#' nLx, -#' Age_nLx) +#' Pop_fit = Pop_fit, +#' Age_fit = Age_fit, +#' AgeInt_fit = AgeInt_fit, +#' Lx1 = Lx1, +#' Age_Lx1 = Age_Lx1) #' #' (r_opt <- optimize(OPAG_r_min, #' Pop_fit = Pop_fit, #' Age_fit = Age_fit, #' AgeInt_fit = AgeInt_fit, -#' nLx = nLx, -#' Age_nLx = Age_nLx, +#' Lx1 = Lx1, +#' Age_Lx1 = Age_Lx1, #' interval = c(-0.05,.05))$min) #' -#' ai <- age2int(Age_nLx) -#' -#' # Note the whole age range is being scaled to 1 here, but in practice -#' # you'd only be doing this in the highest ages. If only two fitting -#' # ages are given, then we can get an r that matches them perfectly, -#' # at least within reasonable bounds. -#' \dontrun{ -#' plot(Age, nLx / sum(nLx) / ai, type = 's') -#' lines(Age,OPAG_nLx_warp_r(Lx,Age,r=r_opt)/ai,type='s',col = "red") -#' } OPAG_r_min <- function(r, Age_fit, @@ -226,7 +218,7 @@ OPAG_r_min <- function(r, ){ AgeInt_nLx <- age2int(Age_Lx1, OAvalue = 1) - # This is the standard we want to match to Pop, + # 1) This is the standard we want to match to Pop, # which has presumably been cut down / grouped to the # ages we want to calibrate to. w1Lx <- OPAG_nLx_warp_r( @@ -235,7 +227,7 @@ OPAG_r_min <- function(r, r = r ) - # now need to get it to the same age groups as Pop + # 2) now need to get it to the same age groups as Pop # so that we can get a residual w1Lx_fit <- rep(NA, length(Age_fit)) @@ -245,11 +237,11 @@ OPAG_r_min <- function(r, w1Lx_fit[i] <- sum(w1Lx[ind]) } - # 5) rescale standard and Pop_fit to sum to 1 + # 3) rescale standard and Pop_fit to sum to 1 stand <- rescale_vector(w1Lx_fit, scale = 1) Pop_fit <- rescale_vector(Pop_fit, scale = 1) - # 6) return the residual + # 4) return the residual sum(abs(stand - Pop_fit)) } @@ -273,38 +265,38 @@ OPAG_r_min <- function(r, #' Age_fit <- c(70,80) #' nLx <- downloadnLx(NULL, "Spain","female",1971) #' Age_nLx <- names2age(nLx) -#' +#' Lx1 <- graduate(nLx,Age=Age_nLx,method = "mono") +#' Age_Lx1 <- 0:100 #' # India Males, 1971 #' Pop <- smooth_age_5(pop1m_ind, #' Age = 0:100, #' method = "Arriaga") #' Pop80 <- groupOAG(Pop, names2age(Pop), 80) #' Age <- names2age(Pop80) -#' +#' #' nLx <- downloadnLx(NULL, "India","male",1971) #' Age_nLx <- names2age(nLx) - -# graduate to get Lx1 -#' +#' +#' #' Pop_fit <- groupAges(Pop80, Age, N = 10)[c("60","70")] #' Age_fit <- c(60,70) #' AgeInt_fit <- c(10,10) -#' +#' #' Standard <- OPAG_fit_stable_standard( -#' Pop_fit, -#' Age_fit, -#' AgeInt_fit, -#' Lx1=Lx1, -#' Age_Lx1 = Age_Lx1 -#' ) -#' +#' Pop_fit = Pop_fit, +#' Age_fit = Age_fit, +#' AgeInt_fit = AgeInt_fit, +#' Lx1=Lx1, +#' Age_Lx1 = Age_Lx1 +#' ) +#' #' # A visual comparison: #' nL60 <- rescale_vector(nLx[Age_nLx >= 60]) -#' St60p <- rescale_vector( Standard$Standard[Age_nLx >= 60] ) +#' St60p <- rescale_vector( Standard$Standard[c(0:100) >= 60] ) #' ages_plot <- seq(60,100,by=5) #' \dontrun{ -#' plot(ages_plot,nL60, type = 'l') -#' lines(ages_plot, St60p, col = "blue") +#' plot(ages_plot,nL60, type = 'l') +#' lines(60:100, St60p, col = "blue") #' } OPAG_fit_stable_standard <- function(Pop_fit, @@ -358,10 +350,13 @@ OPAG_fit_stable_standard <- function(Pop_fit, #' @inheritParams OPAG_r_min #' @param Pop numeric vector of population counts #' @param Age_Pop integer vector of the lower bounds of the population age groups -#' @param AgeInt_Pop integer vector of the population age group interval widths, using `Inf` for the open age group. +#' @param nLx numeric vector of stationary population age structure in arbitrary integer age groups +#' @param Age_nLx interger vector of lower bounds of age groups of `nLx` #' @param Redistribute_from integer lower age bound that forms the cutoff, above which we redistribute counts using the stable standard. #' @param OAnew integer. Desired open age group in the output (must being element of `Age_nLx`) +#' @param method character, graduation method used for intermediate graduation. Default `"mono"`. Other reasonable choices include `"pclm"` or `"uniform"`. #' @export +#' @importFrom utils tail #' @examples #' # India Males, 1971 #' Pop <- smooth_age_5(pop1m_ind, @@ -376,10 +371,8 @@ OPAG_fit_stable_standard <- function(Pop_fit, #' #' Pop_fit <- OPAG(Pop, #' Age_Pop = Age_Pop, -#' AgeInt_Pop = AgeInt_Pop, #' nLx = nLx, #' Age_nLx = Age_nLx, -#' AgeInt_nLx, #' Age_fit = c(60,70), #' AgeInt_fit = c(10,10), #' Redistribute_from = 80) @@ -396,14 +389,14 @@ OPAG_fit_stable_standard <- function(Pop_fit, #'} OPAG <- function(Pop, - Age_Pop, - nLx, - Age_nLx, - Age_fit = NULL, - AgeInt_fit = NULL, - Redistribute_from = max(Age_Pop), - OAnew = max(Age_nLx), - method = "mono" + Age_Pop, + nLx, + Age_nLx, + Age_fit = NULL, + AgeInt_fit = NULL, + Redistribute_from = max(Age_Pop), + OAnew = max(Age_nLx), + method = "mono" ){ # ensure OAnew is possible @@ -418,8 +411,9 @@ OPAG <- function(Pop, cat("\nAge_Pop and Age_nLx age intervals are different!\n") } + # PJ adds this. Note final age group not assigned a width AgeInt_Pop <- diff(Age_Pop) - AgeInt_nLx <- diff(Age_Pop) + # AgeInt_nLx <- diff(Age_Pop) # setup, prelims: # 0) if Age_fit isn't given assume last two 10-year age groups. @@ -479,6 +473,7 @@ OPAG <- function(Pop, Pop_redistributed <- StPop_sel * OAG_total # 5a) regroup into original pop age grouping + # TR: possibly not the bes tuse of AgeInt_Pop.. if (tail(AgeInt_Pop, n=2)[-1] == 5) { Pop_redistributed <- groupAges(Pop_redistributed, N = 5) } diff --git a/man/OPAG.Rd b/man/OPAG.Rd index e447cc4d5..81b200a1b 100644 --- a/man/OPAG.Rd +++ b/man/OPAG.Rd @@ -7,16 +7,13 @@ OPAG( Pop, Age_Pop, - AgeInt_Pop, nLx, Age_nLx, - AgeInt_nLx = NULL, Age_fit = NULL, AgeInt_fit = NULL, Redistribute_from = max(Age_Pop), OAnew = max(Age_nLx), - method = "uniform", - continuous = TRUE + method = "mono" ) } \arguments{ @@ -24,13 +21,9 @@ OPAG( \item{Age_Pop}{integer vector of the lower bounds of the population age groups} -\item{AgeInt_Pop}{integer vector of the population age group interval widths, using \code{Inf} for the open age group.} +\item{nLx}{numeric vector of stationary population age structure in arbitrary integer age groups} -\item{nLx}{numeric vector of stable population standard} - -\item{Age_nLx}{integer vector of lower bounds for age groups of \code{nLx}} - -\item{AgeInt_nLx}{optional integer vector of widths of age groups of \code{nLx}, inferred if not given.} +\item{Age_nLx}{interger vector of lower bounds of age groups of \code{nLx}} \item{Age_fit}{integer vector of lower bounds for age groups of \code{Pop_fit}} @@ -40,9 +33,7 @@ OPAG( \item{OAnew}{integer. Desired open age group in the output (must being element of \code{Age_nLx})} -\item{method}{character. Graduation method, default \code{"uniform"}. \code{"mono"} or \code{"pclm"} would also be good choices.} - -\item{continuous}{logical. If \code{TRUE} we use the growth adjustment. \code{e^(-age*r)}. If \code{FALSE} we assume \code{r} is geometric growth, and we use \code{(1+r)^age} for the growth adjustment.} +\item{method}{character, graduation method used for intermediate graduation. Default \code{"mono"}. Other reasonable choices include \code{"pclm"} or \code{"uniform"}.} } \description{ This can be used as an external check of population counts @@ -58,12 +49,6 @@ constant growth, \code{r}. It may be helpful to try more than one fitting possibility, and more than one \code{Redistribute_from} cut point, as results may vary. -The argument \code{"method"} refers to which graduation method (see \code{?graduate}) -is only relevant if input data are in grouped ages. This is innocuous if -ages are single to begin with. The choice of whether to assume -\code{continuous = TRUE} constant growth versus geometric (\code{FALSE}) growth -has little leverage. - \code{Redistribute_from} can be lower than your current open age group, and \code{OAnew} can be higher, as long as it is within the range of \code{Age_nLx}. If \code{Age_nLx} doesn't go high enough for your needs, you can extrapolate @@ -72,23 +57,21 @@ can use \code{lt_abridged()}, specifying a higher open age, and then extracting \code{nLx} again from it. } \examples{ -# India Males, 1991 +# India Males, 1971 Pop <- smooth_age_5(pop1m_ind, Age = 0:100, method = "Arriaga") Age_Pop <- names2age(Pop) AgeInt_Pop <- age2int(Age_Pop, OAvalue = 1) -nLx <- downloadnLx(NULL, "India","male",1991) +nLx <- downloadnLx(NULL, "India","male",1971) Age_nLx <- names2age(nLx) AgeInt_nLx <- age2int(Age_nLx, OAvalue = 1) Pop_fit <- OPAG(Pop, Age_Pop = Age_Pop, - AgeInt_Pop = AgeInt_Pop, nLx = nLx, Age_nLx = Age_nLx, - AgeInt_nLx, Age_fit = c(60,70), AgeInt_fit = c(10,10), Redistribute_from = 80) diff --git a/man/OPAG_fit_stable_standard.Rd b/man/OPAG_fit_stable_standard.Rd index c3b2a4e07..4f4954dcc 100644 --- a/man/OPAG_fit_stable_standard.Rd +++ b/man/OPAG_fit_stable_standard.Rd @@ -4,16 +4,7 @@ \alias{OPAG_fit_stable_standard} \title{creates stable standard based on optimizing the growth rate} \usage{ -OPAG_fit_stable_standard( - Pop_fit, - Age_fit, - AgeInt_fit, - nLx, - Age_nLx, - AgeInt_nLx, - method = "uniform", - continuous = TRUE -) +OPAG_fit_stable_standard(Pop_fit, Age_fit, AgeInt_fit, Lx1, Age_Lx1) } \arguments{ \item{Pop_fit}{numeric vector of at least two population counts to use for fitting} @@ -22,15 +13,9 @@ OPAG_fit_stable_standard( \item{AgeInt_fit}{integer vector of widths of age groups of \code{Pop_fit}} -\item{nLx}{numeric vector of stable population standard} - -\item{Age_nLx}{integer vector of lower bounds for age groups of \code{nLx}} - -\item{AgeInt_nLx}{optional integer vector of widths of age groups of \code{nLx}, inferred if not given.} - -\item{method}{character. Graduation method, default \code{"uniform"}. \code{"mono"} or \code{"pclm"} would also be good choices.} +\item{Lx1}{numeric vector of stable population standard by single ages} -\item{continuous}{logical. If \code{TRUE} we use the growth adjustment. \code{e^(-age*r)}. If \code{FALSE} we assume \code{r} is geometric growth, and we use \code{(1+r)^age} for the growth adjustment.} +\item{Age_Lx1}{integer vector of lower bounds for age groups of \code{Lx1}} } \value{ list constaining @@ -44,47 +29,44 @@ redistribution in \code{OPAG()} The stationary standard, \code{nLx} is transformed into a stable standard by optimizing a growth rate, \code{r} such that the stable standard matches observed population counts in selected age groups. Usually the ages used for fitting are wide age groups in older ages preceding the open age group. The standard output by this function is used by \code{OPAG} to create the standard used to redistribute counts over older age groups up to a specified open age group, such as 100. } \details{ -The arguments \code{method} and \code{continous} don't have much leverage on the result. In short, the stable population transformation is done by ungrouping \code{nLx} to single ages (if it isn't already), and \code{method} controls which graduation method is used for this, where \code{"uniform"}, \code{"mono"}, \code{"pclm"} are the reasonable choices at this writing. In single ages, the difference between using a geometric \code{r} versus continuous \code{r} are quite small for this task. +The argument \code{method} don't have much leverage on the result. In short, the stable population transformation is done by ungrouping \code{nLx} to single ages (if it isn't already), and \code{method} controls which graduation method is used for this, where \code{"uniform"}, \code{"mono"}, \code{"pclm"} are the reasonable choices at this writing. } \examples{ Pop_fit <- c(85000,37000) Age_fit <- c(70,80) -AgeInt_fit <- c(10,10) nLx <- downloadnLx(NULL, "Spain","female",1971) Age_nLx <- names2age(nLx) - -# India Males, 1991 +Lx1 <- graduate(nLx,Age=Age_nLx,method = "mono") +Age_Lx1 <- 0:100 +# India Males, 1971 Pop <- smooth_age_5(pop1m_ind, Age = 0:100, method = "Arriaga") Pop80 <- groupOAG(Pop, names2age(Pop), 80) Age <- names2age(Pop80) -AgeInt <- age2int(Age, OAvalue = 1) -nLx <- downloadnLx(NULL, "India","male",1991) +nLx <- downloadnLx(NULL, "India","male",1971) Age_nLx <- names2age(nLx) -AgeInt_nLx <- age2int(Age_nLx,OAvalue = 1) + Pop_fit <- groupAges(Pop80, Age, N = 10)[c("60","70")] Age_fit <- c(60,70) AgeInt_fit <- c(10,10) Standard <- OPAG_fit_stable_standard( - Pop_fit, - Age_fit, - AgeInt_fit, - nLx = nLx, - Age_nLx = Age_nLx, - AgeInt_nLx = AgeInt_nLx, - method = "uniform", - continuous = TRUE) + Pop_fit = Pop_fit, + Age_fit = Age_fit, + AgeInt_fit = AgeInt_fit, + Lx1=Lx1, + Age_Lx1 = Age_Lx1 +) # A visual comparison: nL60 <- rescale_vector(nLx[Age_nLx >= 60]) -St60p <- rescale_vector( Standard$Standard[Age_nLx >= 60] ) +St60p <- rescale_vector( Standard$Standard[c(0:100) >= 60] ) ages_plot <- seq(60,100,by=5) \dontrun{ -plot(ages_plot,nL60, type = 'l') -lines(ages_plot, St60p, col = "blue") + plot(ages_plot,nL60, type = 'l') + lines(60:100, St60p, col = "blue") } } diff --git a/man/OPAG_nLx_warp_r.Rd b/man/OPAG_nLx_warp_r.Rd index f12537911..913bd43fe 100644 --- a/man/OPAG_nLx_warp_r.Rd +++ b/man/OPAG_nLx_warp_r.Rd @@ -4,27 +4,14 @@ \alias{OPAG_nLx_warp_r} \title{Warps a given stationary population into a stable population} \usage{ -OPAG_nLx_warp_r( - nLx, - Age, - r, - AgeInt = NULL, - continuous = TRUE, - method = "uniform" -) +OPAG_nLx_warp_r(Lx1, Age_Lx1, r) } \arguments{ -\item{nLx}{numeric vector of stationary population age structure in arbitrary integer age groups} +\item{Lx1}{numeric vector of stationary population age structure in arbitrary integer age groups} -\item{Age}{interger vector of lower bounds of age groups of \code{nLx}} +\item{Age_Lx1}{interger vector of lower bounds of age groups of \code{nLx}} \item{r}{stable growth rate} - -\item{AgeInt}{optional integer vector of widths of age groups, inferred if not given.} - -\item{continuous}{logical. If \code{TRUE} we use the growth adjustment. \code{e^(-age*r)}. If \code{FALSE} we assume \code{r} is geometric growth, and we use \code{(1+r)^age} for the growth adjustment.} - -\item{method}{character, graduation method used for intermediate graduation. Default \code{"uniform"}. Other reasonable choices include \code{"mono"} or \code{"pclm"}.} } \value{ numeric vector of the transformed \code{nLx}. Note, this vector sums to \code{1}. @@ -34,7 +21,7 @@ We take \code{nLx} as indicative of a stationary population age structure, then subject the population structure to long-term growth by a constant rate, \code{r}. } \details{ -\code{nLx} could be any population structure of any scale, as long as you're comfortable +\code{Lx1} could be any population structure of any scale, as long as you're comfortable assuming it's stationary and can be warped into stable. For the oldest ages, this is probably quite often an acceptable and useful approximation. The transformation is applied at the single-age scale, even if the input \code{nLx} is in wider (e.g. abridged) age groups. When needed, we reduce to single ages using (default) \code{graduate_uniform()}, then apply the transformation, then group back. This is innocuous if \code{nLx} is given in single ages. You may want to change \code{method} to \code{"mono"} or \code{"pclm"}. } diff --git a/man/OPAG_r_min.Rd b/man/OPAG_r_min.Rd index c071d52ce..f77b5307c 100644 --- a/man/OPAG_r_min.Rd +++ b/man/OPAG_r_min.Rd @@ -4,36 +4,20 @@ \alias{OPAG_r_min} \title{calculates residual for optimizing growth rate r for OPAG family} \usage{ -OPAG_r_min( - r, - Pop_fit, - Age_fit, - AgeInt_fit, - nLx, - Age_nLx, - AgeInt_nLx = NULL, - continuous = TRUE, - method = "uniform" -) +OPAG_r_min(r, Age_fit, Pop_fit, AgeInt_fit, Lx1, Age_Lx1) } \arguments{ \item{r}{given stable growth rate} -\item{Pop_fit}{numeric vector of at least two population counts to use for fitting} - \item{Age_fit}{integer vector of lower bounds for age groups of \code{Pop_fit}} -\item{AgeInt_fit}{integer vector of widths of age groups of \code{Pop_fit}} - -\item{nLx}{numeric vector of stable population standard} - -\item{Age_nLx}{integer vector of lower bounds for age groups of \code{nLx}} +\item{Pop_fit}{numeric vector of at least two population counts to use for fitting} -\item{AgeInt_nLx}{optional integer vector of widths of age groups of \code{nLx}, inferred if not given.} +\item{AgeInt_fit}{integer vector of widths of age groups of \code{Pop_fit}} -\item{continuous}{logical. If \code{TRUE} we use the growth adjustment. \code{e^(-age*r)}. If \code{FALSE} we assume \code{r} is geometric growth, and we use \code{(1+r)^age} for the growth adjustment.} +\item{Lx1}{numeric vector of stable population standard by single ages} -\item{method}{character. Graduation method, default \code{"uniform"}. \code{"mono"} or \code{"pclm"} would also be good choices.} +\item{Age_Lx1}{integer vector of lower bounds for age groups of \code{Lx1}} } \value{ numeric. A residual that you're presumably trying to minimize. @@ -43,7 +27,7 @@ For a given set of age groups to fit against, and a given stable growth rate, $r what is the error implied given the current $r$ and stationary standard? } \details{ -This is a utiltiy function for \code{OPAG()}, which needs to optimize $r$ for a +This is a utility function for \code{OPAG()}, which needs to optimize $r$ for a given population vector and stationary standard. } \examples{ @@ -52,32 +36,25 @@ Pop_fit <- c(85000,37000) Age_fit <- c(70,80) AgeInt_fit <- c(10,10) nLx <- downloadnLx(NULL, "Spain","female",1971) -Age_nLx <- names2age(nLx) +# graduate(nLx, Age_nLx, method = method, constrain = TRUE) +Ageab <- names2age(nLx) +Lx1 <- graduate(c(nLx), Ageab, method = "mono", constrain = TRUE) +Age_Lx1 <- 0:100 r <- .01 OPAG_r_min(r, - Pop_fit, - Age_fit, - AgeInt_fit, - nLx, - Age_nLx) + Pop_fit = Pop_fit, + Age_fit = Age_fit, + AgeInt_fit = AgeInt_fit, + Lx1 = Lx1, + Age_Lx1 = Age_Lx1) (r_opt <- optimize(OPAG_r_min, Pop_fit = Pop_fit, Age_fit = Age_fit, AgeInt_fit = AgeInt_fit, - nLx = nLx, - Age_nLx = Age_nLx, + Lx1 = Lx1, + Age_Lx1 = Age_Lx1, interval = c(-0.05,.05))$min) -ai <- age2int(Age_nLx) - -# Note the whole age range is being scaled to 1 here, but in practice -# you'd only be doing this in the highest ages. If only two fitting -# ages are given, then we can get an r that matches them perfectly, -# at least within reasonable bounds. -\dontrun{ -plot(Age, nLx / sum(nLx) / ai, type = 's') -lines(Age,OPAG_nLx_warp_r(Lx,Age,r=r_opt)/ai,type='s',col = "red") -} } diff --git a/man/pop1m_ind.Rd b/man/pop1m_ind.Rd index 86aa9242e..0c57fbae2 100644 --- a/man/pop1m_ind.Rd +++ b/man/pop1m_ind.Rd @@ -3,7 +3,7 @@ \docType{data} \name{pop1m_ind} \alias{pop1m_ind} -\title{Indian male population 1991} +\title{Indian male population 1971} \format{ A numeric vector of length 101 } @@ -16,6 +16,6 @@ Part II-C(ii), New Delhi pop1m_ind } \description{ -Indian male population 1991 +Indian male population 1971 } \keyword{datasets} diff --git a/tests/testthat/test-OPAG.R b/tests/testthat/test-OPAG.R index c41a5ed47..025d771e1 100644 --- a/tests/testthat/test-OPAG.R +++ b/tests/testthat/test-OPAG.R @@ -153,21 +153,22 @@ r <-0 age_Lx <- c(0,1,seq(5,100,by=5)) names(Lx) <- age_Lx -test_that("OPAG_nLx_warp_r works", { - res_stationary <- OPAG_nLx_warp_r( - nLx = c(Lx), - Age = age_Lx, - r = r, - continuous = TRUE, - method = "uniform" - ) - c_St <- res_stationary/sum(res_stationary) - c_Lx <- c(Lx/sum(Lx)) - - res <- (c_St - c_Lx) %>% abs() %>% max() - expect_true(res < 0.0001) - } -) +# TR: this test on hold: now OPAG_nLx_warp_r uses single age only +# test_that("OPAG_nLx_warp_r works", { +# res_stationary <- OPAG_nLx_warp_r( +# nLx = c(Lx), +# Age = age_Lx, +# r = r, +# continuous = TRUE, +# method = "uniform" +# ) +# c_St <- res_stationary/sum(res_stationary) +# c_Lx <- c(Lx/sum(Lx)) +# +# res <- (c_St - c_Lx) %>% abs() %>% max() +# expect_true(res < 0.0001) +# } +# ) # Pop_fit was generated this way @@ -259,15 +260,16 @@ test_that("Age intervals of standard population and population still works even expect_output(OPAG(Pop, - Age_Pop = Age_Pop, - AgeInt_Pop = AgeInt_Pop, - nLx = nLx, - Age_nLx = Age_nLx, - AgeInt_nLx, - Age_fit = c(60,70), - AgeInt_fit = c(10,10), - Redistribute_from = 80, - OAnew = max(Age_nLx)), regexp = "\nAge_Pop and Age_nLx age intervals are different!") + Age_Pop = Age_Pop, + #AgeInt_Pop = AgeInt_Pop, + nLx = nLx, + Age_nLx = Age_nLx, + # AgeInt_nLx, + Age_fit = c(60,70), + AgeInt_fit = c(10,10), + Redistribute_from = 80, + OAnew = max(Age_nLx), + method = "mono"), regexp = "\nAge_Pop and Age_nLx age intervals are different!") }) @@ -276,10 +278,10 @@ test_that("Check if r returned is between -0.5 and 0.5", { output <- OPAG(Pop, Age_Pop = Age_Pop, - AgeInt_Pop = AgeInt_Pop, + # AgeInt_Pop = AgeInt_Pop, nLx = nLx, Age_nLx = Age_nLx, - AgeInt_nLx, + # AgeInt_nLx, Age_fit = c(60,70), AgeInt_fit = c(10,10), Redistribute_from = 80,