inst/app/FRFuncsModified.R

In calms: Comprehensive Analysis of Latent Means

miData<-function(models,model,id,compare=NULL){
  if (colnames(models)[1]=="ref-noninv"){
    print(models[id,"ref-noninv"])
  }else{
    print(id)
  }
  print(summary(model,standardized=TRUE,fit.measures=TRUE))
  fit<-as.data.frame(fitMeasures(model))
  models[id,"df"]<-fit["df",]
  models[id,"AIC"]<-fit["aic",]
  models[id,"BIC"]<-fit["bic",]
  models[id,"x2"]<-fit["chisq",]
  models[id,"CFI"]<-fit["cfi",]
  models[id,"RMSEA"]<-fit["rmsea",]
  models[id,"SRMR"]<-fit["srmr",]
  if (!is.null(compare)){
    models[id,"delta x2"]<-models[id,"x2"]-models[compare,"x2"]
    models[id,"delta df"]<-models[id,"df"]-models[compare,"df"]
    models[id,"delta CFI"]<-models[id,"CFI"]-models[compare,"CFI"]
    models[id,"delta RMSEA"]<-models[id,"RMSEA"]-models[compare,"RMSEA"]
    models[id,"delta SRMR"]<-models[id,"SRMR"]-models[compare,"SRMR"]
    models[id,"delta AIC"]<-models[id,"AIC"]-models[compare,"AIC"]
    models[id,"delta BIC"]<-models[id,"BIC"]-models[compare,"BIC"]
    models[id,"delta p"]<-pchisq(models[id,"delta x2"],models[id,"delta df"],lower.tail=FALSE)
  }
  return(invisible(models))
}

compareScales<-function(M1,fit){

lo<-lavInspect(fit,"list")
lo1<-subset(lo,(free==0)&(op=="=~"))
vars<-names(table(lo1$lhs))
varitem<-NULL
varitem<-vector("list",length(vars))
fitl<-NULL
ds1<-lavInspect(fit,"data")
ds2<-NULL

lox<-subset(lo,(user==1) & (block==1) & (op=="=~"))[,c("lhs","op","rhs")]

for (i in 1:length(ds1)){
  ds1a<-ds1[i]
  ds1b<-ds1a[[names(ds1a)]]
  ds1b<-as.data.frame(ds1b)
  ds1b$grp<-i
  rownames(ds1b)<-lavInspect(fit,"case.idx")[[names(ds1a)]]
  ds2<-rbind(ds2,ds1b)
}

colnames(ds2)<-c(lavNames(fit),"grp")

models<-matrix(nrow=length(vars)*2+3,ncol=15)
models<-as.data.frame(models)

rownames(models)<-c("configural","metric",paste("metric",vars,sep="-"),"scalar",paste("scalar",vars,sep="-"))
colnames(models)<-c("x2","df","CFI","RMSEA","SRMR","AIC","BIC","delta x2","delta df","delta p","delta CFI","delta RMSEA","delta SRMR","delta AIC","delta BIC")

model<-cfa(M1,ds2,group="grp")
invisible(models<-miData(models,model,"configural"))

model<-cfa(M1,ds2,group="grp",group.equal=c("loadings"))
models<-miData(models,model,"metric","configural")

for (i in 1:length(vars)){
  gp<-subset(lox,lhs!=vars[i])
  gp<-paste(gp$lhs,gp$rhs,sep="=~")
  model<-cfa(M1,ds2,group="grp",group.equal=c("loadings"),group.partial=gp)
  models<-miData(models,model,paste("metric",vars[i],sep="-"),"configural")
}

model<-cfa(M1,ds2,group="grp",group.equal=c("loadings","intercepts"))
models<-miData(models,model,"scalar","metric")

for (i in 1:length(vars)){
  gp<-subset(lox,lhs!=vars[i])
  gp<-paste(gp$rhs,"~1",sep=" ")
#  print(gp)
  model<-cfa(M1,ds2,group="grp",group.equal=c("loadings","intercepts"),group.partial=gp)
  models<-miData(models,model,paste("scalar",vars[i],sep="-"),"metric")
}

return(models)
}

compareItems<-function(M1,fit,scale,loadings=""){

lo<-lavInspect(fit,"list")
lo1<-subset(lo,free==0)
vars<-names(table(lo1$lhs))
varitem<-NULL
varitem<-vector("list",length(vars))
fitl<-NULL
ds1<-lavInspect(fit,"data")
ds2<-NULL

lox<-subset(lo,(user==1) & (block==1))[,c("lhs","op","rhs")]

for (i in 1:length(ds1)){
  ds1a<-ds1[i]
  ds1b<-ds1a[[names(ds1a)]]
  ds1b<-as.data.frame(ds1b)
  ds1b$grp<-i
  rownames(ds1b)<-lavInspect(fit,"case.idx")[[names(ds1a)]]
  ds2<-rbind(ds2,ds1b)
}

colnames(ds2)<-c(lavNames(fit),"grp")

vlox<-subset(lo,(op=="=~") & (group==1)& (lhs==scale))

vlox2<-subset(lo,(op=="=~") & (group==1)& (lhs==scale) & (rhs!=loadings))


comb<-combn(1:nrow(vlox2),2)
vars<-paste(comb[1,],comb[2,],sep="-")

comb2<-combn(vlox2$rhs,2)
vars2<-paste(comb2[1,],comb2[2,],sep="-")

models<-matrix(nrow=length(vars)+1,ncol=16)
models<-as.data.frame(models)

if (length(fit@Options$group.equal)==0){

  rownames(models)<-c("configural",vars)
  colnames(models)<-c("ref-noninv","x2","df","CFI","RMSEA","SRMR","AIC","BIC","delta x2","delta df","delta p","delta CFI","delta RMSEA","delta SRMR","delta AIC","delta BIC")
  models[,"ref-noninv"]<-c("configural",vars2)

  mc<-cfa(M1,ds2,group="grp")
  models<-miData(models,mc,"configural")

  vitems<-vlox$rhs
  sitems<-subset(lo,(op=="=~") & (group==1)& (lhs!=scale))[,c("lhs","op","rhs")]
  sscale<-table(sitems$lhs)
  sm1<-NULL

  if (length(sscale)!=0){
    for (i in 1:length(sscale)){
      items<-subset(sitems,lhs==names(sscale[i]))
      items<-items$rhs
      items<-paste(items,collapse="+")
      items<-paste(names(sscale[i]),items,sep="=~")
      sm1<-paste(sm1,items,sep="\n ")
    }
  }
  sgp<-subset(lox,(lhs!=scale)&(op!="~1"))
  sgp<-paste(sgp$lhs,sgp$rhs,sep="=~")

  k<-length(vitems)
  for (i in 1:(k-1)){
    vitemx<-vitems[i:k]
    if (i>1){
      vitemx<-c(vitemx,vitems[1:(k-length(vitemx))])
    }
    vitemx<-paste(vitemx,collapse="+")
    vitemx<-paste(scale,vitemx,sep="=~")
    m1<-paste(vitemx,sm1,sep="\n ")
    for (j in (i+1):k){
      vgp<-vlox[-j,]
      vgp<-paste(vgp$lhs,vgp$rhs,sep="=~")
      gp<-c(sgp,vgp)
      id<-paste(i,j,sep="-")
      model<-cfa(m1,ds2,group="grp",group.equal=c("loadings"),group.partial=gp)
      models<-miData(models,model,id,"configural")
    }
  }
}
else {

  rownames(models)<-c("metric",vars)
  colnames(models)<-c("ref-noninv","x2","df","CFI","RMSEA","SRMR","AIC","BIC","delta x2","delta df","delta p","delta CFI","delta RMSEA","delta SRMR","delta AIC","delta BIC")
  models[,"ref-noninv"]<-c("metric",vars2)

  gp<-NULL
  if (length(loadings)>0){
    for (i in 1:length(loadings)){
      mx<-paste(substr(loadings[i],1,2),loadings[i],sep="=~")
      gp<-c(gp,mx)
    }
  }
  lgp<-gp

  mc<-cfa(M1,ds2,group="grp",group.equal=c("loadings"),group.partial=gp)
  models<-miData(models,mc,"metric")

  vitems<-vlox$rhs
  sitems<-subset(lo,(op=="=~") & (group==1)& (lhs!=scale))[,c("lhs","op","rhs")]
  sscale<-table(sitems$lhs)
  sm1<-NULL

  if (length(sscale)!=0){
    for (i in 1:length(sscale)){
      items<-subset(sitems,lhs==names(sscale[i]))
      items<-items$rhs
      sml0<-paste(items[1],"\n",sep="~0")
      sml1<-paste(items[-1],"\n",sep="~1")
      sml1<-paste(sml1,collapse=" ")
      sm12<-paste(sml0,sml1,sep=" ")
      sm1<-paste(sm1,sm12,sep=" ")
      items<-subset(sitems,lhs==names(sscale[i]))
      items<-items$rhs
      items<-paste(items,collapse="+")
      items<-paste(names(sscale[i]),items,sep="=~")
      sm1<-paste(items,sm1,sep="\n ")
      sc<-paste(names(sscale[i]),"\n",sep="~1")
      sm1<-paste(sm1,sc,sep=" ")
    }
  }
  sgp<-subset(lox,(lhs!=scale)&(op!="~1"))
  sgp<-paste(sgp$rhs,"~1",sep=" ")

  k<-length(vitems)
  for (i in 1:(k-1)){
    vitemxs<-vitems[i:k]
    if (i>1){
      vitemxs<-c(vitemxs,vitems[1:(k-length(vitemxs))])
    }
    vitemx<-paste(vitemxs,collapse="+")
    vitemx<-paste(scale,vitemx,sep="=~")
    m1<-paste(vitemx,sm1,sep="\n ")
    vml0<-paste(vitemxs[1],"\n",sep="~0")
    vml1<-paste(vitemxs[-1],"\n",sep="~1")
    vml1<-paste(vml1,collapse=" ")
    vm1<-paste(vml0,vml1,sep=" ")
    sc<-paste(scale,"\n",sep="~1")
    vm1<-paste(vm1,sc,sep=" ")
    m1<-paste(m1,vm1,sep=" ")
    for (j in (i+1):k){
      vgp<-vlox[-j,]
      vgp<-paste(vgp$rhs,"1",sep="~")
      gp<-c(lgp,sgp,vgp)
      id<-paste(i,j,sep="-")
      if (!is.na(models[id,"ref-noninv"])){
        model<-cfa(m1,ds2,group="grp",group.equal=c("loadings","intercepts"),group.partial=gp)
        models<-miData(models,model,id,"metric")
      }
    }
  }

}
return(models)
}
 

listandDelete<-function(k,nonVars,names=NULL){

allVars<-c(1:k)
total<-sum(ids<-2^(allVars-1))
aps<-c(1:(total-1))
aps<-as.data.frame(aps)
ids<-as.data.frame(ids)
aps<-subset(aps,!(aps %in% ids$ids))
bitsB<-NULL
id<-NULL

for (i in 1:nrow(aps)){
  bits<-as.integer(intToBits(aps$aps[i])[1:nrow(ids)])
  bitsB<-rbind(bitsB,bits)
  aps$k[i]<-sum(bits)
  for (j in 1:length(nonVars)){
    if( (bits[as.numeric(nonVars[[j]][1])]==1) & (bits[as.numeric(nonVars[[j]][2])]==1))
      {
      id<-c(id,i)
      }
  }
}

id<-as.data.frame(id[!duplicated(id)])
colnames(id)<-"id"
aps<-cbind(aps,bitsB)

Rule2<-aps[-id$id,]

did<-NULL

for (i in max(Rule2$k):(min(Rule2$k)+1)){
  tempa<-subset(Rule2,k==i)
  if ((nrow(tempa)>0) & (nrow(subset(Rule2,k<i))>0)){
    k2<-max(subset(Rule2,k < i)$k)
    tempb<-subset(Rule2,k<=k2)
    for (j in 1:nrow(tempa)){
      for (k in 1:nrow(tempb)){
        bm<-tempa[j,-c(1,2)]
        cm<-tempb[k,-c(1,2)]
        if (!is.na(bm[1,1]) & !is.na(cm[1,1])){
          if (sum(cm[cm==1]*bm[cm==1])==length(cm[cm==1]))
            did<-c(did,tempb$aps[k])
          }
        }
     }
   }
   did<-did[!duplicated(did)]
   Rule2<-subset(Rule2,!aps %in% did)
   did<-NULL
}

ids<-Rule2[,-c(1,2)]
subsets<-vector("list",nrow(Rule2))
if (!is.null(names)) colnames(ids)<-names
for (i in 1:nrow(ids)){
  subsets[[i]]<-names(ids)[ids[i,]==1]
}
 
return(subsets)
}