Nothing
#radar and spider developed July 10, 2011
#added the ability to rotate the entire figure 02/24/20 and to use keys
#Added label.pos to give better control of the figures
"radar" <- function(x,labels=NULL,keys=NULL,center=FALSE,connect=FALSE,scale=1,ncolors=31,fill=FALSE,add=FALSE,linetyp="solid",
main="Radar Plot",angle=0,absolute=FALSE,show=TRUE,digits=2,cut=.2,circles=TRUE,shape=FALSE, clockwise=FALSE,delta = NULL,label.pos=NULL,
position=NULL ,xlim=c(-1,1),ylim=c(-1,1), ...) {
#hard coded because something is wrong with call
nvar <- length(x)
lty="solid"
if(!is.null(keys) ) {key.ord <- selectFromKeys(keys)
num.keys <- length(keys)
for (i in 1:num.keys) {
select <- sub("-", "", unlist(keys[i]))
keys[[i]]<- select}
key.ord <- unlist(keys)
} else {key.ord <-1:nvar
num.keys <- 1
if (clockwise) key.ord <- nvar:1
}
if(is.null(labels)) {labels <- names(keys)
show.keys<- TRUE} else {labels <- labels[key.ord]
show.keys <- FALSE}
nvar <- length(key.ord)
x <- x[key.ord] #this order the x vector according to the keys vector
if(is.null(labels)) labels <- paste("V",1:nvar,sep="")
if(is.null(delta)) {DELTA <- rep(1.1,nvar)} else {if(length(delta)==1) {DELTA =rep(delta,nvar) } else {DELTA=delta}}
if(is.null(label.pos)) {label.pos <- rep(1.05,nvar) } else {if(length(label.pos)==1) label.pos= rep(label.pos,nvar)}
if(is.null(position)) position <- rep(0,nvar)
if (clockwise) { position <- position[key.ord]
label.pos <- label.pos[key.ord]
DELTA <- DELTA[key.ord]
}
SEGMENTS <- max(153,nvar) #increased from 48 to improve resolution
if(ncolors < 2) {colors <- FALSE} else {colors <- TRUE}
angles <- (0:SEGMENTS) * 2 * pi/SEGMENTS
unit.circle <- cbind(cos(angles), sin(angles))
if(!add) {if(shape) {nx <- SEGMENTS/nvar
Lx <- seq(1,SEGMENTS+1,nx)#%% SEGMENTS + 1
plot(unit.circle[Lx,1],unit.circle[Lx,2],axes=FALSE,xlab="",ylab="",typ="l",xlim=xlim,ylim=ylim)
} else {plot(unit.circle,typ="l",asp=1,axes=FALSE,xlab="",ylab="",main=main,xlim=xlim,ylim=ylim)}
if(circles) {lines(unit.circle*.25,typ="l",lty="dotted",col="red")
lines(unit.circle*.5,typ="l",lty="dotted")
lines(unit.circle*.75,typ="l",lty="dotted",col="blue")} }
if(colors) {
gr <- colorRampPalette(c("red","white","blue")) #added June 20
colramp <- gr(ncolors)
} else {
colramp <- grey((ncolors:0)/ncolors)}
for(c in 1:nvar) {
nx <- (((c-1 + angle*num.keys) %% nvar) +1 )* SEGMENTS/nvar +1
nx <- nx %% SEGMENTS # +1
if(center) {x0 <- unit.circle[nx,1] * .5
y0 <- unit.circle[nx,2] * .5
} else {
x0 <- 0
y0 <- 0}
if(!absolute) {scaler <- (x[c]*scale/2 + .5) } else {scaler <- abs(x[c]*scale )}#stats can go from -1 to 1, scale from 0 to 1
x1 <- unit.circle[nx,1]
y1 <- unit.circle[nx,2]
Lx <- c(x0,x1)*scaler
Ly <- c(y0,y1) *scaler
if(c==1) { Oldx <- unit.circle[(nvar)*SEGMENTS/nvar + 1,1]*(x[nvar]*scale/2 +.5) #had been nvar-1 until 01/09/24
Oldy <- unit.circle[(nvar)*SEGMENTS/nvar + 1,2]*(x[nvar]*scale/2+.5)}
if(colors) {
if(absolute) {
{if (x[c] < 0 ) {col="red"
lty="dotted"} else {col="blue"
lty="solid"}
}} else {if (scaler < .5) {col="red"} else {col="blue"}
}
lines(Lx,Ly,col=col,lty=lty,...) } else {
lines(Lx,Ly,...)}
if(show) {
txt <- paste0(sprintf("%.2f",round(x[c],2)))
if (abs(x[c]) > cut) {text(Lx[2]*DELTA[c],Ly[2]*DELTA[c],txt,...)}
# if (abs(x[c]) > cut) {text(Lx[2]*sign(Lx[2])*DELTA[c],Ly[2]*sign(Ly[2])*DELTA[c],txt)}
}
if(connect) {lines(c(Oldx,x1*scaler),c(Oldy,y1*scaler),lty=linetyp)}
if(fill) {polygon(c(0,Oldx , x1*scaler,0),c(0,Oldy,y1*scaler,0),col=colramp[ceiling(scaler*ncolors)],...)}
Oldx <- x1*scaler
Oldy <- y1* scaler
if(!show.keys) { if(position[c] ==0) {pos=NULL} else { pos=position[c]} #it is not at all clear what I am trying to do here
text(x1*label.pos[c],y1*label.pos[c],labels[c],pos=pos,...)}
if(show.keys) {for(cc in 1:length(labels)) {
nx <- (((cc-1 + angle) %% num.keys) +1 )* SEGMENTS/num.keys +1
x1 <- unit.circle[nx,1]
y1 <- unit.circle[nx,2]
text(x1*label.pos[nx] ,y1*label.pos[nx],labels[cc],...)
}
}
} #end of 1:nvar loop
}
"spider" <- function(y,x,data,labels=NULL,rescale = FALSE,center=FALSE,connect=TRUE,overlay=FALSE,scale=1,ncolors=31,fill=FALSE,main=NULL,...) {
if(inherits(y,"formula")) { #taken from lm -- allows formula input if desired
ps <- fparse(y)
y <- ps$y
x <- ps$x
med <- ps$m #but, mediation is not done here, so we just add this to x
# if(!is.null(med)) x <- c(x,med) #not necessary, because we automatically put this in
prod <- ps$prod
z <- ps$z #do we have any variable to partial out
ex <- ps$ex
}
if(is.null(labels)) labels <- colnames(data)[x]
if(rescale) {
data <- scale(data)/3 } #rescales to -1 to 1
if(length(y)==1) {
if(!is.null(main)) {main=main} else {main <- colnames(data)[y]}
radar(data[y,x],labels=labels,center=center,connect=connect,scale=scale,ncolors=ncolors,fill=fill,main=main,...) } else {
nvar <- length(y)
for (i in 1:nvar) {
if(!is.null(main)) {title=main[y[i]]} else {title <- colnames(data)[y[i]]}
if(overlay) {
if (i==1) {radar(data[y[i],x],labels=labels,center=center,connect=connect,scale=scale,ncolors=ncolors,fill=fill,main=title,...) } else {
radar(data[y[i],x],labels=labels,center=center,connect=connect,scale=scale,ncolors=ncolors,fill=fill,add=TRUE,linetyp=nvar %%6 + 2,main=title,...) }
} else {
radar(data[y[i],x],labels=labels,center=center,connect=connect,scale=scale,ncolors=ncolors,fill=fill,main=title,...)
}}
}
}
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.