Commit 947298d2 authored by Reinhold Kainhofer's avatar Reinhold Kainhofer

Use the mortalityTable's @data$dim list/data.frame as further dimensions/factors in makeQxDataFrame

parent 09a0d925
......@@ -24,42 +24,45 @@ makeQxDataFrame = function(..., YOB = 1972, Period = NA, reference = NULL) {
data = unlist(list(...));
if (is.null(data)) return(data.frame(x = double(), y = double(), group = character()))
names(data) = lapply(data, function(t) t@name);
reference_ages = NULL;
if (missing(Period)) {
# If reference is given, normalize all probabilities by that table!
if (!missing(reference)) {
if (!missing(reference) && !is.null(reference)) {
reference_ages = ages(reference);
reference = deathProbabilities(reference, YOB = YOB);
}
data = lapply(data, function(t) {
normalize_deathProbabilities(
cbind(x = ages(t), y = `names<-`(deathProbabilities(t, YOB = YOB), NULL)),
if (is.data.frame(t@data$dim) || is.list(t@data$dim)) {
cbind(x = ages(t), y = `names<-`(deathProbabilities(t, YOB = YOB), NULL), group = t@name, as.data.frame(t@data$dim))
} else {
cbind(x = ages(t), y = `names<-`(deathProbabilities(t, YOB = YOB), NULL), group = t@name)
},
reference = reference,
referenceAges = reference_ages)
});
} else {
if (!missing(reference)) {
if (!missing(reference) && !is.null(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)),
ifelse(is.data.frame(t@data$dim) || is.list(t@data$dim),
cbind(x = ages(t), y = `names<-`(periodDeathProbabilities(t, Period = Period), NULL), group = t@name, as.data.frame(t@data$dim)),
cbind(x = ages(t), y = `names<-`(periodDeathProbabilities(t, Period = Period), NULL), group = t@name)
),
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) {
normalize_deathProbabilities = function(data, reference = NULL, referenceAges = NULL) {
if (missing(reference) || missing(referenceAges) || is.null(reference) || is.null(referenceAges)) {
return(data);
}
......@@ -71,7 +74,7 @@ normalize_deathProbabilities = function (data, reference = NULL, 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) {
if (length(missingrefs) > 0) {
warning("Reference mortality table does not contain ages ",
missingrefs,
" required for normalization. These ages will not be normalized!")
......
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