Skip to content

Commit f6b720c

Browse files
author
Robitzsch
committed
3.7-13
1 parent dd5d8bd commit f6b720c

27 files changed

+235
-75
lines changed

‎DESCRIPTION

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,8 @@
11
Package: TAM
22
Type: Package
33
Title: Test Analysis Modules
4-
Version: 3.7-5
5-
Date: 2021-05-16 13:48:06
4+
Version: 3.7-13
5+
Date: 2021-06-23 14:35:26
66
Author:
77
Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>),
88
Thomas Kiefer [aut],

‎NAMESPACE

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -136,6 +136,7 @@ export(plotDevianceTAM)
136136
export(require_namespace_msg)
137137
export(Scale)
138138
export(tam)
139+
export(tam.cb)
139140
export(tam.ctt)
140141
export(tam.ctt2)
141142
export(tam.ctt3)

‎R/RcppExports.R

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
## File Name: RcppExports.R
2-
## File Version: 3.007005
2+
## File Version: 3.007013
33
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
44
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
55

‎R/designMatrices.mfr2.R

Lines changed: 17 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
## File Name: designMatrices.mfr2.R
2-
## File Version: 9.448
2+
## File Version: 9.480
33

44

55
##*** create design matrices
@@ -69,9 +69,12 @@ designMatrices.mfr2 <- function( resp, formulaA=~ item + item:step, facets=NULL,
6969

7070
# A Matrix
7171
if( is.null(A) ){
72-
AX <- tam_A_matrix2( resp=resp, formulaA=formulaA, facets=facets,
72+
#AX <- tam_A_matrix2( resp=resp, formulaA=formulaA, facets=facets,
73+
# constraint=constraint, progress=progress, Q=Q)
74+
AX <- .A.matrix2( resp=resp, formulaA=formulaA, facets=facets,
7375
constraint=constraint, progress=progress, Q=Q)
7476
A <- AX$A
77+
7578
X <- AX$X
7679
otherFacets <- AX$otherFacets
7780
xsi.elim <- AX$xsi.elim
@@ -176,7 +179,6 @@ designMatrices.mfr2 <- function( resp, formulaA=~ item + item:step, facets=NULL,
176179
colnames(gresp) <- rownames(X)
177180
# X$empty <- 1* (colSums( gresp, na.rm=TRUE )==0)
178181
X$empty <- tam_rcpp_mml_mfr_colsums_gresp( gresp )
179-
180182
colnames(gresp.noStep) <- rownames(X.noStep)
181183
# X.noStep$empty <- 1* (colSums( gresp.noStep, na.rm=TRUE )==0)
182184
X.noStep$empty <- tam_rcpp_mml_mfr_colsums_gresp( gresp.noStep)
@@ -213,6 +215,11 @@ designMatrices.mfr2 <- function( resp, formulaA=~ item + item:step, facets=NULL,
213215
str.ss2 <- gsub( paste0("(^|-)+",str.ss), "", rownames(x)[iss] )
214216
ind_str_ss2 <- intersect( str.ss2, dimnames(x2)[[2]] )
215217
x2[ss+1,ind_str_ss2,] <- x[ iss, ]
218+
219+
# version 3.4
220+
# iss <- grep( paste0(str.ss,"+(-|$)"), rownames(x) )#, fixed=TRUE )
221+
# str.ss2 <- gsub( paste0("(^|-)+",str.ss), "", rownames(x)[iss] )
222+
# x2[ss+1,str.ss2,] <- x[ iss, ]
216223
}
217224
x2 <- aperm( x2, c(2,1,3) )
218225

@@ -275,18 +282,21 @@ designMatrices.mfr2 <- function( resp, formulaA=~ item + item:step, facets=NULL,
275282
}
276283
# cat(".....\nbefore rename A" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
277284
# print("g100")
278-
A <- .rename.items( matr=A, itemren )
279285

286+
A <- .rename.items( matr=A, itemren )
280287
dimnames(A)[[1]] <- .rename.items2aa( vec=dimnames(A)[[1]],
281288
facet.list=facet.list, I=I )
282289

283290
# cat(".rename.items (A)" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
284291
xsi.table <- xsi.constr$xsi.table
285292
# A <- .rename.items3( matr=A, facet.list, I )
286293
#cat(".rename.items3 (A)" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
294+
287295
A <- .rename.items3a( matr=A, facet.list, I, cols=TRUE, xsi.table )
296+
288297
#cat(".rename.items3a (A)" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
289298
B <- .rename.items( matr=B, itemren )
299+
290300
# cat(".rename.items (B)" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
291301
dimnames(B)[[1]] <- dimnames(A)[[1]]
292302
# B <- .rename.items3( matr=B, facet.list )
@@ -307,6 +317,7 @@ designMatrices.mfr2 <- function( resp, formulaA=~ item + item:step, facets=NULL,
307317
# Q <- .rename.items3( matr=Q, facet.list, cols=FALSE)
308318
X <- .rename.items( matr=X, itemren, cols=FALSE)
309319
dimnames(X)[[1]] <- dimnames(A)[[1]]
320+
310321
# X <- .rename.items3( matr=X, facet.list, cols=FALSE)
311322
# cat(".rename.items (Q,X)" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
312323
X.noStep <- .rename.items( matr=X.noStep, itemren, cols=FALSE)
@@ -319,6 +330,7 @@ designMatrices.mfr2 <- function( resp, formulaA=~ item + item:step, facets=NULL,
319330
#cat(".rename.items2a (G1$parameter) " ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
320331
G1$parameter <- .rename.items2b( paste( G1$parameter), facet.list, I, xsi.table )
321332
xsi.constr$xsi.table <- G1
333+
322334
# cat(".rename.items2b (G1$parameter) " ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
323335
#***
324336
G1 <- xsi.constr$xsi.constraints
@@ -347,6 +359,7 @@ designMatrices.mfr2 <- function( resp, formulaA=~ item + item:step, facets=NULL,
347359
# B
348360
B.flat.0 <- B.flat <- B; B.flat.0[ind,] <- 0
349361
B.3d <- .generateB.3d( B.flat )
362+
350363
B.flat <- B.flat[!ind,]
351364
B.3d.0 <- .generateB.3d( B.flat.0 )
352365
if(!is.null(B.store.in)) B.3d.0[] <- B.store.in

‎R/designMatrices_aux2.R

Lines changed: 33 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,9 @@
11
## File Name: designMatrices_aux2.R
2-
## File Version: 9.167
2+
## File Version: 9.201
33

44

5-
## function tam_A_matrix2
5+
###########################################################
6+
## function .A.matrix
67
.A.matrix2 <- function( resp, formulaA=~ item + item*step, facets=NULL,
78
constraint=c("cases", "items"), progress=FALSE,
89
maxKi=NULL, Q=Q )
@@ -25,7 +26,6 @@
2526
}
2627
}
2728
#cat(" +++ v62" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
28-
2929
### Basic Information and Initializations
3030
constraint <- match.arg(constraint)
3131
if ( is.null(maxKi) ){
@@ -70,9 +70,10 @@
7070
expand.list[[vv]] <- paste( expand.list[[vv]] )
7171
}
7272

73+
7374
# cat(" +++ v110" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
7475
g2 <- g1 <- expand.grid(expand.list)
75-
diffK <- ( stats::sd( maxKi) > 1e-10 )
76+
diffK <- ( stats::sd( maxKi) > 0 )
7677
# diffK <- FALSE
7778
diffK <- TRUE
7879
# reduced combinations of items
@@ -137,8 +138,8 @@
137138
}
138139

139140
A <- NULL
140-
stepgroups <- unique( gsub( "(^|-)+step([[:digit:]])*", "\\1step([[:digit:]])*",
141-
x=rownames(X), perl=TRUE ) )
141+
142+
stepgroups <- unique( gsub( "(^|-)+step([[:digit:]])*", "\\1step([[:digit:]])*", rownames(X) ) )
142143
X.out <- data.frame(as.matrix(X), stringsAsFactors=FALSE)
143144
#cat(" +++ v150" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
144145
if (progress){
@@ -155,21 +156,23 @@
155156
}
156157
}
157158
#******
158-
159-
160159
# collect xsi parameters to be excluded
161160
xsi.elim.index <- xsi.elim <- NULL
162161
ii <- 0 ; vv <- 1
163-
for( sg in stepgroups ){
164-
mm1 <- grep(paste0("(", sg, ")+$"), rownames(mm))
165-
ind2 <- grep( paste0("(", sg, ")+$"), rownames(mm))
166-
mm.sg.temp <- rbind( 0, apply( mm[ ind2,,drop=FALSE], 2, cumsum ) )
167-
if ( is.null(rownames(mm.sg.temp)) ){
168-
rownames(mm.sg.temp) <- paste0("rn", seq(0,nrow(mm.sg.temp)-1) )
169-
}
162+
for( sg in stepgroups ){
163+
# sg <- stepgroups[2]
164+
# mm1 <- mm[ grep(sg, rownames(mm)),]
165+
mm1 <- grep(paste0("(", sg, ")+$"), rownames(mm))
166+
# ind2 <- grep(sg, rownames(mm))
167+
ind2 <- grep( paste0("(", sg, ")+$"), rownames(mm))
168+
# if (length(ind2)>0){
169+
mm.sg.temp <- rbind( 0, apply( mm[ ind2,,drop=FALSE], 2, cumsum ) )
170+
# }
171+
if ( is.null(rownames(mm.sg.temp)) ){
172+
rownames(mm.sg.temp) <- paste0("rn", seq(0,nrow(mm.sg.temp)-1) )
173+
}
170174
# substitute the following line later if ...
171-
rownames(mm.sg.temp)[1] <- gsub("step([[:digit:]])*", "step0", sg, fixed=TRUE)
172-
# rownames(mm.sg.temp)[1] <- gsub("step([[:digit:]])*", "step0", sg, fixed=FALSE, perl=TRUE)
175+
rownames(mm.sg.temp)[1] <- gsub("step([[:digit:]])*", "step0", sg, fixed=T)
173176
rownames(mm.sg.temp)[-1] <- rownames(mm[ind2,,drop=FALSE])
174177
#****
175178
# set entries to zero if there are no categories in data
@@ -255,10 +258,7 @@
255258
facet.design <- list( "facets"=facets, "facets.orig"=facets0,
256259
"facet.list"=facet.list[otherFacets])
257260
A <- A[ ! duplicated( rownames(A) ), ]
258-
259-
if ( max(apply(resp,2,max,na.rm=TRUE)) > 9 ){
260-
A <- A[order(rownames(A)),,drop=FALSE]
261-
}
261+
A <- A[order(rownames(A)),,drop=FALSE]
262262
X.out <- X.out[order(rownames(X.out)),,drop=FALSE]
263263

264264

@@ -269,30 +269,32 @@
269269
xsi.elim <- data.frame( xsi.elim, xsi.elim.index )
270270
xsi.elim <- xsi.elim[ ! duplicated( xsi.elim[,2] ), ]
271271
xsi.elim <- xsi.elim[ order( xsi.elim[,2] ), ]
272-
}
272+
# A <- A[,-xsi.elim[,2] ]
273+
}
274+
273275

274-
#--- clean xsi.constr
276+
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ARb 2015-10-16
277+
#@@@@ clean xsi.constr
275278
xsi1 <- xsi.constr$xsi.constraints
276279
xsi.constr$intercept_included <- FALSE
277280
ind <- grep("(Intercept", rownames(xsi1), fixed=TRUE)
278281
if ( length(ind) > 0 ){
279282
xsi1 <- xsi1[ - ind, ]
280283
xsi.constr$xsi.constraints <- xsi1
281284
xsi.constr$intercept_included <- TRUE
282-
}
285+
}
283286
xsi1 <- xsi.constr$xsi.table
284287
ind <- grep("(Intercept", paste(xsi1$parameter), fixed=TRUE)
285288
if ( length(ind) > 0 ){
286289
xsi1 <- xsi1[ - ind, ]
287290
xsi.constr$xsi.table <- xsi1
288-
}
291+
}
292+
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
289293

290294
#cat(" +++ out .A.matrix" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
291-
res <- list( "A"=A, "X"=X.out, "otherFacets"=otherFacets, "xsi.constr"=xsi.constr,
292-
"facet.design"=facet.design, "xsi.elim"=xsi.elim )
293-
return(res)
295+
return(list( "A"=A, "X"=X.out, "otherFacets"=otherFacets, "xsi.constr"=xsi.constr,
296+
"facet.design"=facet.design, "xsi.elim"=xsi.elim ) )
294297
}
298+
## end .A.matrix
299+
#####################################################
295300

296-
297-
298-
.A.matrix2 -> tam_A_matrix2

‎R/tam.cb.R

Lines changed: 119 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,119 @@
1+
## File Name: tam.cb.R
2+
## File Version: 0.16
3+
4+
5+
6+
tam.cb <- function( dat, wlescore=NULL, group=NULL, max_ncat=30, progress=TRUE,
7+
pweights=NULL, digits_freq=5)
8+
{
9+
resp <- dat
10+
wgt <- pweights
11+
if (is.null(wgt)){
12+
wgt <- rep(1,nrow(resp))
13+
}
14+
I <- ncol(resp)
15+
if ( is.null(wlescore) ){
16+
est_wle <- 0
17+
wlescore <- rep(1, nrow(resp) )
18+
} else {
19+
est_wle <- 1
20+
}
21+
22+
resp0 <- resp
23+
wlescore0 <- wlescore
24+
25+
# define progress bar
26+
if ( is.null(group) ){
27+
group <- rep(1, nrow(resp) )
28+
}
29+
groups <- sort( unique( group ) )
30+
G <- length(groups)
31+
I <- ncol(resp)
32+
dfr <- NULL
33+
for (gg in 1:G){
34+
ind.gg <- which( group==groups[gg] )
35+
resp <- resp0[ ind.gg, ]
36+
wlescore <- wlescore0[ ind.gg ]
37+
wgt1 <- wgt[ind.gg]
38+
prg <- round( seq( 1, I, len=10 ) )
39+
prg[ prg==I ] <- I-1
40+
if (progress){
41+
cat("|")
42+
cat( paste( rep("*", 10 ), collapse="") )
43+
cat("| Group", groups[gg], "\n|")
44+
prg <- round( seq( 1, I, len=10 ) )
45+
prg[ prg==I ] <- I-1
46+
}
47+
48+
if ( ! progress ){
49+
prg <- 1
50+
}
51+
52+
dfr.gg <- data.frame( "group"=groups[gg], "groupindex"=gg,
53+
"itemno"=1:I, "item"=colnames(resp0))
54+
nar <- is.na(resp)
55+
dfr.gg$N <- colSums(1-nar)
56+
dfr.gg$W <- colSums(wgt1*(1-nar))
57+
dfr.gg$miss_prop <- colSums(wgt1*nar)/sum(wgt1)
58+
dfr.gg$is_numeric <- 0
59+
dfr.gg$M <- NA
60+
dfr.gg$kurtosis <- dfr.gg$skewness <- dfr.gg$SD <- NA
61+
dfr.gg$Min <- NA
62+
dfr.gg$Max <- NA
63+
dfr.gg$N_unique_val <- NA
64+
dfr.gg$freq <- ""
65+
if (est_wle){
66+
dfr.gg$r.WLE <- NA
67+
}
68+
69+
resp1 <- data.matrix(frame=resp)
70+
for (ii in 1:I){
71+
v1 <- resp[,ii]
72+
v2 <- paste(v1)
73+
v3 <- suppressWarnings(as.numeric(v2))
74+
is_num <- FALSE
75+
if ( mean(is.na(v3))<1 ){
76+
v2 <- v3
77+
is_num <- TRUE
78+
dfr.gg$is_numeric[ii] <- 1
79+
}
80+
if ( is_num ){
81+
dfr.gg$M[ii] <- weighted_mean(x=v3, w=wgt1)
82+
dfr.gg$SD[ii] <- weighted_sd(x=v3, w=wgt1)
83+
dfr.gg$skewness[ii] <- weighted_skewness(x=v3, w=wgt1)
84+
dfr.gg$kurtosis[ii] <- weighted_kurtosis(x=v3, w=wgt1)
85+
dfr.gg$Min[ii] <- min(v2, na.rm=TRUE)
86+
dfr.gg$Max[ii] <- max(v2, na.rm=TRUE)
87+
if (est_wle){
88+
x2 <- data.frame( v3, wlescore )
89+
ind <- which(rowSums(is.na(x2))==0)
90+
c1 <- stats::cov.wt(x2[ind,], wt=wgt1[ind], method="ML")$cov
91+
eps <- 1e-15
92+
diag(c1) <- diag(c1) + eps
93+
dfr.gg$r.WLE[ii] <- stats::cov2cor(c1)[1,2]
94+
}
95+
}
96+
l1 <- length(setdiff(unique(v1),NA))
97+
dfr.gg$N_unique_val[ii] <- l1
98+
if (l1 < max_ncat){
99+
wt <- weighted_table(v2, w=wgt1)
100+
wt <- wt / sum(wt)
101+
dfr.gg$freq[ii] <- paste0( " ", paste0( paste0( names(wt), " : ", round(wt,digits_freq)),
102+
collapse=" # " ) )
103+
}
104+
if ( ii %in% prg){
105+
cat("-")
106+
utils::flush.console()
107+
}
108+
109+
}
110+
dfr <- rbind( dfr, dfr.gg )
111+
if (progress){
112+
cat("|\n")
113+
}
114+
} # end group
115+
dfr <- dfr[ order( paste0( 10000+ dfr$itemno, dfr$group ) ), ]
116+
dfr <- data.frame( "index"=seq(1,nrow(dfr) ), dfr )
117+
return(dfr)
118+
}
119+

‎R/tam.mml.2pl.R

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
## File Name: tam.mml.2pl.R
2-
## File Version: 9.588
2+
## File Version: 9.589
33

44
tam.mml.2pl <- function( resp, Y=NULL, group=NULL, irtmodel="2PL",
55
formulaY=NULL, dataY=NULL,
@@ -338,7 +338,7 @@ tam.mml.2pl <- function( resp, Y=NULL, group=NULL, irtmodel="2PL",
338338
# cat("m step regression") ; a1 <- Sys.time(); print(a1-a0) ; a0 <- a1
339339

340340
beta <- resr$beta
341-
variance <- resr$variance
341+
variance <- resr$variance
342342
itemwt <- resr$itemwt
343343
variance_acceleration <- resr$variance_acceleration
344344
variance_change <- resr$variance_change

‎R/tam.mml.3pl.R

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
## File Name: tam.mml.3pl.R
2-
## File Version: 9.878
2+
## File Version: 9.879
33

44
tam.mml.3pl <- function( resp, Y=NULL, group=NULL,
55
formulaY=NULL, dataY=NULL,
@@ -720,7 +720,7 @@ tam.mml.3pl <- function( resp, Y=NULL, group=NULL,
720720

721721
#*** include NAs in AXsi
722722
AXsi <- tam_mml_include_NA_AXsi(AXsi=AXsi, maxcat=maxcat, A=A, xsi=xsi)
723-
723+
724724
#**** standard errors AXsi
725725
se.AXsi <- tam_mml_se_AXsi( AXsi=AXsi, A=A, se.xsi=se.xsi, maxK=maxK )
726726

0 commit comments

Comments
 (0)