diff --git a/.RData b/.RData index bc879d38..c18bcffd 100644 Binary files a/.RData and b/.RData differ diff --git a/R/AGEINT.R b/R/AGEINT.R index 13135c72..e875e4b1 100644 --- a/R/AGEINT.R +++ b/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 } diff --git a/R/utils_downloads.R b/R/utils_downloads.R index 02a7f56c..af435bda 100644 --- a/R/utils_downloads.R +++ b/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 diff --git a/man/downloadAsfr.Rd b/man/downloadAsfr.Rd index e48ab2ad..609808be 100644 --- a/man/downloadAsfr.Rd +++ b/man/downloadAsfr.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils_downloads.R \name{downloadAsfr} \alias{downloadAsfr} -\title{Extract ASFR estimates from WPP2019} +\title{Extract ASFR estimates from WPP2019. Mainly an util function for other ones.} \usage{ downloadAsfr(Asfrmat, location = NULL, AsfrDatesIn, method = "linear") } diff --git a/man/downloadnLx.Rd b/man/downloadnLx.Rd index c95a7575..0b5f18d6 100644 --- a/man/downloadnLx.Rd +++ b/man/downloadnLx.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils_downloads.R \name{downloadnLx} \alias{downloadnLx} -\title{Extract Lx estimates from WPP2019} +\title{Extract Lx estimates from WPP2019. Mainly an util function for other ones.} \usage{ downloadnLx(nLx, location, gender, nLxDatesIn, method = "linear") } diff --git a/tests/testthat/test-basepop.R b/tests/testthat/test-basepop.R index 287a0691..fc3d7bc3 100644 --- a/tests/testthat/test-basepop.R +++ b/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") +}) diff --git a/tests/testthat/test_AGEINT.R b/tests/testthat/test_AGEINT.R new file mode 100644 index 00000000..a3b50e0a --- /dev/null +++ b/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.") +})