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