The hardware and bandwidth for this mirror is donated by dogado GmbH, the Webhosting and Full Service-Cloud Provider. Check out our Wordpress Tutorial.
If you wish to report a bug, or if you are interested in having us mirror your free-software or open-source project, please feel free to contact us at mirror[@]dogado.de.

HMDCM

library(hmcdm)

Load the spatial rotation data

N = dim(Design_array)[1]
J = nrow(Q_matrix)
K = ncol(Q_matrix)
L = dim(Design_array)[3]

(1) Simulate responses based on the HMDCM model

class_0 <- sample(1:2^K, N, replace = L)
Alphas_0 <- matrix(0,N,K)
for(i in 1:N){
 Alphas_0[i,] <- inv_bijectionvector(K,(class_0[i]-1))
}
thetas_true = rnorm(N)
lambdas_true = c(-1, 1.8, .277, .055)
Alphas <- sim_alphas(model="HO_sep", 
                    lambdas=lambdas_true, 
                    thetas=thetas_true, 
                    Q_matrix=Q_matrix, 
                    Design_array=Design_array)
table(rowSums(Alphas[,,5]) - rowSums(Alphas[,,1])) # used to see how much transition has taken place
#> 
#>   0   1   2   3   4 
#>  29  44  94 146  37
itempars_true <- matrix(runif(J*2,.1,.2), ncol=2)

Y_sim <- sim_hmcdm(model="DINA",Alphas,Q_matrix,Design_array,
                   itempars=itempars_true)

(2) Run the MCMC to sample parameters from the posterior distribution

output_HMDCM = hmcdm(Y_sim,Q_matrix,"DINA_HO",Test_order = Test_order, Test_versions = Test_versions,
                     chain_length=100,burn_in=30,
                     theta_propose = 2,deltas_propose = c(.45,.35,.25,.06))
#> 0

output_HMDCM = hmcdm(Y_sim,Q_matrix,"DINA_HO",Design_array,
                     chain_length=100,burn_in=30,
                     theta_propose = 2,deltas_propose = c(.45,.35,.25,.06))
#> 0

output_HMDCM
#> 
#> Model: DINA_HO 
#> 
#> Sample Size: 350
#> Number of Items: 
#> Number of Time Points: 
#> 
#> Chain Length: 100, burn-in: 30

summary(output_HMDCM)
#> 
#> Model: DINA_HO 
#> 
#> Item Parameters:
#>  ss_EAP  gs_EAP
#>  0.2185 0.10447
#>  0.1509 0.13416
#>  0.1460 0.11755
#>  0.1109 0.13345
#>  0.1572 0.09776
#>    ... 45 more items
#> 
#> Transition Parameters:
#>    lambdas_EAP
#> λ0     -2.4904
#> λ1      2.6343
#> λ2      0.1570
#> λ3      0.2787
#> 
#> Class Probabilities:
#>      pis_EAP
#> 0000  0.1662
#> 0001  0.1550
#> 0010  0.1321
#> 0011  0.2856
#> 0100  0.1660
#>    ... 11 more classes
#> 
#> Deviance Information Criterion (DIC): 18988.66 
#> 
#> Posterior Predictive P-value (PPP):
#> M1: 0.5091
#> M2:  0.49
#> total scores:  0.6293
a <- summary(output_HMDCM)
a$ss_EAP
#>            [,1]
#>  [1,] 0.2185359
#>  [2,] 0.1508975
#>  [3,] 0.1459935
#>  [4,] 0.1109146
#>  [5,] 0.1571771
#>  [6,] 0.1235457
#>  [7,] 0.1948160
#>  [8,] 0.1361677
#>  [9,] 0.1980192
#> [10,] 0.1456517
#> [11,] 0.1848870
#> [12,] 0.1110574
#> [13,] 0.1350646
#> [14,] 0.2528662
#> [15,] 0.1748883
#> [16,] 0.1655557
#> [17,] 0.1385431
#> [18,] 0.2223850
#> [19,] 0.2045615
#> [20,] 0.1695176
#> [21,] 0.1571944
#> [22,] 0.1124408
#> [23,] 0.1301153
#> [24,] 0.1855921
#> [25,] 0.2202243
#> [26,] 0.1525441
#> [27,] 0.1647866
#> [28,] 0.1680615
#> [29,] 0.1172905
#> [30,] 0.1777252
#> [31,] 0.1769316
#> [32,] 0.1109865
#> [33,] 0.1442771
#> [34,] 0.1556111
#> [35,] 0.1155413
#> [36,] 0.1378859
#> [37,] 0.1235549
#> [38,] 0.1348546
#> [39,] 0.1591436
#> [40,] 0.1086104
#> [41,] 0.2079835
#> [42,] 0.1215910
#> [43,] 0.1214257
#> [44,] 0.1450547
#> [45,] 0.1473684
#> [46,] 0.1487711
#> [47,] 0.1697238
#> [48,] 0.1425989
#> [49,] 0.1396481
#> [50,] 0.2310405
a$lambdas_EAP
#>          [,1]
#> λ0 -2.4903700
#> λ1  2.6343340
#> λ2  0.1569946
#> λ3  0.2786637
mean(a$PPP_total_scores)
#> [1] 0.6291429
mean(upper.tri(a$PPP_item_ORs))
#> [1] 0.49
mean(a$PPP_item_means)
#> [1] 0.5071429

(3) Evaluate the accuracy of estimated parameters

Attribute-wise agreement rate between true and estimated alphas

AAR_vec <- numeric(L)
for(t in 1:L){
  AAR_vec[t] <- mean(Alphas[,,t]==a$Alphas_est[,,t])
}
AAR_vec
#> [1] 0.9385714 0.9442857 0.9657143 0.9671429 0.9771429

Pattern-wise agreement rate between true and estimated alphas

PAR_vec <- numeric(L)
for(t in 1:L){
  PAR_vec[t] <- mean(rowSums((Alphas[,,t]-a$Alphas_est[,,t])^2)==0)
}
PAR_vec
#> [1] 0.7828571 0.8085714 0.8714286 0.8800000 0.9171429

(4) Evaluate the fit of the model to the observed response

a$DIC
#>              Transition Response_Time Response    Joint    Total
#> D_bar          2010.410            NA 14851.39 1274.630 18136.42
#> D(theta_bar)   1714.288            NA 14343.59 1226.313 17284.19
#> DIC            2306.531            NA 15359.18 1322.946 18988.66

head(a$PPP_total_scores)
#>           [,1]      [,2]      [,3]      [,4]      [,5]
#> [1,] 0.4571429 0.8142857 1.0000000 0.8857143 0.5142857
#> [2,] 0.2571429 0.9142857 1.0000000 0.2714286 0.5142857
#> [3,] 0.4571429 0.6000000 0.5571429 0.6571429 0.6000000
#> [4,] 0.6000000 0.7142857 0.5428571 1.0000000 0.2428571
#> [5,] 0.6714286 0.3142857 1.0000000 0.4000000 0.1285714
#> [6,] 0.9428571 0.3857143 0.2142857 0.5428571 0.5142857
head(a$PPP_item_means)
#> [1] 0.5000000 0.5000000 0.4857143 0.5857143 0.4714286 0.5857143
head(a$PPP_item_ORs)
#>      [,1]      [,2]      [,3]      [,4]      [,5]      [,6]      [,7]      [,8]
#> [1,]   NA 0.6285714 0.8714286 0.5000000 0.6571429 0.5571429 0.5714286 0.4714286
#> [2,]   NA        NA 0.8142857 0.9142857 0.2000000 0.4571429 0.2571429 0.2857143
#> [3,]   NA        NA        NA 0.4000000 0.9428571 0.8857143 0.7857143 0.9285714
#> [4,]   NA        NA        NA        NA 0.7714286 0.4142857 0.9428571 0.9000000
#> [5,]   NA        NA        NA        NA        NA 0.8000000 0.6428571 0.6428571
#> [6,]   NA        NA        NA        NA        NA        NA 0.5571429 0.6857143
#>           [,9]      [,10]     [,11]      [,12]     [,13]     [,14]     [,15]
#> [1,] 0.3142857 0.02857143 0.1714286 0.38571429 0.4428571 0.5857143 0.5428571
#> [2,] 0.6571429 0.77142857 0.5142857 0.87142857 0.3000000 0.4428571 0.9428571
#> [3,] 0.9142857 0.50000000 0.3428571 0.31428571 0.8428571 0.9571429 0.9714286
#> [4,] 0.6571429 0.72857143 0.6142857 0.08571429 0.4714286 0.8714286 0.4714286
#> [5,] 0.3428571 0.67142857 0.1571429 0.70000000 0.2000000 0.7142857 0.8142857
#> [6,] 0.3857143 0.78571429 0.2857143 0.68571429 0.2857143 0.8428571 0.5428571
#>           [,16]     [,17]     [,18]     [,19]     [,20]     [,21]     [,22]
#> [1,] 0.07142857 0.3714286 0.1285714 0.2142857 0.5142857 0.2857143 0.5142857
#> [2,] 0.54285714 0.4714286 0.4714286 0.7571429 0.8714286 0.5000000 0.7857143
#> [3,] 0.20000000 0.6142857 0.8714286 0.6714286 0.4857143 0.2428571 0.4285714
#> [4,] 0.05714286 0.3571429 0.1857143 0.4428571 0.5285714 0.6714286 0.4285714
#> [5,] 0.42857143 0.4857143 0.4142857 0.5714286 0.8142857 0.5285714 0.6428571
#> [6,] 0.61428571 0.9428571 0.6285714 0.3714286 0.8571429 0.8000000 0.6857143
#>           [,23]     [,24]      [,25]      [,26]     [,27]     [,28]     [,29]
#> [1,] 0.37142857 0.1857143 0.50000000 0.10000000 0.6142857 0.3714286 0.3571429
#> [2,] 0.68571429 0.7857143 0.88571429 0.98571429 0.9142857 0.8428571 0.7428571
#> [3,] 0.30000000 0.7000000 0.75714286 0.78571429 0.3714286 0.8857143 0.3428571
#> [4,] 0.04285714 0.4428571 0.07142857 0.04285714 0.9142857 0.8428571 0.4428571
#> [5,] 0.42857143 0.7428571 0.47142857 0.27142857 0.7714286 0.8285714 0.5571429
#> [6,] 0.10000000 0.8285714 0.25714286 0.61428571 0.5857143 0.5000000 0.8142857
#>          [,30]     [,31]     [,32]     [,33]     [,34]      [,35]     [,36]
#> [1,] 0.3857143 0.2000000 0.2428571 0.3714286 0.4000000 0.34285714 0.6571429
#> [2,] 0.5571429 0.6285714 0.3857143 0.5000000 0.1285714 0.35714286 0.2571429
#> [3,] 0.7857143 0.5142857 0.2142857 0.8571429 0.7428571 0.84285714 0.9857143
#> [4,] 0.3714286 0.8857143 0.3857143 0.2714286 0.6428571 0.07142857 0.7714286
#> [5,] 0.5714286 0.2571429 0.1857143 0.8285714 0.3571429 0.25714286 0.3428571
#> [6,] 0.2285714 0.6714286 0.6857143 0.7571429 0.5571429 0.61428571 0.9571429
#>          [,37]     [,38]     [,39]     [,40]     [,41]     [,42]     [,43]
#> [1,] 0.4571429 0.4428571 0.9714286 0.4428571 0.9142857 0.1285714 0.5571429
#> [2,] 0.5428571 0.4571429 0.8000000 0.5000000 0.8857143 0.4428571 0.2142857
#> [3,] 0.2142857 0.8714286 0.6000000 0.9428571 0.7285714 0.3000000 0.3142857
#> [4,] 0.3000000 0.0000000 0.4285714 0.4857143 0.5714286 0.5428571 0.1000000
#> [5,] 0.1571429 0.6714286 0.7714286 0.5714286 0.9285714 0.7857143 0.8571429
#> [6,] 0.5571429 0.9000000 0.7142857 0.9714286 0.9428571 0.3857143 0.1000000
#>          [,44]      [,45]      [,46]     [,47]     [,48]     [,49]      [,50]
#> [1,] 0.6428571 0.74285714 0.07142857 0.9714286 0.3571429 0.2857143 0.62857143
#> [2,] 0.3428571 0.42857143 0.60000000 0.9285714 0.1571429 0.4857143 0.51428571
#> [3,] 0.4285714 0.77142857 0.81428571 0.9714286 0.2428571 0.4714286 0.21428571
#> [4,] 0.1428571 0.87142857 0.15714286 0.9000000 0.2571429 0.3000000 0.08571429
#> [5,] 0.7714286 0.84285714 0.44285714 0.8428571 0.4714286 0.5714286 0.30000000
#> [6,] 0.5285714 0.08571429 0.11428571 0.4428571 0.1857143 0.5000000 0.00000000
library(bayesplot)
pp_check(output_HMDCM)

pp_check(output_HMDCM, plotfun="dens_overlay", type="item_mean")

pp_check(output_HMDCM, plotfun="hist", type="item_OR")
#> Note: in most cases the default test statistic 'mean' is too weak to detect anything of interest.
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.

pp_check(output_HMDCM, plotfun="stat_2d", type="item_mean")
#> Note: in most cases the default test statistic 'mean' is too weak to detect anything of interest.

pp_check(output_HMDCM, plotfun="scatter_avg", type="total_score")

pp_check(output_HMDCM, plotfun="error_scatter_avg", type="total_score")

Convergence checking

Checking convergence of the two independent MCMC chains with different initial values using coda package.

# output_HMDCM1 = hmcdm(Y_sim, Q_matrix, "DINA_HO", Design_array,
#                      chain_length=100, burn_in=30,
#                      theta_propose = 2, deltas_propose = c(.45,.35,.25,.06))
# output_HMDCM2 = hmcdm(Y_sim, Q_matrix, "DINA_HO", Design_array,
#                      chain_length=100, burn_in=30,
#                      theta_propose = 2, deltas_propose = c(.45,.35,.25,.06))
# 
# library(coda)
# 
# x <- mcmc.list(mcmc(t(rbind(output_HMDCM1$ss, output_HMDCM1$gs, output_HMDCM1$lambdas))),
#                mcmc(t(rbind(output_HMDCM2$ss, output_HMDCM2$gs, output_HMDCM2$lambdas))))
# 
# gelman.diag(x, autoburnin=F)

These binaries (installable software) and packages are in development.
They may not be fully stable and should be used with caution. We make no claims about them.
Health stats visible at Monitor.