Nothing
## File Name: designMatrices.mfr.R
## File Version: 9.419
designMatrices.mfr <- function( resp, formulaA=~ item + item:step, facets=NULL,
constraint=c("cases", "items"), ndim=1,
Q=NULL, A=NULL, B=NULL, progress=FALSE )
{
tamcat_active <- TRUE
tamcat_active <- FALSE
z0 <- Sys.time()
### Basic Information and Initializations
constraint <- match.arg(constraint)
## restructure formulaA
t1 <- attr( stats::terms(formulaA), "term.labels" )
t2 <- intersect( c("item", "step", "item:step"), t1 )
t0 <- attr( stats::terms(formulaA), "intercept" )
inc <- ""
if ( t0 %in% c(0,-1) ){ inc <- "0 + "}
formulaA <- paste( paste( c(t2, setdiff(t1, t2 ) ), collapse=" + " ) )
formulaA <- stats::as.formula( paste( " ~ ", inc, formulaA ) )
#--- change formate in facets
FF <- ncol(facets)
NFF <- nrow(facets)
if (progress){
cat( " o Check facets (", paste(Sys.time()), ")\n") ; flush.console();
}
if ( is.null(FF) ){ FF <- 0 }
if (FF>0){
for (ff in 1:FF){
# ff <- 1
#**** inclusion ARb 2013-09-07
# cff <- nchar(facets[,ff] )
cff <- nchar(paste( facets[,ff] ) )
Mff <- max(cff)
sff <- paste( rep("_", Mff ), collapse="" )
if( min(cff) < Mff ){
facets.ff0 <- facets[,ff]
# facets[,ff] <- paste0( facets[,ff], substring( sff, 1, Mff - cff ) )
facets[,ff] <- paste0( "_", facets[,ff], substring( sff, 1, Mff - cff ) )
if (progress){
u1 <- unique( setdiff( paste(facets[,ff]), paste( facets.ff0 ) ) )
p1 <- paste0( " * Changed levels of facet ", colnames(facets)[ff], ":" )
p1 <- paste( p1, paste( paste0("'",u1,"'"), collapse=" " ) )
cat(p1, "\n")
}
}
}
}
z0 <- tamcat( " --- z50", z0, tamcat_active )
#********************************
# resp[ is.na(resp) ] <- 0
# maxKi <- apply( resp, 2, max, na.rm=TRUE )
maxKi <- tam_max_categories(resp=resp)
maxK <- max( maxKi )
I <- nI <- ncol( resp )
item <- rep( 1:nI, maxKi+1 )
if ( is.null( colnames(resp) ) ){
colnames(resp) <- paste0( "item", 1:nI )
}
z0 <- tamcat( " --- before .A.matrix", z0, tamcat_active )
# A Matrix
if( is.null(A) ){
#!!!! work on speeding this step!!
AX <- .A.matrix( resp, formulaA=formulaA, facets=facets, constraint=constraint,
progress=progress)
z0 <- tamcat( " --- after .A.matrix", z0, tamcat_active )
A <- AX$A; X <- AX$X; otherFacets <- AX$otherFacets
xsi.constr <- AX$xsi.constr
facet.design <- AX$facet.design
facet.list <- facet.design$facet.list
facets <- facet.design$facets
X.noStep <- unique(X[,- grep("step", colnames(X)), drop=FALSE ])
rownames(X.noStep) <- gsub("-step([[:digit:]])*", "", rownames(X.noStep))
}
z0 <- tamcat( " --- A matrix (is.null(A)", z0, tamcat_active )
# TK: 2014-03-12
# Consider long vector response matrix
if( "item" %in% colnames(facets) & "item" %in% t2 ) otherFacets <- c("item", otherFacets)
X.ind <- if( "item" %in% colnames(facets) | nI==1) rep(1,nrow(X)) else as.numeric(X[,"item"])
X.noStep.ind <- if( "item" %in% colnames(facets) | nI==1)
rep(1,nrow(X.noStep)) else as.numeric(X.noStep[,"item"])
if (progress){
cat( " o Created A Matrix (", paste(Sys.time()), ")\n") ; flush.console();
}
z0 <- tamcat( " --- created A matrix", z0, tamcat_active )
# Q Matrix
if( is.null(Q) ){
if( ndim > 1 ) warning("random q matrix")
Q <- matrix( 0, nrow=nI, ncol=ndim )
Q[ cbind( 1:nI, sample(1:ndim, nI, replace=T) ) ] <- 1
}
Q <- Q[X.ind,,drop=FALSE]
dimnames(Q) <- list( rownames(X),
paste( "Dim", add.lead( 1:ndim, ceiling(log(ndim, 10)) ), sep="")
)
# ndim
ndim <- dim(Q)[2]
z0 <- tamcat( " --- after Q", z0, tamcat_active )
# B Matrix
if( is.null(B) ){
B.store.in <- NULL
B <- Q * as.numeric(X$step)
}else{
B.store.in <- B
B <- Q * as.numeric(X$step)
}
if (progress){
cat( " o Created B Matrix (", paste(Sys.time()), ")\n") ; flush.console();
}
# gresp
ind.resp.cols <- as.numeric(X.ind)
z0 <- tamcat( " --- before gresp", z0, tamcat_active )
gresp <- resp[,ind.resp.cols]
z0 <- tamcat( " --- after gresp selection ", z0, tamcat_active )
# res <- gresp_selection( as.matrix(resp), ind.resp.cols-1 )
# no much time gain with Rcpp function
# cat(" --- after gresp selection (Rcpp) " ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
# gresp <- 1* ( gresp==t(array( X[, "step"], dim=dim(t(gresp)) )) )
# gresp <- 1*(gresp==matrix( as.numeric(X[,"step"]), nrow(gresp), ncol(gresp), byrow=TRUE ))
# This step is time-consuming!!
#**** ARb 2014-05-30
gresp <- tam_rcpp_mml_mfr_gresp_extend( gresp=as.matrix(gresp), xstep=as.numeric( X[,"step"] ) )
z0 <- tamcat( " --- after gresp ", z0, tamcat_active )
ind.resp.cols <- as.numeric(X.noStep.ind)
gresp.noStep <- resp[,ind.resp.cols]
z0 <- tamcat( " --- gresp ind.resp.cols ", z0, tamcat_active )
if( length(otherFacets) > 0 ){
rnFacets <- rownames( rownames.design2( as.matrix(facets[,otherFacets]) ))
rnX <- rownames( rownames.design2( as.matrix(X[,otherFacets]) ))
rnX.noStep <- rownames( rownames.design2( as.matrix(X.noStep[,otherFacets]) ))
z0 <- tamcat( " --- rownames.design2 ", z0, tamcat_active )
#*** ARb 2013-03-26:
#*** Set all entries in gresp and gresp.noStep to missing
#*** if they are not observed.
# gresp <- gresp * (1* outer(rnFacets, rnX, "=="))
# gresp[ outer(rnFacets, rnX, "!=") ] <- NA
# gresp.noStep <- gresp.noStep * (1* outer(rnFacets, rnX.noStep, "=="))
# gresp.noStep[ outer(rnFacets, rnX.noStep, "!=") ] <- NA
gresp <- tam_rcpp_mml_mfr_gresp_na_facets( gresp=as.matrix(gresp),
rnfacets=rnFacets, rnx=rnX )
z0 <- tamcat( " --- gresp na facets gresp ", z0, tamcat_active )
gresp.noStep <- tam_rcpp_mml_mfr_gresp_na_facets( gresp=as.matrix(gresp.noStep),
rnfacets=rnFacets, rnx=rnX.noStep )
z0 <- tamcat( " --- gresp na facets gresp.noStep ", z0, tamcat_active )
}
# cat(" --- after other facets" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
colnames(gresp) <- rownames(X)
X$empty <- tam_rcpp_mml_mfr_colsums_gresp( gresp )
z0 <- tamcat( " --- col sums (gresp) in X (Rcpp)", z0, tamcat_active )
colnames(gresp.noStep) <- rownames(X.noStep)
# X.noStep$empty <- 1* (colSums( gresp.noStep, na.rm=TRUE )==0)
X.noStep$empty <- tam_rcpp_mml_mfr_colsums_gresp( gresp.noStep )
z0 <- tamcat( " --- col sums (gresp noStep) in X (Rcpp)", z0, tamcat_active )
### output
ind <- X[,"empty"]==1
nStep <- maxK+1
nGenit <- nrow(X)
.generate.3d <- function(x){
return( aperm( array( as.matrix(x), dim=c( nStep, nGenit/nStep, ncol(x) ),
dimnames=list( paste("_step",0:maxK, sep=""),
unique(gsub("-step([[:digit:]])*", "", rownames(x))),
colnames(x) ) )
, c(2,1,3)
) )
}
#**************************
# generate B
.generateB.3d <- function(x){
x2 <- array( 0, c(nStep, nGenit/nStep, ncol(x) ) )
dimnames(x2) <- list( paste("_step",0:maxK, sep=""),
unique(gsub("(^|-)+step([[:digit:]])*", "", rownames(x))),
colnames(x) )
for (ss in 0:(nStep-1)){
str.ss <- paste0("step",ss )
iss <- grep( paste0(str.ss,"+(-|$)"), rownames(x) )#, fixed=TRUE )
iss <- setdiff(iss, grep( paste0( "step", ss, ss,"+(-|$)"), rownames(x) ) )
str.ss2 <- gsub( paste0("(^|-)+",str.ss), "", rownames(x)[iss] )
x2[ss+1,str.ss2,] <- x[ iss, ]
}
x2 <- aperm( x2, c(2,1,3) )
return(x2)
}
#**************************
# cat(" --- before item rename" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
#***
# debugging ind manually
ind <- FALSE * ind
#*************
# rename items
# TK 2014-03-12: consider "item" in facets or long vector response MX
if( "item" %in% colnames(facets) ){
itemren <- data.frame(
"item"=unique(facet.design$facets.orig[,"item"]),
"itemren"=paste0( "item", unique(facet.design$facets[,"item"]) ) )
} else {
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ARb 2015-10-16
n1 <- nI
if ( xsi.constr$intercept_included ){ n1 <- nI - 1 }
itemren <- data.frame( "item"=colnames(resp)[1:n1],
"itemren"=paste0( "item", 1:n1 ) )
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
}
# cat(" --- .....before rename A" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
A <- .rename.items( matr=A, itemren )
z0 <- tamcat( " --- .rename.items (A)", z0, tamcat_active )
# print( dimnames(A) )
# print(facet.list)
dimnames(A)[[1]] <- .rename.items2aa( vec=dimnames(A)[[1]],
facet.list=facet.list, I=I )
z0 <- tamcat( " --- .rename.items2aa (A)", z0, tamcat_active )
xsi.table <- xsi.constr$xsi.table
A <- .rename.items3a( matr=A, facet.list=facet.list, I=I, cols=TRUE, xsi.table=xsi.table )
z0 <- tamcat( " --- .rename.items3a (A)", z0, tamcat_active )
# B <- .rename.items( matr=B, itemren )
# z0 <- tamcat( " --- .rename.items (B)", z0, tamcat_active )
dimnames(B)[[1]] <- dimnames(A)[[1]]
z0 <- tamcat( " --- dimnames(B)", z0, tamcat_active )
# B <- .rename.items3( matr=B, facet.list )
# gresp <- t( .rename.items( matr=t(gresp), itemren, cols=FALSE) )
# z0 <- tamcat( " --- .rename.items (gresp)", z0, tamcat_active )
dimnames(gresp)[[2]] <- dimnames(A)[[1]]
z0 <- tamcat( " --- colnames(gresp) <- dimnames(A)", z0, tamcat_active )
#Revalpr("sum(dimnames(A)[[1]] !=colnames(gresp))")
# gresp <- t( .rename.items3( matr=t(gresp), facet.list, cols=FALSE) )
dimnames(gresp)[[2]] <- dimnames(A)[[1]]
gresp.noStep <- t( .rename.items( matr=t(gresp.noStep), itemren, cols=FALSE) )
z0 <- tamcat( " --- .rename.items (gresp.noStep)", z0, tamcat_active )
# gresp.noStep <- t( .rename.items3( matr=t(gresp.noStep), facet.list, I, cols=FALSE) )
gresp.noStep <- t( .rename.items3a( matr=t(gresp.noStep), facet.list, I, cols=FALSE,
xsi.table ) )
z0 <- tamcat( " --- .rename.items (gresp.noStep) facet list", z0, tamcat_active )
Q <- .rename.items( matr=Q, itemren, cols=FALSE)
dimnames(Q)[[1]] <- dimnames(A)[[1]]
z0 <- tamcat( " --- .rename.items (Q)", z0, tamcat_active )
# Q <- .rename.items3( matr=Q, facet.list, cols=FALSE)
X <- .rename.items( matr=X, itemren, cols=FALSE)
dimnames(X)[[1]] <- dimnames(A)[[1]]
# X <- .rename.items3( matr=X, facet.list, cols=FALSE)
z0 <- tamcat( " --- .rename.items (Q,X)", z0, tamcat_active )
X.noStep <- .rename.items( matr=X.noStep, itemren, cols=FALSE)
z0 <- tamcat( " --- .rename.items (X.noStep)", z0, tamcat_active )
# X.noStep <- .rename.items3( matr=X.noStep, facet.list, cols=FALSE)
#***
G1 <- xsi.constr$xsi.table
G1$parameter <- .rename.items2( paste( G1$parameter), itemren)
z0 <- tamcat( " --- .rename.items2 (G1$parameter)", z0, tamcat_active )
# G1$parameter <- .rename.items2a( paste( G1$parameter), facet.list, I)
# cat(" --- .rename.items2a (G1$parameter) " ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
G1$parameter <- .rename.items2b( paste( G1$parameter), facet.list, I, xsi.table )
xsi.constr$xsi.table <- G1
z0 <- tamcat( " --- .rename.items2b (G1$parameter)", z0, tamcat_active )
#***
G1 <- xsi.constr$xsi.constraints
rownames(G1) <- .rename.items2( rownames(G1), itemren)
colnames(G1) <- .rename.items2( colnames(G1), itemren)
z0 <- tamcat( " --- .rename.items2 (colnames(G1))", z0, tamcat_active )
colnames(G1) <- .rename.items2b( colnames(G1), facet.list, I, xsi.table, sel1=1)
rownames(G1) <- .rename.items2b( rownames(G1), facet.list, I, xsi.table, sel1=2)
z0 <- tamcat( " --- .rename.items2b (dimnames(G1))", z0, tamcat_active )
G1 -> xsi.constr$xsi.constraints
#cat(" --- rename items" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
if (progress){
cat( " o Relabeled Variable Names (", paste(Sys.time()), ")\n") ; flush.console();
}
z0 <- tamcat( " --- after all renames", z0, tamcat_active )
# A
A.flat.0 <- A.flat <- A; A.flat.0[ind,] <- 0
A.3d <- .generateB.3d( A.flat )
A.flat <- A.flat[!ind,]
A.3d.0 <- .generateB.3d( A.flat.0 )
z0 <- tamcat( " --- A generate 3d", z0, tamcat_active )
# B
B.flat.0 <- B.flat <- B; B.flat.0[ind,] <- 0
B.3d <- .generateB.3d( B.flat )
B.flat <- B.flat[!ind,]
B.3d.0 <- .generateB.3d( B.flat.0 )
if(!is.null(B.store.in)) B.3d.0[] <- B.store.in
z0 <- tamcat( " --- B generate 3d", z0, tamcat_active )
# Q
Q.flat.0 <- Q.flat <- Q; Q.flat.0[ind,] <- 0
Q.3d <- .generateB.3d( Q.flat )
Q.flat <- Q.flat[!ind,]
Q.3d.0 <- .generateB.3d( Q.flat.0 )
z0 <- tamcat( " --- Q generate 3d", z0, tamcat_active )
# out
out <- list( "gresp"=list("gresp"=gresp, "gresp.noStep"=gresp.noStep),
"A"=list("A.flat"=A.flat, "A.flat.0"=A.flat.0,
"A.3d"=A.3d, "A.3d.0"=A.3d.0),
"B"=list("B.flat"=B.flat, "B.flat.0"=B.flat.0,
"B.3d"=B.3d, "B.3d.0"=B.3d.0),
"Q"=list("Q.flat"=Q.flat, "Q.flat.0"=Q.flat.0,
"Q.3d"=Q.3d, "Q.3d.0"=Q.3d.0),
"X"=list("X"=X, "X.noStep"=X.noStep),
"xsi.constr"=xsi.constr
)
class(out) <- "designMatrices.mfr"
return(out)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.