Permalink
Cannot retrieve contributors at this time
Name already in use
A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
eoR/R/GENESISClasses.R
Go to fileThis commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
257 lines (209 sloc)
8.78 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # Rainer Walke, MPIDR Rostock | |
| #' @importFrom methods new show validObject | |
| NULL | |
| #' @importFrom data.table := fread setnames | |
| NULL | |
| #### | |
| # Class for 'GENESIS-Tabelle: 12613-02-02-4' | |
| #' @export | |
| setClass("RD1", | |
| slots=c( | |
| header="vector", # file header | |
| footer="vector", # file footer | |
| rd1="data.table", # exposure table | |
| content="character", # content | |
| region="character", # region | |
| protocol="character" # protocol version | |
| ) | |
| ) | |
| # slot getters | |
| #' @export | |
| setMethod("header", "RD1", function(object) object@header) | |
| #' @export | |
| setMethod("footer", "RD1", function(object) object@footer) | |
| #' @export | |
| setMethod("rd1", "RD1", function(object) object@rd1) | |
| #' @export | |
| setMethod("content", "RD1", function(object) object@content) | |
| #' @export | |
| setMethod("region", "RD1", function(object) object@region) | |
| #' @export | |
| setMethod("protocol", "RD1", function(object) object@protocol) | |
| # slot setters | |
| #' @export | |
| setReplaceMethod("rd1", "RD1", function(object, value) {object@rd1 <- value; validObject(object); object}) | |
| # constructor | |
| #' @export | |
| RegDeath1 <- function(header, footer, rd1, content, region, protocol) | |
| new("RD1", header=header, footer=footer, rd1=rd1, content=content, region=region, protocol=protocol) | |
| # methods | |
| #' @export | |
| setMethod("length", "RD1", function(x) dim(x@rd1)[1]) | |
| #' @export | |
| setMethod("show", "RD1", | |
| function(object) | |
| cat(class(object), "instance with length", length(object), "\n") | |
| ) | |
| #' @export | |
| 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)) | |
| } | |
| ) | |
| #' @export | |
| 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)) | |
| } | |
| ) | |
| # validity method | |
| #' @export | |
| setValidity("RD1", | |
| function(object) { | |
| msg <- NULL | |
| valid <- TRUE | |
| rd1colnames <- c("Year","Region_Code","Region_Name","Age_Name","Total1","Male","Female","D_Total","D_Male","D_Female", "AgeLow") | |
| if (!all(rd1colnames %in% colnames(object@rd1))) { | |
| valid <- FALSE | |
| msg <- c(msg, paste(c("ex1 must contain:",rd1colnames), collapse=" ")) | |
| } | |
| if (valid) TRUE else msg | |
| } | |
| ) | |
| #### | |
| # Class for 'GENESIS-Tabelle: 12411-03-03-4' | |
| #' @export | |
| setClass("RE1", | |
| slots=c( | |
| header="vector", # file header | |
| footer="vector", # file footer | |
| re1="data.table", # exposure table | |
| content="character", # content | |
| region="character", # region | |
| protocol="character" # protocol version | |
| ) | |
| ) | |
| # slot getters | |
| #' @export | |
| setMethod("header", "RE1", function(object) object@header) | |
| #' @export | |
| setMethod("footer", "RE1", function(object) object@footer) | |
| #' @export | |
| setMethod("re1", "RE1", function(object) object@re1) | |
| #' @export | |
| setMethod("content", "RE1", function(object) object@content) | |
| #' @export | |
| setMethod("region", "RE1", function(object) object@region) | |
| #' @export | |
| setMethod("protocol", "RE1", function(object) object@protocol) | |
| # slot setters | |
| #' @export | |
| setReplaceMethod("re1", "RE1", function(object, value) {object@re1 <- value; validObject(object); object}) | |
| # constructor | |
| #' @export | |
| RegExp1 <- function(header, footer, re1, content, region, protocol) | |
| new("RE1", header=header, footer, re1=re1, content=content, region=region, protocol=protocol) | |
| # methods | |
| #' @export | |
| setMethod("length", "RE1", function(x) dim(x@re1)[1]) | |
| #' @export | |
| setMethod("show", "RE1", | |
| function(object) | |
| cat(class(object), "instance with length", length(object), "\n") | |
| ) | |
| #' @export | |
| 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)) | |
| } | |
| ) | |
| #' @export | |
| 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)) | |
| } | |
| ) | |
| # validity method | |
| #' @export | |
| setValidity("RE1", | |
| function(object) { | |
| msg <- NULL | |
| valid <- TRUE | |
| re1colnames <-c("Region_Code","Region_Name","Age_Name","Total1","Male","Female","D_Total","D_Male","D_Female", | |
| "A_Total","A_Male","A_Female", "Year", "AgeLow") | |
| if (!all(re1colnames %in% colnames(object@re1))) { | |
| valid <- FALSE | |
| msg <- c(msg, paste(c("ex1 must contain:",re1colnames), collapse=" ")) | |
| } | |
| if (valid) TRUE else msg | |
| } | |
| ) | |
| #### | |
| # read all information from 'GENESIS-Tabelle: 12613-02-02-4' | |
| # Statistische Ämter des Bundes und der Länder, Deutschland, 2019 | |
| #' @export | |
| readRegDeath <- function(infile) | |
| { | |
| bb <- scan(infile, what=character(), blank.lines.skip = FALSE, encoding="ANSI", sep="\n") | |
| h2 <- grep(";Insgesamt;m\u00e4nnlich",bb) | |
| f1 <- grep("__________",bb) | |
| f2 <- length(bb) | |
| header <- bb[1:h2] | |
| footer <- bb[f1:f2] | |
| rdft <- data.table::fread(infile, skip=h2, nrows=(f1-h2-1)) | |
| 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")) | |
| # 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", | |
| "15 bis unter 20 Jahre","20 bis unter 25 Jahre", | |
| "25 bis unter 30 Jahre","30 bis unter 35 Jahre", | |
| "35 bis unter 40 Jahre","40 bis unter 45 Jahre", | |
| "45 bis unter 50 Jahre","50 bis unter 55 Jahre", | |
| "55 bis unter 60 Jahre","60 bis unter 65 Jahre", | |
| "65 bis unter 70 Jahre","70 bis unter 75 Jahre", | |
| "75 bis unter 80 Jahre","80 bis unter 85 Jahre", | |
| "85 Jahre und mehr"), | |
| AgeLow=c(0,1,seq(5,85,by=5))) | |
| 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")) | |
| } | |
| # read all information from 'GENESIS-Tabelle: 12613-02-02-4' | |
| # Statistische Ämter des Bundes und der Länder, Deutschland, 2019 | |
| #' @export | |
| readRegExp <- function(infile) | |
| { | |
| bb <- scan(infile, what=character(), blank.lines.skip = FALSE, encoding="ANSI", sep="\n") | |
| h2 <- grep(";Insgesamt;m\u00e4nnlich",bb) | |
| f1 <- grep("__________",bb) | |
| f2 <- length(bb) | |
| header <- bb[1:h2] | |
| footer <- bb[f1:f2] | |
| rexpt <- data.table::fread(infile, skip=h2, nrows=(f1-h2-1)) | |
| data.table::setnames(rexpt, c("V1","V2","V3","V4","V5","V6","V7","V8","V9","V10","V11","V12"), | |
| c("Region_Code","Region_Name","Age_Name","Total1","Male","Female","D_Total","D_Male","D_Female", | |
| "A_Total","A_Male","A_Female")) | |
| # add the year | |
| Year <- NULL # avoid NOTE | |
| rexpt[, Year:=2016] | |
| # 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", | |
| "15 bis unter 18 Jahre","18 bis unter 20 Jahre", | |
| "20 bis unter 25 Jahre", | |
| "25 bis unter 30 Jahre","30 bis unter 35 Jahre", | |
| "35 bis unter 40 Jahre","40 bis unter 45 Jahre", | |
| "45 bis unter 50 Jahre","50 bis unter 55 Jahre", | |
| "55 bis unter 60 Jahre","60 bis unter 65 Jahre", | |
| "65 bis unter 70 Jahre","70 bis unter 75 Jahre", | |
| "75 bis unter 80 Jahre","80 bis unter 85 Jahre", | |
| "85 bis unter 90 Jahre","90 Jahre und mehr"), | |
| AgeLow=c(0,3,6,10,15,18,seq(20,90,by=5))) | |
| 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")) | |
| } | |
| #### |