From 514f506a68f6b6ad5f6393589c3fd9244177d164 Mon Sep 17 00:00:00 2001
From: gdutz <30431062+gdutz@users.noreply.github.com>
Date: Wed, 11 Aug 2021 15:29:14 +0200
Subject: [PATCH] Remove old files and functions
---
R/leo_design.R | 89 --------------------
R/leo_format.R | 75 -----------------
R/leo_tab.R | 201 ----------------------------------------------
R/leo_table.R | 137 -------------------------------
leo_design_test.R | 17 ----
leo_format_test.R | 29 -------
leo_table_test.R | 71 ----------------
variancetest.R | 62 --------------
8 files changed, 681 deletions(-)
delete mode 100644 R/leo_design.R
delete mode 100644 R/leo_format.R
delete mode 100644 R/leo_tab.R
delete mode 100644 R/leo_table.R
delete mode 100644 leo_design_test.R
delete mode 100644 leo_format_test.R
delete mode 100644 leo_table_test.R
delete mode 100644 variancetest.R
diff --git a/R/leo_design.R b/R/leo_design.R
deleted file mode 100644
index 41be818..0000000
--- a/R/leo_design.R
+++ /dev/null
@@ -1,89 +0,0 @@
-#' Creates survey design objects for LEO 2010 and 2018.
-#'
-#' @param leodata Original dataframe of LEO 2010 or LLEO 2018.
-#' @param year Either 2010 or 2018.
-#' @return A survey design object.
-#'
-#' @export
-leo_getdesign <- function(leodata, year = 2018) {
-
- library(purrr)
- library(dplyr)
-
- # Lower variable names
- names(leodata) <- tolower(names(leodata))
-
- if (year == 2010) {
- # logits entfernen
- leodata <- leodata %>% select(-matches("^PV[1-5]$"))
- # Level und PV 2010 umbenennen
- data.table::setnames(leodata,
- old=c("pv1_62", "pv2_62", "pv3_62", "pv4_62", "pv5_62"),
- new=c("pv1", "pv2", "pv3", "pv4", "pv5"))
- data.table::setnames(leodata,
- old=c("pv1_alphalevel_62", "pv2_alphalevel_62", "pv3_alphalevel_62", "pv4_alphalevel_62", "pv5_alphalevel_62"),
- new=c("alpha.pv1", "alpha.pv2", "alpha.pv3", "alpha.pv4", "alpha.pv5"))
- }
-
- names(leodata) <- tolower(names(leodata))
-
- if (year == 2018) {
- # PV-Variable für Alpha 1-3 (gering literalisiert)
- leodata$alpha3.pv1 <- cut(leodata$alpha.pv1, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv2 <- cut(leodata$alpha.pv2, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv3 <- cut(leodata$alpha.pv3, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv4 <- cut(leodata$alpha.pv4, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv5 <- cut(leodata$alpha.pv5, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv6 <- cut(leodata$alpha.pv6, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv7 <- cut(leodata$alpha.pv7, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv8 <- cut(leodata$alpha.pv8, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv9 <- cut(leodata$alpha.pv9, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv10 <- cut(leodata$alpha.pv10, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- # Alpha-Level in Faktorvariable
- leodata <- leodata %>% mutate_at(vars(matches("^alpha.pv[0-9]+$")), to_factor)
- # Spaltennamen mit PVs und Leveln mit Hilfe eines regulären Ausdrucks (regexp) finden
- lit <- grep("^pv[0-9]+$", colnames(leodata), value = TRUE)
- alp <- grep("^alpha.pv[0-9]+$", colnames(leodata), value = TRUE)
- gl <- grep("^alpha3.pv[0-9]+$", colnames(leodata), value = TRUE)
- } else if (year == 2010) {
- # PV-Variable für Alpha 1-3 (gering literalisiert)
- leodata$alpha3.pv1 <- cut(leodata$alpha.pv1, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv2 <- cut(leodata$alpha.pv2, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv3 <- cut(leodata$alpha.pv3, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv4 <- cut(leodata$alpha.pv4, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- leodata$alpha3.pv5 <- cut(leodata$alpha.pv5, breaks = c(0, 3, 5), labels = c("gl", "nicht gl"))
- # Alpha-Level in Faktorvariable
- leodata <- leodata %>% mutate_at(vars(matches("^alpha.pv[1-5]$")), to_factor)
- # Spaltennamen mit PVs und Leveln mit Hilfe eines regulären Ausdrucks (regexp) finden
- lit <- grep("^pv[1-5]$", colnames(leodata), value = TRUE)
- alp <- grep("^alpha.pv[1-5]$", colnames(leodata), value = TRUE)
- gl <- grep("^alpha3.pv[1-5]$", colnames(leodata), value = TRUE)
- }
-
- # Spaltennamen der HG-Variablen
- alle <- leodata %>% select(-one_of(lit), -one_of(alp), -one_of(gl))
- alle <- colnames(alle)
-
- # Liste der Daten erstellen mit einer pv-Variable und einem Alpha-Level
- leoList <- lit %>%
- purrr::map(function(s) {select(leodata, alle, paste0("alpha.", s), paste0("alpha3.", s), s) %>%
- rename(pv := !!s) %>%
- rename(alpha.pv := !!paste0("alpha.", s)) %>%
- rename(alpha3.pv := !!paste0("alpha3.", s))})
-
- # Survey Design erstellen
- if (year == 2018) {
- # Survey Design erstellen
- leo_design <- survey::svydesign(
- ids = ~0,
- weights = ~pgewges,
- data = mitools::imputationList(leoList))
- } else if (year == 2010) {
- leo_design <- survey::svydesign(
- ids = ~0,
- weights = ~gewleointegr,
- data = mitools::imputationList(leoList))
- }
-
- return <- leo_design
-}
diff --git a/R/leo_format.R b/R/leo_format.R
deleted file mode 100644
index 1fa7bcb..0000000
--- a/R/leo_format.R
+++ /dev/null
@@ -1,75 +0,0 @@
-#' Condenses rows and columns of a frequency table by summing the cells.
-#'
-#' @param a A leo_table object.
-#' @param upper An integer.
-#' @param lower An integer.
-#' @param left An integer.
-#' @param right An integer.
-#' @return An xtabs object.
-#' @examples
-#' example <- example
-#'
-#' @export
-leo.format <- function(a, upper, lower, left, right) {
- stopifnot(inherits(a, what = "leo_table"))
-
- x <- dim(a)[1]
- y <- dim(a)[2]
-
- cs <- NULL
- rs <- NULL
-
- if (!missing(upper)) {
- a_upper <- t(matrix(colSums(a[1:upper,])))
- rownames(a_upper)[1] <- paste0("1:", upper)
- cs <- rbind(a_upper, a[(upper+1):x,])
- }
-
- if (!missing(lower)) {
- a_lower <- t(matrix(colSums(a[(x-lower+1):y,])))
- rownames(a_lower)[1] <- paste0((x-lower+1), ":", x)
- cs <- rbind(a[1:(x-lower),], a_lower)
- }
-
- if (!missing(upper) & !missing(lower)) {
- if ( upper + lower == x) {
- cs <- rbind(a_upper, a_lower)
- colnames(cs) <- colnames(a)
- } else {
- cs <- rbind(a_upper, a[(upper+1):(x-lower),])
- cs <- rbind(cs, a_lower)
- }
- }
-
- if (!is.null(cs)) {a <- cs}
-
- if (!missing(left)) {
- a_left <- matrix(rowSums(a[, 1:left]))
- colnames(a_left)[1] <- paste0("1:", left)
- rs <- cbind(a_left, a[,(left+1):y])
- }
-
- if (!missing(right)) {
- a_right <- matrix(rowSums(a[, (y-right+1):y]))
- colnames(a_right)[1] <- paste0((y-right+1),":", y)
- rs <- cbind(a[,1:(y-right)], a_right)
- }
-
- if (!missing(left) & !missing(right)) {
- if ( left + right == y) {
- rs <- cbind(a_left, a_right)
- rownames(rs) <- rownames(a)
- } else {
- rs <- cbind(a_left, a[,(left+1):(y-right)])
- rs <- cbind(rs, a_right)
- }
- }
-
- if (is.null(rs))
- {
- ret <- cs
- } else {
- ret <- rs
- }
-
-}
diff --git a/R/leo_tab.R b/R/leo_tab.R
deleted file mode 100644
index 9b38662..0000000
--- a/R/leo_tab.R
+++ /dev/null
@@ -1,201 +0,0 @@
-#' Creates survey design objects for LEO 2010 and 2018.
-#'
-#' @param varName Original dataframe of LEO 2010 or LLEO 2018.
-#' @param Richtung Either 2010 or 2018.
-#' @param sheet.name Either 2010 or 2018.
-#' @param Excel.Name Either 2010 or 2018.
-#' @param ListenName Either 2010 or 2018.
-#' @param pWert Either 2010 or 2018.
-#'
-#' @return A dataframe with frequencies
-#'
-#' @export
-leo_tab <- function(varName, Richtung = 1, sheet.Name = "Mappe", Excel.Name,
- ListenName = leoList, pWert=FALSE){
-
- if (file.exists(Excel.Name) && (sheet.Name %in% readxl::excel_sheets(Excel.Name))) {
- warning(sprintf("%s: Sheet already existing. Skipping calculations.", sheet.Name))
- return(NULL)
- }
-
- ### Chi2
- # Dummyvariablen erstellen
- ListenName <- lapply(leoList, function(x) {dummy_cols(x, select_columns = varName)})
-
- # das design für gewichtete Berechnungen im Datensatz erstellen
- desName <- svydesign(ids = ~0, weights = ~pgewges,
- data = mitools::imputationList(ListenName))
- # das Design für auf die Grundgesamtheit hochgerechnete Werte erstellen
- desOhne<- svydesign(ids = ~0, weights = ~1,
- data= mitools::imputationList(ListenName))
-
- if(Richtung == 1){
- i1 <- varName
- i2 <- 'alpha.pv'
- } else {
- i1 <- 'alpha.pv'
- i2 <- varName
- }
-
- ### Chi2 Berechnung ----
- # Hilfsfunktion, um micombine.chisquare nicht immer wiederholen zu müssen
- chi2.comb <- function(C) {
- micombine.chisquare(dk=sapply(C, FUN = function(x) x$statistic),
- df=mean(sapply(C, FUN = function(x) x$parameter)))
- }
- # Chi2 für die gesamte Tabelle
- chi.gesamt <- with(desName, svychisq(as.formula(paste0("~", i1, "+alpha2")), statistic ="Chisq"))
- chi.gesamt <- chi2.comb(chi.gesamt)
- cat(round(chi.gesamt["p"], 3))
- cat("\n")
-
- # Chi2 für einzelne Ausprägungen
- lvls <- levels(to_factor(leoList[[1]][[varName]], levels="labels"))
- #Levelnamen kürzen und Leerzeichen rausnehmen
- lvls.short <- gsub(" ", "_", lvls)
- #lvls.short <- substr(lvls.short, 0, 25)
-
- chiNames <- paste0(varName, "_", lvls.short)
- cat(chiNames)
- chilist <- list()
- bonferroni <- list()
- for (i in seq_along(chiNames)) {
- print(chiNames[[i]])
- chiformula <- as.formula(paste0("~",chiNames[[i]], "+alpha2"))
- chicomb <- chi2.comb(with(desName, svychisq(chiformula, statistic = "Chisq")))
- chilist[i] <- chicomb[["p"]]
- bonferroni[i] <- ifelse(chicomb[["p"]] < 0.05/length(lvls), "sig.", "n.s.")
- }
-
- chilist <- append(chilist, chi.gesamt["p"])
- bonferroni <- append(bonferroni, ifelse(chi.gesamt["p"] < 0.05, "sig.", "n.s."))
- cat(round(unlist(chilist),3))
- cat("\n")
- cat(unlist(bonferroni))
- cat("\n")
- chi2 <- data.frame(Chi2 = round(unlist(chilist), 3), Bonferroni = unlist(bonferroni))
-
- ### Absolute Werte UNGEWICHTET und für Signifikanz gewichtete für A1-3 vs. höher ----
- n.werte.alpha <- summary(MIcombine(with(desOhne, svyby(as.formula(paste0("~to_factor(", i1, ")")),
- as.formula(paste0("~to_factor(", i2, ")")), svytotal, na.rm=TRUE))))
-
- # Reihe mit sauberen Namen einfügen
- n.werte.alpha[,'nam'] <- rownames(n.werte.alpha)
- n.werte.alpha <- n.werte.alpha %>% mutate(nam1 = gsub(":to_factor.*$", "", nam)) %>%
- mutate(nam2 = gsub("^.*\\)", "", nam)) %>% select(-nam)
- # n.werte.alpha[paste0("nam", Richtung)] <- gsub("^a", "Alpha ", n.werte.alpha[[paste0("nam", Richtung)]])
-
- # und das Ganze noch mal für die binäre Variable
- n.werte.alpha.bi <- summary(MIcombine(with(desOhne,
- svyby(as.formula(paste0("~to_factor(", varName,")")), ~to_factor(alpha2), svytotal, na.rm=T))))
-
- # und auch hier saubere Namen einfügen
- n.werte.alpha.bi[,'nam'] <- rownames(n.werte.alpha.bi)
-
- if(Richtung == 1){
- n.werte.alpha.bi <- n.werte.alpha.bi %>% mutate(nam1 = gsub(":to_factor.*$", "", nam)) %>%
- mutate(nam2 = gsub("^.*\\)", "", nam)) %>% select(-nam)
- } else{
- n.werte.alpha.bi <- n.werte.alpha.bi %>% mutate(nam2 = gsub(":to_factor.*$", "", nam)) %>%
- mutate(nam1 = gsub("^.*\\)", "", nam)) %>% select(-nam)
- }
-
- # und für die Signifikanzen die gewichteten Anteile
- n.werte.alpha.bi.weighted <- summary(MIcombine(with(desName,
- svyby(as.formula(paste0("~to_factor(", varName, ")")),
- ~to_factor(alpha2), svytotal, na.rm = TRUE))))
- # und auch hier saubere Namen einfügen
- n.werte.alpha.bi.weighted[,'nam'] <- rownames(n.werte.alpha.bi.weighted)
-
- if(Richtung == 1){
- n.werte.alpha.bi.weighted <- n.werte.alpha.bi.weighted %>% mutate(nam1 = gsub(":to_factor.*$", "", nam)) %>%
- mutate(nam2 = gsub("^.*\\)", "", nam)) %>% select(-nam)
- } else{
- n.werte.alpha.bi.weighted <- n.werte.alpha.bi.weighted %>% mutate(nam2 = gsub(":to_factor.*$", "", nam)) %>%
- mutate(nam1 = gsub("^.*\\)", "", nam)) %>% select(-nam)
- }
-
- ### Anteile von Alpha-Leveln ----
- anteile.alpha <- summary(MIcombine(with(desName, svyby(as.formula(paste0("~to_factor(", i1, ")")),
- as.formula(paste0("~to_factor(", i2, ")")), svymean, na.rm=TRUE))))
- anteile.alpha[,'nam'] <- rownames(anteile.alpha)
- anteile.alpha <- anteile.alpha %>% mutate(nam1 = gsub(":to_factor.*$", "", nam)) %>%
- mutate(nam2 = gsub("^.*\\)", "", nam)) %>% select(-nam)
-
- ### Anteile von Gesamtbevölkerung ----
- anteile.gb <- summary(MIcombine(with(desName, svyby(as.formula(paste0("~to_factor(", varName, ")")),
- ~a, svymean, na.rm=TRUE))))
- anteile.gb[,'nam'] <- rownames(anteile.gb)
-
- if(Richtung == 1){
- anteile.gb <- anteile.gb %>% mutate(nam1 = gsub(".*", "GB", nam)) %>%
- mutate(nam2 = gsub(".*\\)", "", nam)) %>% select(-nam)
- anteile.gb[paste0("nam", Richtung)] <- gsub("^a" ,"Alpha ", anteile.gb[[paste0("nam", Richtung)]])
- }else {
- anteile.gb <- anteile.gb %>% mutate(nam2 = gsub(".*", "GB", nam)) %>%
- mutate(nam1 = gsub(".*\\)", "", nam)) %>% select(-nam)
- }
-
- ### Anteile von Alpha 1-3 vs. Rest ----
- if(Richtung == 1){
- anteile.alpha.bi <- summary(MIcombine(with(desName, svyby(as.formula(paste0("~to_factor(", i1, ")")),
- ~alpha2, svymean, na.rm=TRUE))))
- }else{
- anteile.alpha.bi <- summary(MIcombine(with(desName, svyby(~to_factor(alpha2),
- as.formula(paste0("~to_factor(", varName, ")")),
- svymean, na.rm=TRUE))))
- }
-
- anteile.alpha.bi[,'nam'] <- rownames(anteile.alpha.bi)
- anteile.alpha.bi <- anteile.alpha.bi %>% mutate(nam1 = gsub(":to_factor.*$", "", nam)) %>%
- mutate(nam2 = gsub("^.*\\)", "", nam)) %>% select(-nam)
-
- # Alle Anteile in einen Datensatz
- alle <- bind_rows(anteile.alpha, anteile.alpha.bi, anteile.gb)
-
- aTab <- alle %>%
- mutate(results = round(results * 100, 1)) %>%
- select(results, nam1, nam2) %>%
- pivot_wider(names_from = nam1, values_from = results)
-
- nTab <- n.werte.alpha %>%
- select(results, nam1, nam2) %>%
- pivot_wider(names_from = nam1, values_from = results) %>%
- select(-nam2)
- colnames(nTab) <- paste("n", colnames(nTab))
-
- nBi <- n.werte.alpha.bi %>%
- select(results, nam1, nam2) %>%
- pivot_wider(names_from = nam1, values_from = results) %>%
- select(-nam2) %>%
- mutate("GB" = rowSums(.))
- colnames(nBi) <- paste("n", colnames(nBi))
-
- rnames <- select(aTab, nam2)
- rnames[nrow(rnames) + 1,] <- "Sum"
- aTab <- select(aTab, -nam2)
- aTab <- bind_cols(aTab, nTab, nBi)
- aTab[nrow(aTab) + 1,] = colSums(aTab)
- aTab <- bind_cols(rnames, aTab)
-
- # Chi2 Hinzufügen
- if(Richtung==1) aTab <- add_column(aTab, Chi2 = chi2[[1]], Bonferroni = chi2[[2]], .after = 9)
-
- #umsortieren
- #if(Richtung == 1) aTab <- aTab[, c(1:6,9,7,8,11,10,12:ncol(aTab))]
- if(Richtung == 2) aTab <- aTab[c(1:5,8,6:7,9:nrow(aTab)),]
-
- # SPEICHERN
- if(sheet.Name == "Mappe") sheet.Name <- paste(varName, " (", Richtung, ")")
-
- write.xlsx(as.data.frame(aTab), Excel.Name, sheetName = sheet.Name , append = TRUE, row.names = FALSE)
- if(Richtung == 2) write.xlsx(chi2, Excel.Name, sheetName = paste0(sheet.Name, "_sig"), append = TRUE,
- row.names = FALSE)
-
- # wb <- openxlsx::createWorkbook()
- # openxlsx::addWorksheet(wb, sheetName = sheet.Name)
- # openxlsx::writeDataTable(wb, sheet = 1, x = aTab,colNames = TRUE, rowNames = FALSE, tableStyle = "none")
- # openxlsx::saveWorkbook(wb, Excel.Name)
-
- return(as.data.frame(aTab))
- }
diff --git a/R/leo_table.R b/R/leo_table.R
deleted file mode 100644
index c9ee1e6..0000000
--- a/R/leo_table.R
+++ /dev/null
@@ -1,137 +0,0 @@
-#' Calculates frequency tables for multiply imputed and weighted data.
-#'
-#' @param rowvar A vector or a dataframe of multiply imputed variables.
-#' @param colvar A vector or a dataframe of multiply imputed variables.
-#' @param supercolvar A vector or a dataframe of multiply imputed variables.
-#' @param weight A vector with frequency weights.
-#' @param data A dataframe that contains above variables
-#' @return An xtabs object.
-#' @examples
-#' leo <- haven::read_sav("~/leo.sav")
-#' leo$f001 <- labelled::to_factor(leo$f001)
-#' leo$altgr5 <- labelled::to_factor(leo$altgr5)
-#' pvs <- leo %>% select(matches("^alpha.pv[0-9]+")) %>% to_factor()
-#' # 1-way
-#' leo_table(rowvar = pvs, weight = leo$pgewges, data = leo)
-#' # 2-way
-#' leo_table(rowvar = leo$pol001, colvar = pvs, weight = leo$pgewges, data = leo)
-#' # 3-way
-#' leo_table(rowvar = pvs, colvar = leo$altgr5, supercolvar = leo$f001, weight = leo$pgewges, data = leo)
-#'
-#' @export
-leo_table <- function(rowvar, colvar, supercolvar, weight, data) {
- # check for missing and/or wrong arguments
- if (missing(data))
- stop("'data' is missing")
- if (missing(rowvar))
- stop("'rowvar' is missing")
- if (!missing(supercolvar) && missing (colvar))
- stop("'colvar' is missing")
-
- # deparse variables for later use
- rowvar_d <- deparse(substitute(rowvar))
- colvar_d <- deparse(substitute(colvar))
- supercolvar_d <- deparse(substitute(supercolvar))
-
- # if no weight is supplied, weight = 1 for every case
- if (missing(weight)) {
- data$weight_gen_38376z5 <- 1
- weight <- "weight_gen_38376z5"
- } else {
- weight <- deparse(substitute(weight))
- }
-
- # 1-way table ----
- if (missing(colvar) && missing(supercolvar)) {
- if (is.atomic(rowvar)) {
- cat("1-way table\n")
- f <- as.formula(paste(weight, "~", rowvar_d))
- tbl <- xtabs(formula = f, data = data)
- } else {
- cat("1-way table with multiple imputations\n")
- mi <- names(rowvar)
- tbl.list <- lapply(X = mi, FUN = function(x) {
- f <- as.formula(paste(weight, "~", x))
- xtabs(f, data = data)})
- tbl <- Reduce("+", tbl.list)/10
- names(attr(tbl, "dimnames")) <- c("mi")
- }
- }
-
- # 2-way table ----
- if (missing(supercolvar) && !missing(colvar)) {
- if (is.atomic(rowvar) && is.atomic(colvar)) {
- cat("2-way table\n")
- f <- as.formula(paste(weight, "~", rowvar_d, "+", colvar_d))
- tbl <- xtabs(formula = f, data = data)
- } else {
- cat("2-way table with multiple imputations\n")
- if (is.recursive(rowvar) && is.atomic(colvar)) {
- cat("rowvar is multiple imputed\n")
- mi <- names(rowvar)
- tbl.list <- lapply(X = mi, FUN = function(x) {
- f <- as.formula(paste(weight, "~", x, "+", colvar_d))
- xtabs(f, data = data)})
- tbl <- Reduce("+", tbl.list)/10
- names(attr(tbl, "dimnames"))[1] <- "mi"
- } else if (is.atomic(rowvar) && is.recursive(colvar)) {
- cat("colvar is multiple imputed\n")
- mi <- names(colvar)
- tbl.list <- lapply(X = mi, FUN = function(x) {
- f <- as.formula(paste(weight, "~", rowvar_d, "+", x))
- xtabs(f, data = data)})
- tbl <- Reduce("+", tbl.list)/10
- names(attr(tbl, "dimnames"))[2] <- "mi"
- } else {
- stop("only one variable can be multiply imputed")
- }
- }
- }
-
- # 3-way table ----
- if (!missing(supercolvar)) {
- if (is.atomic(rowvar) && is.atomic(colvar) && is.atomic(supercolvar)) {
- cat("3-way table\n")
- rowvar <- deparse(substitute(rowvar))
- colvar <- deparse(substitute(colvar))
- supercolvar <- deparse(substitute(supercolvar))
- f <- as.formula(paste(weight, "~", rowvar, "+", colvar, "+", supercolvar))
- tbl <- xtabs(formula = f, data = data)
- } else {
- cat("3-way table with multiple imputations\n")
- if (is.recursive(rowvar) && is.atomic(colvar) && is.atomic(supercolvar)) {
- cat("rowvar is multiple imputed\n")
- mi <- names(rowvar)
- tbl.list <- lapply(X = mi, FUN = function(x) {
- f <- as.formula(paste(weight, "~", x, "+", colvar_d, "+", supercolvar_d))
- xtabs(f, data = data)})
- tbl <- Reduce("+", tbl.list)/10
- names(attr(tbl, "dimnames"))[1] <- "mi"
- } else if (is.atomic(rowvar) && is.recursive(colvar) && is.atomic(supercolvar)) {
- cat("colvar is multiple imputed\n")
- mi <- names(colvar)
- tbl.list <- lapply(X = mi, FUN = function(x) {
- f <- as.formula(paste(weight, "~", rowvar_d, "+", x, "+", supercolvar_d))
- xtabs(f, data = data)})
- tbl <- Reduce("+", tbl.list)/10
- names(attr(tbl, "dimnames"))[2] <- "mi"
- } else if (is.atomic(rowvar) && is.atomic(colvar) && is.recursive(supercolvar)) {
- cat("supercolvar is multiple imputed\n")
- mi <- names(supercolvar)
- tbl.list <- lapply(X = mi, FUN = function(x) {
- f <- as.formula(paste(weight, "~", rowvar_d, "+", colvar_d, "+", x))
- xtabs(f, data = data)})
- tbl <- Reduce("+", tbl.list)/10
- names(attr(tbl, "dimnames"))[3] <- "mi"
- } else {
- stop("only one variable can be multiply imputed")
- }
- }
- }
-
- if (exists("tbl.list") == TRUE) attr(tbl, "tbl.list") <- tbl.list
-
- print(tbl)
- class(tbl) <- append(class(tbl),"leo_table")
- ret <- tbl
-}
diff --git a/leo_design_test.R b/leo_design_test.R
deleted file mode 100644
index 863470c..0000000
--- a/leo_design_test.R
+++ /dev/null
@@ -1,17 +0,0 @@
-rm(list=ls(all=TRUE)) # REMOVE ALL OBJECTS FROM WORKSPACE
-
-library(haven)
-library(leo)
-
-#leo2018 <- read_sav("C:/Users/Dutz/Documents/daten/leo2018/leo7192_mit_PVs_v1.1.sav")
-leo2010 <- read_sav("C:/Users/Dutz/Documents/daten/leo2010/Leo_Enddaten_mit_PVs.sav")
-
-#test2018 <- leo_getdesign(leo2018)
-leodata <- leo_getdesign(leo2010, year = 2010)
-
-
-lit <- grep("^pv[1-5]", colnames(leodata), value = TRUE)
-alp <- grep("^alpha.pv[1-5]", colnames(leodata), value = TRUE)
-gl <- grep("^alpha3.pv[1-5]", colnames(leodata), value = TRUE)
-
-alle <- leodata %>% select(-one_of(lit))
diff --git a/leo_format_test.R b/leo_format_test.R
deleted file mode 100644
index 800c377..0000000
--- a/leo_format_test.R
+++ /dev/null
@@ -1,29 +0,0 @@
-rm(list=ls(all=TRUE)) # REMOVE ALL OBJECTS FROM WORKSPACE
-
-library(haven)
-library(labelled)
-library(tidyverse)
-library(leo)
-
-leo <- read_sav("C:/Users/Dutz/Documents/daten/leo2018/leo7192_mit_PVs_v1.1.sav")
-names(leo) <- tolower(names(leo))
-
-pvs <- leo %>% select(matches("^alpha.pv[0-9]+")) %>% to_factor()
-
-leo$f001 <- to_factor(leo$f001)
-leo$altgr5 <- to_factor(leo$altgr5)
-leo$schulab <- to_factor(leo$schulab)
-leo$erstspr <- to_factor(leo$erstspr)
-leo$migra <- to_factor(leo$migra)
-
-t <- leo_table(leo$altgr5, pvs, weight = leo$pgewges, data = leo)
-class(t) <- append(class(t),"leo_table")
-
-t1 <- leo.format(t, right = 3)
-t1
-t2 <- leo.format(t, upper = 2)
-t2
-t3 <- leo.format(t, right = 3, upper = 2)
-t3
-t4 <- leo.format(t, right = 3, left = 2, lower = 2 , upper = 2)
-t4
diff --git a/leo_table_test.R b/leo_table_test.R
deleted file mode 100644
index c4084c3..0000000
--- a/leo_table_test.R
+++ /dev/null
@@ -1,71 +0,0 @@
-rm(list=ls(all=TRUE)) # REMOVE ALL OBJECTS FROM WORKSPACE
-
-library(haven)
-library(labelled)
-library(tidyverse)
-library(xlsx)
-library(leo)
-
-#leo <- read_sav("C:/Users/Dutz/Documents/daten/leo2018/leo7192_mit_PVs_v1.1.sav")
-leo <- read_sav("G:/leo2018/leo7192_mit_PVs_v1.1.sav")
-names(leo) <- tolower(names(leo))
-
-# Variablen in Faktoren umwandeln
-leo$pol001 <- to_factor(leo$pol001)
-leo$f001 <- to_factor(leo$f001)
-leo$altgr5 <- to_factor(leo$altgr5)
-
-# Alpha-Level in separatem DF speichern
-pvs <- leo %>% select(matches("^alpha.pv[0-9]+")) %>% to_factor()
-
-# ohne Alpha-Level
-# 1-way
-tbl1 <- leo_table(rowvar = leo$pol001, weight = leo$pgewges, data = leo)
-# 2-way
-tbl2 <- leo_table(rowvar = leo$pol001, colvar = leo$f001, weight = leo$pgewges, data = leo)
-# 3-way
-tbl3 <- leo_table(rowvar = leo$pol001, colvar = leo$altgr5, supercolvar = leo$f001, weight = leo$pgewges, data = leo)
-
-# mit Alpha-Level
-# 1-way
-leo_table(rowvar = pvs, weight = leo$pgewges, data = leo)
-# 2-way
-leo_table(rowvar = leo$pol001, colvar = pvs, weight = leo$pgewges, data = leo)
-leo_table(rowvar = pvs, colvar = leo$f001, weight = leo$pgewges, data = leo)
-# 3-way
-leo_table(rowvar = pvs, colvar = leo$altgr5, supercolvar = leo$f001, weight = leo$pgewges, data = leo)
-leo_table(rowvar = leo$altgr5, colvar = pvs, supercolvar = leo$f001, weight = leo$pgewges, data = leo)
-leo_table(rowvar = leo$altgr5, colvar = leo$f001, supercolvar = pvs, weight = leo$pgewges, data = leo)
-
-# In Excel-Datei schreiben
-write.xlsx(tbl1, "test.xlsx", sheetName = "tbl1",
- col.names = TRUE, row.names = FALSE, append = FALSE)
-write.xlsx(tbl2, "test.xlsx", sheetName = "tbl2",
- col.names = TRUE, row.names = FALSE, append = TRUE)
-write.xlsx(tbl3, "test.xlsx", sheetName = "tbl3",
- col.names = TRUE, row.names = FALSE, append = TRUE)
-
-tbl4 <- leo_table(rowvar = pvs, colvar = leo$altgr5, supercolvar = leo$f001, weight = leo$pgewges, data = leo)
-# Mit relativen Häufigkeiten für 3-way tables
-# Insgesamt = 100%
-prop.table(tbl4)
-# Reihen über alle Gruppen/supercolvar = 100%
-prop.table(tbl4, 1)
-# Spalten über alle Gruppen/supercolvar = 100%
-prop.table(tbl4, 2)
-# Jede Gruppe/supercolvar = 100%
-prop.table(tbl4, 3)
-# Jede Supercolvar = 100%
-prop.table(tbl4, c(3, 1)) # <- Wahrscheinlich am interessantesten
-# Jede Spalte in jeder Gruppe/supercolvar = 100%
-prop.table(tbl4, c(3, 2))
-
-# 3-way-table plotten
-tbl5 <- leo_table(pvs, leo$altgr5, leo$f001, leo$pgewges, leo)
-tbl5 <- prop.table(tbl5, c(3, 1))
-df5 <- data.frame(tbl5)
-ggplot(data = df5, aes(x = leo.altgr5, y = Freq, fill = leo.f001, label = round(Freq, 2))) +
- geom_bar(position = "dodge", stat = "identity") +
- facet_grid(mi ~ leo.f001) +
- scale_fill_brewer(palette = "Paired") +
- geom_text(aes(y=mean(Freq)), size = 3)
diff --git a/variancetest.R b/variancetest.R
deleted file mode 100644
index 52a1098..0000000
--- a/variancetest.R
+++ /dev/null
@@ -1,62 +0,0 @@
-rm(list=ls(all=TRUE)) # REMOVE ALL OBJECTS FROM WORKSPACE
-
-library(haven)
-library(labelled)
-library(tidyverse)
-library(xlsx)
-library(leo)
-
-leo <- read_sav("C:/Users/Dutz/Documents/daten/leo2018/leo7192_mit_PVs_v1.1.sav")
-names(leo) <- tolower(names(leo))
-
-# Alpha-Level in separatem DF speichern
-pvs <- leo %>% select(matches("^alpha.pv[0-9]+")) %>% to_factor()
-
-alpha <- leo.table(rowvar = pvs, weight = leo$pgewges, data = leo)
-
-alpha.prop <- prop.table(alpha)
-n <- sum(alpha.prop)
-
-mtr <- matrix(data = NA , nrow = NCOL(alpha.prop), ncol = NROW(alpha.prop))
-
-if (NCOL(alpha.prop) == 1 ) {
- for (x in 1:NROW(alpha.prop)) {
- mtr[x] <- sqrt((alpha.prop[x]*(1-alpha.prop[x]))/n)
- }
-}
-
-
-alpha.list <- attr(alpha, "tbl.list")
-
-alpha.prop.list <- lapply(alpha.list, prop.table)
-n <- table.sum <- sum(alpha.prop.list) # equals 1
-
-sqrt((table.prop[x, y] * (1 - table.prop[x, y])) / n)
-
-
-
-# leo <- read_sav("C:/Users/Dutz/Documents/daten/leo2018/leo7192_mit_PVs.sav")
-#
-# # Alpha-Level in separatem DF speichern
-# pvs <- leo %>% select(matches("^alpha.pv[0-9]+")) %>% to_factor()
-#
-# t <- leo.table(pvs, leo$pol001, weight = leo$pgewges, data = leo)
-
-leo2010 <- read_sav("C:/Users/Dutz/Documents/daten/leo2010/Leo_Enddaten_mit_PVs.sav")
-names(leo2010) <- tolower(names(leo2010))
-
-leo2010$f001 <- to_factor(leo2010$f001)
-pvs <- leo2010 %>% select(matches("^pv[0-9]+_alphalevel_62")) %>% to_factor()
-
-t <- prop.table(leo.table(pvs, leo2010$f001, weight = leo2010$gewleointegr, data = leo2010), 2)
-tbl.list <- attr(t, "tbl.list")
-tbl.list <- lapply(tbl.list, prop.table, margin = 2)
-
-mtr <- matrix(data = NA , nrow = dim(tbl.list[[1]])[1], ncol = dim(tbl.list[[1]])[2])
-m <- length(tbl.list) # number of imputations
-for (x in 1:dim(tbl.list[[1]])[1]) {
- for (y in 1:dim(tbl.list[[1]])[2]) {
- mtr[x,y] <- var(sapply(tbl.list, `[`, x, y))
- }
-}
-between <- mtr
--
GitLab