-
Notifications
You must be signed in to change notification settings - Fork 2
/
removeValLabels.R
84 lines (77 loc) · 3.24 KB
/
removeValLabels.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
#### Remove value label
#############################################################################
#' Remove value labels.
#'
#' Remove value labels of a variable as part of a \code{GADSdat} or \code{all_GADSdat} object.
#'
#' If the argument \code{valLabel} is provided the function checks for \code{value} and \code{valLabel} pairs in the
#' meta data that match both arguments.
#'
#'@param GADSdat \code{GADSdat} object imported via \code{eatGADS}.
#'@param varName Character string of a variable name.
#'@param value Numeric values.
#'@param valLabel [optional] Regular expressions in the value labels corresponding to \code{value}.
#'
#'@return Returns the \code{GADSdat} object with changed meta data.
#'
#'@examples
#'# Remove a label based on value
#'extractMeta(pisa, "schtype")
#'pisa2 <- removeValLabels(pisa, varName = "schtype", value = 1)
#'extractMeta(pisa2, "schtype")
#'
#'# Remove multiple labels based on value
#'extractMeta(pisa, "schtype")
#'pisa3 <- removeValLabels(pisa, varName = "schtype", value = 1:3)
#'extractMeta(pisa3, "schtype")
#'
#'# Remove multiple labels based on value - valLabel combination
#'extractMeta(pisa, "schtype")
#'pisa4 <- removeValLabels(pisa, varName = "schtype",
#' value = 1:3, valLabel = c("Gymnasium", "other", "several courses"))
#'extractMeta(pisa4, "schtype")
#'
#'@export
removeValLabels <- function(GADSdat, varName, value, valLabel = NULL) {
UseMethod("removeValLabels")
}
#'@export
removeValLabels.GADSdat <- function(GADSdat, varName, value, valLabel = NULL) {
checkValRemoveInput(varName = varName, value = value, labels = GADSdat$labels)
all_rows <- which(GADSdat$labels$varName == varName)
remove_rows <- which(GADSdat$labels$varName == varName & GADSdat$labels$value %in% value)
if(!is.null(valLabel)) {
if(length(value) != length(valLabel)) stop("'value' and 'valLabel' need to be of identical length.")
remove_rows <- integer(0)
for(i in seq_along(value)) {
remove_rows <- c(remove_rows, which(GADSdat$labels$varName == varName &
GADSdat$labels$value == value[i] &
grepl(valLabel[i], GADSdat$labels$valLabel)))
}
}
if(length(remove_rows) == 0) {
warning("None of 'value' are labeled 'values'. Meta data are unchanged.")
return(GADSdat)
}
if(length(all_rows) > length(remove_rows)) {
GADSdat$labels <- GADSdat$labels[-remove_rows, ]
}
if(length(all_rows) == length(remove_rows)) {
if(length(remove_rows) > 1) {
remove_rows2 <- remove_rows[-1]
GADSdat$labels <- GADSdat$labels[-remove_rows2, ]
}
GADSdat$labels[remove_rows[1], c("value", "valLabel", "missings")] <- NA
GADSdat$labels[remove_rows[1], c("labeled")] <- "no"
}
GADSdat
}
#'@export
removeValLabels.all_GADSdat <- function(GADSdat, varName, value, valLabel = NULL) {
stop("This method has not been implemented yet")
}
checkValRemoveInput <- function(varName, value, labels) {
if(!is.character(varName) || !length(varName) == 1) stop("'varName' is not a character vector of length 1.")
if(!varName %in% labels$varName) stop("'varName' is not a variable name in the GADSdat.")
return()
}