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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
setGeneric("prep_for_tibble",function(x,...)standardGeneric("prep_for_tibble"))
setMethod("prep_for_tibble",signature(x="item.vector"),function(x,...)
prep_for_tibble_item_vector(x))
prep_for_tibble_item_vector <- function(x,...){
y <- if(inherits(x,"character.item")) as.character(x)
else if(is.ordinal(x)) as.ordered(x)
else if(is.nominal(x)) as.factor(x)
else as.vector(x)
d <- description(x)
if(length(d))
attr(y,"label") <- d
return(y)
}
as_tibble.data.set <- function(x, ...){
y <- lapply(x@.Data,
prep_for_tibble_item_vector)
names(y) <- names(x)
attr(y,"row.names") <- x@row_names
class(y) <- c("tbl_df","tbl","data.frame")
return(y)
}
sanitize_labels <- function(labels){
labn <- names(labels)
if(length(unique(labels)) < length(labn)){
dup <- duplicated(labels)
warning(sprintf("Dropped non-unique label(s) %s",
paste(paste(labn[dup],"=",labels[dup]),collapse=", ")),
call.=FALSE,immediate.=TRUE)
labels <- labels[!dup]
}
labels
}
setOldClass("labelled")
setMethod("as.item",signature(x="labelled"),function(x,...){
annotation <- c(description=attr(x,"label",exact=TRUE))
labels <- attr(x,"labels",exact=TRUE)
labels <- sanitize_labels(labels)
attributes(x) <- NULL
as.item(x,labels=labels,
annotation=annotation)
})
setMethod("codebookEntry","labelled",function(x){
x <- as.item(x)
annotation <- annotation(x)
spec <- c(
"Storage mode:"=storage.mode(x),
"Measurement:"="undefined"
)
new("codebookEntry",
spec = spec,
stats = codebookStatsCateg(x),
annotation = annotation
)
})
# if(!requireNamespace("haven",quietly = TRUE))
setOldClass("haven_labelled")
setMethod("as.item",signature(x="haven_labelled"),function(x,...){
annotation <- c(description=attr(x,"label",exact=TRUE))
labels <- attr(x,"labels",exact=TRUE)
labels <- sanitize_labels(labels)
attributes(x) <- NULL
as.item(x,labels=labels,
annotation=annotation)
})
setMethod("codebookEntry","haven_labelled",function(x){
x <- as.item(x)
annotation <- annotation(x)
spec <- c(
"Storage mode:"=storage.mode(x),
"Measurement:"="undefined"
)
new("codebookEntry",
spec = spec,
stats = codebookStatsCateg(x),
annotation = annotation
)
})
# if(!requireNamespace("haven",quietly = TRUE))
setOldClass("haven_labelled_spss")
setMethod("as.item",signature(x="haven_labelled_spss"),function(x,...){
annotation <- c(description=attr(x,"label",exact=TRUE))
labels <- attr(x,"labels",exact=TRUE)
labels <- sanitize_labels(labels)
mis_range <- attr(x,"na_range")
mis_values <- attr(x,"na_values")
attributes(x) <- NULL
value_filter <- new("missing.values",
filter=mis_values,
range=mis_range)
as.item(x,labels=labels,
annotation=annotation,
value.filter=value_filter)
})
setMethod("codebookEntry","haven_labelled_spss",function(x){
x <- as.item(x)
annotation <- annotation(x)
filter <- x@value.filter
spec <- c(
"Storage mode:"=storage.mode(x),
"Measurement:"="undefined"
)
if(length(filter)) spec <- c(spec,
switch(class(filter),
missing.values = c("Missing values:" = format(filter)),
valid.values = c("Valid values:" = format(filter)),
valid.range = c("Valid range:" = format(filter))
))
new("codebookEntry",
spec = spec,
stats = codebookStatsCateg(x),
annotation = annotation
)
})
setGeneric("as_haven",function(x,...)standardGeneric("as_haven"))
setMethod("as_haven",signature(x="data.set"),function(x,user_na=FALSE,...){
y <- lapply(x@.Data,as_haven,user_na=user_na,...)
names(y) <- names(x)
names(y) <- gsub(".","_",names(y),fixed=TRUE)
attr(y,"row.names") <- x@row_names
class(y) <- c("tbl_df","tbl","data.frame")
return(y)
})
setMethod("as_haven",signature(x="item.vector"),function(x,user_na=FALSE,...){
y <- x@.Data
if(length(description(x)))
attr(y,"label") <- description(x)
if(is.character(x))
labels(x) <- NULL
if(length(labels(x))){
l <- as.vector(labels(x))
storage.mode(y) <- "integer"
storage.mode(l) <- "integer"
attr(y,"labels") <- l
ms <- missing.values(x)
if(user_na && length(ms)){
attr(y,"na_values") <- as.integer(ms@filter)
attr(y,"na_range") <- as.integer(ms@range)
class(y) <- "haven_labelled_spss"
} else {
ism <- is.missing(x)
y[ism] <- NA
class(y) <- "haven_labelled"
}
}
return(y)
})
|
