Nothing
#Adapted from the help for pairs
#modified December 15, 2011 to add the rug option
#further modified March 30, 2012 to add the method of correlation option (suggested by Carsten Dormann).
#Fixed a bug in show.points on March 18, 2017 (reported by Matthew Labrum)
#August 11, 2017 Added confidence intervals and adjust the histogram so it lines up with wht data points (suggested by Julan Martin)
#by moving all the little functions to be outside the main function, this allows method and rug to be passed to these lower order functions.
#this should allow for somewhat cleaner code for the other functions
#modified March 15, 2015 to add the ability to control the size of the correlation separately from the cex variable in the points
#also added the ability to set the number of breaks in the histograms
#added the hist.border parameter as suggested by Jordan Adamson (2/11/24)
"pairs.panels" <-
function (x, smooth = TRUE, scale = FALSE, density=TRUE,ellipses=TRUE,digits = 2, method="pearson",pch = 20,
lm=FALSE,cor=TRUE,jiggle=FALSE,factor=2,hist.col="cyan",show.points=TRUE,rug=TRUE, breaks="Sturges",
cex.cor = 1 ,wt=NULL,smoother=FALSE,stars=FALSE,ci=FALSE,alpha=.05,
hist.border="black",...) #combines a splom, histograms, and correlations
{
#First define all the "little functions" that are internal to pairs.panels. This allows easier coding later
"panel.hist.density" <-
function(x,...) {
usr <- par("usr"); on.exit(par("usr"))
# par(usr = c(usr[1]-abs(.05*usr[1]) ,usr[2]+ abs(.05*usr[2]) , 0, 1.5) )
par(usr = c(usr[1] ,usr[2] , 0, 1.5) )
tax <- table(x)
if(length(tax) < 11) {breaks <- as.numeric(names(tax))
y <- tax/max(tax)
interbreak <- min(diff(breaks))*(length(tax)-1)/41
rect(breaks-interbreak,0,breaks + interbreak,y,col=hist.col,border=hist.border)
} else {
h <- hist(x,breaks=breaks, plot = FALSE)
breaks <- h$breaks; nB <- length(breaks)
y <- h$counts; y <- y/max(y)
rect(breaks[-nB], 0, breaks[-1], y,col=hist.col,border=hist.border)
}
if(density) { tryd <- try( d <- density(x,na.rm=TRUE,bw="nrd",adjust=1.2),silent=TRUE)
if(!inherits(tryd,"try-error")) {
d$y <- d$y/max(d$y)
lines(d)}}
if(rug) rug(x)
}
"panel.cor" <-
function(x, y, prefix="",...) {
usr <- par("usr"); on.exit(par("usr"))
par(usr = c(0, 1, 0, 1))
if(is.null(wt)) { r <- cor(x, y,use="pairwise",method=method)} else {
r <- cor.wt(data.frame(x,y),w=wt[,c(1:2)])$r[1,2]}
txt <- format(c(round(r,digits), 0.123456789), digits=digits)[1]
txt <- paste(prefix, txt, sep="")
if(stars) {pval <- r.test(sum(!is.na(x*y)),r)$p
symp <- symnum(pval, corr = FALSE,cutpoints = c(0, .001,.01,.05, 1),
symbols = c("***","**","*"," "),legend=FALSE)
txt <- paste0(txt,symp)}
cex <- cex.cor*0.8/(max(strwidth("0.12***"),strwidth(txt)))
if(scale) {cex1 <- cex * abs(r)
if(cex1 < .25) cex1 <- .25 #otherwise they just vanish
text(0.5, 0.5, txt, cex = cex1) } else {
text(0.5, 0.5, txt,cex=cex)}
}
"panel.smoother" <-
function (x, y,pch = par("pch"),
col.smooth = "red", span = 2/3, iter = 3, ...)
{
# usr <- par("usr"); on.exit(par(usr))
# par(usr = c(usr[1]-abs(.05*usr[1]) ,usr[2]+ abs(.05*usr[2]) , usr[3],usr[4]) ) #doensn't affect the axis correctly
xm <- mean(x,na.rm=TRUE)
ym <- mean(y,na.rm=TRUE)
xs <- sd(x,na.rm=TRUE)
ys <- sd(y,na.rm=TRUE)
r = cor(x, y,use="pairwise",method=method)
if(jiggle) { x <- jitter(x,factor=factor)
y <- jitter(y,factor=factor)}
if(smoother) {smoothScatter(x,y,add=TRUE, nrpoints=0)} else {if(show.points) points(x, y, pch = pch, ...)}
ok <- is.finite(x) & is.finite(y)
if (any(ok)) {
if(smooth & ci) { lml <- loess(y~x ,degree=1,family="symmetric")
tempx <- data.frame(x = seq(min(x,na.rm=TRUE),max(x,na.rm=TRUE),length.out=47))
pred <- predict(lml,newdata=tempx,se=TRUE )
if(ci) { upperci <- pred$fit + confid*pred$se.fit
lowerci <- pred$fit - confid*pred$se.fit
polygon(c(tempx$x,rev(tempx$x)),c(lowerci,rev(upperci)),col=adjustcolor("light grey", alpha.f=0.8), border=NA)
}
lines(tempx$x,pred$fit, col = col.smooth, ...) #this is the loess fit
} else {if(smooth) lines(stats::lowess(x[ok],y[ok],f=span,iter=iter),col=col.smooth) }}
if(ellipses) draw.ellipse(xm,ym,xs,ys,r,col.smooth=col.smooth,...) #this just draws the ellipse
}
"panel.lm" <-
function (x, y, pch = par("pch"),
col.lm = "red", ...)
{ ymin <- min(y)
ymax <- max(y)
xmin <- min(x)
xmax <- max(x)
ylim <- c(min(ymin,xmin),max(ymax,xmax))
xlim <- ylim
if(jiggle) { x <- jitter(x,factor=factor)
y <- jitter(y,factor=factor)}
if(smoother) {smoothScatter(x,y,add=TRUE, nrpoints=0)} else {if(show.points) {points(x, y, pch = pch,ylim = ylim, xlim= xlim, ...)}}# if(show.points) points(x, y, pch = pch,ylim = ylim, xlim= xlim,...)
ok <- is.finite(x) & is.finite(y)
if (any(ok)) {
lml <- lm(y ~ x)
if(ci) {
tempx <- data.frame(x = seq(min(x,na.rm=TRUE),max(x,na.rm=TRUE),length.out=47))
pred <- predict.lm(lml,newdata=tempx,se.fit=TRUE) #from Julian Martins
upperci <- pred$fit + confid*pred$se.fit
lowerci <- pred$fit - confid*pred$se.fit
polygon(c(tempx$x,rev(tempx$x)),c(lowerci,rev(upperci)),col=adjustcolor("light grey", alpha.f=0.8), border=NA)
}
if(ellipses) {
xm <- mean(x,na.rm=TRUE)
ym <- mean(y,na.rm=TRUE)
xs <- sd(x,na.rm=TRUE)
ys <- sd(y,na.rm=TRUE)
r = cor(x, y,use="pairwise",method=method)
draw.ellipse(xm,ym,xs,ys,r,col.smooth=col.lm,...) #just draw the ellipse
}
abline(lml, col = col.lm, ...)
}
}
"draw.ellipse" <- function(x=0,y=0,xs=1,ys=1,r=0,col.smooth,add=TRUE,segments=51,...) {
#based upon John Fox's ellipse functions
angles <- (0:segments) * 2 * pi/segments
unit.circle <- cbind(cos(angles), sin(angles))
if(!is.na(r)) {
if (abs(r)>0 )theta <- sign(r)/sqrt(2) else theta=1/sqrt(2)
shape <- diag(c(sqrt(1+r),sqrt(1-r))) %*% matrix(c(theta,theta,-theta,theta),ncol=2,byrow=TRUE)
ellipse <- unit.circle %*% shape
ellipse[,1] <- ellipse[,1]*xs + x
ellipse[,2] <- ellipse[,2]*ys + y
if(show.points) points(x,y,pch=19,col=col.smooth,cex=1.5 ) #draw the mean
lines(ellipse, ...) }
}
"panel.ellipse" <-
function (x, y, pch = par("pch"),
col.smooth = "red", ...)
{ segments=51
usr <- par("usr"); on.exit(par("usr"))
par(usr = c(usr[1]-abs(.05*usr[1]) ,usr[2]+ abs(.05*usr[2]) , 0, 1.5) )
xm <- mean(x,na.rm=TRUE)
ym <- mean(y,na.rm=TRUE)
xs <- sd(x,na.rm=TRUE)
ys <- sd(y,na.rm=TRUE)
r = cor(x, y,use="pairwise",method=method)
if(jiggle) { x <- jitter(x,factor=factor)
y <- jitter(y,factor=factor)}
if(smoother) {smoothScatter(x,y,add=TRUE, nrpoints=0)} else {if(show.points) {points(x, y, pch = pch, ...)}}
angles <- (0:segments) * 2 * pi/segments
unit.circle <- cbind(cos(angles), sin(angles))
if(!is.na(r)) {
if (abs(r)>0 ) theta <- sign(r)/sqrt(2) else theta=1/sqrt(2)
shape <- diag(c(sqrt(1+r),sqrt(1-r))) %*% matrix(c(theta,theta,-theta,theta),ncol=2,byrow=TRUE)
ellipse <- unit.circle %*% shape
ellipse[,1] <- ellipse[,1]*xs + xm
ellipse[,2] <- ellipse[,2]*ys + ym
points(xm,ym,pch=19,col=col.smooth,cex=1.5 ) #draw the mean
if(ellipses) lines(ellipse, ...)
}
}
#######
#Beginning of the main function
######
#The original organization was very clunky, but has finally been cleaned up with lots of extra comments removed (8/13/17)
old.par <- par(no.readonly = TRUE) # save default, for resetting...
on.exit(par(old.par)) #and when we quit the function, restore to original values
if(missing(cex.cor)) cex.cor <- 1 #this allows us to scale the points separately from the correlations
for(i in 1:ncol(x)) { #treat character data as numeric
if(is.character(x[[i]] )) { x[[i]] <- as.numeric(as.factor(x[[i]]) )
colnames(x)[i] <- paste(colnames(x)[i],"*",sep="")}
}
n.obs <- nrow(x)
confid <- qt(1-alpha/2,n.obs-2) #used in finding confidence intervals for regressions and loess
if(!lm) { #the basic default is here
if(cor) {
pairs(x, diag.panel = panel.hist.density, upper.panel = panel.cor
, lower.panel = panel.smoother, pch=pch, ...)} else {
pairs(x, diag.panel = panel.hist.density, upper.panel = panel.smoother, lower.panel = panel.smoother, pch=pch, ...)}
} else { #lm is TRUE
if(!cor) { #this case does not show the correlations, but rather shows the regression lines above and below the diagonal
pairs(x, diag.panel = panel.hist.density, upper.panel = panel.lm, lower.panel = panel.lm, pch=pch, ...)
} else { #the normal case is to show the regressions below and the rs above
pairs(x, diag.panel = panel.hist.density, upper.panel = panel.cor, lower.panel = panel.lm,pch=pch, ...)
}
}
} #end of pairs.panels
###
"histo" <- function(x,breaks="Sturges", ...) {
tax <- table(x)
if(length(tax) < 11) {breaks <- as.numeric(names(tax))
y <- tax/max(tax)
interbreak <- min(diff(breaks))*(length(tax)-1)/21
rect(breaks-interbreak,0,breaks + interbreak,y)
} else {
h <- hist(x,breaks=breaks)
}}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.