lista2

1 - Ajuste o modelo logístico de 2 parâmetros:

dados <- read.fwf(file="/Users/Gustavo/Documents/unb/mestrado/TRI/altura211.txt",widths=c(3,4,1,1,1,1,1,1,1,1,1,1,1,1,1,1))
no.item <- ncol(dados[,3:16])
altura.tpm <- tpm(dados[,3:16],constraint=cbind(1:no.item,1,0))
par.est <- coef(altura.tpm)

par.est

##     Gussng     Dffclt    Dscrmn
## V3       0  2.4766246 0.3050309
## V4       0  1.2030785 1.1775555
## V5       0  1.2127106 1.4914835
## V6       0  1.3532827 0.8536786
## V7       0  1.0685997 2.2192583
## V8       0  1.1264211 1.7863638
## V9       0 -0.1165783 4.0878507
## V10      0  2.6491185 1.0915323
## V11      0 -0.9305322 1.2671910
## V12      0  0.0326274 3.1611235
## V13      0  0.4039899 1.1670463
## V14      0  0.2303836 2.4254712
## V15      0  0.8098480 1.7307504
## V16      0  0.4978901 2.8614209

2 - Construa a curva característica dos 14 itens:

theta <- c(-4.5,-4,-3.5,-3,-2.5,-2,-1.5,-1,-0.5,0,0.5,1,1.5,2,2.5,3,3.5,4)

for(i in 1:14){
P2 <- 1/(1+exp(-par.est[i,3]*(theta-par.est[i,2])))
plot(theta,P2, main = paste0("Item ",i))
lines(theta,P2, type = "l", lty = 1)
}

3A - Calcule as funções de informação dos item:

fii.calc <- function(a,b,c, theta){
  
  require(Deriv)
  P3 <- function(theta) c+(1-c)/(1+exp(-a*(theta-b)))
  
  Pi3 <- P3(theta)
  Qi3 <- 1 - Pi3
  Df3 <- Deriv(P3)
  FII3 <- Df3(theta)^2/(Pi3*Qi3)
  
  tab <- data.frame(FII3, theta) 
  
return(tab)
}

for(i in 1:14) assign(paste0("tab",i),fii.calc(par.est[i,3],par.est[i,2],par.est[i,1],round( runif(10000, -4.5, 4.5), 2 )))

## Loading required package: Deriv

3B - Gráfico das funções de informação do item:

for(i in 1:14){
plot(eval(parse(text=paste0("tab",i,"$theta"))), eval(parse(text=paste0("tab",i,"$FII3"))), main = paste0("FII ", i), xlab = "Theta", ylab = "Informação do Item")
}

4 - Quais itens são mais adequados para a estimação da altura de pessoas baixas?

Em geral, os itens discriminam apenas alturas médias a altas, podemos ver pelos gráficos de 3B que os itens são bem mais informativos com thetas iguais ou superiores a zero. O item 9 foi o item mais informativo para alturas baixas, seguido pelo item 11. Entretanto, se olharmos a magnitude da informação para estes itens, vemos que, apesas deles serem mais informativos para altura baixas que para thetas mais elevados, eles não tem um poder de discriminação elevado.

5 - Calcule e esboce em um gráfico a função de informação do teste. Este teste é adequado para a estimação de pessoas com baixa estatura?

tabb <- round( runif(10000, -4.5, 4.5),2)
soma.fii <- data.frame(matrix(ncol= 15, nrow = 10000))
for(i in 1:14){
  soma.fii[,1] <- tabb
  soma.fii[,i+1] <- fii.calc(par.est[i,3],par.est[i,2],par.est[i,1],tabb)[1]
}

dados_fit <- data.frame(theta = soma.fii[,1], informacao = rowSums(soma.fii[,2:15]))

plot(dados_fit$theta, dados_fit$informacao, ylab = "Informação", xlab = "Theta")

Pelo gráfico da informação do teste, fica bem visível que o teste é adequado apenas para pessoas médias à altas, não sendo um teste adequado para discriminar observações com estatura baixa.

6 - Converta as alturas estimadas para a escala com média e desvio-padrão iguais à altura média e desvio padrões reais:

theta.est.eap <- eap(dados[3:16], cbind(par.est[,3],par.est[,2],par.est[,1]), qu=normal.qu())
theta.est <- mean(dados[,2]) + sd(dados[,2])*theta.est.eap[,1]

theta.est

##   [1] 1.771263 1.598950 1.757839 1.796428 1.691920 1.691920 1.598950
##   [8] 1.598950 1.750035 1.689726 1.598950 1.695056 1.724441 1.639973
##  [15] 1.905013 1.686451 1.598950 1.598950 1.632626 1.773041 1.598950
##  [22] 1.598950 1.560835 1.560835 1.560835 1.598950 1.663669 1.560835
##  [29] 1.560835 1.682860 1.662982 1.560835 1.757834 1.802098 1.560835
##  [36] 1.663810 1.560835 1.663810 1.851200 1.713057 1.641772 1.756910
##  [43] 1.641497 1.807969 1.704808 1.647079 1.606088 1.606088 1.746635
##  [50] 1.772486 1.637062 1.772535 1.594529 1.841084 1.832297 1.763963
##  [57] 1.675845 1.641640 1.793819 1.598950 1.757834 1.643445 1.815659
##  [64] 1.560835 1.737093 1.839813 1.598950 1.839813 1.824924 1.709568
##  [71] 1.785877 1.641764 1.711762 1.724673 1.678620 1.751771 1.756535
##  [78] 1.718245 1.727465 1.760024 1.700615 1.637218 1.656207 1.816546
##  [85] 1.713075 1.623228 1.851200 1.732305 1.800841 1.598950 1.754798
##  [92] 1.807969 1.691727 1.650473 1.759622 1.688883 1.634634 1.833798
##  [99] 1.658161 1.560835 1.721732 1.662793 1.671840 1.669716 1.598950
## [106] 1.661955 1.623228 1.641491 1.711102 1.725583 1.598950 1.702147
## [113] 1.708289 1.759088 1.708600 1.635784 1.694137 1.649183 1.867360
## [120] 1.623228 1.697929 1.730437 1.688814 1.700467 1.751142 1.736275
## [127] 1.731350 1.759817 1.676143 1.615499 1.640414 1.818423 1.737196
## [134] 1.650295 1.707486 1.654759 1.652698 1.658034 1.663669 1.707486
## [141] 1.650512 1.707486 1.615499 1.640414 1.818423 1.737196 1.650295
## [148] 1.707486 1.650512 1.710015 1.718655 1.754937 1.560835 1.768742
## [155] 1.715056 1.560835 1.721584 1.666472 1.606088 1.712962 1.560835
## [162] 1.788549 1.678620 1.814402 1.705530 1.560835 1.691190 1.652698
## [169] 1.659014 1.685681 1.571453 1.646109 1.652766 1.749957 1.683637
## [176] 1.767151 1.864113 1.617092 1.699887 1.864113 1.793190 1.636621
## [183] 1.679707 1.889983 1.560835 1.623072 1.914026 1.889983 1.655508
## [190] 1.560835 1.560835 1.560835 1.700534 1.615499 1.686451 1.606088
## [197] 1.715228 1.723562 1.691920 1.571453 1.851026 1.824946 1.769067
## [204] 1.665672 1.882250 1.586969 1.785189 1.571453 1.571453 1.560835
## [211] 1.576800

7 - Compare graficamente (e através do coeficiente de correlação) as alturas reais e as alutras estimadas:

plot(dados[,2],theta.est)
abline(0,1)

cor(dados[,2],theta.est)

## [1] 0.8009637

lista2_tri