From 5a42978671275e8bdeaf5059e361c900ab34db60 Mon Sep 17 00:00:00 2001 From: Rainer Walke Date: Tue, 8 Oct 2019 14:39:29 +0200 Subject: [PATCH] add two slots for the total sum information stored in the GENESIS data --- NAMESPACE | 2 ++ R/AllGeneric.R | 4 ++++ R/GENESISClasses.R | 41 ++++++++++++++++++++++++++++++----------- tests/Simple1.R | 8 ++++++++ 4 files changed, 44 insertions(+), 11 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 6b19c74..431e76e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,7 +25,9 @@ exportMethods(length) exportMethods(lt1) exportMethods(protocol) exportMethods(rd1) +exportMethods(rd1total) exportMethods(re1) +exportMethods(re1total) exportMethods(region) exportMethods(selectRegion) exportMethods(selectYears) diff --git a/R/AllGeneric.R b/R/AllGeneric.R index ef0e091..b2f3e11 100644 --- a/R/AllGeneric.R +++ b/R/AllGeneric.R @@ -23,11 +23,15 @@ setGeneric("ex1<-", function(object, value) standardGeneric("ex1<-")) setGeneric("rd1", function(object) standardGeneric("rd1")) +setGeneric("rd1total", function(object) standardGeneric("rd1total")) + setGeneric("rd1<-", function(object, value) standardGeneric("rd1<-")) setGeneric("selectRegion", function(object, selectRegion) standardGeneric("selectRegion")) setGeneric("re1", function(object) standardGeneric("re1")) +setGeneric("re1total", function(object) standardGeneric("re1total")) + setGeneric("re1<-", function(object, value) standardGeneric("re1<-")) diff --git a/R/GENESISClasses.R b/R/GENESISClasses.R index eeada71..0ad2983 100644 --- a/R/GENESISClasses.R +++ b/R/GENESISClasses.R @@ -14,6 +14,7 @@ setClass("RD1", header="vector", # file header footer="vector", # file footer rd1="data.table", # exposure table + rd1total="data.table", # exposure table total sums content="character", # content region="character", # region protocol="character" # protocol version @@ -27,6 +28,8 @@ setMethod("header", "RD1", function(object) object@header) setMethod("footer", "RD1", function(object) object@footer) #' @export setMethod("rd1", "RD1", function(object) object@rd1) +#' @export +setMethod("rd1total", "RD1", function(object) object@rd1total) #' @export setMethod("content", "RD1", function(object) object@content) @@ -41,8 +44,8 @@ setReplaceMethod("rd1", "RD1", function(object, value) {object@rd1 <- value; val # constructor #' @export -RegDeath1 <- function(header, footer, rd1, content, region, protocol) - new("RD1", header=header, footer=footer, rd1=rd1, content=content, region=region, protocol=protocol) +RegDeath1 <- function(header, footer, rd1, rd1total, content, region, protocol) + new("RD1", header=header, footer=footer, rd1=rd1, rd1total=rd1total, content=content, region=region, protocol=protocol) # methods #' @export @@ -58,7 +61,8 @@ setMethod("show", "RD1", setMethod("selectYears", "RD1", function(object, selectYears) { Year <- NULL # evoid NOTE .rd1 <- object@rd1[Year %in% selectYears] - return(new("RD1", header=object@header, footer=object@footer, rd1=.rd1, content=object@content, region=object@region, protocol=object@protocol)) + .rd1total <- object@rd1total[Year %in% selectYears] + return(new("RD1", header=object@header, footer=object@footer, rd1=.rd1, rd1total=.rd1total, content=object@content, region=object@region, protocol=object@protocol)) } ) @@ -66,7 +70,8 @@ setMethod("selectYears", "RD1", function(object, selectYears) { setMethod("selectRegion", "RD1", function(object, selectRegion) { Region_Code <- NULL # evoid NOTE .rd1 <- object@rd1[Region_Code %in% selectRegion] - return(new("RD1", header=object@header, footer=object@footer, rd1=.rd1, content=object@content, region=object@region, protocol=object@protocol)) + .rd1total <- object@rd1total[Region_Code %in% selectRegion] + return(new("RD1", header=object@header, footer=object@footer, rd1=.rd1, rd1total=.rd1total, content=object@content, region=object@region, protocol=object@protocol)) } ) @@ -97,6 +102,7 @@ setClass("RE1", header="vector", # file header footer="vector", # file footer re1="data.table", # exposure table + re1total="data.table", # exposure table total sums content="character", # content region="character", # region protocol="character" # protocol version @@ -110,6 +116,8 @@ setMethod("header", "RE1", function(object) object@header) setMethod("footer", "RE1", function(object) object@footer) #' @export setMethod("re1", "RE1", function(object) object@re1) +#' @export +setMethod("re1total", "RE1", function(object) object@re1total) #' @export setMethod("content", "RE1", function(object) object@content) @@ -124,8 +132,8 @@ setReplaceMethod("re1", "RE1", function(object, value) {object@re1 <- value; val # constructor #' @export -RegExp1 <- function(header, footer, re1, content, region, protocol) - new("RE1", header=header, footer, re1=re1, content=content, region=region, protocol=protocol) +RegExp1 <- function(header, footer, re1, re1total, content, region, protocol) + new("RE1", header=header, footer, re1=re1, re1total=re1total, content=content, region=region, protocol=protocol) # methods #' @export @@ -141,7 +149,8 @@ setMethod("show", "RE1", setMethod("selectYears", "RE1", function(object, selectYears) { Year <- NULL # evoid NOTE .re1 <- object@re1[Year %in% selectYears] - return(new("RE1", header=object@header, footer=object@footer, re1=.re1, content=object@content, region=object@region, protocol=object@protocol)) + .re1total <- object@re1total[Year %in% selectYears] + return(new("RE1", header=object@header, footer=object@footer, re1=.re1, re1total=.re1total, content=object@content, region=object@region, protocol=object@protocol)) } ) @@ -149,7 +158,8 @@ setMethod("selectYears", "RE1", function(object, selectYears) { setMethod("selectRegion", "RE1", function(object, selectRegion) { Region_Code <- NULL # evoid NOTE .re1 <- object@re1[Region_Code %in% selectRegion] - return(new("RE1", header=object@header, footer=object@footer, re1=.re1, content=object@content, region=object@region, protocol=object@protocol)) + .re1total <- object@re1total[Region_Code %in% selectRegion] + return(new("RE1", header=object@header, footer=object@footer, re1=.re1, re1total=.re1total, content=object@content, region=object@region, protocol=object@protocol)) } ) @@ -190,7 +200,11 @@ readRegDeath <- function(infile) data.table::setnames(rdft, c("V1","V2","V3","V4","V5","V6","V7","V8","V9","V10"), c("Year","Region_Code","Region_Name","Age_Name","Total1","Male","Female","D_Total","D_Male","D_Female")) - + + # extract the total sums + Age_Name <- NULL # to prevent a note + rd1total <- rdft[Age_Name=="Insgesamt"] + # merge the lower age limit age_code1 <- data.table::data.table(Age_Name=c("unter 1 Jahr","1 bis unter 5 Jahre", "5 bis unter 10 Jahre","10 bis unter 15 Jahre", @@ -206,7 +220,7 @@ readRegDeath <- function(infile) rdft <- merge(rdft,age_code1,by="Age_Name") - return(new("RD1", header=header, footer=footer, rd1=rdft, content="GENESIS-Tabelle: 12613-02-02-4", region="Germany", protocol="unknown")) + return(new("RD1", header=header, footer=footer, rd1=rdft, rd1total = rd1total, content="GENESIS-Tabelle: 12613-02-02-4", region="Germany", protocol="unknown")) } @@ -234,6 +248,11 @@ readRegExp <- function(infile) Year <- NULL # avoid NOTE rexpt[, Year:=2016] + Age_Name <- NULL # to prevent a note + # extract the total sums + re1total <- rexpt[Age_Name=="Insgesamt"] + + # merge the lower age limit age_code2 <- data.table::data.table(Age_Name=c("unter 3 Jahre","3 bis unter 6 Jahre", "6 bis unter 10 Jahre","10 bis unter 15 Jahre", @@ -250,7 +269,7 @@ readRegExp <- function(infile) rexpt <- merge(rexpt, age_code2 ,by="Age_Name") - return(new("RE1", header=header, footer=footer, re1=rexpt, content="GENESIS-Tabelle: 12613-02-02-4", region="Germany", protocol="unknown")) + return(new("RE1", header=header, footer=footer, re1=rexpt, re1total=re1total, content="GENESIS-Tabelle: 12613-02-02-4", region="Germany", protocol="unknown")) } diff --git a/tests/Simple1.R b/tests/Simple1.R index ee73ac6..a589dea 100644 --- a/tests/Simple1.R +++ b/tests/Simple1.R @@ -94,6 +94,7 @@ d1 header(d1) footer(d1) rd1(d1) +rd1total(d1) # descriptive tables and a ranges rd1(d1)[, table(Year)] @@ -112,6 +113,7 @@ rd1(d2)[, table(Age_Name)] rd1(d2)[, range(AgeLow)] rd1(d2) +rd1total(d2) # select a reagion (d3 <- selectRegion(d2, "13003")) @@ -121,7 +123,9 @@ rd1(d3)[, table(Age_Name)] rd1(d3)[, range(AgeLow)] rd1(d3) +rd1total(d3) +merge(rd1(d3), rd1total(d3)[,c("Region_Code","Total1","Male","Female")], by = "Region_Code") class(d1) showClass("RD1") @@ -141,6 +145,7 @@ r1 header(r1) footer(r1) re1(r1) +re1total(r1) ## # descriptive tables and a ranges @@ -160,6 +165,7 @@ re1(r2)[, table(Age_Name)] re1(r2)[, range(AgeLow)] re1(r2) +re1total(r2) # select a reagion (r3 <- selectRegion(r2, "13003")) @@ -169,7 +175,9 @@ re1(r3)[, table(Age_Name)] re1(r3)[, range(AgeLow)] re1(r3) +re1total(r3) +merge(re1(r3), re1total(r3)[,c("Region_Code","Total1","Male","Female")], by = "Region_Code") class(r1) showClass("RE1")