inst/app/calmSupport.R

In calms: Comprehensive Analysis of Latent Means

source("FRFuncsModified.R")

psacall<-function(input,cov,covs){

group<-input$group
seed<-input$seed

dspsm<-datau

form<-paste(group,"~",sep="")
for (i in 1:length(covs)){
  if (i!=length(covs)){
    form<-paste(form,covs[i],"+",sep="")
  }else{
    form<-paste(form,covs[i],sep="")
  }
}

return(paste("matchit(",form,", data=dspsm, method='nearest', caliper=.2, pop.size=1000)",sep=""))

#return("matchit(USA~SelfEmp+PrivateOrg,data=dspsm,method='genetic',distance='glm',link='logit',caliper=.2,replace=FALSE,pop.size=1000)")
}
lmean<-function(ds,group,items,loadings,intercepts,means){

  ds[,group]<-as.factor(ds[,group])
  mi<-NULL
  mx<-NULL
  itemsx<-NULL
  si2<-NULL
  M2<-NULL
  si<-vector("list",length(scales))
  gp<-NULL
  for (i in 1:length(scales)){
    itemsx<-items[grepl(scales[i],items)]
    if(length(loadings)>0){
      loadingsx<-loadings[grepl(scales[i],loadings)]
      if (length(loadingsx)>0){
        m<-match(loadingsx,itemsx)
        itemsx<-c(itemsx[-m],itemsx[m])
      }
    }
    mx<-paste(scales[i],"=~",paste(itemsx,collapse="+"))
    if (!is.null(M2)){
      M2<-paste(M2,mx,sep="\n ")
    }else{
      M2<-mx
    }
  }

  for (i in 1:length(scales)){
    itemsx<-items[grepl(scales[i],items)]
    if(length(loadings)>0){
      loadingsx<-loadings[grepl(scales[i],loadings)]
      if (length(loadingsx)>0){
        m<-match(loadingsx,itemsx)
        itemsx<-c(itemsx[-m],itemsx[m])
      }
    }
    mx<-paste(scales[i],"=~",paste(itemsx,collapse="+"))
    si[[i]]<-paste(scales[i],"~c(",sep="")
    grpest<-paste(scales[i],"g",levels(ds[,group]),sep="")
    si[[i]]<-paste(si[[i]],paste(grpest,collapse=","),")*1","\n ",sep="")
    si[[i]]<-paste(si[[i]],scales[i],"diff := ",paste(grpest,collapse="-"),sep="")
    si2<-paste(si2,paste(scales[i],"~1"),sep="\n ")
    itemsx<-items[grepl(scales[i],items)]
    if(length(intercepts)>0){
      interceptsx<-intercepts[grepl(scales[i],intercepts)]
      if (length(interceptsx)>0){
        m<-match(interceptsx,itemsx)
        itemsx<-c(itemsx[-m],itemsx[m])
      }
    }
    for (j in 1:length(itemsx)){
      if (j==1){
        mxj<-paste(itemsx[j],"~","0")
      } else {
        mxj<-paste(mxj,paste(itemsx[j],"~","1"),sep="\n ")
      }
    }
    mx<-paste(mx,mxj,sep="\n ")
    if (!is.null(mi)){
      mi<-paste(mi,mx,sep="\n ")
    }else{
      mi<-mx
    }
  }
#  M2<-paste(mi,paste(si,collapse="\n "),sep="\n ")
  M3<-paste(mi,si2,sep="\n ")
  gp<-NULL

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

  if(length(loadings)>0){
    for (i in 1:length(loadings)){
      mx<-paste(substr(loadings[i],1,2),loadings[i],sep="=~")
      gp<-c(gp,mx)
    }
  }
  scalar<-cfa(M2,ds,group=group,group.equal=c("loadings","intercepts"),group.partial=gp)

  sscalar<-standardizedSolution(scalar)
  pscalar<-parameterEstimates(scalar)
  oute<-NULL
  outd<-NULL
  for (i in 1:length(levels(ds[,group]))){
    pscalarl<-subset(pscalar,group==i)
    sscalarl<-subset(sscalar,group==i)
    oute<-rbind(oute,pscalarl[(nrow(pscalarl)-(length(scales)-1)):nrow(pscalarl),])
    outd<-rbind(outd,sscalarl[(nrow(sscalarl)-(length(scales)-1)):nrow(sscalarl),])
  }
  out3<-cbind(oute,outd$est)
  out3<-out3[,-c(2:4,6)]
  out3$group<-as.factor(out3$group)
  levels(out3$group)<-levels(ds[,group])
  colnames(out3)[c(1,2,9)]<-c("scale",group,"d")
  out3<-na.omit(out3)
  if (!is.null(means)){
    gp<-c(gp,paste(means,1,sep="~"))
  }
  structural<-cfa(M3,ds,group=group,group.equal=c("loadings","intercepts","means"),group.partial=gp)

  models<-matrix(nrow=2,ncol=15)
  models<-as.data.frame(models)
  rownames(models)<-c("scalar","structural")
  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")
  models<-miData(models,scalar,"scalar")
  models<-miData(models,structural,"structural","scalar")

  return(list(models=models,out3=out3))
}

config<-function(ds,group,items){
  M0<-NULL
  for (i in 1:length(scales)){
    mx<-paste(scales[i],"=~",paste(itemsx<-items[grepl(scales[i],items)],collapse="+"))
    mx<-paste(mx,paste(scales[i],"~1"),sep="\n ")
    for (j in 1:length(itemsx)){
      if (j==1){
        mxj<-paste(itemsx[j],"~","0")
      } else {
        mxj<-paste(mxj,paste(itemsx[j],"~","1"),sep="\n ")
      }
    }
    mx<-paste(mx,mxj,sep="\n ")
    if (!is.null(M0)){
      M0<-paste(M0,mx,sep="\n ")
    }else{
      M0<-mx
    }
  }
  config<-cfa(M0,ds,group=group)
  return(list(model=M0,config=config))
}

metric<-function(ds,group,items,loadings){
  M0<-NULL
  for (i in 1:length(scales)){
    itemsx<-items[grepl(scales[i],items)]
    if(length(loadings)>0){
      loadingsx<-loadings[grepl(scales[i],loadings)]
      if (length(loadingsx)>0){
        m<-match(loadingsx,itemsx)
        itemsx<-c(itemsx[-m],itemsx[m])
      }
    }
    mx<-paste(scales[i],"=~",paste(itemsx,collapse="+"))
    mx<-paste(mx,paste(scales[i],"~1"),sep="\n ")
    for (j in 1:length(itemsx)){
      if (j==1){
        mxj<-paste(itemsx[j],"~","0")
      } else {
        mxj<-paste(mxj,paste(itemsx[j],"~","1"),sep="\n ")
      }
    }
    mx<-paste(mx,mxj,sep="\n ")
    if (!is.null(M0)){
      M0<-paste(M0,mx,sep="\n ")
    }else{
      M0<-mx
    }
  }
  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)
    }
  }
  metric<-cfa(M0,ds,group=group,group.equal=c("loadings"),group.partial=gp)
  return(list(model=M0,metric=metric))
}

mi<-function(ds,group,items){
 
#print(scales)
#print(items)
  configout<-config(ds,group,items)
  return(compareScales(configout$model,configout$config))


}

psacheck<-function(group,covs,seed){


form<-paste(group,"~",sep="")
for (i in 1:length(covs)){
  if (i!=length(covs)){
    form<-paste(form,covs[i],"+",sep="")
  }else{
    form<-paste(form,covs[i],sep="")
  }
}
set.seed(seed)
m.out <- matchit(as.formula(form), data = datau, method = NULL, distance = "glm")


  psacheck<-matrix(nrow=length(covs),ncol=4)
  rownames(psacheck)<-covs
  colnames(psacheck)<-c("x2","df","p","Cramer V")
  ds<-datau
  ds[,group]<-factor(ds[,group])
  for (i in 1:length(covs)){
    ds[,covs[i]]<-factor(ds[,covs[i]])
    x.out<-chisq.test(tout<-table(ds[,covs[i]],ds[,group]),correct=FALSE)
    psacheck[i,"x2"]<-x.out$statistic[[1]]
    psacheck[i,"df"]<-x.out$parameter[[1]]
    psacheck[i,"p"]<-x.out$p.value[[1]]
    psacheck[i,"Cramer V"]<-cramersV(tout)
  }
psacheck<-as.data.frame(psacheck)


return(list(chktab=psacheck,chksum=m.out))

}
 
psa<-function(input,covs,covs2){

group<-input$group
seed<-input$seed

dspsm<-datau

form<-paste(group,"~",sep="")
for (i in 1:length(covs)){
  if (i!=length(covs)){
    form<-paste(form,covs[i],"+",sep="")
  }else{
    form<-paste(form,covs[i],sep="")
  }
}

#m.out <- matchit(as.formula(form), data = dspsm, method = input$method, distance = input$distance, link = input$link, caliper=input$caliper, replace = input$replace, pop.size = input$pop.size)

if(input$psaarg==TRUE){
  expr<-parse(text=mcall)
}else{
  err<-tryCatch(expr<-parse(text= input$ccall),error=function(w){w})
#  expr<-parse(text=input$ccall)
  if (inherits(err, "error")){ 
    showNotification(err$message,type="error")
    return(NULL)
  }
}

#m.out<-eval(expr)

set.seed(seed)

err <- NULL  # Initialize error variable

# Use tryCatch to prevent system crash on error
m.out <- tryCatch(
  {
    withCallingHandlers(
      {
        eval(expr)
      },
      warning = function(w) {
        showNotification(w$message)
        invokeRestart("muffleWarning")  # Prevent warning from printing
      }
    )
  },
  error = function(e) {
    showNotification(e$message,type="error",duration=30,id="psasetup")
    err <<- e  # Store the error
    return(NULL)  # Return NULL to avoid system crash
  }
)

if  (!is.null(err)){
  return(NULL)
}else{
  removeNotification(id="psasetup")
}

#extract datafile (m.data) with matched cases
psads<<-match.data(object=m.out, group="all", distance = "distance", weights = "weights")

  psa<-matrix(nrow=length(covs2),ncol=4)
  rownames(psa)<-covs2
  colnames(psa)<-c("x2","df","p","Cramer V")
  ds<-psads
  ds[,group]<-factor(ds[,group])
  for (i in 1:length(covs2)){
    ds[,covs2[i]]<-factor(ds[,covs2[i]])
    x.out<-chisq.test(tout<-table(ds[,covs2[i]],ds[,group]),correct=FALSE)
    psa[i,"x2"]<-x.out$statistic[[1]]
    psa[i,"df"]<-x.out$parameter[[1]]
    psa[i,"p"]<-x.out$p.value[[1]]
    psa[i,"Cramer V"]<-cramersV(tout)
  }
psa<-as.data.frame(psa)

return(list(psatab=psa,psasum=m.out))
}