rpa.R

# McCrae's rpa (r profile agreement)
rpa <- function(p1,p2){
  if (length(p1) != length(p2)) 
    stop("'p1' and 'p2' must have the same length")
  k <- length(p1)
  sumM.sq <- sum(((p1 + p2)/2)^2)
  sumd.sq <- sum((p1 - p2)^2)
  ipa <- (k + 2*sumM.sq - sumd.sq) / sqrt(10*k)
  rpa <- ipa / sqrt(k - 2 + ipa^2)
  return(rpa)
}

#Example 1
#Result graph https://dl.dropboxusercontent.com/u/33111025/pic/rpa.png 
b5plus <- c("Экстраверсия", "Согласие","Самоконтроль", "Стабильность", "Новаторство")
p1 <- c(9.3, 2.1, 4.8, 8.5, 7.2) 
p2 <- c(6.5, 1, 4.8, 3.1, 1.8)
id <- c(7.1, 3.5, 6.0, 7.7, 6.8)
profile1 <- c(1.90, -1.70, -0.35,  1.50,  0.85) 
profile2 <- c(0.50, -2.25, -0.35, -1.20, -1.85)
ideal <- c(0.80, -1.00,  0.25,  1.10,  0.65)

#rpa
r <- rpa(profile1,ideal)
r2 <- rpa(profile2,ideal)
r3 <- rpa(profile1,profile1)

#r
cor(p1, id)
cor(p2, id)
cor(p1, p2)

plot(id, type="o", col="blue", lty=1, lwd=2, axes=FALSE, ann=FALSE, ylim=c(1,10))
axis(1, at=1:5, lab=b5plus)
axis(2, at=1:10)
lines(p1, type="o", col="green", lty=1, lwd=2, axes=FALSE, ann=FALSE)
lines(p2, type="o", col="red", lty=1, lwd=2, axes=FALSE, ann=FALSE)
title(xlab="Шкалы большой пятерки (методика b5plus)", col.lab=rgb(0,0.5,0))
title(ylab="Стены", col.lab=rgb(0,0.5,0))
title(main="Сходство \"реального\" и \"идеального\" профиля руководителя", col.main="black", font.main=1)
legend(1.5, 10, c("Идеальный","Реальный (успешный)", "Реальный (неуспешный)"), cex=0.8, 
       col=c("blue","green", "red"), lty=c(1,1,1), lwd=c(2,2,2))
text(4, 9, col="green", paste("rpa (успеш) = ",round(r, 2)), cex=0.8)
text(4, 2, col="red", paste("rpa (неуспеш) = ",round(r2, 2)), cex=0.8)

#Example 2 Two personality profiles agreement

neo <- c("N", "E","O", "A", "C")
p1 <- c(7.5, 3.5, 4.5, 6.5, 3.5) # Sten Scores
p2 <- c(3.5, 7.5, 5.5, 5.5, 7.5)
p3 <- c(6.5, 4.5, 5.5, 5.5, 4.5)
profile1 <- c(1.0, -1.0, -0.5,  0.5, -1.0) # Scores are standardized (i.e., z-scores, µ = 0 σ = 1)
profile2 <- c(-1,  1,  0,  0,  1)
profile3 <- c(0.5, -0.5,  0.0,  0.0, -0.5)

r <- rpa(profile1,profile2)

plot(p1, type="o", col="blue", axes=FALSE, ann=FALSE)
axis(1, at=1:5, lab=neo)
axis(2, las=1, at=1:10)
lines(p2, type="o", col="red", axes=FALSE, ann=FALSE)
title(xlab="NEO-PI R", col.lab=rgb(0,0.5,0))
title(ylab="Sten scores", col.lab=rgb(0,0.5,0))
title(main="Two personality profiles agreement", col.main="red", font.main=4)
legend(3, 7.5, c("profile1","profile2"), cex=0.8, 
       col=c("blue","red"), pch=21:22, lty=1:2)
text(4, 4, paste("rpa = ",round(r, 3)))

r <- rpa(profile1,profile3)

plot(p1, type="o", col="blue", axes=FALSE, ann=FALSE)
axis(1, at=1:5, lab=neo)
axis(2, las=1, at=1:10)
lines(p3, type="o", col="red", axes=FALSE, ann=FALSE)
title(xlab="NEO-PI R", col.lab=rgb(0,0.5,0))
title(ylab="Sten scores", col.lab=rgb(0,0.5,0))
title(main="Two personality profiles agreement", col.main="red", font.main=4)
legend(3, 7.5, c("profile1","profile2"), cex=0.8, 
       col=c("blue","red"), pch=21:22, lty=1:2)
text(4, 4, paste("rpa = ",round(r, 3)))