Peter Prevos — Apr 13, 2014, 6:00 PM
#PERSONALITY TEST
#Data analysis of the Lucid Manager persoanlity test
#www.lucidmanager.org/personality-test
#Code by Peter Prevos
#Initiation
setwd("/home/peter/Documents/LucidManager/PersonalityTest/")
options(width=100) #Modify screen width
library(psych) #Library for psychometric statistics
library(pyramid) #Population pyramid
personality <- read.csv("PersonalityTest.csv", header=T) #Read survey data
personality[,c(4,7,11,12,15,17,19,20,21)+8] <- 6-personality[,c(4,7,11,12,15,17,19,20,21)+8] #Reverse values
personality$education <- factor(personality$education,levels=0:6,labels=c("None","Primary","Secondary", "Trade", "Bachelor", "Masters", "Doctorate")) #Create factor variable for education
#Remove all respondents with identical or empty answers for all questions
check <- 1:nrow(personality)
for (i in 1: nrow(personality)) {
check[i] <- sd(personality[i,1:22+8])
}
personality <- personality[!check==0,] #Remove where sd=0
personality <- personality[!is.na(check),] #Remove where check=NA
attach(personality) #Make variable searchable
#############
#Demographics
#############
nrow(personality) #Count total number of responses
[1] 415
sum(is.na(personality))/(nrow(personality)*ncol(personality))*100 #Percentage of missing data points
[1] 1.55
addmargins(table(gender))
gender
Female Male Sum
184 231 415
chisq.test(table(gender)) #H0: male=female
Chi-squared test for given probabilities
data: table(gender)
X-squared = 5.323, df = 1, p-value = 0.02105
summary(age) #Overall age
Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
12.0 24.0 29.5 33.0 42.8 103.0 25
population <- table(age,gender) #Define age distribution by gender
population <- data.frame(population[,0],population[,1:2]) #Reverse columns
par(mar=rep(1,4)) #Set graphics margins
pyramid(population,Llab="Female",Rlab="Male", AxisFM="d", AxisBM=",", Csize=0.8, Cstep=10, Lcol="pink", Rcol="lightblue") #Population pyramid
#Generation definitions: Boomer 1945-1964, GenX 1965-1979, GenY 1980-2000 (Wikipedia)
bb <- length(subset(birth,birth>=1946 & birth<=1964)) #Number of Baby Boomers
gx <- length(subset(birth,birth>=1965 & birth<=1979)) #Number of Generation X
gy <- length(subset(birth,birth>=1980 & birth<=1999)) #Number of Generation Y
addmargins(table(education,gender)) #Education by gender
gender
education Female Male Sum
None 3 10 13
Primary 7 4 11
Secondary 35 34 69
Trade 10 17 27
Bachelor 67 85 152
Masters 55 77 132
Doctorate 7 4 11
Sum 184 231 415
par(mar=c(4,4,1,1))
barplot(table(gender,education), xlab="Education", ylab="Respondents", col=c("pink", "lightblue"))
barplot(table(education), xlab="Education", ylab="Respondents")
#########################################
#Construct Validity
#########################################
#Factor Analysis
reordered <- personality[,c(2,17,18,19,7,8,10,16,21,3:5,11,1,6,12,20,9,13:15,22)+8] #Reorder items to follow construct order
factanal(reordered, factors=5, rotation="varimax")
Call:
factanal(x = reordered, factors = 5, rotation = "varimax")
Uniquenesses:
q2 q17 q18 q19 q7 q8 q10 q16 q21 q3 q4 q5 q11 q1 q6 q12
0.572 0.644 0.835 0.091 0.434 0.743 0.738 0.777 0.645 0.674 0.834 0.904 0.578 0.923 0.585 0.816
q20 q9 q13 q14 q15 q22
0.584 0.582 0.210 0.461 0.723 0.531
Loadings:
Factor1 Factor2 Factor3 Factor4 Factor5
q2 0.394 0.254 0.401 -0.205
q17 -0.160 -0.275 -0.166 0.442 0.178
q18 0.138 0.188 0.300 -0.110
q19 -0.204 -0.131 -0.107 0.872 0.281
q7 -0.131 -0.300 -0.677
q8 0.421 -0.276
q10 0.443 0.198 -0.135
q16 0.416 0.218
q21 -0.119 0.119 0.565
q3 0.146 0.507 0.112 -0.185
q4 0.116 0.182 0.340
q5 0.134 -0.166 -0.218
q11 -0.631
q1 0.152 -0.221
q6 0.112 0.132 0.618
q12 -0.186 -0.155 -0.120 0.333
q20 -0.392 0.161 0.246 0.412
q9 0.577 0.147 0.170 -0.184
q13 0.868 0.108 -0.134
q14 0.716 0.134
q15 0.345 -0.228 -0.109 0.301
q22 0.579 0.325 -0.104 -0.101
Factor1 Factor2 Factor3 Factor4 Factor5
SS loadings 2.279 1.876 1.379 1.360 1.224
Proportion Var 0.104 0.085 0.063 0.062 0.056
Cumulative Var 0.104 0.189 0.252 0.313 0.369
Test of the hypothesis that 5 factors are sufficient.
The chi square statistic is 241.8 on 131 degrees of freedom.
The p-value is 1.33e-08
#Cronbach Alpha estimated without autocorrection of negative correlation
alpha(personality[,c(2,17,18,19)+8], check.keys=F) #Energy (q2, q17, q18, q19)
Reliability analysis
Call: alpha(x = personality[, c(2, 17, 18, 19) + 8], check.keys = F)
raw_alpha std.alpha G6(smc) average_r mean sd
0.22 0.25 0.36 0.078 2.9 0.62
Reliability if an item is dropped:
raw_alpha std.alpha G6(smc) average_r
q2 0.085 0.147 0.283 0.054
q17 0.106 0.123 0.160 0.044
q18 0.483 0.486 0.487 0.239
q19 -0.070 -0.084 -0.031 -0.027
Item statistics
n r r.cor r.drop mean sd
q2 415 0.59 0.31 0.18 3.0 1.1
q17 415 0.60 0.48 0.17 2.6 1.0
q18 415 0.34 -0.14 -0.12 3.3 1.2
q19 415 0.70 0.68 0.28 2.8 1.1
Non missing response frequency for each item
1 2 3 4 5 miss
q2 0.07 0.33 0.26 0.24 0.10 0
q17 0.10 0.47 0.22 0.15 0.05 0
q18 0.07 0.23 0.17 0.31 0.21 0
q19 0.10 0.38 0.20 0.25 0.06 0
alpha(personality[,c(7,8,10,16,21)+8], check.keys=F) #Intellect (q7, q8, q10, q16, q21)
Warning: NaNs produced
Reliability analysis
Call: alpha(x = personality[, c(7, 8, 10, 16, 21) + 8], check.keys = F)
raw_alpha std.alpha G6(smc) average_r mean sd
-0.11 -0.16 -0.0018 -0.028 3.1 0.51
Reliability if an item is dropped:
raw_alpha std.alpha G6(smc) average_r
q7 0.250 0.232 0.238 0.070
q8 -0.221 -0.245 -0.084 -0.052
q10 -0.332 -0.367 -0.166 -0.072
q16 -0.308 -0.327 -0.135 -0.066
q21 -0.023 -0.086 0.061 -0.020
Item statistics
n r r.cor r.drop mean sd
q7 415 0.14 NaN -0.327 2.3 1.1
q8 415 0.49 NaN 0.037 3.3 1.3
q10 415 0.55 NaN 0.125 3.4 1.1
q16 415 0.53 NaN 0.081 2.8 1.3
q21 415 0.40 NaN -0.086 3.5 1.1
Non missing response frequency for each item
1 2 3 4 5 miss
q7 0.24 0.43 0.17 0.12 0.04 0
q8 0.10 0.22 0.14 0.33 0.21 0
q10 0.05 0.18 0.25 0.35 0.18 0
q16 0.19 0.31 0.17 0.21 0.12 0
q21 0.06 0.15 0.18 0.46 0.15 0
alpha(personality[,c(3:5,11)+8], check.keys=F) #Perspective (q3, q4, q5, q11)
Warning: NaNs produced
Reliability analysis
Call: alpha(x = personality[, c(3:5, 11) + 8], check.keys = F)
raw_alpha std.alpha G6(smc) average_r mean sd
-0.36 -0.37 -0.2 -0.072 3.2 0.53
Reliability if an item is dropped:
raw_alpha std.alpha G6(smc) average_r
q3 -0.09 -0.093 -0.055 -0.029
q4 -0.44 -0.473 -0.214 -0.120
q5 -0.42 -0.403 -0.172 -0.106
q11 -0.11 -0.106 -0.062 -0.033
Item statistics
n r r.cor r.drop mean sd
q3 415 0.37 NaN -0.205 3.5 1.2
q4 415 0.52 NaN -0.051 3.7 1.1
q5 415 0.50 NaN -0.073 2.8 1.3
q11 415 0.38 NaN -0.196 2.7 1.2
Non missing response frequency for each item
1 2 3 4 5 miss
q3 0.06 0.18 0.19 0.36 0.21 0
q4 0.05 0.13 0.14 0.44 0.25 0
q5 0.18 0.31 0.19 0.21 0.11 0
q11 0.13 0.40 0.17 0.22 0.07 0
alpha(personality[,c(1,6,12,20)+8], check.keys=F) #Activity (q1, q6, q12, q20)
Warning: NaNs produced
Reliability analysis
Call: alpha(x = personality[, c(1, 6, 12, 20) + 8], check.keys = F)
raw_alpha std.alpha G6(smc) average_r mean sd
-0.097 -0.1 -0.038 -0.023 3.3 0.57
Reliability if an item is dropped:
raw_alpha std.alpha G6(smc) average_r
q1 -0.037 -0.036 -0.018 -0.012
q6 -0.232 -0.224 -0.112 -0.065
q12 0.104 0.101 0.080 0.036
q20 -0.165 -0.176 -0.068 -0.053
Item statistics
n r r.cor r.drop mean sd
q1 415 0.46 NaN -0.057 3.1 1.2
q6 415 0.55 NaN 0.040 3.3 1.2
q12 415 0.39 NaN -0.143 3.6 1.1
q20 415 0.53 NaN 0.009 3.3 1.2
Non missing response frequency for each item
1 2 3 4 5 miss
q1 0.10 0.31 0.17 0.29 0.13 0
q6 0.08 0.20 0.24 0.33 0.16 0
q12 0.06 0.13 0.17 0.41 0.24 0
q20 0.08 0.20 0.22 0.37 0.13 0
alpha(personality[,c(9,13:15,22)+8], check.keys=F) #Amity (q9, q13, q14, q15, q22)
Reliability analysis
Call: alpha(x = personality[, c(9, 13:15, 22) + 8], check.keys = F)
raw_alpha std.alpha G6(smc) average_r mean sd
0.75 0.76 0.74 0.38 3.4 0.83
Reliability if an item is dropped:
raw_alpha std.alpha G6(smc) average_r
q9 0.70 0.71 0.68 0.38
q13 0.64 0.64 0.59 0.31
q14 0.68 0.68 0.65 0.35
q15 0.81 0.80 0.77 0.51
q22 0.70 0.70 0.68 0.37
Item statistics
n r r.cor r.drop mean sd
q9 415 0.72 0.62 0.54 3.5 1.1
q13 415 0.83 0.82 0.70 3.3 1.2
q14 415 0.77 0.71 0.60 3.2 1.2
q15 415 0.50 0.28 0.25 3.5 1.2
q22 415 0.73 0.63 0.55 3.4 1.1
Non missing response frequency for each item
1 2 3 4 5 miss
q9 0.05 0.17 0.21 0.39 0.19 0
q13 0.07 0.22 0.18 0.36 0.16 0
q14 0.08 0.26 0.18 0.35 0.12 0
q15 0.07 0.19 0.13 0.37 0.24 0
q22 0.05 0.15 0.28 0.36 0.16 0
############################
#Intercorrelations of traits
############################
energy <- rowSums(personality[,c(2,17,18,19)+8])
intellect <- rowSums(personality[,c(7,8,10,16,21)+8])
perspective <- rowSums(personality[,c(3:5,11)+8])
activity <- rowSums(personality[,c(1,6,12,20)+8])
amity <- rowSums(personality[,c(9,13:15,22)+8])
pairs.panels(cbind(energy,intellect,perspective,activity,amity), pch=20, jiggle=T, factor=3)
NULL
####################
#Appreciation scores
####################
addmargins(table(appreciation)) #Distribution of scores
appreciation
1 2 3 4 5 Sum
13 23 28 141 67 272
summary(appreciation) #Summary Statistics
Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
1.00 4.00 4.00 3.83 4.00 5.00 143
par(mar=c(4,4,2,1), mfcol=c(1,2), cex.main=1) #Set graphics margins
barplot(table(appreciation), xlab="Appreciation", ylab="n", main="Lucid Manager Test") #Display values
wilcox.test(appreciation, mu=3) #H0: mean = 3
Wilcoxon signed rank test with continuity correction
data: appreciation
V = 25334, p-value < 2.2e-16
alternative hypothesis: true location is not equal to 3
#Comparison with Work Personality Index (http://www.psychometrics.com/docs/wpi-m.pdf)
wpi <- c(rep(1,17),rep(2,149),rep(3,1205),rep(4,2178),rep(5,1183))
addmargins(table(wpi)) #Distribution of scares
wpi
1 2 3 4 5 Sum
17 149 1205 2178 1183 4732
summary(wpi) #Summary Statistics
Min. 1st Qu. Median Mean 3rd Qu. Max.
1.00 3.00 4.00 3.92 4.25 5.00
barplot(table(wpi), xlab="Appreciation", main="Work Personality Index") #Display values
wilcox.test(wpi, mu=3) #H0: mean = 3
Wilcoxon signed rank test with continuity correction
data: wpi
V = 5998424, p-value < 2.2e-16
alternative hypothesis: true location is not equal to 3
#appreciation by gender
addmargins(table(appreciation,gender)) #Show appreciation by gender
gender
appreciation Female Male Sum
1 7 6 13
2 9 14 23
3 8 20 28
4 68 73 141
5 33 34 67
Sum 125 147 272
boxplot(appreciation~gender, ylab="Appreciation", xlab="gender", col=c("pink","lightblue")) #Display
wilcox.test(appreciation~gender) #H0: male=female
Wilcoxon rank sum test with continuity correction
data: appreciation by gender
W = 9870, p-value = 0.2509
alternative hypothesis: true location shift is not equal to 0
#appreciation by education
addmargins(table(appreciation,education)) #Show appreciation by education
education
appreciation None Primary Secondary Trade Bachelor Masters Doctorate Sum
1 0 0 1 0 6 6 0 13
2 2 3 5 0 5 7 1 23
3 3 1 7 0 4 10 3 28
4 0 3 18 12 58 46 4 141
5 1 0 14 2 28 19 3 67
Sum 6 7 45 14 101 88 11 272
boxplot(appreciation~education, xlab="Education level", ylab="Appreciation", col=rainbow(7))
kruskal.test(appreciation~education) #H0: appreciation is same for all levels of education
Kruskal-Wallis rank sum test
data: appreciation by education
Kruskal-Wallis chi-squared = 13.08, df = 6, p-value = 0.04183
#########################
#Check influence of Amity
#########################
#Amity is the only trait with a Cronbach alpha > 0.7
star <- rowSums(personality[,c(9,13:15,22)+8])>15 #Calculate 'STAR'
#By gender
addmargins(table(star,gender)) #Distribution by gender
gender
star Female Male Sum
FALSE 58 88 146
TRUE 126 143 269
Sum 184 231 415
chisq.test(star,gender) #H0: STAR female(STAR)=male(STAR)
Pearson's Chi-squared test with Yates' continuity correction
data: star and gender
X-squared = 1.663, df = 1, p-value = 0.1972
#By age
par(mar=c(4,4,1,1)) #Set graphics parameters
boxplot(age~star, ylab="Age", xlab="Star", col=c("red","green")) #Age distribution for STAR
wilcox.test(age~star) #H0: age(STAR)=age(!STAR)
Wilcoxon rank sum test with continuity correction
data: age by star
W = 19436, p-value = 0.01872
alternative hypothesis: true location shift is not equal to 0
cor.test(amity[age<80],age[age<80]) #Test for correlation between trait score and age (excluding extreme values)
Pearson's product-moment correlation
data: amity[age < 80] and age[age < 80]
t = -2.583, df = 387, p-value = 0.01017
alternative hypothesis: true correlation is not equal to 0
95 percent confidence interval:
-0.22667 -0.03115
sample estimates:
cor
-0.1302
#By education
boxplot(as.numeric(education)~star, ylab="Education", xlab="Star", col=c("red","green"))
addmargins(table(star,education)) #Distribution by education
education
star None Primary Secondary Trade Bachelor Masters Doctorate Sum
FALSE 7 4 23 10 52 47 3 146
TRUE 6 7 46 17 100 85 8 269
Sum 13 11 69 27 152 132 11 415
chisq.test(star,education) #H0: education(STAR)=eduction(!STAR)
Warning: Chi-squared approximation may be incorrect
Pearson's Chi-squared test
data: star and education
X-squared = 2.512, df = 6, p-value = 0.8671
#By appreciation
boxplot(appreciation~star, ylab="Appreciation", xlab="Star", col=c("red","green")) #Display appreciation for STAR
wilcox.test(appreciation~star) #H0: appreciation(STAR) = appreciation(!STAR)
Wilcoxon rank sum test with continuity correction
data: appreciation by star
W = 7300, p-value = 0.07024
alternative hypothesis: true location shift is not equal to 0
###########################
#SAVE PRESENTATION GRAPHICS
###########################
jpeg('appreciation.jpg', width=800, height=600)
par(mar=c(4,4,2,1), mfcol=c(1,2), cex=1.5) #Set graphics margins
barplot(table(appreciation), xlab="Face Validity", ylab="n", main="Lucid Manager Test") #Display values
barplot(table(wpi), xlab="Face Validity", main="Work Personality Index") #Display values
dev.off()
pdf
2
