Split code over multiple files (one per class/function), fix documentation

.Rbuildignore

 ^.*\.Rproj$
 ^\.Rproj\.user$
+ValuationTables.RData
+data.saved

DESCRIPTION

@@ -9,7 +9,6 @@ Maintainer: Reinhold Kainhofer <reinhold@kainhofer.com>
 Depends:
     ggplot2,
     methods,
-    openxlsx,
     scales,
     utils
 Suggests:
@@ -21,3 +20,28 @@ Description: This package provides classes to implement cohort life tables
     merged life tables.
 License: GPL (>= 2)
 RoxygenNote: 5.0.1
+Collate:
+    'ValuationTables.R'
+    'valuationTable.R'
+    'valuationTable.period.R'
+    'valuationTable.ageShift.R'
+    'ageShift.R'
+    'valuationTable.observed.R'
+    'valuationTable.joined.R'
+    'valuationTable.mixed.R'
+    'ages.R'
+    'baseTable.R'
+    'baseYear.R'
+    'valuationTable.improvementFactors.R'
+    'valuationTable.trendProjection.R'
+    'deathProbabilities.R'
+    'getCohortTable.R'
+    'getOmega.R'
+    'getPeriodTable.R'
+    'lifeTable.R'
+    'makeQxDataFrame.R'
+    'periodDeathProbabilities.R'
+    'plotValuationTableComparisons.R'
+    'plotValuationTables.R'
+    'setLoading.R'
+    'undampenTrend.R'

NAMESPACE

 # Generated by roxygen2: do not edit by hand
 
 export(makeQxDataFrame)
+export(plotValuationTableComparisons)
 export(plotValuationTables)
 export(valuationTable)
-export(valuationTable_ageShift)
-export(valuationTable_improvementFactors)
-export(valuationTable_joined)
-export(valuationTable_mixed)
-export(valuationTable_observed)
-export(valuationTable_period)
-export(valuationTable_trendProjection)
+export(valuationTable.ageShift)
+export(valuationTable.improvementFactors)
+export(valuationTable.joined)
+export(valuationTable.mixed)
+export(valuationTable.observed)
+export(valuationTable.period)
+export(valuationTable.trendProjection)
 exportClasses(valuationTable)
-exportClasses(valuationTable_ageShift)
-exportClasses(valuationTable_improvementFactors)
-exportClasses(valuationTable_joined)
-exportClasses(valuationTable_mixed)
-exportClasses(valuationTable_observed)
-exportClasses(valuationTable_period)
-exportClasses(valuationTable_trendProjection)
+exportClasses(valuationTable.ageShift)
+exportClasses(valuationTable.improvementFactors)
+exportClasses(valuationTable.joined)
+exportClasses(valuationTable.mixed)
+exportClasses(valuationTable.observed)
+exportClasses(valuationTable.period)
+exportClasses(valuationTable.trendProjection)
 exportMethods(ageShift)
 exportMethods(ages)
 exportMethods(baseTable)
@@ -28,7 +29,8 @@ exportMethods(getOmega)
 exportMethods(getPeriodTable)
 exportMethods(lifeTable)
 exportMethods(periodDeathProbabilities)
+exportMethods(setLoading)
 exportMethods(undampenTrend)
 import(ggplot2)
 import(methods)
-import(openxlsx)
+import(scales)

R/ageShift.R

+#' @include valuationTable.ageShift.R
+NULL
+
+#' Return the age shift of the age-shifted life table given the birth year
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param ... Other parameters (currently unused)
+#' @param YOB The birth year for which the age shift should be determined.
+#'
+#' @exportMethod ageShift
+setGeneric("ageShift", function(object, YOB=1975, ...) standardGeneric("ageShift"));
+
+#' @describeIn ageShift Return the age shift of the age-shifted life table
+#'                      given the birth year
+setMethod("ageShift",
+          "valuationTable.ageShift",
+          function(object, YOB, ...) {
+              shift = object@ageShifts[toString(YOB),];
+              if (is.na(shift)) {
+                  # The row names (YOB) are unfortunately strings, so we cannot easily query them.
+                  # TODO: Change the data.frame to use a real column for the YOB
+                  firstYOB = utils::head(rownames(object@ageShifts), n = 1);
+                  lastYOB = utils::tail(rownames(object@ageShifts), n = 1);
+                  if (YOB < as.integer(firstYOB)) {
+                      shift = object@ageShifts[firstYOB,];
+                  } else if (YOB > as.integer(lastYOB)) {
+                      shift = object@ageShifts[lastYOB,];
+                  }
+              }
+              shift
+          })
+

R/ages.R

+#' @include valuationTable.period.R valuationTable.mixed.R valuationTable.joined.R valuationTable.observed.R
+NULL
+
+#' Return the defined ages of the life table
+#'
+#' @param object A life table object (instance of a \code{valuationTable} class)
+#' @param ... Currently unused
+#'
+#' @exportMethod ages
+setGeneric("ages", function(object, ...) standardGeneric("ages"));
+
+#' @describeIn ages Return the defined ages of the life table
+setMethod("ages", "valuationTable.period",
+          function (object, ...) {
+              object@ages;
+          })
+
+#' @describeIn ages Return the defined ages of the life table
+setMethod("ages", "valuationTable.mixed",
+          function (object, ...) {
+              ages(object@table1);
+          })
+
+#' @describeIn ages Return the defined ages of the life table
+setMethod("ages", "valuationTable.joined",
+          function (object, ...) {
+              ages(object@table1);
+          })
+
+#' @describeIn ages Return the defined ages of the life table
+setMethod("ages", "valuationTable.observed",
+          function (object, ...) {
+              object@ages;
+          })
+

R/baseTable.R

+#' @include valuationTable.R valuationTable.period.R
+NULL
+
+#' Return the base table of the life table
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param ... Other parameters (currently unused)
+#'
+#' @exportMethod baseTable
+setGeneric("baseTable", function(object, ...) standardGeneric("baseTable"));
+
+#' @describeIn baseTable Return the base table of the life table
+setMethod("baseTable", "valuationTable",
+          function (object,  ...) {
+              c()
+          })
+
+#' @describeIn baseTable Return the base table of the life table
+setMethod("baseTable", "valuationTable.period",
+          function (object,  ...) {
+              object@deathProbs
+          })

R/baseYear.R

+#' @include valuationTable.R valuationTable.mixed.R
+NULL
+
+#' Return the base year of the life table
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param ... Other parameters (currently unused)
+#'
+#' @exportMethod baseYear
+setGeneric("baseYear", function(object, ...) standardGeneric("baseYear"));
+
+#' @describeIn baseYear Return the base year of the life table
+setMethod("baseYear", "valuationTable",
+          function (object,  ...) {
+              object@baseYear
+          })
+
+#' @describeIn baseYear Return the base year of the life table
+setMethod("baseYear", "valuationTable.mixed",
+          function (object,  ...) {
+              baseYear(object@table1)
+          })

R/deathProbabilities.R

+#' @include valuationTable.R valuationTable.period.R valuationTable.ageShift.R valuationTable.trendProjection.R valuationTable.improvementFactors.R valuationTable.mixed.R
+NULL
+
+#' Return the (cohort) death probabilities of the life table given the birth year (if needed)
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param ... Other parameters (currently unused)
+#' @param YOB The birth year for which the death probabilities should be calculated
+#'
+#' @exportMethod deathProbabilities
+setGeneric("deathProbabilities", function(object, ..., YOB = 1975) standardGeneric("deathProbabilities"));
+
+#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
+#'                                life table given the birth year (if needed)
+setMethod("deathProbabilities", "valuationTable.period",
+          function(object, ..., YOB = 1975) {
+              object@modification(object@deathProbs * (1 + object@loading));
+          })
+
+#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
+#'                                life table given the birth year (if needed)
+setMethod("deathProbabilities","valuationTable.ageShift",
+          function (object,  ..., YOB = 1975) {
+              qx=object@deathProbs * (1 + object@loading);
+              shift = ageShift(object, YOB);
+              if (shift>0) {
+                  qx = c(qx[(shift+1):length(qx)], rep(qx[length(qx)], shift));
+              } else if (shift<0) {
+                  qx = c(rep(0, -shift), qx[1:(length(qx)-(-shift))])
+              }
+              object@modification(qx)
+          })
+
+#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
+#'                                life table given the birth year (if needed)
+setMethod("deathProbabilities","valuationTable.trendProjection",
+          function (object,  ..., YOB = 1975) {
+              qx=object@deathProbs * (1 + object@loading);
+              if (is.null(object@trend2) || length(object@trend2) <= 1) {
+                  ages = 0:(length(qx)-1);
+                  damping = sapply(
+                      ages,
+                      function (age) { object@dampingFunction(YOB + age - object@baseYear) }
+                  );
+                  finalqx = exp(-object@trend * damping) * qx;
+              } else {
+                  # dampingFunction interpolates between the two trends:
+                  weights = sapply(YOB + 0:(length(qx)-1), object@dampingFunction);
+                  finalqx = qx * exp(
+                      -(object@trend * (1 - weights) + object@trend2 * weights) *
+                          (YOB + 0:(length(qx)-1) - object@baseYear))
+              }
+              object@modification(finalqx)
+          })
+
+#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
+#'                                life table given the birth year (if needed)
+setMethod("deathProbabilities","valuationTable.improvementFactors",
+          function (object,  ..., YOB = 1975) {
+              qx = object@deathProbs * (1 + object@loading);
+              finalqx = (1 - object@improvement)^(YOB + 0:(length(qx) - 1) - object@baseYear) * qx;
+              object@modification(finalqx)
+          })
+
+#' @describeIn deathProbabilities Return the (cohort) death probabilities of the
+#'                                life table given the birth year (if needed)
+setMethod("deathProbabilities","valuationTable.mixed",
+          function (object,  ..., YOB = 1975) {
+              qx1 = deathProbabilities(object@table1, ..., YOB) * (1 + object@loading);
+              qx2 = deathProbabilities(object@table2, ..., YOB) * (1 + object@loading);
+              mixedqx = (object@weight1 * qx1 + object@weight2 * qx2)/(object@weight1 + object@weight2);
+              object@modification(mixedqx)
+          })
+

R/getCohortTable.R

+#' @include valuationTable.R
+NULL
+
+#' Return the cohort life table as a \code{valuationTable.period} object
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param YOB The birth year for which the life table should be calculated
+#' @param ... Other parameters (currently unused)
+#'
+#' @exportMethod getCohortTable
+setGeneric("getCohortTable", function(object, YOB, ...) standardGeneric("getCohortTable"));
+
+#' @describeIn getCohortTable Return the cohort life table as a
+#'             \code{valuationTable.period} object
+setMethod("getCohortTable","valuationTable",
+          function (object, YOB, ...) {
+              valuationTable.period(
+                  name = paste(object@name, ", YOB ", YOB),
+                  baseYear = YOB,
+                  ages = ages(object),
+                  deathProbs = deathProbabilities(object, YOB = YOB)
+              );
+          })

R/getOmega.R

+#' @include valuationTable.R valuationTable.period.R valuationTable.mixed.R valuationTable.joined.R valuationTable.observed.R
+NULL
+
+#' Return the maximum age of the life table
+#'
+#' @param object A life table object (instance of a \code{valuationTable} class)
+#'
+#' @exportMethod getOmega
+setGeneric("getOmega", function(object) standardGeneric("getOmega"));
+
+#' @describeIn getOmega Return the maximum age of the period life table
+setMethod("getOmega", "valuationTable.period",
+          function (object) {
+              max(object@ages, na.rm = TRUE);
+          })
+
+#' @describeIn getOmega Return the maximum age of the mixed life table
+setMethod("getOmega", "valuationTable.mixed",
+          function (object) {
+              getOmega(object@table1);
+          })
+
+#' @describeIn getOmega Return the maximum age of the joined life table
+setMethod("getOmega", "valuationTable.joined",
+          function (object) {
+              getOmega(object@table1);
+          })
+
+#' @describeIn getOmega Return the maximum age of the joined life table
+setMethod("getOmega", "valuationTable.observed",
+          function (object) {
+              max(object@ages, na.rm = TRUE);
+          })

R/getPeriodTable.R

+#' @include valuationTable.R
+NULL
+
+#' Return the period life table as a \code{valuationTable.period} object
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param Period The observation year, for which the death probabilities should
+#'        be determined
+#' @param ... Other parameters (currently unused)
+#'
+#' @exportMethod getPeriodTable
+setGeneric("getPeriodTable",
+           function(object, Period, ...)
+               standardGeneric("getPeriodTable")
+);
+
+#' @describeIn getPeriodTable Return the period life table as a
+#'             \code{valuationTable.period} object
+setMethod("getPeriodTable","valuationTable",
+          function (object, Period, ...) {
+              valuationTable.period(
+                  name = paste(object@name, ", Period ", Period),
+                  baseYear = Period,
+                  ages = ages(object),
+                  deathProbs = periodDeathProbabilities(object, Period = Period)
+              )
+          })

R/lifeTable.R

+#' @include valuationTable.R
+NULL
+
+#' Return the lifetable object (package lifecontingencies) for the cohort life table
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param ... Parameters to be passed to the \code{deathProbabilities} method
+#'            of the life table
+#'
+#' @exportMethod lifeTable
+setGeneric("lifeTable", function(object, ...) standardGeneric("lifeTable"));
+
+#' @describeIn lifeTable Return the lifetable object (package lifecontingencies)
+#'             for the cohort life table
+setMethod("lifeTable","valuationTable",
+          function (object,  ...) {
+              qx = deathProbabilities(object, ...);
+              if (qx[[length(qx)]] != 1) {
+                  qx = c(qx, 1, 1);
+              }
+              lifecontingencies::probs2lifetable(qx, type = "qx")
+          })

R/makeQxDataFrame.R

+#' Converts one or multiple life table objects to a data frame that can be
+#' plotted by \code{plotValuationTables} or \code{plotValuationTableComparisons}
+#'
+#' It is not required to call this function manually, \code{plotValuationTables}
+#' will automatically do it if object derived from class \code{valuationTable}
+#' are passed.
+#'
+#' @param ... Life tables (objects of classes derived from \code{valuationTable})
+#' @param YOB desired year of birth to be plotted as cohort life table (default: 1972)
+#' @param Period desired observation year to be plotted (default: NA). If both
+#'        \code{YOB} and \code{Period} are given, a period comparison is generated.
+#' @param reference Reference life table, used to show relative death
+#'        probabilities (i.e. the q_x for all ages are divided by the
+#'        corresponding probabilities of the reference table)
+#'
+#' @export
+makeQxDataFrame = function(..., YOB = 1972, Period = NA, reference = NULL) {
+    # If reference is given, normalize all probabilities by that table!
+    data = list(...);
+    names(data) = lapply(data, function(t) t@name);
+    reference_ages = NULL;
+
+    if (missing(Period)) {
+        if (!missing(reference)) {
+            reference_ages = ages(reference);
+            reference = deathProbabilities(reference, YOB = YOB);
+        }
+        data = lapply(data, function(t) {
+            normalize_deathProbabilities(
+                cbind(x = ages(t), y = deathProbabilities(t, YOB = YOB)),
+                reference = reference,
+                referenceAges = reference_ages)
+        });
+    } else {
+        if (!missing(reference)) {
+            reference_ages = ages(reference);
+            reference = periodDeathProbabilities(reference, Period = Period);
+        }
+        data = lapply(data, function(t) {
+            normalize_deathProbabilities(
+                cbind(x = ages(t), y = periodDeathProbabilities(t, Period = Period)),
+                reference = reference,
+                referenceAges = reference_ages)
+        });
+    }
+
+    list.names = names(data)
+    lns <- sapply(data, nrow)
+    data <- as.data.frame(do.call("rbind", data))
+    data$group <- rep(list.names, lns)
+    data
+}
+
+normalize_deathProbabilities = function (data, reference = NULL, referenceAges = NULL) {
+    if (missing(reference) || missing(referenceAges) || is.null(reference) || is.null(referenceAges)) {
+        return(data);
+    }
+    # Find which ages exist in both and obtain those indices from the data and the reference list:
+    useages = intersect(data[,"x"], referenceAges)
+    dataindices = match(useages, data[,"x"])
+    refindices = match(useages, referenceAges)
+
+    # Find which ages in data do NOT exist in the reference ages (and are thus NOT normalized at all)
+    # Print a warning!
+    missingrefs = setdiff(data[,"x"], referenceAges)
+    if (length(missingrefs)>0) {
+        warning("Reference mortality table does not contain ages ",
+                missingrefs,
+                " required for normalization. These ages will not be normalized!")
+    }
+
+    # Now divide the data by the corresponding entries from the reference list
+    data[dataindices, "y"] = data[dataindices, "y"] / reference[refindices]
+    data
+}
+

R/periodDeathProbabilities.R

+#' @include valuationTable.R valuationTable.period.R valuationTable.trendProjection.R valuationTable.improvementFactors.R valuationTable.mixed.R
+NULL
+
+#' Return the (period) death probabilities of the life table for a given
+#' observation year
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#' @param ... Other parameters (currently unused)
+#' @param Period  The observation year for which the period death probabilities should be determined
+#'
+#' @exportMethod periodDeathProbabilities
+setGeneric("periodDeathProbabilities", function(object, ..., Period = 1975) standardGeneric("periodDeathProbabilities"));
+
+#' @describeIn periodDeathProbabilities Return the (period) death probabilities
+#'             of the life table for a given observation year
+setMethod("periodDeathProbabilities", "valuationTable.period",
+          function(object, ..., Period = 1975) {
+              object@modification(object@deathProbs * (1 + object@loading));
+          })
+
+#' @describeIn periodDeathProbabilities Return the (period) death probabilities
+#'             of the life table for a given observation year
+setMethod("periodDeathProbabilities", "valuationTable.ageShift",
+          function (object,  ..., Period = 1975) {
+              # TODO
+              qx = object@deathProbs * (1 + object@loading);
+              # TODO!!!
+              # shift.index = match(YOB, object@shifts, 0);
+              # if (shift.index) {}
+              object@modification(qx)
+          })
+
+#' @describeIn periodDeathProbabilities Return the (period) death probabilities
+#'             of the life table for a given observation year
+setMethod("periodDeathProbabilities", "valuationTable.trendProjection",
+          function (object,  ..., Period = 1975) {
+              qx = object@deathProbs * (1 + object@loading);
+              if (is.null(object@trend2) || length(object@trend2) <= 1) {
+                  # ages = 0:(length(qx)-1);
+                  damping = object@dampingFunction(Period - object@baseYear);
+                  finalqx = exp(-object@trend * damping) * qx;
+              } else {
+                  # TODO!!!
+                  # dampingFunction interpolates between the two trends:
+                  # weights = sapply(YOB+0:(length(qx)-1), object@dampingFunction);
+                  # finalqx = qx*exp(-(object@trend*(1-weights) + object@trend2*(weights))*(YOB+0:(length(qx)-1)-object@baseYear));
+              }
+              object@modification(finalqx)
+          })
+
+#' @describeIn periodDeathProbabilities Return the (period) death probabilities
+#'             of the life table for a given observation year
+setMethod("periodDeathProbabilities", "valuationTable.improvementFactors",
+          function (object, ..., Period = 1975) {
+              qx = object@deathProbs * (1 + object@loading);
+              finalqx = (1 - object@improvement) ^ (Period - object@baseYear) * qx;
+              object@modification(finalqx)
+          })
+
+#' @describeIn periodDeathProbabilities Return the (period) death probabilities
+#'             of the life table for a given observation year
+setMethod("periodDeathProbabilities", "valuationTable.mixed",
+          function (object,  ..., Period = 1975) {
+              qx1 = periodDeathProbabilities(object@table1, ..., Period = Period) * (1 + object@loading);
+              qx2 = periodDeathProbabilities(object@table2, ..., Period = Period) * (1 + object@loading);
+              mixedqx = (object@weight1 * qx1 + object@weight2 * qx2) / (object@weight1 + object@weight2);
+              object@modification(mixedqx)
+          })
+

R/plotValuationTableComparisons.R

+#' Plot multiple valuation tables (life tables) in one plot, relative to a given reference table
+#'
+#' \code{plotValuationTableComparisons} prints multiple life tables (objects of child classes of \code{valuationTable}) in one plot and scales each by the given reference table, so that the relative mortality can be easily seen. A legend is added showing the names of the tables.
+#'
+#' @inheritParams plotValuationTables
+#' @param reference The reference table that determines the 100\% values. If not given, the first argument of \code{data} is used as reference table.
+#'
+#' @import scales
+#' @export
+plotValuationTableComparisons = function(
+    data, ...,
+    xlim = NULL, ylim = NULL,
+    xlab = NULL, ylab = NULL,
+    title = "",
+    legend.position = c(0.9,0.1), legend.key.width = unit(25, "mm"),
+    reference = NULL)
+{
+    # If no reference mortality table is given, use the first table (data if its a valuation table)
+    if (missing(reference)) {
+        if (inherits(data, "valuationTable")) {
+            reference = data;
+        } else {
+            reference = NULL;# TODO;
+        }
+    }
+    if (!is.data.frame(data)) {
+        data = makeQxDataFrame(data, ..., reference=reference);
+    }
+    if (missing(xlab)) xlab = "Alter";
+    if (missing(ylab)) {
+        ylab = substitute(paste("Sterbewahrscheinlichkeit  ", q[x],
+                                " relativ zu ", refname),
+                          env=list(refname=reference@name));
+    }
+
+    pl = ggplot(data, aes(x = x, y = y, colour = data$group)) +
+        theme_bw() +
+        theme(
+            plot.title = element_text(size=18, face="bold"),
+            legend.title = element_text(size=14, face="bold.italic"),
+            # legend in bottom right corner of the plot
+            legend.justification=c(1,0), legend.position=legend.position,
+            # No box around legend entries
+            legend.key = element_blank(),
+            legend.key.width = legend.key.width,
+            legend.background = element_rect(colour="gray50", linetype="solid")
+        ) +
+        geom_line() +
+        coord_cartesian(xlim=xlim, ylim=ylim) +
+        scale_y_continuous(
+            name=ylab,
+            labels=percent
+            #            # breaks = scales::trans_breaks('log10', function(x) 10^x),
+            #            # labels = scales::trans_format('log10', scales::math_format(10^.x))
+            #            #minor_breaks = log(c(sapply(x, function(x) seq(0, x, x/10))), 10)
+        ) +
+        scale_x_continuous(
+            name = xlab,
+            #breaks = function (limits) scales::trans_breaks('', function(x) 10^x),
+            breaks = function (limits) seq(max(min(limits),0),max(limits),5),
+            minor_breaks = function (limits) seq(max(round(min(limits)),0),round(max(limits)),1)#,
+            #labels = scales::trans_format('log10', scales::math_format(10^.x))
+
+        ) +
+        # annotation_logticks(sides="lr") +
+        xlab("Alter") + labs(colour="Sterbetafel");
+    if (title != "") {
+        pl = pl + ggtitle(title);
+    }
+    pl
+}

R/plotValuationTables.R

-#' @export
-#' If reference is given, normalize all probabilities by that table!
-makeQxDataFrame = function(..., YOB=1972, Period=NA, reference=NULL) {
-    data=list(...);
-    names(data) = lapply(data, function(t) t@name);
-    reference_ages = NULL;
-
-    if (missing(Period)) {
-        cat("Year of birth: ", YOB, "\n");
-        if (!missing(reference)) {
-            reference_ages = ages(reference);
-            reference = deathProbabilities(reference, YOB=YOB);
-        }
-        data = lapply(data, function(t) {
-            str(deathProbabilities(t, YOB=YOB));
-            normalize_deathProbabilities(
-                cbind(x=ages(t), y=deathProbabilities(t, YOB=YOB)),
-                reference = reference,
-                referenceAges = reference_ages)
-            });
-    } else {
-        cat("Period: ", Period,"\n");
-        if (!missing(reference)) {
-            reference_ages = ages(reference);
-            reference = periodDeathProbabilities(reference, Period=Period);
-        }
-        data = lapply(data, function(t) {
-            str(deathProbabilities(t, YOB=YOB));
-            normalize_deathProbabilities(
-                cbind(x=ages(t), y=periodDeathProbabilities(t, Period=Period)),
-                reference = reference,
-                referenceAges = reference_ages)
-        });
-    }
-
-    list.names = names(data)
-    lns <- sapply(data, nrow)
-    data <- as.data.frame(do.call("rbind", data))
-    data$group <- rep(list.names, lns)
-    data
-}
-
-normalize_deathProbabilities = function (data, reference=NULL, referenceAges=NULL) {
-    if (missing(reference) || missing(referenceAges) || is.null(reference) || is.null(referenceAges)) {
-        return(data);
-    }
-# browser();
-    # Find which ages exist in both and obtain those indices from the data and the reference list:
-    useages = intersect(data[,"x"], referenceAges)
-    dataindices = match(useages, data[,"x"])
-    refindices = match(useages, referenceAges)
-
-    # Find which ages in data do NOT exist in the reference ages (and are thus NOT normalized at all)
-    # Print a warning!
-    missingrefs = setdiff(data[,"x"], referenceAges)
-    if (length(missingrefs)>0) {
-        warning("Reference mortality table does not contain ages ",
-                missingrefs,
-                " required for normalization. These ages will not be normalized!")
-    }
-
-    # Now divide the data by the corresponding entries from the reference list
-    data[dataindices, "y"] = data[dataindices, "y"] / reference[refindices]
-    data
-}
-
 #' Plot multiple valuation tables (life tables) in one plot
 #'
 #' \code{plotValuationTables} prints multiple life tables (objects of child classes of \code{valuationTable}) in one log-linear plot, with a legend showing the names of the tables.
 #'
 #' @param data First life table to be plotted. Either a \code{data.frame} generated by \code{makeQxDataFrame} or a \code{valuationTable} object
 #' @param ... Additional life tables to be plotted (if \code{data} is a \code{valuationTable} object)
+#' @param xlim X-axis limitatation (as a two-element vector)
+#' @param ylim Y-axis limitatation (as a two-element vector)
+#' @param xlab X-axis label (default: "Alter")
+#' @param ylab Y-axis label (default: "Sterbewahrscheinlichkeit q_x relativ zu ....")
 #' @param title The plot title
 #' @param legend.position The position of the legend (default is \code{c(0.9,0.1)})
 #' @param legend.key.width The keywith of the lines in the  legend (default is \code{unit(25,"mm")})
 #'
+#' @import scales
 #' @export
-plotValuationTables = function(data, ..., xlim=NULL, ylim=NULL, title = "", legend.position=c(0.9,0.1), legend.key.width = unit(25, "mm")) {
+plotValuationTables = function(data, ..., xlim=NULL, ylim=NULL, xlab=NULL, ylab=NULL, title = "", legend.position=c(0.9,0.1), legend.key.width = unit(25, "mm")) {
   if (!is.data.frame(data)) {
     data = makeQxDataFrame(data, ...);
   }
+    if (missing(xlab)) xlab="Alter";
+    if (missing(ylab)) ylab=expression(paste("Sterbewahrscheinlichkeit ", q[x]));
 
   pl = ggplot(data, aes(x = x, y = y, colour = data$group)) +
     theme_bw() +
@@ -94,16 +35,16 @@ plotValuationTables = function(data, ..., xlim=NULL, ylim=NULL, title = "", lege
     ) +
     geom_line() +
     scale_y_log10(
-      name=expression(paste("Sterbewahrscheinlichkeit  ", q[x])),
+      name = ylab,
       breaks = scales::trans_breaks('log10', function(x) 10^x),
       labels = scales::trans_format('log10', scales::math_format(10^.x))
       #minor_breaks = log(c(sapply(x, function(x) seq(0, x, x/10))), 10)
     ) +
     scale_x_continuous(
-      name="Alter",
+      name = xlab,
       #breaks = function (limits) scales::trans_breaks('', function(x) 10^x),
       breaks = function (limits) seq(max(min(limits),0),max(limits),5),
-      minor_breaks = function (limits) seq(max(round(min(limits)),0),round(max(limits)),1),
+      minor_breaks = function (limits) seq(max(round(min(limits)),0),round(max(limits)),1)
       #labels = scales::trans_format('log10', scales::math_format(10^.x))
 
     ) +
@@ -116,60 +57,6 @@ plotValuationTables = function(data, ..., xlim=NULL, ylim=NULL, title = "", lege
   pl
 }
 
-plotValuationTableComparisons = function(data, ..., xlim=NULL, ylim=NULL, title = "", legend.position=c(0.9,0.1), legend.key.width = unit(25, "mm"), reference=NULL) {
-    # If no reference mortality table is given, use the first table (data if its a valuation table)
-    if (missing(reference)) {
-        if (inherits(data, "valuationTable")) {
-            reference = data;
-        } else {
-            reference = NULL;# TODO;
-        }
-    }
-    refname=reference@name;
-    yAxisLabel = expression(paste("Sterbewahrscheinlichkeit  ", q[x], " relativ zu ", refname));
-yAxisLabel[1][3]="asfd"
-yAxisLabel
-    if (!is.data.frame(data)) {
-        data = makeQxDataFrame(data, ..., reference=reference);
-    }
-
-    pl = ggplot(data, aes(x = x, y = y, colour = data$group)) +
-        theme_bw() +
-        theme(
-            plot.title = element_text(size=18, face="bold"),
-            legend.title = element_text(size=14, face="bold.italic"),
-            # legend in bottom right corner of the plot
-            legend.justification=c(1,0), legend.position=legend.position,
-            # No box around legend entries
-            legend.key = element_blank(),
-            legend.key.width = legend.key.width,
-            legend.background = element_rect(colour="gray50", linetype="solid")
-        ) +
-        geom_line() +
-        coord_cartesian(xlim=xlim, ylim=ylim) +
-       scale_y_continuous(
-#            #name=substitute(paste("Sterbewahrscheinlichkeit  ", q[x], " relativ zu ", refname), env=list(refname=refname))#,
-           name=substitute(refname^3, env=list(refname=refname)),
-           labels=percent
-#            # breaks = scales::trans_breaks('log10', function(x) 10^x),
-#            # labels = scales::trans_format('log10', scales::math_format(10^.x))
-#            #minor_breaks = log(c(sapply(x, function(x) seq(0, x, x/10))), 10)
-       ) +
-        scale_x_continuous(
-            name="Alter",
-            #breaks = function (limits) scales::trans_breaks('', function(x) 10^x),
-            breaks = function (limits) seq(max(min(limits),0),max(limits),5),
-            minor_breaks = function (limits) seq(max(round(min(limits)),0),round(max(limits)),1),
-            #labels = scales::trans_format('log10', scales::math_format(10^.x))
-
-        ) +
-        # annotation_logticks(sides="lr") +
-        xlab("Alter") + labs(colour="Sterbetafel");
-    if (title != "") {
-        pl = pl + ggtitle(title);
-    }
-    pl
-}
 
 #
 # plotValuationTables(mort.AT.census.1869.male, mort.AT.census.1869.female, mort.AT.census.2011.male, mort.AT.census.2011.female, AVOe2005R.male, AVOe2005R.female, YOB=1972,title="Vergleich österreichische Sterbetafeln, YOB=1972 (bei Generationentafeln)")

R/setLoading.R

+#' @include valuationTable.R
+NULL
+
+#' Return a copy of the table with an additional loading added
+#'
+#' @param object A life table object (instance of a \code{valuationTable} class)
+#' @param loading The additional (security) loading to be added to the table.
+#'
+#' @exportMethod setLoading
+setGeneric("setLoading", function(object, loading = 0) standardGeneric("setLoading"));
+
+#' @describeIn setLoading Return the life table with the given loading set
+setMethod("setLoading", "valuationTable",
+          function (object, loading = 0) {
+              object@loading = loading;
+              object
+          })

R/undampenTrend.R

+#' @include valuationTable.trendProjection.R
+NULL
+
+#' Return a \code{valuationTable.trendProjection} object with the trend damping removed.
+#'
+#' @param object The life table object (class inherited from valuationTable)
+#'
+#' @exportMethod undampenTrend
+setGeneric("undampenTrend", function (object) standardGeneric("undampenTrend"));
+
+#' @describeIn undampenTrend Return a \code{valuationTable.trendProjection}
+#'             object with the trend damping removed.
+setMethod("undampenTrend", "valuationTable.trendProjection",
+          function (object) {
+              object@dampingFunction=identity;
+              object
+          })

R/valuationTable.R

+#' Provide life table classes for life insurance purposes
+#'
+#' @import methods
+#' @import ggplot2
+#'
+"_PACKAGE"
+
+
+#' Class valuationTable
+#'
+#' Class \code{valuationTable} is the (virtual) base class for all valuation
+#' tables. It contains the name and some general values applying to all
+#' types of tables, but does not contain any data itself. Use a child class
+#' to create actual valuation tables.
+#'
+#' @slot name     The human-readable name of the valuation table
+#' @slot baseYear The base year of the valuation table (e.g. for tables with trend projection)
+#' @slot modification A function that will be called with the final death probabilities
+#'        to give the user a way to modify the final probabilities
+#' @slot loading  Additional security loading on the resulting table (single numeric
+#'        value, e.g. 0.05 adds 5\% security margin to the probabilities)
+#'
+#' @export valuationTable
+#' @exportClass valuationTable
+valuationTable=setClass(
+    "valuationTable",
+    slots = list(
+        name = "character",
+        baseYear = "numeric",
+        loading = "numeric",
+        modification = "function"
+    ),
+    prototype = list(
+        name = "Actuarial Valuation Table",
+        baseYear = 2000,
+        loading = 0,
+        modification = identity
+    ),
+    contains = "VIRTUAL"
+)