R/residuals.psych.R

In psych: Procedures for Psychological, Psychometric, and Personality Research

"residuals.psych" <- 
function(object,diag=TRUE,...) {
result <- NULL
if(length(class(object)) > 1)  {
obnames <- cs( fa, principal, omega, irt.fa, esem, extension)
extension <-  esem  <- NA
 value <- inherits(object, obnames, which=TRUE)
 if (any(value > 1)) {value <- obnames[which(value >0)]} else {value <- "none"} 
 } else {value <- "none"}
switch(value,

fa = {residual <- object$residual},
principal = {residual <- object$residual},
omega = {residual <- object$stats$residual},
irt.fa ={residual <- object$fa$residual},
esem = {residual <- object$residual},
extension = {residual <- object$resid},
none = {stop("No appropriate residual found")}
    )
if(!diag)  diag(residual) <- NA 
class(residual) <- c("psych","residuals")
return(residual)
}


#added January 30, 2012
"resid.psych" <- 
function(object,diag=TRUE,...) {
    residuals(object,diag=diag,...)
}




#added Feb 4, 2012
#modified April 15, 2016 to add chisquare and histograms as well as to identify variables
#modified June 23, 2016 to make the names on the right hand side have pos=2
"plot.residuals" <-
function(x,main,type=c("qq","chi","hist","cor"),std,bad=4,numbers=TRUE,upper=FALSE,diag=FALSE,...) {
if(missing(type)) type <- "qq"
nr <- nrow(x)
nc <- ncol(x)
if(!is.null(rownames(x))) {rname <- rownames(x)} else {rname <- paste0("V",1:nr)}
diag(x) <- NA

switch(type,
hist = {
if(missing(std)) std <- FALSE
x <- x[lower.tri(x,diag=TRUE)]
std.x <- x/sd(x,na.rm=TRUE)
if(std) {if(missing(main)) main <- "Histogram of standardized residuals"
   hist(std.x,main=main,...)} else {
if(missing(main)) main <- "Histogram of residuals"
hist(x,main=main,...)}},

qq= {  if(missing(std)) std <- TRUE
		x <- x[lower.tri(x,diag=TRUE)]
		if(std) {
     	if(missing(main)) main <- "Plot of standardized residuals"
		std.x <- x/sd(x,na.rm=TRUE)
		xy <- qqnorm(std.x,main=main)
		qqline(std.x)
		 worst <- order(abs(std.x), decreasing = TRUE)
		} else {
		  if(missing(main)) main <- "Plot of raw residuals"
		xy <- qqnorm(x,main=main,...)
		qqline(x)
		worst <- order(abs(x), decreasing = TRUE)}

    worstItems <- arrayInd(worst[1:bad],c(nr,nc))
    pos <- rep(4,bad)
    pos[x[worst[1:bad]]>0] <- 2
    text(xy$x[worst[1:bad]],xy$y[worst[1:bad]],paste(rname[worstItems[,2]],rname[worstItems[,1]]),pos=pos,...)
},

chi = {#note that xy reported for qqplot is already sorted
 if(missing(std)) std <- TRUE
   x <- x[lower.tri(x,diag=TRUE)] 
  if(std) {x <- x/sd(x,na.rm=TRUE)
           if(missing(main)) main <- "Plot of squared standardized residuals"} else {
           if(missing(main)) main <- "Plot of squared residuals"}
  nx <- length(x) - nr
xy <-   qqplot(qchisq(ppoints(nx),df=1),y=x^2,main=main,ylab="Quantiles of Squared residuals",xlab="Expected value for quantile")
  qqline(x^2,distribution=function(p) qchisq(p,df=1))
   worst <- order(abs(x^2), decreasing = TRUE)
 worstItems <- arrayInd(worst[1:5],c(nr,nc))
 text(xy$x[nx:(nx-4)],xy$y[nx:(nx-4)],paste(rname[worstItems[,2]],rname[worstItems[,1]]),pos=2,...)
  },

cor= {if(missing(main)) main <- "Plot of residual correlations"
cor.plot(x,main=main,numbers=numbers,upper=upper,diag=diag)})

}