add the class EX1 and an example data set for exposure times

R/eo1.R

@@ -5,6 +5,8 @@ require(data.table)
 ####
 
 # S4 class definitions
+# class for life-tables 1x1
+
 setClass("LT1",
          slots=c(
            header1="vector", # file header
@@ -77,6 +79,74 @@ setValidity("LT1",
             }
 )
 
+
+####
+# 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
+            }
+)
+
 ####
 
 
@@ -89,6 +159,16 @@ readLT1x1 <- function(infile)
   return(new("LT1", header1=LT0, lt1=LT1, content="Life tables (period 1x1), Females", country="Germany", protocol="v6 (2017)"))
 }
 
+
+# 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)
+  return(new("EX1", header1=EX0, ex1=EX1, content="Exposure to risk (period 1x1)", country="Germany", protocol="v6 (2017)"))
+}
+
 ####
 
 # example and trials
@@ -129,4 +209,41 @@ class(o1)
 showClass("LT1")
 showMethods("length")
 
+
+# read all information from the file Exposures_1x1
+# example data source: Human Mortality Database https://www.mortality.org/
+# period life tables 1x1 female
+infile2 <- file.path("..","data","DEUTNP.Exposures_1x1.txt")
+
+e1 <- readEX1x1(infile2)
+
+length((e1))
+e1
+
+header1(e1)
+ex1(e1)
+
+# descriptive tables and a ranges
+ex1(e1)[, table(Year)]
+ex1(e1)[, table(Age)]
+ex1(e1)[, range(AgeLow)]
+
+content(e1)
+country(e1)
+protocol(e1)
+
+# select some years
+(e2 <- selectYears(e1, c(1999,2000)))
+# descriptive tables and a ranges
+ex1(e2)[, table(Year)]
+ex1(e2)[, table(Age)]
+ex1(e2)[, range(AgeLow)]
+
+ex1(e2)
+
+
+class(e1)
+showClass("EX1")
+showMethods("length")
+
 sessionInfo()