Nothing
## File Name: tam_mml_mfr_proc_multiple_person_ids.R
## File Version: 0.252
tam_mml_mfr_proc_multiple_person_ids <- function(pid,tp, gresp, gresp.noStep,
progress=TRUE, group=NULL, Y=NULL, pweights=NULL )
{
persons <- sort( unique( pid ) )
NP <- length( persons )
person.ids <- sapply( persons, FUN=function(pp){ which( pid==pp ) },
simplify=FALSE)
PP <- matrix( NA, nrow=NP, ncol=tp)
for (pos in 1:tp){
PP[,pos] <- unlist( lapply( person.ids, FUN=function(vv){ vv[pos] } ) )
}
if (! is.null(group)){
group <- group[ PP[,1] ]
}
if (! is.null(Y)){
Y <- Y[ PP[,1],, drop=FALSE ]
}
if (! is.null(pweights)){
pweights <- pweights[ PP[,1] ]
}
gresp0 <- matrix( NA, nrow=NP, ncol=ncol(gresp) )
colnames(gresp0) <- colnames(gresp)
gresp0.noStep <- matrix( NA, nrow=NP, ncol=ncol(gresp.noStep) )
colnames(gresp0.noStep) <- colnames(gresp.noStep)
grespNA <- ( ! is.na( gresp ) )
grespnoStepNA <- ( ! is.na( gresp.noStep ) )
#-- check multiple rows
m1 <- rowsum( 1-is.na(gresp.noStep), pid )
h1 <- sum(m1>1)
if (h1>0){
cat("* Combinations of person identifiers and facets are not unique.\n")
cat("* Use an extended 'formulaA' to include all \n")
cat(" relevant facets and the argument 'xsi.setnull'.\n")
cat(" See the help page of 'tam.mml' (?tam.mml) Example 10a.\n")
stop()
}
for (pos in 1:tp){
ind.pos <- which( ! is.na( PP[,pos] ) )
PP.pos <- PP[ind.pos,pos]
g1 <- gresp[ PP.pos, ]
g0 <- gresp0[ ind.pos, ]
ig1 <- grespNA[ PP.pos, ]
# * this check is time-consuming! release it to rcpp
g0[ ig1 ] <- g1[ ig1 ]
gresp0[ ind.pos, ] <- g0
g1 <- gresp.noStep[ PP.pos, ]
g0 <- gresp0.noStep[ ind.pos, ]
ig1 <- grespnoStepNA[ PP.pos, ]
g0[ ig1 ] <- g1[ ig1 ]
gresp0.noStep[ ind.pos, ] <- g0
}
gresp0 -> gresp
gresp0.noStep -> gresp.noStep
pid <- persons
if (progress){
cat(" * Arranged Response Data with Multiple Person Rows (",
paste(Sys.time()), ")\n")
utils::flush.console()
}
# if (is.null(Y)){
# Y <-
# }
#--- OUTPUT
res <- list(pid=pid, gresp=gresp, gresp.noStep=gresp.noStep,
group=group, Y=Y, pweights=pweights)
return(res)
}
# cat("*** multiple persons lapply function" ) ; a1 <- Sys.time() ; print(a1-a0) ; a0 <- a1
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.