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