From 769b51d0d0b70a1dd3e9e3013cd1b0c6a1ca4b57 Mon Sep 17 00:00:00 2001 From: Rainer Walke Date: Wed, 6 Nov 2019 10:29:40 +0100 Subject: [PATCH] add generator files for example data --- tests/generator_12411-03-03-4m.R | 140 ++++++++++++++++++++ tests/generator_12613-02-02-4m.R | 135 +++++++++++++++++++ tests/generator_DEUTNP.Exposures_1x1m.R | 134 +++++++++++++++++++ tests/generator_DEUTNP.fltper_1x1m.R | 166 ++++++++++++++++++++++++ 4 files changed, 575 insertions(+) create mode 100644 tests/generator_12411-03-03-4m.R create mode 100644 tests/generator_12613-02-02-4m.R create mode 100644 tests/generator_DEUTNP.Exposures_1x1m.R create mode 100644 tests/generator_DEUTNP.fltper_1x1m.R diff --git a/tests/generator_12411-03-03-4m.R b/tests/generator_12411-03-03-4m.R new file mode 100644 index 0000000..990aa31 --- /dev/null +++ b/tests/generator_12411-03-03-4m.R @@ -0,0 +1,140 @@ +# Rainer Walke, MPIDR Rostock +# create artifical example data +# 12411-03-03-4m.csv + +require(data.table) + +h1 <- 1 +h2 <- 8 + +f1 <- h2 + 22 * 5 + 1 +f2 <- f1 + 27 + +# low lines +header <- c("example data similar to 12411-03-03-4.csv", + rep("some text", times=(h2-2)), + ";;;;Insgesamt;m\xe4nnlich;more;more;;;;;") +header + +footer <- c("\x5f\x5f\x5f\x5f\x5f\x5f\x5f\x5f\x5f\x5f", + rep("some text", times=(f2-f1))) + +footer + + +block1 <- function(mult) { + + V13 <- c(250L,200L,300L,300L,250L,150L,550L, + 700L,700L,850L,800L,700L,500L,400L, + 350L,300L,200L,100L,50L,30L,20L) + V13 <- as.integer(V13 * mult) + + (V12 <- as.integer(1.4 * V13)) + (V11 <- V12 + V13) + + (V10 <- as.integer(22.1 * V13)) + (V9 <- as.integer(0.9* V10)) + (V8 <- V9 + V10) + + (V7 <- V10 + V13) + (V6 <- V9 + V12) + (V5 <- V8 + V11) + + b1 <- data.table(V5=V5, V6=V6, V7=V7, V8=V8, V9=V9, V10=V10, V11=V11, V12=V12, V13=V13) + b2 <- rbind(b1, t(colSums(b1))) + return(b2) + +} + +b2a <- sapply(block1(1.0), paste) + +b2b <- sapply(block1(1.474), paste) + +b2c <- sapply(block1(2.782), paste) + +b2d <- apply(b2c, 2, function(x) gsub(".*", "-", x)) + +b2e <- sapply(block1(7.532), paste) + + +age_code2 <- 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", + "Insgesamt") + +(content <- data.table( + V1=rep(c("31.12.2011", rep(c("31.12.2016"), 4)), each=22), + V2=rep(c("01","02","03","04","DX"), each=22), + V3=rep(paste("Kreis-",seq(1,5), sep=''), each=22), + V4=rep(age_code2, 5), + rbind(b2a,b2b,b2c,b2d,b2e))) + + + +cc <- c(header, apply(content, 1, paste, collapse=';'), footer) + +# write(cc, file = file.path(".", "12411-03-03-4m.csv")) + +# final test + +library(eoR) + +# compare the files with the eoR file +cc2 <- readLines(file.path(system.file(package="eoR"), "extdata", "12411-03-03-4m.csv")) +stopifnot(all.equal(cc,cc2)) + + + +dd <- readRegExp(file.path(system.file(package="eoR"), "extdata", "12411-03-03-4m.csv")) + + +length((dd)) +dd + +header(dd) +footer(dd) +re1(dd) +re1total(dd) + +## +# descriptive tables and a ranges +re1(dd)[, table(Year)] +re1(dd)[, table(Age_Name)] +re1(dd)[, range(AgeLow)] + +content(dd) +region(dd) +protocol(dd) + +# select some years +(dd2 <- selectYears(dd, c(2016))) +# descriptive tables and a ranges +re1(dd2)[, table(Year)] +re1(dd2)[, table(Age_Name)] +re1(dd2)[, range(AgeLow)] + +re1(dd2) +re1total(dd2) + +# select a reagion +(dd3 <- selectRegion(dd2, "03")) +# descriptive tables and a ranges +re1(dd3)[, table(Year)] +re1(dd3)[, table(Age_Name)] +re1(dd3)[, range(AgeLow)] + +re1(dd3) +re1total(dd3) + +merge(re1(dd3), re1total(dd3)[,c("Region_Code","Total1","Male","Female")], by = "Region_Code") + + + diff --git a/tests/generator_12613-02-02-4m.R b/tests/generator_12613-02-02-4m.R new file mode 100644 index 0000000..c4a3add --- /dev/null +++ b/tests/generator_12613-02-02-4m.R @@ -0,0 +1,135 @@ +# Rainer Walke, MPIDR Rostock +# create artifical example data +# 12613-02-02-4m.csv + +require(data.table) + +h1 <- 1 +h2 <- 7 + +f1 <- h2 + 20 * 5 + 1 +f2 <- f1 + 53 + +# low lines +header <- c("example data similar to 12613-02-02-4.csv", + rep("some text", times=(h2-2)), + ";;;;Insgesamt;m\xe4nnlich;more;more;;") +header + +footer <- c("\x5f\x5f\x5f\x5f\x5f\x5f\x5f\x5f\x5f\x5f", + rep("some text", times=(f2-f1))) + +footer + + +block1 <- function(mult) { + + V10 <- c(30L,5L,2L,10L,10L,20L,10L, + 30L,40L,90L,200L,300L,450L,600L, + 750L,1300L,2200L,2700L,8200L) + V10 <- as.integer(V10 * mult) + + (V9 <- as.integer(1.1 * V10)) + (V8 <- V9 + V10) + + (V7 <- as.integer(1.11 * V10)) + (V6 <- as.integer(1.21* V9)) + (V5 <- V6 + V7) + + b1 <- data.table(V5=V5, V6=V6, V7=V7, V8=V8, V9=V9, V10=V10) + b2 <- rbind(b1, t(colSums(b1))) + return(b2) + +} + +b2a <- apply(sapply(block1(1.0), paste), 2, function(x) gsub("^0$", "-", x)) + +b2b <- apply(sapply(block1(0.174), paste), 2, function(x) gsub("^0$", "-", x)) + +b2c <- apply(sapply(block1(0.208), paste), 2, function(x) gsub("^0$", "-", x)) + +b2d <- apply(b2c, 2, function(x) gsub(".*", "-", x)) + +b2e <- apply(sapply(block1(7.532), paste), 2, function(x) gsub("^0$", "-", x)) + + +age_code1 <- 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", + "Insgesamt") + + +(content <- data.table(V1=rep(c("2017", rep(c("2016"), 4)), each=20), V2=rep(c("01","02","03","04","DX"), each=20), + V3=rep(paste("Kreis-",seq(1,5), sep=''), each=20), + V4=rep(age_code1, 5), + rbind(b2a,b2b,b2c,b2d,b2e))) + + + +cc <- c(header, apply(content, 1, paste, collapse=';'), footer) + + +# write(cc, file = file.path(".", "12613-02-02-4m.csv")) + +# final test + +library(eoR) + +# compare the files with the eoR file +cc2 <- readLines(file.path(system.file(package="eoR"), "extdata", "12613-02-02-4m.csv")) +stopifnot(all.equal(cc,cc2)) + + + +dd <- readRegDeath(file.path(system.file(package="eoR"), "extdata", "12613-02-02-4m.csv")) + + +length((dd)) +dd + +header(dd) +footer(dd) +rd1(dd) +rd1total(dd) + +## +# descriptive tables and a ranges +rd1(dd)[, table(Year)] +rd1(dd)[, table(Age_Name)] +rd1(dd)[, range(AgeLow)] + +content(dd) +region(dd) +protocol(dd) + +# select some years +(dd2 <- selectYears(dd, c(2016))) +# descriptive tables and a ranges +rd1(dd2)[, table(Year)] +rd1(dd2)[, table(Age_Name)] +rd1(dd2)[, range(AgeLow)] + +rd1(dd2) +rd1total(dd2) + +# select a reagion +(dd3 <- selectRegion(dd2, "03")) +# descriptive tables and a ranges +rd1(dd3)[, table(Year)] +rd1(dd3)[, table(Age_Name)] +rd1(dd3)[, range(AgeLow)] + +rd1(dd3) +rd1total(dd3) + +merge(rd1(dd3), rd1total(dd3)[,c("Region_Code","Total1","Male","Female")], by = "Region_Code") + + + diff --git a/tests/generator_DEUTNP.Exposures_1x1m.R b/tests/generator_DEUTNP.Exposures_1x1m.R new file mode 100644 index 0000000..9ad52c4 --- /dev/null +++ b/tests/generator_DEUTNP.Exposures_1x1m.R @@ -0,0 +1,134 @@ +# Rainer Walke, MPIDR Rostock +# create artifical example data +# DEUTNP.Exposures_1x1m.txt + +require(data.table) + +h1 <- 1 +h2 <- 2 + +f1 <- h2 + 111 * 7 + 1 +f2 <- f1 + 0 + +header <- c("Exland, Exposure to risk (period 1x1), Last modified: 01 Jan 2018; Methods Protocol: vY (2017)", + rep("", times=(h2-1))) +header + +footer <- c(rep("t", times=(f2-f1))) + +footer + + +block2 <- function(mult) { + + Female <- c(436000, 437200, 437000, 428000, 414000, 409000, 407000, 418000, 421000, 424000, + 413000, 396000, 395000, 389000, 381000, 381500, 390000, 413000, 477000, 519000, + 555000, 605000, 635000, 656000, 670000, 679000, 687000, 677000, 663000, 650000, + 632000, 611000, 588000, 578000, 566000, 559000, 553000, 551000, 549000, 547000, + 545000, 519000, 476000, 462000, 382000, 439000, 508000, 505000, 554000, 628000, + 644000, 621000, 584000, 563000, 554000, 532000, 469000, 424000, 433000, 456000, + 467000, 465000, 459000, 458500, 473000, 471000, 462000, 469500, 492000, 501000, + 434000, 403000, 232000, 236000, 283000, 360000, 395000, 384000, 359000, 335000, + 321000, 296000, 265000, 234000, 201000, 170000, 144000, 120000, 99000, 77000, + 59000, 45000, 34000, 24000, 17000, 11000, 7000, 5000, 3000, 2000, + 1000, 500, 250, 150, 90, 50, 20, 10, 6, 10, + 1) + + Male <- c(465000, 460200, 461000, 451000, 436000, 430000, 428000, 440000, 443000, 445000, + 433000, 417000, 417500, 410000, 401000, 403000, 411000, 435000, 501000, 543000, + 578000, 631000, 666000, 691000, 710000, 725000, 734000, 723000, 703000, 687000, + 669000, 648000, 624000, 612000, 597000, 584000, 571000, 566000, 565000, 564000, + 564500, 542000, 499000, 483000, 397000, 455000, 529000, 528000, 578000, 652000, + 666000, 640000, 600000, 575000, 561000, 537000, 471000, 421000, 424000, 439000, + 443000, 433000, 407000, 367500, 343000, 311000, 284000, 285000, 293000, 287000, + 243000, 168000, 127000, 126000, 146000, 180000, 194000, 186000, 169000, 151000, + 138000, 124000, 109000, 93000, 79000, 66000, 53000, 42000, 33000, 24000, + 17000, 12000, 8000, 6000, 4000, 2500, 1600, 1000, 700, 500, + 250, 120, 60, 30, 20, 10, 6, 3, 1, 2, + 0.3) + + Female1 <- round(Female * mult, 2) + Male1 <- round(Male * mult, 2) + Total1 <- Female1 + Male1 + + + return( data.table(Female = Female1, Male = Male1, Total = Total1) ) + +} + +b2a <- block2(0.95*pi/3.14) + +b2b <- block2(0.92*pi/3.14) + +b2c <- block2(0.94*pi/3.14) + +b2d <- block2(0.93*pi/3.14) + +b2e <- block2(0.89*pi/3.14) + +b2f <- block2(0.88*pi/3.14) + +b2g <- block2(0.87*pi/3.14) + + + + +age_code3 <- c( paste(seq(0,109)," ",sep=""), "110+") + + +(content <- data.table( Year = rep( paste(seq(2011,2017)), each = 111), + Age = rep(age_code3, 7), + rbind(b2a,b2b,b2c,b2d,b2e,b2f,b2g) + )) + +content2 <- apply(content,2, format, justify="right", width=6) + +content3 <- paste(content2[,1], " ", content2[,2], " ", + content2[,3], " ", content2[,4], " ", + content2[,5]) + +colnames1 <- " Year Age Female Male Total" + +cc <- c(header, colnames1, content3, footer) + + +# write(cc, file = file.path(".", "DEUTNP.Exposures_1x1m.txt")) + +# final test + +library(eoR) + +# compare the files with the eoR file +cc2 <- readLines(file.path(system.file(package="eoR"), "extdata", "DEUTNP.Exposures_1x1m.txt")) +stopifnot(all.equal(cc,cc2)) + + +dd <- readEX1x1(file.path(system.file(package="eoR"), "extdata", "DEUTNP.Exposures_1x1m.txt")) + + +length((dd)) +dd + +header(dd) +ex1(dd) + +## +# descriptive tables and a ranges +ex1(dd)[, table(Year)] +ex1(dd)[, table(Age)] +ex1(dd)[, range(AgeLow)] + +content(dd) +region(dd) +protocol(dd) + +# select some years +(dd2 <- selectYears(dd, c(2016))) +# descriptive tables and a ranges +ex1(dd2)[, table(Year)] +ex1(dd2)[, table(Age)] +ex1(dd2)[, range(AgeLow)] + +ex1(dd2) + + diff --git a/tests/generator_DEUTNP.fltper_1x1m.R b/tests/generator_DEUTNP.fltper_1x1m.R new file mode 100644 index 0000000..b991b64 --- /dev/null +++ b/tests/generator_DEUTNP.fltper_1x1m.R @@ -0,0 +1,166 @@ +# Rainer Walke, MPIDR Rostock +# create artifical example data +# DEUTNP.fltper_1x1m.txt + +require(data.table) + +h1 <- 1 +h2 <- 2 + +f1 <- h2 + 111 * 7 + 1 +f2 <- f1 + 0 + + +header <- c("Exland, Life tables (period 1x1), Females Last modified: 01 Jan 2018; Methods Protocol: vY (2017)", + rep("", times=(h2-1))) + +header + +footer <- c(rep("t", times=(f2-f1))) + +footer + +#### + +block3 <- function(mult) { + + # simple Siler model, see for example https://www.demographic-research.org/volumes/vol38/29/38-29.pdf + + + alpha_t <- 5.124e-03 + beta1_t <- 2.048 + c_t <- 1.627e-04 + beta2_t <- 0.1013 + M_t <- 84.79 * mult + + + ltA <- data.table(AgeLow=seq(0,110)) + ltA[, mx := alpha_t * exp(-beta1_t * AgeLow) + c_t + beta2_t * exp(beta2_t * (AgeLow - M_t))][] + ltA[, ax := c(0.14, rep(0.5, 109), 1/ltA[AgeLow==110,mx])][] + + ltA[, qx := mx/(1 + (1-ax)*mx)][] + setcolorder(ltA, c("AgeLow", "mx", "qx", "ax")) + + ltA[, px := 1 - qx][] + + + # ltA[,pxlag := shift(px, 1L, type="lag")] + + ltA[AgeLow==0, lx := 100000][] + + for (x in seq(1,110)) { + + ltA[AgeLow == x, lx := ltA[AgeLow == (x-1), lx] * ltA[AgeLow == (x-1), px]] + + } + + ltA[AgeLow == 110, dx := lx][] + ltA[AgeLow == 110, Lx := lx * ax][] + + for (x in seq(109,0)) { + + ltA[AgeLow == x, dx := lx * qx] + ltA[AgeLow == x, Lx := lx - ( 1 - ax ) * dx] + + } + + ltA[AgeLow == 110, Tx := Lx][] + + for (x in seq(109,0)) { + + ltA[AgeLow == x, Tx := ltA[AgeLow == (x+1), Tx] + Lx] + + } + + ltA[, ex := Tx / lx][] + + + ltA[, px := NULL] + ltA[, AgeLow := NULL] + + ltA[, Age := c( paste(seq(0,109)," ",sep=""), "110+")] + setcolorder(ltA, "Age") + + # round everything + ltA[, ':=' (mx = round(mx,5), qx = round(qx,5), ax = round(ax,2), + lx = ceiling(lx), dx = ceiling(dx), Lx = ceiling(Lx), + Tx = ceiling(Tx), ex = round(ex,2))][] + + return(ltA) +} + + +# block3(1.0) + + +b2a <- block3(0.99) + +b2b <- block3(1.00) + +b2c <- block3(1.01) + +b2d <- block3(1.02) + +b2e <- block3(1.03) + +b2f <- block3(1.04) + +b2g <- block3(1.05) + +(content <- data.table( Year = rep( paste(seq(2011,2017)), each = 111), + rbind(b2a,b2b,b2c,b2d,b2e,b2f,b2g) + )) + +content2 <- apply(content,2, format, justify="right", width=6) + +content3 <- paste(content2[,1], " ", content2[,2], " ", + content2[,3], " ", content2[,4], "", + content2[,5], " ", content2[,6], " ", + content2[,7], " ", content2[,8], " ", + content2[,9], " ", content2[,10], sep="") + +colnames1 <- " Year Age mx qx ax lx dx Lx Tx ex" + +cc <- c(header, colnames1, content3, footer) + + +# write(cc, file = file.path(".", "DEUTNP.fltper_1x1m.txt")) + + +# final test + +library(eoR) + +# compare the files with the eoR file +cc2 <- readLines(file.path(system.file(package="eoR"), "extdata", "DEUTNP.fltper_1x1m.txt")) +stopifnot(all.equal(cc,cc2)) + + +dd <- readLT1x1(file.path(system.file(package="eoR"), "extdata", "DEUTNP.fltper_1x1m.txt")) + +length((dd)) +dd + +header(dd) +lt1(dd) + +## +# descriptive tables and a ranges +lt1(dd)[, table(Year)] +lt1(dd)[, table(Age)] +lt1(dd)[, range(AgeLow)] + +content(dd) +region(dd) +protocol(dd) + +# select some years +(dd2 <- selectYears(dd, c(2016))) +# descriptive tables and a ranges +lt1(dd2)[, table(Year)] +lt1(dd2)[, table(Age)] +lt1(dd2)[, range(AgeLow)] + +lt1(dd2) + +