diff --git a/NAMESPACE b/NAMESPACE index 35abca9..30fbb46 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,3 +2,12 @@ exportPattern("^[[:alpha:]]+") importFrom("methods", "new", "validObject") import("data.table") + + +## Generics and functions defined in this package +export("header1", "lt1", + "content", + "country", + "protocol", "lt1<-", + "selectYears", "ex1", "ex1<-", "rd1", "rd1<-", + "selectRegion", "re1", "re1<-") diff --git a/R/AllGeneric.R b/R/AllGeneric.R new file mode 100644 index 0000000..e7345a2 --- /dev/null +++ b/R/AllGeneric.R @@ -0,0 +1,31 @@ +# Rainer Walke, MPIDR Rostock + +setGeneric("header1", function(x) standardGeneric("header1")) + +setGeneric("lt1", function(x) standardGeneric("lt1")) + +setGeneric("content", function(x) standardGeneric("content")) + +setGeneric("country", function(x) standardGeneric("country")) + +setGeneric("protocol", function(x) standardGeneric("protocol")) + +setGeneric("lt1<-", function(x, value) standardGeneric("lt1<-")) + +setGeneric("selectYears", function(x, selectYears) standardGeneric("selectYears")) + +setGeneric("ex1", function(x) standardGeneric("ex1")) + +setGeneric("ex1<-", function(x, value) standardGeneric("ex1<-")) + + +setGeneric("rd1", function(x) standardGeneric("rd1")) + +setGeneric("rd1<-", function(x, value) standardGeneric("rd1<-")) + +setGeneric("selectRegion", function(x, selectRegion) standardGeneric("selectRegion")) + +setGeneric("re1", function(x) standardGeneric("re1")) + +setGeneric("re1<-", function(x, value) standardGeneric("re1<-")) + diff --git a/R/eo1.R b/R/GENESISClasses.R similarity index 55% rename from R/eo1.R rename to R/GENESISClasses.R index 8cc9bdf..c1956fc 100644 --- a/R/eo1.R +++ b/R/GENESISClasses.R @@ -2,153 +2,6 @@ require(data.table) -#### - -# S4 class definitions -# class for life-tables 1x1 - -setClass("LT1", - slots=c( - header1="vector", # file header - lt1="data.table", # life table - content="character", # content - country="character", # country - protocol="character" # protocol version - ) -) - -# slot getters -setGeneric("header1", function(x) standardGeneric("header1")) -setMethod("header1", "LT1", function(x) x@header1) - -setGeneric("lt1", function(x) standardGeneric("lt1")) -setMethod("lt1", "LT1", function(x) x@lt1) - -setGeneric("content", function(x) standardGeneric("content")) -setMethod("content", "LT1", function(x) x@content) -setGeneric("country", function(x) standardGeneric("country")) -setMethod("country", "LT1", function(x) x@country) -setGeneric("protocol", function(x) standardGeneric("protocol")) -setMethod("protocol", "LT1", function(x) x@protocol) - -# slot setters -setGeneric("lt1<-", function(x, value) standardGeneric("lt1<-")) -setReplaceMethod("lt1", "LT1", function(x, value) {x@lt1 <- value; validObject(x); x}) - - - -# constructor -LTable1 <- function(header1, lt1, content, country, protocol) - new("LT1", header1=header1, lt1=lt1, content=content, country=country, protocol=protocol) - -# methods -setMethod("length", "LT1", function(x) dim(x@lt1)[1]) -setMethod("show", "LT1", - function(object) - cat(class(object), "instance with length", length(object), "\n") -) - -setGeneric("selectYears", function(x, selectYears) standardGeneric("selectYears")) -setMethod("selectYears", "LT1", function(x, selectYears) { - .lt1 <- x@lt1[Year %in% selectYears] - return(new("LT1", header1=x@header1, lt1=.lt1, content=x@content, country=x@country, protocol=x@protocol)) - } -) - -# validity method -setValidity("LT1", - function(object) { - msg <- NULL - valid <- TRUE - - lt1colnames <- c("Year","Age","mx","qx","ax","lx","dx","Lx","Tx","ex") - if (!all(lt1colnames %in% colnames(object@lt1))) { - valid <- FALSE - msg <- c(msg, paste(c("lt1 must contain:",lt1colnames), collapse=" ")) - } - - # add a pure numeric age - object@lt1[,AgeLow:=as.numeric(sub("\\+","",Age))] - - if(max(lt1(object)$lx > 100000)) { - valid <- FALSE - msg <- c(msg,("lx must be not larger than 100000")) - } - - if (valid) TRUE else msg - } -) - - -#### -# Class for exposures 1x1 - -setClass("EX1", - slots=c( - header1="vector", # file header - ex1="data.table", # exposure table - content="character", # content - country="character", # country - protocol="character" # protocol version - ) -) - -# slot getters -#setGeneric("header1", function(x) standardGeneric("header1")) -setMethod("header1", "EX1", function(x) x@header1) - -setGeneric("ex1", function(x) standardGeneric("ex1")) -setMethod("ex1", "EX1", function(x) x@ex1) - -#setGeneric("content", function(x) standardGeneric("content")) -setMethod("content", "EX1", function(x) x@content) -#setGeneric("country", function(x) standardGeneric("country")) -setMethod("country", "EX1", function(x) x@country) -#setGeneric("protocol", function(x) standardGeneric("protocol")) -setMethod("protocol", "EX1", function(x) x@protocol) - -# slot setters -setGeneric("ex1<-", function(x, value) standardGeneric("ex1<-")) -setReplaceMethod("ex1", "EX1", function(x, value) {x@ex1 <- value; validObject(x); x}) - -# constructor -Exposure1 <- function(header1, ex1, content, country, protocol) - new("EX1", header1=header1, ex1=ex1, content=content, country=country, protocol=protocol) - -# methods -setMethod("length", "EX1", function(x) dim(x@ex1)[1]) -setMethod("show", "EX1", - function(object) - cat(class(object), "instance with length", length(object), "\n") -) - -setMethod("selectYears", "EX1", function(x, selectYears) { - .ex1 <- x@ex1[Year %in% selectYears] - return(new("EX1", header1=x@header1, ex1=.ex1, content=x@content, country=x@country, protocol=x@protocol)) -} -) - -# validity method -setValidity("EX1", - function(object) { - msg <- NULL - valid <- TRUE - - ex1colnames <- c("Year","Age","Female","Male","Total") - if (!all(ex1colnames %in% colnames(object@ex1))) { - valid <- FALSE - msg <- c(msg, paste(c("ex1 must contain:",ex1colnames), collapse=" ")) - } - - # add a pure numeric age - object@ex1[,AgeLow:=as.numeric(sub("\\+","",Age))] - - if (valid) TRUE else msg - } -) - - - #### # Class for 'GENESIS-Tabelle: 12613-02-02-4' @@ -164,8 +17,6 @@ setClass("RD1", # slot getters setMethod("header1", "RD1", function(x) x@header1) - -setGeneric("rd1", function(x) standardGeneric("rd1")) setMethod("rd1", "RD1", function(x) x@rd1) setMethod("content", "RD1", function(x) x@content) @@ -173,7 +24,6 @@ setMethod("country", "RD1", function(x) x@country) setMethod("protocol", "RD1", function(x) x@protocol) # slot setters -setGeneric("rd1<-", function(x, value) standardGeneric("rd1<-")) setReplaceMethod("rd1", "RD1", function(x, value) {x@rd1 <- value; validObject(x); x}) # constructor @@ -193,7 +43,6 @@ setMethod("selectYears", "RD1", function(x, selectYears) { } ) -setGeneric("selectRegion", function(x, selectRegion) standardGeneric("selectRegion")) setMethod("selectRegion", "RD1", function(x, selectRegion) { .rd1 <- x@rd1[Region_Code %in% selectRegion] return(new("RD1", header1=x@header1, rd1=.rd1, content=x@content, country=x@country, protocol=x@protocol)) @@ -217,9 +66,6 @@ setValidity("RD1", ) - - - #### # Class for 'GENESIS-Tabelle: 12411-03-03-4' @@ -235,8 +81,6 @@ setClass("RE1", # slot getters setMethod("header1", "RE1", function(x) x@header1) - -setGeneric("re1", function(x) standardGeneric("re1")) setMethod("re1", "RE1", function(x) x@re1) setMethod("content", "RE1", function(x) x@content) @@ -244,7 +88,6 @@ setMethod("country", "RE1", function(x) x@country) setMethod("protocol", "RE1", function(x) x@protocol) # slot setters -setGeneric("re1<-", function(x, value) standardGeneric("re1<-")) setReplaceMethod("re1", "RE1", function(x, value) {x@re1 <- value; validObject(x); x}) # constructor @@ -286,42 +129,8 @@ setValidity("RE1", } ) - - #### - -# read all information from the file 1x1 period life table -# Human Mortality Database https://www.mortality.org/ -readLT1x1 <- function(infile) -{ - LT0 <- readLines(infile, n=2) - LT1 <- fread(infile) - - B1 <- sapply(strsplit(LT0,"[,\t;:]"), trimws) - country <- B1[[1]][1] - content <- paste(B1[[1]][2],B1[[1]][3], sep=", ") - protocol <- B1[[1]][7] - - return(new("LT1", header1=LT0, lt1=LT1, content=content, country=country, protocol=protocol)) -} - - -# read all information from the file 1x1 exposure table -# Human Mortality Database https://www.mortality.org/ -readEX1x1 <- function(infile) -{ - EX0 <- readLines(infile, n=2) - EX1 <- fread(infile) - - B1 <- sapply(strsplit(EX0,"[,\t;:]"), trimws) - country <- B1[[1]][1] - content <- B1[[1]][2] - protocol <- B1[[1]][7] - - return(new("EX1", header1=EX0, ex1=EX1, content=content, country=country, protocol=protocol)) -} - # read all information from 'GENESIS-Tabelle: 12613-02-02-4' # Statistische ?mter des Bundes und der L?nder, Deutschland, 2019 readRegDeath <- function(infile) @@ -385,6 +194,4 @@ readRegExp <- function(infile) } - #### - diff --git a/R/HMDClasses.R b/R/HMDClasses.R new file mode 100644 index 0000000..cd25c73 --- /dev/null +++ b/R/HMDClasses.R @@ -0,0 +1,169 @@ +# Rainer Walke, MPIDR Rostock + +require(data.table) + +#### + +# S4 class definitions +# class for life-tables 1x1 + +setClass("LT1", + slots=c( + header1="vector", # file header + lt1="data.table", # life table + content="character", # content + country="character", # country + protocol="character" # protocol version + ) +) + +# slot getters +setMethod("header1", "LT1", function(x) x@header1) +setMethod("lt1", "LT1", function(x) x@lt1) + +setMethod("content", "LT1", function(x) x@content) +setMethod("country", "LT1", function(x) x@country) +setMethod("protocol", "LT1", function(x) x@protocol) + +# slot setters +setReplaceMethod("lt1", "LT1", function(x, value) {x@lt1 <- value; validObject(x); x}) + + + +# constructor +LTable1 <- function(header1, lt1, content, country, protocol) + new("LT1", header1=header1, lt1=lt1, content=content, country=country, protocol=protocol) + +# methods +setMethod("length", "LT1", function(x) dim(x@lt1)[1]) +setMethod("show", "LT1", + function(object) + cat(class(object), "instance with length", length(object), "\n") +) + +setMethod("selectYears", "LT1", function(x, selectYears) { + .lt1 <- x@lt1[Year %in% selectYears] + return(new("LT1", header1=x@header1, lt1=.lt1, content=x@content, country=x@country, protocol=x@protocol)) + } +) + +# validity method +setValidity("LT1", + function(object) { + msg <- NULL + valid <- TRUE + + lt1colnames <- c("Year","Age","mx","qx","ax","lx","dx","Lx","Tx","ex") + if (!all(lt1colnames %in% colnames(object@lt1))) { + valid <- FALSE + msg <- c(msg, paste(c("lt1 must contain:",lt1colnames), collapse=" ")) + } + + # add a pure numeric age + object@lt1[,AgeLow:=as.numeric(sub("\\+","",Age))] + + if(max(lt1(object)$lx > 100000)) { + valid <- FALSE + msg <- c(msg,("lx must be not larger than 100000")) + } + + if (valid) TRUE else msg + } +) + + +#### +# Class for exposures 1x1 + +setClass("EX1", + slots=c( + header1="vector", # file header + ex1="data.table", # exposure table + content="character", # content + country="character", # country + protocol="character" # protocol version + ) +) + +# slot getters +setMethod("header1", "EX1", function(x) x@header1) +setMethod("ex1", "EX1", function(x) x@ex1) + +setMethod("content", "EX1", function(x) x@content) +setMethod("country", "EX1", function(x) x@country) +setMethod("protocol", "EX1", function(x) x@protocol) + +# slot setters +setReplaceMethod("ex1", "EX1", function(x, value) {x@ex1 <- value; validObject(x); x}) + +# constructor +Exposure1 <- function(header1, ex1, content, country, protocol) + new("EX1", header1=header1, ex1=ex1, content=content, country=country, protocol=protocol) + +# methods +setMethod("length", "EX1", function(x) dim(x@ex1)[1]) +setMethod("show", "EX1", + function(object) + cat(class(object), "instance with length", length(object), "\n") +) + +setMethod("selectYears", "EX1", function(x, selectYears) { + .ex1 <- x@ex1[Year %in% selectYears] + return(new("EX1", header1=x@header1, ex1=.ex1, content=x@content, country=x@country, protocol=x@protocol)) +} +) + +# validity method +setValidity("EX1", + function(object) { + msg <- NULL + valid <- TRUE + + ex1colnames <- c("Year","Age","Female","Male","Total") + if (!all(ex1colnames %in% colnames(object@ex1))) { + valid <- FALSE + msg <- c(msg, paste(c("ex1 must contain:",ex1colnames), collapse=" ")) + } + + # add a pure numeric age + object@ex1[,AgeLow:=as.numeric(sub("\\+","",Age))] + + if (valid) TRUE else msg + } +) + + +#### + +# read all information from the file 1x1 period life table +# Human Mortality Database https://www.mortality.org/ +readLT1x1 <- function(infile) +{ + LT0 <- readLines(infile, n=2) + LT1 <- fread(infile) + + B1 <- sapply(strsplit(LT0,"[,\t;:]"), trimws) + country <- B1[[1]][1] + content <- paste(B1[[1]][2],B1[[1]][3], sep=", ") + protocol <- B1[[1]][7] + + return(new("LT1", header1=LT0, lt1=LT1, content=content, country=country, protocol=protocol)) +} + + +# read all information from the file 1x1 exposure table +# Human Mortality Database https://www.mortality.org/ +readEX1x1 <- function(infile) +{ + EX0 <- readLines(infile, n=2) + EX1 <- fread(infile) + + B1 <- sapply(strsplit(EX0,"[,\t;:]"), trimws) + country <- B1[[1]][1] + content <- B1[[1]][2] + protocol <- B1[[1]][7] + + return(new("EX1", header1=EX0, ex1=EX1, content=content, country=country, protocol=protocol)) +} + +####