-
Notifications
You must be signed in to change notification settings - Fork 2
/
getChangeMeta.R
112 lines (105 loc) · 4.72 KB
/
getChangeMeta.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
#### Extract Change Meta data on Variable Level
#############################################################################
#' Extract table for Meta Data Changes.
#'
#' Function to obtain a data frame from a \code{GADSdat} object for for changes to meta data on variable or on value level.
#'
#' Changes on variable level include variable names (\code{varName}), variable labels (\code{varLabel}),
#' SPSS format ((\code{format})) and display width (\code{display_width}).
#' Changes on value level include values (\code{value}), value labels (\code{valLabel}) and
#' missing codes (\code{missings}).
#'
#'@param GADSdat \code{GADSdat} object imported via \code{eatGADS}.
#'@param level \code{'variable'} or \code{'value'}.
#'
#'@return Returns the meta data sheet for all variables including the corresponding change columns.
#'
#'@examples
#'# For changes on variable level
#'varChangeTable <- getChangeMeta(pisa, level = "variable")
#'
#'# For changes on value level
#'valChangeTable <- getChangeMeta(pisa, level = "value")
#'
#'@export
getChangeMeta <- function(GADSdat, level = "variable") {
UseMethod("getChangeMeta")
}
#'@export
getChangeMeta.GADSdat <- function(GADSdat, level = "variable") {
check_GADSdat(GADSdat)
labels <- GADSdat[["labels"]]
if(identical(level, "variable")) {
oldCols <- c("varName", "varLabel", "format", "display_width")
newCols <- paste0(oldCols, "_new")
for(n in newCols) labels[, n] <- NA
change_sheet <- unique(labels[, c(oldCols, newCols)])
return(new_varChanges(change_sheet))
}
if(identical(level, "value")) {
oldCols <- c("value", "valLabel", "missings")
newCols <- paste0(oldCols, "_new")
for(n in newCols) labels[, n] <- NA
change_sheet <- labels[, c("varName", oldCols, newCols)]
return(new_valChanges(change_sheet))
}
stop("Invalid level argument.")
}
#'@export
getChangeMeta.all_GADSdat <- function(GADSdat, level = "variable") {
check_all_GADSdat(GADSdat)
changeSheet_list <- lapply(names(GADSdat$datList), function(nam ) {
single_GADSdat <- extractGADSdat(GADSdat, name = nam)
getChangeMeta(single_GADSdat, level = level)
})
names(changeSheet_list) <- names(GADSdat$datList)
changeSheet_list
}
new_varChanges <- function(df) {
stopifnot(is.data.frame(df))
structure(df, class = c("varChanges", "data.frame"))
}
check_varChanges <- function(changeTable, checkVarNames) {
if(!is.data.frame(changeTable)) stop("changeTable is not a data.frame.")
colNames <- c("varName", "varLabel", "format", "display_width")
colNames <- c(colNames, paste0(colNames, "_new"))
if(any(!names(changeTable) %in% colNames)) stop("Irregular column names in changeTable.")
# tbd: content checks for format and display width
# SQLite compliance
if(checkVarNames) {
not_na <- !is.na(changeTable$varName_new)
changeTable$varName_new[not_na] <- checkVarNames(as.character(changeTable$varName_new[not_na]))
}
changeTable
}
new_valChanges <- function(df) {
stopifnot(is.data.frame(df))
structure(df, class = c("valChanges", "data.frame"))
}
check_valChanges <- function(changeTable) {
if(!is.data.frame(changeTable)) stop("changeTable is not a data.frame.")
# Columns
oldCols <- c("value", "valLabel", "missings")
newCols <- paste0(oldCols, "_new")
colNames <- c("varName", oldCols, newCols)
if(any(!names(changeTable) %in% colNames)) stop("Irregular column names in changeTable.")
# Values in columns
if(!all(changeTable[, "missings_new"] %in% c("miss", "valid") | is.na(changeTable[, "missings_new"]))) {
stop("Irregular values in 'missings_new' column.")
}
# Numeric value columns
if(is.character(changeTable[, "value_new"])) {
changeTable[, "value_new"] <- suppressWarnings(eatTools::asNumericIfPossible(changeTable[, "value_new"],
force.string = FALSE))
if(is.character(changeTable[, "value_new"])) stop("Column 'value_new' in 'changeTable' is character and can not be transformed to numeric.")
}
if(is.character(changeTable[, "value"])) {
changeTable[, "value"] <- suppressWarnings(eatTools::asNumericIfPossible(changeTable[, "value"],
force.string = FALSE))
if(is.character(changeTable[, "value"])) stop("Column 'value' in 'changeTable' is character and can not be transformed to numeric.")
}
wrong_new_miss <- which((changeTable$missings_new == "miss" | !is.na(changeTable$valLabel_new))
& is.na(changeTable$value) & is.na(changeTable$value_new))
if(length(wrong_new_miss) > 0) stop("Value 'NA' can not receive a value label.")
changeTable
}