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
|
impute <- function(x, ...) UseMethod("impute")
impute.default <- function(x, fun=median, ...)
{
m <- is.na(x)
k <- sum(m)
if(k==0)
return(x)
nam <- names(x)
if(!length(nam)) {
nam <- as.character(1:length(x)); names(x) <- nam
}
if(!is.function(fun)) {
fill <- fun
if(is.character(fill) && length(fill)==1 && fill=="random")
fill <- sample(x[!is.na(x)], sum(is.na(x)), replace=TRUE)
} else if(is.factor(x)) {
freq <- table(x)
fill <- names(freq)[freq==max(freq)][1] #take first if not unique
} else
fill <-
if(missing(fun) && is.logical(x))
(if(sum(x[!m]) >= sum(!m)/2)
TRUE
else
FALSE)
else
fun(x[!m])
## median(logical vector) doesn't work - know trying to get median
## if fun is omitted. Get mode.
if(length(fill)>1 && length(fill)!=k)
stop("length of vector of imputed values != no. NAs in x")
## lab <- label(x)
## if(is.null(lab) || lab=="") lab <- name
## lab <- paste(lab,"with",sum(m),"NAs imputed to",format(fill))
## attr(x, "label") <- lab
if(is.factor(x)) {
newlev <- sort(unique(fill))
if(any(!(z <- newlev %in% levels(x)))) {
xc <- as.character(x)
xc[m] <- fill
x <- factor(xc, c(levels(x), newlev[!z]))
} else x[m] <- fill
} else x[m] <- fill
structure(x, imputed=(1:length(x))[m],
class=c('impute', attr(x, 'class')))
}
print.impute <- function(x, ...)
{
i <- attr(x,"imputed")
if(!length(i)) {
print.default(x);
return(invisible())
}
if(is.factor(x))
w <- as.character(x)
else
w <- format(x)
names(w) <- names(x)
w[i] <- paste(w[i], "*", sep="")
attr(w, "label") <- attr(w,"imputed") <- attr(w, "class") <- NULL
print.default(w, quote=FALSE)
invisible()
}
summary.impute <- function(object, ...)
{
i <- attr(object, "imputed")
oi <- object
attr(oi,'class') <- attr(oi,'class')[attr(oi,'class')!="impute"]
oi <- oi[i]
if(all(oi==oi[1]))
cat("\n",length(i),"values imputed to",
if(is.numeric(oi))
format(oi[1])
else
as.character(oi[1]),
"\n\n")
else {
cat("\nImputed Values:\n\n")
if(length(i)<20)
print(oi)
else
print(describe(oi, descript=as.character(sys.call())[2]))
cat("\n")
}
NextMethod("summary")
}
"[.impute" <- function(x, ..., drop=FALSE)
{
ats <- attributes(x)
ats$dimnames <- NULL
ats$dim <- NULL
ats$names <- NULL
attr(x,'class') <- NULL
y <- x[..., drop = drop]
if(length(y)==0)
return(y)
k <- 1:length(x);
names(k) <- names(x)
k <- k[...]
attributes(y) <- c(attributes(y), ats)
imp <- attr(y, "imputed")
attr(y, "imputed") <- j <- (1:length(k))[k %in% imp]
if(length(j)==0) {
cy <- attr(y,'class')[attr(y,'class')!='impute']
y <- structure(y, imputed=NULL,
class=if(length(cy))
cy
else
NULL)
}
y
}
is.imputed <- function(x)
{
w <- rep(FALSE, if(is.matrix(x))nrow(x) else length(x))
if(length(z <- attr(x,"imputed")))
w[z] <- TRUE
w
}
as.data.frame.impute <- function(x, row.names = NULL, optional = FALSE, ...)
{
nrows <- length(x)
if(!length(row.names)) {
## the next line is not needed for the 1993 version of data.class and is
## included for compatibility with 1992 version
if(length(row.names <- names(x)) == nrows &&
!anyDuplicated(row.names)) {
} else if(optional)
row.names <- character(nrows)
else
row.names <- as.character(1:nrows)
}
value <- list(x)
if(!optional)
names(value) <- deparse(substitute(x))[[1]]
structure(value, row.names=row.names, class='data.frame')
}
|
