Merge pull request #232 from IvanWilli/IW

downloads details + interp

R/AGEINT.R

@@ -283,7 +283,10 @@ interp <- function(popmat,
   }
 
   # IW: no negatives when extrapolate. Thinking in pop and lt expressions
-  int[int<0] <- 0
-
+  if(all(!is.na(int)) & any(int<0)){
+    cat("Negative values were turned 0. No accepted in population counts, fertility rates or life table functions.\n")
+    int[int<0] <- 0  
+  }
+
   int
 }

R/utils_downloads.R

@@ -2,7 +2,7 @@
 # These utils might be used by basepop, interp_coh, OPAG, mig_resid*,
 # and potentially others.
 
-#' Extract Lx estimates from WPP2019
+#' Extract Lx estimates from WPP2019. Mainly an util function for other ones.
 #' @description We extract `Lx` from `wpp2019`, interpolated to exact dates. Different methods availables. 
 #' A vector of countries can handle, but with an unique sex. Row names are not indicative of countries.
 #' @param nLx numeric. either `NULL` or a numeric vector of lifetable exposure. If it's the second then we just pass it back.
@@ -15,6 +15,7 @@
 #' @export
 #' @importFrom stats setNames
 #' @importFrom stats reshape
+#' @importFrom fertestr is_LocID
 #' @examples
 #' # life expectancy calculated from Lx downloaded from WPP19. Using names or codes.
 #' Lxs_name <- downloadnLx(nLx=NULL, location = "Argentina",
@@ -55,8 +56,8 @@ downloadnLx <- function(nLx, location, gender, nLxDatesIn, method="linear") {
     if (is.null(location)){
       stop("You need to provide a location to download the data for nLx")
     } 
-    if (!any(is_LocID(location))) {
-      location_code <- get_location_code(location)
+    if (!any(fertestr::is_LocID(location))) {
+      location_code <- fertestr::get_location_code(location)
     }else {
       location_code <- as.integer(location)
     }
@@ -100,10 +101,14 @@ downloadnLx <- function(nLx, location, gender, nLxDatesIn, method="linear") {
             apply(X[,-c(1:3)] %>% 
                     as.data.frame()%>% stats::setNames(as.character(nLxDatesIn)), 2,
                     function(S){
-                        MortalityLaws::LifeTable(x = Age,
-                                                 mx = S,
-                                                 lx0 = 1,
-                                                 sex = Sex_mortlaws)$lt$Lx
+                        # MortalityLaws::LifeTable(x = Age,
+                        #                          mx = S,
+                        #                          lx0 = 1,
+                        #                          sex = Sex_mortlaws)$lt$Lx
+                        DemoTools::lt_abridged(nMx=S,
+                                               Age = Age,
+                                               radix = 1,
+                                               Sex=sex_code)$nLx
                   })
           }) %>% 
           do.call("rbind", .)
@@ -115,7 +120,7 @@ downloadnLx <- function(nLx, location, gender, nLxDatesIn, method="linear") {
   }
 }
 
-#' Extract ASFR estimates from WPP2019
+#' Extract ASFR estimates from WPP2019. Mainly an util function for other ones.
 #' @description We extract `ASFRx` from `wpp2019`, interpolated to exact dates. Different methods availables.
 #' A vector of countries can handle, but with an unique sex. Row names are not indicative of countries.
 #' @param Asfrmat numeric.
@@ -126,6 +131,7 @@ downloadnLx <- function(nLx, location, gender, nLxDatesIn, method="linear") {
 #' @return numeric matrix interpolated asfr
 #' @export
 #' @importFrom fertestr get_location_code
+#' @importFrom fertestr is_LocID
 #' @importFrom stats setNames
 #' @examples
 #' # Total fertility ratio calculated from ASFRx downloaded from WPP19. 
@@ -135,7 +141,7 @@ downloadnLx <- function(nLx, location, gender, nLxDatesIn, method="linear") {
 #' plot(1950:2025, as.numeric(colSums(ASFR_Arg))*5, xlab = "Year", ylab="TFR", ylim=c(1.5,4), t="l")
 #' }
 downloadAsfr <- function(Asfrmat, location = NULL, AsfrDatesIn, method="linear") {
-  #requireNamespace("fertestr", quietly = TRUE)
+
   verbose <- getOption("basepop_verbose", TRUE)
 
   if (!is.null(Asfrmat)) {
@@ -147,8 +153,8 @@ downloadAsfr <- function(Asfrmat, location = NULL, AsfrDatesIn, method="linear")
   if (is.null(location)){
     stop("You need to provide a location to download the data for Asfrmat")
   } 
-  if (!any(is_LocID(location))) {
-    location_code <- get_location_code(location)
+  if (!any(fertestr::is_LocID(location))) {
+    location_code <- fertestr::get_location_code(location)
   }else {
     location_code <- as.integer(location)
   }
@@ -188,9 +194,9 @@ downloadAsfr <- function(Asfrmat, location = NULL, AsfrDatesIn, method="linear")
 #' @param location UN Pop Div `LocName` or `LocID`
 #' @param DatesOut numeric vector of three decimal dates produced by `basepop_ive()`
 #' @param verbose logical, shall we send optional messages to the console?
-#'
 #' @return numeric vector with three SRB estimates
 #' @export
+#' @importFrom stats setNames
 
 
 downloadSRB <- function(SRB, location, DatesOut, verbose = TRUE){
@@ -334,7 +340,7 @@ interp_coh_download_mortality <- function(location, sex, date1, date2, OAnew = 1
 
 loc_message <- function(location){
   cds     <- DemoToolsData::WPP_codes
-  if (is_LocID(location)){
+  if (fertestr::is_LocID(location)){
     LocName   <- get_LocName(location)
     LocID     <- location
   } else {
@@ -346,7 +352,7 @@ loc_message <- function(location){
 }
 
 get_LocID <- function(location){
-  if (is_LocID(location)){
+  if (fertestr::is_LocID(location)){
     return(location)
   } else {
     cds     <- DemoToolsData::WPP_codes
@@ -359,7 +365,7 @@ get_LocID <- function(location){
   }
 }
 get_LocName <- function(location){
-  if (is_LocID(location)){
+  if (fertestr::is_LocID(location)){
     cds         <- DemoToolsData::WPP_codes
     ind         <- cds$LocID == location
     if (!any(ind)){
@@ -373,7 +379,7 @@ get_LocName <- function(location){
 }
 
 is_Loc_available <- function(location){
-  isID   <- is_LocID(location)
+  isID   <- fertestr::is_LocID(location)
   cds <- DemoToolsData::WPP_codes
   if (isID){
     out <- location %in% cds$LocID

tests/testthat/test-basepop.R

@@ -840,3 +840,34 @@ test_that("downloadSRB works as expected", {
   )
 })
 
+# Interpolation between pivot wpp years, also into the period 1950-1955
+tfr_pj <- data.frame(
+           year = c(1950.0,1950.5,1951.5,1952.5,1953.0,
+                    1953.5,1954.5,1955.0,1955.5,
+                    1956.5,1957.5,1958.0,1958.5,
+                    1959.5,1960.0,1960.5,1961.5,
+                    1962.5,1963.0,1963.5,1964.5,
+                    1965.0,1965.5,1966.5,1967.5,
+                    1968.0,1968.5,1969.5,1970.0,
+                    1970.5,1971.5,1972.5,1973.0),
+           tfr = c(7.2986,7.3290,7.3898,7.4506,7.4810,7.5114,7.5722,7.6026,7.6330,
+                   7.6938,7.7546,7.7850,7.8130,7.8690,7.8970,7.9250,7.9810,8.0370,
+                   8.0650,8.0695,8.0785,8.0830,8.0875,8.0965,8.1055,8.1100,8.0980,
+                   8.0740,8.0620,8.0500,8.0260,8.0020,7.9900))
+
+test_that("Replicate Peter Johnson´s excel for extrapolatebeyond 1955",{
+  expect_equal(tfr_pj$tfr,
+               downloadAsfr(Asfrmat = NULL, location = "Kenya", 
+                            AsfrDatesIn = tfr_pj$year) %>% colSums() %>% 
+                            as.numeric() * 5
+               )
+})
+
+test_that("Receive a message if asked dates are not in 1950-2025 interval",{
+  expect_output(downloadAsfr(Asfrmat = NULL, location = "Kenya", 
+                             AsfrDatesIn = 1900),
+                regexp = "Careful, extrapolating beyond range 1950-2025")
+  expect_output(downloadnLx(nLx = NULL, location = "Kenya", 
+                            nLxDatesIn = 1900, gender="both"),
+                regexp = "Careful, extrapolating beyond range 1950-2025")
+})

tests/testthat/test_AGEINT.R

@@ -0,0 +1,66 @@
+# test for basic interpolation function `interp`
+
+context("test-AGEINT")
+
+test_that("basic interpolation function",{
+
+  # Toy example: two ages, two dates, expected result by eye
+  popmatr <- matrix(1:2,2,2,byrow = T)
+  dates <- dec.date(c(2000.5,2010.5))
+
+  # interp
+  expect_true(
+    all( 1.5 ==
+           interp(popmat = popmatr, 
+                  datesIn = dates,
+                  datesOut = dec.date(2005.5))
+    )
+  )
+  # extrap
+  expect_true(
+    all( 2.5 ==
+           interp(popmat = popmatr, 
+                  datesIn = dates,
+                  datesOut = dec.date(2015.5), extrap = T)
+    )
+  )
+  # constant inputs
+  expect_true(
+    all( 1 ==
+           interp(popmat = matrix(1,2,2,byrow = T), 
+                  datesIn = dates,
+                  datesOut = dec.date(2005.5)),
+         1 ==
+           interp(popmat = matrix(1,2,2,byrow = T), 
+                  datesIn = dates,
+                  datesOut = dec.date(2015.5), extrap = T)
+    )
+  )
+
+  # you set an output date beyond observed range, but without extrap=T, receive NA
+  # this is an interp function by default, so the argument to change the deafult behaviour
+  # must be explicit
+  expect_true(
+    all(
+      is.na(
+        interp(popmat = popmatr, 
+               datesIn = dates,
+               datesOut = dec.date(2015.5))
+      )
+    )
+  )
+
+  # no negative values
+  expect_true(
+    all(interp(popmat = popmatr, 
+               datesIn = dates,
+               datesOut = dec.date(1900.5), 
+               extrap = T)>=0
+    )
+  )
+  expect_output(interp(popmat = popmatr, 
+                       datesIn = dates,
+                       datesOut = dec.date(1900.5), 
+                       extrap = T),
+                regexp = "Negative values were turned 0. No accepted in population counts, fertility rates or life table functions.")
+})