1## Enhancement of na.omit  F. Harrell 20 Oct 91
2## Allows an element of the data frame to be another data frame
3## Note: S does not invoke na.action if only a data frame variable is missing!
4
5na.delete <- function(frame)
6{
7  y.detail <- na.detail.response(frame)
8  n <- length(frame)
9  omit <- FALSE
10  vars <- seq(length = n)
11  nmiss <- rep(0,n)
12  storage.mode(nmiss) <- "integer"
13  for(j in vars) {
14    x <- frame[[j]]
15    if(is.data.frame(x))
16      x <- as.matrix(x)
17
18    oldClass(x) <- NULL	#so Surv object is.na ignored
19    if(!is.atomic(x))
20      stop("non-atomic, non-data frame variables not allowed")
21
22    ## variables are assumed to be either some sort of matrix, numeric or cat'y
23    isna <- is.na(x)	#Change from T. Therneau
24    d <- dim(x)
25    if(is.null(d) || length(d) != 2) {
26      ##isna <- is.na(x)
27      nmiss[j] <- sum(isna)
28      omit <- omit | isna
29    } else {
30      ##isna <-is.na(x %*% rep(0,d[2]))
31      isna <- (isna %*% rep(1,d[2])) > 0
32      nmiss[j] <- sum(isna)
33      omit <- omit | isna
34    }
35  }
36
37  if(any(omit)) {
38    rn <- row.names(frame)
39
40    frame <- frame[!omit,,drop=FALSE]
41    names(nmiss) <- names(frame)
42    ## a %ia% b terms are included - delete them since main effects
43    ## already counted  (next 2 stmts reinstated 27Oct93)
44
45    i <- grep("%ia%", names(nmiss))
46    if(length(i)>0)
47      nmiss <- nmiss[-i]
48
49    attr(frame,"nmiss") <- nmiss    # for backward compatibility
50    temp <- seq(omit)[omit]
51    names(temp) <- rn[omit]
52    na.info <- list(nmiss=nmiss, omit=temp,
53                    na.detail.response=y.detail)
54
55    oldClass(na.info) <- "delete"
56    attr(frame, "na.action") <- na.info
57  }
58
59  frame
60}
61
62
63naprint.delete <- function(x, ...)
64{
65  if(length(g <- x$nmiss)) {
66    cat("Frequencies of Missing Values Due to Each Variable\n")
67    print(g)
68    cat("\n")
69  }
70
71  if(length(g <- x$na.detail.response)) {
72    cat("\nStatistics on Response by Missing/Non-Missing Status of Predictors\n\n")
73    print(oldUnclass(g))
74    cat("\n")
75  }
76
77  invisible()
78}
79
80
81naresid.delete <- napredict.delete <- function(omit, x, ...)
82{
83  omit <- omit$omit
84  ## 28Oct99:
85  if(exists('naresid.omit'))
86    naresid.omit(omit, x)
87  else {
88    if(.R. && !existsFunction('naresid.exclude'))
89      naresid.exclude <- getFromNamespace('naresid.exclude','stats')
90
91    naresid.exclude(omit, x)
92  }
93}
94
95
96nafitted.delete <- function(obj, x)
97{
98  omit <- obj$omit
99  if(exists('naresid.omit'))
100    naresid.omit(omit, x)
101  else
102    naresid.exclude(omit, x)
103}
104