Commit c4243b2a authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

Rename haveAges -> givenAges, needAges -> neededAges in fillAges; Fix ifelse...

Rename haveAges -> givenAges, needAges -> neededAges in fillAges; Fix ifelse problem (vectorized, so we need to use if instead to return a vector); add missing age parameter to transitionProbabilities
parent 037ef402
......@@ -21,8 +21,8 @@ setMethod("deathProbabilities", "mortalityTable.period",
function(object, ..., ages = NULL, YOB = 1975) {
fillAges(
object@modification(object@deathProbs * (1 + object@loading)),
haveAges = ages(object),
needAges = ages
givenAges = ages(object),
neededAges = ages
);
})
......@@ -37,7 +37,7 @@ setMethod("deathProbabilities","mortalityTable.ageShift",
} else if (shift < 0) {
qx = c(rep(0, -shift), qx[1:(length(qx) - (-shift))])
}
fillAges(object@modification(qx), haveAges = ages(object), needAges = ages)
fillAges(object@modification(qx), givenAges = ages(object), neededAges = ages)
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
......@@ -46,9 +46,9 @@ setMethod("deathProbabilities","mortalityTable.trendProjection",
function(object, ..., ages = NULL, YOB = 1975) {
qx = object@deathProbs * (1 + object@loading);
if (is.null(object@trend2) || length(object@trend2) <= 1) {
haveAges = object@ages;
givenAges = object@ages;
damping = sapply(
haveAges,
givenAges,
function(age) { object@dampingFunction(YOB + age - object@baseYear) }
);
finalqx = exp(-object@trend * damping) * qx;
......@@ -61,7 +61,7 @@ setMethod("deathProbabilities","mortalityTable.trendProjection",
-(object@trend * (1 - weights) + object@trend2 * weights) *
(YOB + 0:(length(qx) - 1) - object@baseYear))
}
fillAges(object@modification(finalqx), givenAges = haveAges, neededAges = ages)
fillAges(object@modification(finalqx), givenAges = givenAges, neededAges = ages)
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
......@@ -72,8 +72,8 @@ setMethod("deathProbabilities","mortalityTable.improvementFactors",
impr = calculateImprovements(object, ..., YOB = YOB)
fillAges(
object@modification(impr * qx),
haveAges = ages(object),
needAges = ages)
givenAges = ages(object),
neededAges = ages)
})
#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
......
......@@ -6,12 +6,13 @@
#' @param neededAges desired age range for output
#'
#' @export fillAges
fillAges = function(probs = c(), haveAges = c(), neededAges = NULL) {
fillAges = function(probs = c(), givenAges = c(), neededAges = NULL, fill = NA_real_) {
if (!is.null(neededAges)) {
# initialize result with NA, then fill in all known ages from probs
result = rep(NA_real_, length(neededAges))
providedAges = intersect(neededAges, haveAges)
result[match(providedAges, neededAges)] = probs[match(providedAges, haveAges)]
result = rep(fill, length(neededAges))
providedAges = intersect(neededAges, givenAges)
result[match(providedAges, neededAges)] = probs[match(providedAges, givenAges)]
result
} else {
probs
}
......
......@@ -131,11 +131,11 @@ setMethod("transitionProbabilities", "pensionTable",
invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
if (!missing(Period) && !is.null(Period)) {
return(periodTransitionProbabilities(
object, ..., Period = Period, retirement = retirement,
object, ..., ages = ages, Period = Period, retirement = retirement,
invalids.retire = invalids.retire,
as.data.frame = as.data.frame))
}
x = ifelse(is.null(ages), ages(object@qx), ages);
x = if (is.null(ages)) ages(object@qx) else ages;
# TODO: Make sure all sub-tables have the same age range!
q = deathProbabilities(object@qx, ..., ages = ages, YOB = YOB);
i = deathProbabilities(object@ix, ..., ages = ages, YOB = YOB);
......@@ -219,8 +219,8 @@ setGeneric("periodTransitionProbabilities", function(object, ...) standardGeneri
#' @describeIn periodTransitionProbabilities Return all transition probabilities of the pension table for the period Period
setMethod("periodTransitionProbabilities", "pensionTable",
function(object, Period = 2017, ..., OverallMortality = FALSE, retirement = NULL, invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
x = ifelse(is.null(ages), ages(object@qx), ages);
function(object, Period = 2017, ..., ages = NULL, OverallMortality = FALSE, retirement = NULL, invalids.retire = object@invalids.retire, as.data.frame = TRUE) {
x = if (is.null(ages)) ages(object@qx) else ages;
q = periodDeathProbabilities(object@qx, ..., ages = ages, Period = Period);
i = periodDeathProbabilities(object@ix, ..., ages = ages, Period = Period);
qi = periodDeathProbabilities(object@qix, ..., ages = ages, Period = Period);
......@@ -272,3 +272,4 @@ avoe08p.period = periodTransitionProbabilities(AVOe2008P.male, Period = 2007, as
pensionTables.list(package = "MortalityTablesPrivate")
pensionTables.load("Austria_AVOe1999P")
}
......@@ -15,7 +15,10 @@ setGeneric("periodDeathProbabilities", function(object, ..., ages = NULL, Period
#' of the life table for a given observation year
setMethod("periodDeathProbabilities", "mortalityTable.period",
function(object, ..., ages = NULL, Period = 1975) {
object@modification(object@deathProbs * (1 + object@loading));
fillAges(
object@modification(object@deathProbs * (1 + object@loading)),
givenAges = ages(object),
neededAges = ages)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
......@@ -29,8 +32,8 @@ setMethod("periodDeathProbabilities", "mortalityTable.ageShift",
# if (shift.index) {}
fillAges(
object@modification(qx),
haveAges = ages(object),
needAges = ages)
givenAges = ages(object),
neededAges = ages)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
......@@ -51,8 +54,8 @@ setMethod("periodDeathProbabilities", "mortalityTable.trendProjection",
}
fillAges(
object@modification(finalqx),
haveAges = ages(object),
needAges = ages)
givenAges = ages(object),
neededAges = ages)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
......@@ -63,8 +66,8 @@ setMethod("periodDeathProbabilities", "mortalityTable.improvementFactors",
impr = calculateImprovements(object, ..., Period = Period)
fillAges(
object@modification(qx * impr),
haveAges = ages(object),
needAges = ages)
givenAges = ages(object),
neededAges = ages)
})
#' @describeIn periodDeathProbabilities Return the (period) death probabilities
......
......@@ -4,14 +4,15 @@
\alias{fillAges}
\title{Fill the given probabilities with NA to match the desired age range.}
\usage{
fillAges(probs = c(), haveAges = c(), neededAges = NULL)
fillAges(probs = c(), givenAges = c(), neededAges = NULL,
fill = NA_real_)
}
\arguments{
\item{probs}{Numeric vector}
\item{haveAges}{ages assigned to the given vector}
\item{neededAges}{desired age range for output}
\item{haveAges}{ages assigned to the given vector}
}
\description{
Fill the given probabilities with NA to match the desired age range.
......
......@@ -9,7 +9,7 @@
periodTransitionProbabilities(object, ...)
\S4method{periodTransitionProbabilities}{pensionTable}(object, Period = 2017,
..., OverallMortality = FALSE, retirement = NULL,
..., ages = NULL, OverallMortality = FALSE, retirement = NULL,
invalids.retire = object@invalids.retire, as.data.frame = TRUE)
}
\arguments{
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment