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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
view <- function(x,
title=deparse(substitute(x)),
vfunc=getOption("vfunc","View"),
...)
{
# cls <- class(x)
# title <- paste0(cls,": ",title)
prepd <- viewPrep(x,title,...)
title <- attr(prepd,"title")
View.call <- call(vfunc,x=prepd,title=title)
eval(View.call,globalenv())
}
viewPrep <- function(x,title,...)UseMethod("viewPrep")
viewPrep.default <- function(x,title,...){
return(structure(x,title=title))
}
viewPrep.data.set <- function(x,title,...){
# title <- paste("Data set:",title)
Data <- lapply(x@.Data,format,justify="left")
frame <- structure(Data,
row.names=x@row_names,
names=x@names,
class="data.frame")
for(n in names(frame)){
d <- description(x[[n]])
if(length(d))
attr(frame[[n]],"label") <- d
}
return(structure(frame,title=title))
}
viewPrep.data.frame <- function(x,title,...){
structure(x,title=title)
}
viewPrep.descriptions <- function(x,title,...){
# title <- paste("Descriptions:",title)
viewPrep.data.frame(as.data.frame(x),
title=title,
...)
}
parse_string <- function(x)parse(file=NULL,text=x)
format_lab_view <- function(x){
fmt <- paste(unname(x),sQuote(names(x)))
fmt <- paste(fmt,collapse=", ")
return(fmt)
}
in_range <- function(x,rng){
x >= rng[1] & x <= rng[2]
}
view1cp <- function(x){
n <- x["name"]
d <- x["description"]
l <- x["labels"]
if(nzchar(l))
l <- eval(parse(text=l))
else
l <- NULL
ms <- x["measurement"]
vf <- x["value.filter"]
if(nzchar(vf)){
vf <- paste0("list(",vf,")")
vf <- eval(parse(text=vf))
cl <- names(vf)
vf <- vf[[1]]
if(cl=="missing")
vf <- new("missing.values",
filter=vf$values,
range=vf$range
)
else if(cl=="valid"){
if(length(vf$values))
vf <- new("valid.values",filter=vf$values)
else if(length(vf$range))
vf <- new("valid.range",filter=vf$range)
}
} else vf <- NULL
nl <- length(l)
tab <- matrix("",ncol=4,nrow=max(1,nl))
colnames(tab) <- c("variable","description","value","label")
tab[1,1] <- n
tab[1,2] <- d
omtab <- NULL
if(nl>0){
if(length(vf))
ism <- is.missing2(l,vf)
else
ism <- FALSE
tab[1:nl,3] <- paste(unname(l),ifelse(ism,"M"," "))
tab[1:nl,4] <- names(l)
if(length(vf) && inherits(vf,"missing.values")){
if(length(vf@filter) && any(vf@filter %nin% l)){
omiss <- setdiff(vf@filter,l)
omiss <- paste(omiss,"M")
omtab <- rbind(omtab,cbind("","",omiss,"(unlabelled)"))
}
# if(length(vf@range) && any(!in_range(l,vf@range))){
# omiss <- paste(vf@range[1],"--",vf@range[2],"M")
# omtab <- rbind(omtab,cbind("","",omiss,"(unlabelled)"))
# }
}
} else if(length(vf)){
if(inherits(vf,"missing.values")){
if(length(vf@filter)){
omiss <- setdiff(vf@filter,l)
omiss <- paste(omiss,"M")
omtab <- rbind(omtab,cbind("","",omiss,"(unlabelled)"))
}
if(length(vf@range)){
omiss <- paste(vf@range[1],"--",vf@range[2],"M")
omtab <- rbind(omtab,cbind("","",omiss,"(unlabelled)"))
}
} else if(inherits(vf,"valid.values")){
nvd <- length(vf@filter)
if(nvd > 1)
tab <- rbind(tab,matrix("",ncol=ncol(tab),nrow=nvd-1))
tab[1:nvd,3] <- paste(vf@filter," ")
tab[1:nvd,4] <- "(unlabelled)"
} else if(inherits(vf,"valid.range")){
tab[1,3] <- paste(vf@filter[1],"--",vf@filter[2]," ")
tab[1:nvd,4] <- "(unlabelled)"
}
}
if(length(omtab)){
tab <- rbind(tab,omtab)
}
return(tab)
}
viewPrep.codeplan <- function(x,title,compact=FALSE,...){
# title <- paste("Code plan:",title)
if(compact){
labels <- x$labels
nll <- nzchar(labels)
labels <- as.list(labels)
labels[nll] <- lapply(labels[nll],parse_string)
labels[nll] <- lapply(labels[nll],eval)
labels[nll] <- lapply(labels[nll],format_lab_view)
labels <- unlist(labels)
frame <- data.frame(variable=x$name,
description=x$description,
labels=labels,
value.filter=x$value.filter)
viewPrep.data.frame(frame,
title=title,
...)
}
else {
if(nrow(x)>1){
tabs <- apply(x,1,view1cp)
tab <- do.call(rbind,tabs)
}
else
tab <- view1cp(unlist(x))
tab[,3] <- format(trimws(tab[,3]),justify="right",width=5)
viewPrep.default(tab,
title=title,
...)
}
}
viewPrep.importer <- function(x,title,compact=TRUE,...){
cp <- codeplan(x)
viewPrep.codeplan(x=cp,title=title,compact=compact,...)
}
|
