distribute the classes to different files and use the NAMESPACE

walke · Sep 20, 2019 · 3340c09 · 3340c09
1 parent 81a25c3
commit 3340c09
Show file tree

Hide file tree

Showing 4 changed files with 209 additions and 193 deletions.
diff --git 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
@@ -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 → R/GENESISClasses.R b/R/eo1.R → 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,16 +17,13 @@ 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)
 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,16 +81,13 @@ 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)
 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)
 
 }
 
-
 ####
-