calms
Comprehensive Analysis of Latent Means

Package index
Search the calms package
Vignettes
Functions
3
Source code
10
Man pages
2
Home
/
CRAN
/
calms
/
inst/app/server.R

inst/app/server.R
In calms: Comprehensive Analysis of Latent Means 

server = function(input, output,session) {

output$frame<-renderUI({
  test<-"https://player.vimeo.com/video/1102286467?h=045f02e910&amp;title=0&amp;byline=0&amp;portrait=0&amp;badge=0&amp;autopause=0&amp;player_id=0&amp;app_id=58479"
  my_test<-tags$iframe(src=test,height=600,width=535)
  my_test<-tags$iframe(src=test,style="height:600px;width:100%",allowfullscreen=TRUE)
  my_test
})

output$output<-NULL

shinyjs::disable("analyze")
shinyjs::disable("datbut")
shinyjs::disable("chkbut")
shinyjs::disable("psabut")
shinyjs::disable("datbut2")
shinyjs::disable("mibut")
shinyjs::disable("mimodbut")
shinyjs::disable("metricbut")
shinyjs::disable("metricmodbut")
shinyjs::disable("scalarbut")
shinyjs::disable("scalarmodbut")
shinyjs::disable("latentbut")
shinyjs::disable("latentbut2")
shinyjs::disable("latentmodbut")

observeEvent(input$ccall,{
  if (is.character(input$ccall)==TRUE){
    formc<-sub("data=dspsm.*","",input$ccall)
    formm<-sub("data=dspsm.*","",mcall)
    if (formc!= formm){
      shinyjs::disable("analyze")
      showNotification("Call to matchit must have the same formula and data arguments as the default",type="error")
    }else{
      if (str_sub(input$ccall,-1,-1)==")"){
        shinyjs::enable("analyze")
      }else{
        shinyjs::disable("analyze")
        showNotification("Call to matchit missing ')'",type="error")
      }
    }
  }else{
    shinyjs::disable("analyze")
  }

})

observeEvent(input$psaarg,{
    hideTab(inputId="tabSelected",target="psa")
    if (input$anal=="psa") updateTabsetPanel(session,"tabSelected","psasetup")
    if (input$psaarg==TRUE){
     output$call<-NULL
     output$ccall<-NULL
    }else{
      output$ccall<-renderUI({
        textAreaInput("ccall","Edit code after 'data=dspsm' to customize arguments to matchit",value=mcall,width='120%')
        }) 
    }
})

observeEvent(input$usewos,{
      hideTab(inputId="tabSelected",target="check")
      hideTab(inputId="tabSelected",target="psa")
      hideTab(inputId="tabSelected",target="mi")
      hideTab(inputId="tabSelected",target="metric")
      hideTab(inputId="tabSelected",target="scalar")
      hideTab(inputId="tabSelected",target="latent")
      hideTab(inputId="tabSelected",target="psasetup")
      if (input$usewos==TRUE){
        datau<<-read.spss("WosDemo.sav",use.value.labels=TRUE, max.value.labels=Inf, to.data.frame=TRUE)
        metad<<-as.data.frame(read.csv("WosDemoMeta.csv"))
        colnames(datau)<<-metad$item
        slevels<-table(subset(metad,type=="item")$scale)
        scales<-names(slevels)
        scales<<-scales
        group<-metad$item[metad$type=="group"]
        cov<-metad$item[metad$type=="cov"]
        items<-metad$item[(metad$type=="item")]
        datau<<-datau[,stringr::str_sort(colnames(datau),numeric=TRUE)]
        datal<-select_if(datau,is.numeric)
        datal<-datal[,grepl("[0-9]",colnames(datal))]
        updateSelectInput(session,"usepsa",choices=FALSE)
        updateSelectInput(session,"checkvars",choices=cov,selected=cov)
        updateSelectInput(session,"psavars",choices=cov,selected=cov)
        updateSelectInput(session,"items",choices=items,selected=items)
        updateSelectInput(session, "group",choices = group,selected=group)
        updateSelectInput(session,"scales",choices=scales)
        updateSelectInput(session,"means",choices=scales)
        updateSelectInput(session,"anal",choices = c("Check Group Equivalency"='check',"Propensity Score Analysis"='psa',
                                                  "Measurement Invariance"='mi',
                                                  "Metric Invariance"='metric',
                                                  "Scalar Invariance"='scalar',"Structural Invariance"='latent'))
        shinyjs::enable("analyze")
        output$metatab<-renderDT(metad,caption="Meta Data",rownames=FALSE,options=list(pageLength=5,lengthChange=FALSE,searching=FALSE))
        output$datatab<-renderDT(datau,caption="Cleaned Data",rownames=TRUE,options=list(pageLength=5,lengthChange=FALSE,searching=FALSE,scrollX=TRUE))
#        updateTabsetPanel(session,"tabSelected","data")
        output$metbut <- downloadHandler(
            filename = function() {
            "meta.csv"
        },
        content = function(file) {
            write.csv(metad,file,row.names=FALSE)
        }
        )
        shinyjs::enable("metbut")
      } else {
          datau<<-NULL
          metad<<-NULL
          shinyjs::disable("analyze")
          updateSelectInput(session,"usepsa",choices=FALSE)
          updateSelectInput(session,"anal",choices=c("None"))
      }
})

  observeEvent(input$upload,{
#    cleanup(output)
    shinyjs::disable("metbut")
    shinyjs::disable("datbut")
    error<-TRUE
    if (length(input$upload$name)!=2){
      showNotification("Only two files should be uploaded.",type="error")
    } else {
      metaf<-NULL
      dataf<-1  
      for (i in 1:2){
        if (str_sub(input$upload$name[i],-8,-1)=="Meta.csv"){
          metaf<-i
        }
      }
      if (is.null(metaf)){
        showNotification("*Meta.csv not uploaded.",type="error")
      } else {
        if (metaf==1) dataf<-2
        metad<-read.csv(input$upload$datapath[metaf])
        if (sum(colnames(metad)==c("itemo","item","type","scale","ds","missing"))!=6){
          showNotification("*Meta.csv not correctly formatted.",type="error")
        } else if (metad[1,"ds"]!=input$upload$name[dataf]){
          showNotification("Dataset identified in metadata not uploaded.",type="error")
        }else{
          ext<-str_sub(input$upload$name[dataf],-4,-1)
          if (ext==".dat"){
            datau<-read.table(input$upload$datapath[dataf],sep="\t")
            error<-FALSE
          } else if (ext == ".csv"){
            datau<-read.csv(input$upload$datapath[dataf])
            error<-FALSE
          } else if (ext == ".sav") {
            datau<-read.spss(input$upload$datapath[dataf])
            error<-FALSE
          } else {
            showNotification("Unsupported file type detected. Please upload a .CSV, .DAT, or .SAV file.",type="error")
          }
        }
      }
    }
    if (error==FALSE){
      datau<-as.data.frame(datau)
      metado<-as.data.frame(metad)
      metad<-subset(metado,((type=="item") | (type=="cov")| (type=="group")))
      if (nrow(metado)!= nrow(metad)){
        showNotification("type must be item, cov, or group",type="error")
        error<-TRUE
      }else if ((length(unique(metad$itemo))!=nrow(metad)) | (length(unique(metad$item))!=nrow(metad))){
        showNotification("Not all item names in meta file are unique.",type="error")
        error<-TRUE
      } else {
        check<-na.omit(match(metad$itemo,colnames(datau)))
        if (length(check)!=nrow(metad)){
          showNotification("Not all variables in meta file contained in data file.", type="error")
          error<-TRUE
        }
      }
    }
    if (error==FALSE){
        slevels<-table(subset(metad,type=="item")$scale)
        if (length(slevels)<1){
           showNotification("At least one scale needs to be identified",type="error")   
        } else if ((length(slevels)==1)& (min(slevels)<3)){
           showNotification("At least one scale with three items need to be identified",type="error")     
        } else if ((length(slevels)>1) & (min(slevels)<2)){
           showNotification("At least two scales with two items each need to be identified",type="error")          
        }else{ 
          metad<<-metad
          scales<<-names(slevels)
          colnames(datau)[check]<-metad$item
          datau<-datau[,metad$item]
          datau<-select_if(datau,is.numeric)
          if (is.numeric(metad[1,"missing"])) datau<-datau %>% replace_with_na_all(condition= ~.x == metad[1,"missing"])
          datau<-as.data.frame(datau)
          datau<-na.omit(datau)
          datau<-datau[,stringr::str_sort(colnames(datau),numeric=TRUE)]
          head(datau)
          datau<<-datau
          psads<<-datau
          group<-metad$item[metad$type=="group"]
          cov<-metad$item[metad$type=="cov"]
          items<-metad$item[(metad$type=="item")]
          updateCheckboxInput(session,"usewos",value=FALSE)
          updateSelectInput(session,"usepsa",choices=FALSE)
          updateSelectInput(session,"checkvars",choices=cov,selected=cov)
          updateSelectInput(session,"psavars",choices=cov,selected=cov)
          updateSelectInput(session,"items",choices=items,selected=items)
          updateSelectInput(session, "group",choices = group,selected=group)
          updateSelectInput(session,"scales",choices=scales)
          updateSelectInput(session,"means",choices=scales)
          updateSelectInput(session,"anal",choices = c("Check Group Equivalency"='check',"Propensity Score Analysis"='psa',
                                                  "Measurement Invariance"='mi',
                                                  "Metric Invariance"='metric',
                                                  "Scalar Invariance"='scalar',"Structural Invariance"='latent'))
          output$metatab<-renderDT(metad,caption="Meta Data",rownames=FALSE,options=list(pageLength=5,lengthChange=FALSE,searching=FALSE))
          output$datatab<-renderDT(datau,caption="Cleaned Data",rownames=TRUE,options=list(pageLength=5,lengthChange=FALSE,searching=FALSE,scrollX=TRUE))
          updateTabsetPanel(session,"tabSelected","data")
          output$metbut <- downloadHandler(
            filename = function() {
            "meta.csv"
          },
          content = function(file) {
            write.csv(metad,file,row.names=FALSE)
          }
          )
          output$datbut <- downloadHandler(
            filename = function() {
            "clean_data.csv"
          },
          content = function(file) {
            write.csv(datau,file,row.names=TRUE)
          }
          )
          shinyjs::enable("metbut")
          shinyjs::enable("datbut")
#          shinyjs::enable("analyze")
        }
#      }
    }
  }) #observeEvent

observeEvent(input$psavars,{

        if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            showTab(inputId="tabSelected",target="psasetup")
            updateTabsetPanel(session,"tabSelected","psasetup")
            ds2<-datau %>% dplyr::select(!!!input$psavars)
            covs<-covs2<-colnames(ds2)
            if (length(input$checkvars)>0){
              ds2<-datau %>% dplyr::select(!!!input$checkvars)
              covs2<-colnames(ds2)
            }
            mcall<<-psacall(input,cov,covs)
            output$mcall <- renderUI({
              HTML(paste("Default call to matchit:", "<br><br>", mcall, "<br>"))
            })
            if (input$psaarg==FALSE){
              output$ccall<-renderUI({
                textAreaInput("ccall","Edit code below to create custom call to matchit",value=mcall,width='100%')
              })
            } 
            hideTab(inputId="tabSelected",target="psa")
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        }
})

observeEvent(input$anal,{

        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            showTab(inputId="tabSelected",target="psasetup")
            updateTabsetPanel(session,"tabSelected","psasetup")
            ds2<-datau %>% dplyr::select(!!!input$psavars)
            covs<-covs2<-colnames(ds2)
            if (length(input$checkvars)>0){
              ds2<-datau %>% dplyr::select(!!!input$checkvars)
              covs2<-colnames(ds2)
            }
            mcall<<-psacall(input,cov,covs)
#            output$mcall<-renderUI({HTML(paste("Default call to matchit:","<br>","<br>",mcall,"<br>"))})
            output$mcall <- renderUI({
              HTML(paste(
                'Default call to <a href="https://rdrr.io/cran/MatchIt/man/matchit.html" target="_blank">matchit</a>:',
                "<br><br>",
                mcall
              ))
            })
            if (input$psaarg==FALSE){
              output$ccall<-renderUI({
                textAreaInput("ccall","Edit code below to create custom call to matchit",value=mcall,width='100%')
              })
            } 
            hideTab(inputId="tabSelected",target="psa")
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
  
})

observeEvent(input$loadings,{

        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
  
})

observeEvent(input$intercepts,{

        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
  
})


observeEvent(input$group,{

        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
  
})

observeEvent(input$checkvars,{

        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
  
})

observeEvent(input$items,{
    error<-TRUE
    if ((!is.null(input$items))&&(length(input$items) >0) ){
      scaletab<-table(na.omit(metad$scale[match(input$items,metad$item)]))
      if (min(scaletab)>1){
        error<-FALSE
        scales<<-names(scaletab)
        updateSelectInput(session,"loadings",choices=input$items)
        updateSelectInput(session,"intercepts",choices=input$items)
        updateSelectInput(session,"scales",choices=scales)
        updateSelectInput(session,"means",choices=scales)
      } 
    }
    if (error==TRUE){
      showNotification("Each scale must have at least three items.",type="error")
    }else{
        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
     }
})

observeEvent(input$psavars,{

        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
  
})



observeEvent(input$scales,{

        if ((input$anal=="check") & (input$group!="") & (input$group!="None") & (length(input$checkvars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if ((input$anal=="psa")&(input$group!="") & (input$group!="None") & (length(input$psavars)>0)){
          if (length(table(datau[,input$group]))==2){
            shinyjs::enable("analyze")
          } else {
            showNotification("Group must have two levels",type="error")
            shinyjs::disable("analyze")
          }
        } else if (((input$anal=="mi")| (input$anal=="latent"))&(input$group!="") & (input$group!="None") & (length(input$items)>0)){
          shinyjs::enable("analyze")
        } else if ((input$anal=="metric")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else if ((input$anal=="scalar")&(input$group!="") & (input$group!="None") & (input$scales!="None")){
          shinyjs::enable("analyze")
        } else {
          shinyjs::disable("analyze")
        }
  
})


observeEvent(input$analyze,{

  if((input$anal=="check")&(!is.null(input$checkvars))){
    shinyjs::disable("analyze")
    shinyjs::disable("chkbut")
    showTab(inputId="tabSelected",target="check")
    updateTabsetPanel(session,"tabSelected","check")
    ds2<-datau %>% dplyr::select(!!!input$checkvars)
    covs<-colnames(ds2)
    chkout<-psacheck(input$group,covs,input$seed)
    chktab<-chkout[[1]]
    chktabo<-chktab
    chktabo$x<-""
    output$chktab<-renderDT({
      colnames(chktabo)[5]<-" "
      datatable(chktabo,rownames=TRUE,options=list(pageLength=5,columnDefs=list(list(targets=5,width='300px'),
                                                                   list(targets=0,width='100px'),
                                                                   list(targets=c(1:4),width='70px')))) %>%  
#              formatStyle(0,target="row",backgroundColor=styleRow(seq(1,nrow(chktabo),2),"lightgrey")) %>%
              formatRound(columns=c(1,3:4),digits=3)
    })
    chktxt<-chkout[[2]]
    chktxt$call<-NULL
    output$chktxt<-renderText({old<-options(width=172);on.exit(options(old))
                               paste(capture.output(summary(chktxt)),collapse="\n")})
#    updateVarSelectInput(session,"psavars",data=ds2)
    shinyjs::enable("chkbut")
    output$chkbut <- downloadHandler(
     filename = function() {
       "Check.csv"
     },
     content = function(file) {
       write.csv(chktab,file,row.names=TRUE)
     }
    )
  } else if((input$anal=="psa")&(!is.null(input$psavars))){
    shinyjs::disable("analyze")
    shinyjs::disable("psabut")
    shinyjs::disable("datbut2")
    ds2<-datau %>% dplyr::select(!!!input$psavars)
    covs<-covs2<-colnames(ds2)
    if (length(input$checkvars)>0){
         ds2<-datau %>% dplyr::select(!!!input$checkvars)
         covs2<-colnames(ds2)
    }
    psaout<-psa(input,covs,covs2)
    if (!is.null(psaout)){
      showTab(inputId="tabSelected",target="psa")
      updateTabsetPanel(session,"tabSelected","psa")
      updateSelectInput(session,"usepsa",choices=c(TRUE,FALSE),selected=TRUE)
      psatab<-psaout[[1]]
      psatabo<-psatab
      psatabo$x<-""  
      output$psatab<-renderDT({
      colnames(psatabo)[5]<-" "
      dt<-datatable(psatabo,rownames=TRUE,options=list(pageLength=5,columnDefs=list(list(targets=5,width='400px'),
                                                                   list(targets=c(1:4),width='70px')))) %>%   
#              formatStyle(0,target="row",backgroundColor=styleRow(seq(1,nrow(psatab),2),"lightgrey")) %>%
              formatRound(columns=c(1,3:4),digits=3)
      })
      psatxt<-psaout[[2]]
      psatxt$call<-NULL
      output$psatxt<-renderText({old<-options(width=172);on.exit(options(old))
                               paste(capture.output(summary(psatxt)),collapse="\n")})
      shinyjs::enable("psabut")
      output$psabut <- downloadHandler( 
       filename = function() {
       "PSA.csv"
      },
      content = function(file) {write.csv(psatab,file,row.names=TRUE)})

      output$datbut2 <- downloadHandler(
       filename = function() {
         "PSAData.csv"
       },
       content = function(file) {write.csv(psads,file,row.names=FALSE)})
      shinyjs::enable("psabut")
      if (input$usewos==FALSE) shinyjs::enable("datbut2")
    }
  } else if ((input$anal == "mi")&(length(input$items)>0)){
    shinyjs::disable("analyze")
    shinyjs::disable("mibut")
    shinyjs::disable("mimodbut")
    showTab(inputId="tabSelected",target="mi")
    updateTabsetPanel(session,"tabSelected","mi")
    ds2<-datau %>% dplyr::select(!!!input$items)
    items<-colnames(ds2)
#print("kim1")
#print(items)
#print(scales)
    if (input$usepsa){
      mioutt<-capture.output(mi(psads,input$group,items))
      miout<-mi(psads,input$group,items)
    } else {
      mioutt<-capture.output(mi(datau,input$group,items))
      miout<-mi(datau,input$group,items)
    }
#print("kim2")
    mioutl<-miout
    dt<-datatable(mioutl,rownames=TRUE,options=list(scrollX=TRUE)) %>%  
              formatRound(columns=c(1,3:8,10:15),digits=3)
    mioutt<-mioutt[-c((length(mioutt)-((nrow(mioutl)+1)*3)):length(mioutt))]
    output$mimodbut <- downloadHandler(
       filename = function() {
         "MeasurementInvariateModel.txt"
     },
     content = function(file) {
       writeLines(mioutt,file)
     }
     )

    output$mitab<-renderDT(dt)
    output$mibut <- downloadHandler(
     filename = function() {
       "MI.csv"
     },
     content = function(file) {
       write.csv(miout,file,row.names=TRUE)
     }
    )
    shinyjs::enable("mibut")
    shinyjs::enable("mimodbut")
  } else if ((input$anal == "metric")&(length(input$items)>2)){
    shinyjs::disable("analyze")
    shinyjs::disable("metricbut")
    shinyjs::disable("metricmodbut")
    showTab(inputId="tabSelected",target="metric")
    updateTabsetPanel(session,"tabSelected","metric")
    items<-input$items
    ds2<-datau %>% dplyr::select(!!!input$items)
    if (input$usepsa){
      configout<-config(psads,input$group,items)
    } else {
      configout<-config(datau,input$group,items)
    }
    metricOut<-compareItems(configout$model,configout$config,input$scales)
    metricOutt<-capture.output(compareItems(configout$model,configout$config,input$scales))
    metricOutt<-metricOutt[-c((length(metricOutt)-((nrow(metricOut)+1)*3)):length(metricOutt))]
    output$metricmodbut <- downloadHandler(
       filename = function() {
         "MetricInvarianceModel.txt"
     },
     content = function(file) {
       writeLines(metricOutt,file)
     }
     )

    nonInvar<-metricOut[(!is.na(metricOut[,"delta p"])& metricOut[,"delta p"]<input$threshold),]
    k<-length(grep(input$scales,colnames(ds2)))
    if ((nrow(nonInvar)>0) & (nrow(nonInvar)< (k*(k-1)/2))){
      itemSubsets<-listandDelete(k,strsplit(rownames(nonInvar),"-"))
      itemSubsetOut<-NULL
      for (i in 1:length(itemSubsets)){
        x<-paste(input$scales,itemSubsets[[i]],sep="")
        x<-paste(x,collapse=",")
        if (i==1){
          itemSubsetOut<-paste(itemSubsetOut,x,sep="")
        }else{
          itemSubsetOut<-paste(itemSubsetOut,x,sep="; ")
        }
      }
    }else if (nrow(nonInvar)==0){
      im<-metricOut[-1,1]
      im<-strsplit(im,"-")
      x<-NULL
      for (i in 1:length(im)){
        x<-c(x,im[[i]])
      }
      x<-as.factor(x)
      itemSubsetOut<-levels(x)
    } else {
      itemSubsetOut<-"None"
    }
    itemSubsetOut<-c("Subsets of invariant items: ",itemSubsetOut)
    output$metrictxt<-renderText({itemSubsetOut})
    output$metricbut <- downloadHandler(
     filename = function() {
       "METRIC.csv"
     },
     content = function(file) {
       write.csv(metricOut,file,row.names=TRUE)
     }
    )
    metricOutl<-metricOut
    dt<-datatable(metricOutl,rownames=FALSE,options=list(scrollX=TRUE)) %>%  
              formatRound(columns=c(2,4:9,11:16),digits=3)
    output$metrictab<-renderDT(dt)
    shinyjs::enable("metricbut")
    shinyjs::enable("metricmodbut")
  } else if ((input$anal == "scalar")&(input$scales!="None")){
    if (length(input$loadings)==0) {
      loads<-""
    }else{
      ds2<-datau %>% dplyr::select(!!!input$loadings)
      loads<-colnames(ds2)
    }
    shinyjs::disable("analyze")
    shinyjs::disable("scalarbut")
    shinyjs::disable("scalarmodbut")
    showTab(inputId="tabSelected",target="scalar")
    updateTabsetPanel(session,"tabSelected","scalar")
    ds2<-datau %>% dplyr::select(!!!input$items)
    items<-colnames(ds2)
    if (input$usepsa){
      metricout<-metric(psads,input$group,items,loads)
    } else {
      metricout<-metric(datau,input$group,items,loads)
    }
    scalarOut<-compareItems(metricout$model,metricout$metric,input$scales,loads)
    scalarOutt<-capture.output(compareItems(metricout$model,metricout$metric,input$scales,loads))
    scalarOutt<-scalarOutt[-c((length(scalarOutt)-((nrow(scalarOut)+1)*3)):length(scalarOutt))]
    output$scalarmodbut <- downloadHandler(
       filename = function() {
         "ScalarInvarianceModel.txt"
     },
     content = function(file) {
       writeLines(scalarOutt,file)
     }
     )

    nonInvar<-scalarOut[(!is.na(scalarOut[,"delta p"])& scalarOut[,"delta p"]<input$threshold),]
    k<-length(grep(input$scales,colnames(ds2)))
    if ((nrow(nonInvar)>0) & (nrow(nonInvar)< (k*(k-1)/2))){
      itemSubsets<-listandDelete(k,strsplit(rownames(nonInvar),"-"))
      itemSubsetOut<-NULL
      for (i in 1:length(itemSubsets)){
        x<-paste(input$scales,itemSubsets[[i]],sep="")
        x<-paste(x,collapse=",")
        if (i==1){
          itemSubsetOut<-paste(itemSubsetOut,x,sep="")
        }else{
          itemSubsetOut<-paste(itemSubsetOut,x,sep="; ")
        }
      }
    }else if (nrow(nonInvar)==0){
      im<-scalarOut[-1,1]
      im<-strsplit(im,"-")
      x<-NULL
      for (i in 1:length(im)){
        x<-c(x,im[[i]])
      }
      x<-as.factor(x)
      itemSubsetOut<-levels(x)
    } else {
      itemSubsetOut<-"None"
    }
    itemSubsetOut<-c("Subsets of invariant items: ",itemSubsetOut)
    output$scalartxt<-renderText({itemSubsetOut})
    output$scalarbut <- downloadHandler(
     filename = function() {
       "SCALAR.csv"
     },
     content = function(file) {
       write.csv(scalarOut,file,row.names=TRUE)
     }
    )
    scalarOutl<-scalarOut
    dt<-datatable(scalarOutl,rownames=FALSE,options=list(scrollX=TRUE)) %>%  
              formatRound(columns=c(2,4:9,11:16),digits=3)
    output$scalartab<-renderDT(dt)
    shinyjs::enable("scalarbut")
    shinyjs::enable("scalarmodbut")
  } else if ((input$anal == "latent")&(length(input$items)>0)){

    if (length(input$intercepts)==0) {
      icepts<-""
    }else{
      ds2<-datau %>% dplyr::select(!!!input$intercepts)
      icepts<-colnames(ds2)
    }
    if (length(input$loadings)==0) {
      loads<-""
    }else{
      ds2<-datau %>% dplyr::select(!!!input$loadings)
      loads<-colnames(ds2)
    }
    shinyjs::disable("analyze")
    shinyjs::disable("latentbut")
    shinyjs::disable("latentmodbut")
    showTab(inputId="tabSelected",target="latent")
    updateTabsetPanel(session,"tabSelected","latent")
    ds2<-datau %>% dplyr::select(!!!input$items)
    items<-colnames(ds2)
    if ((loads[1]!="") && (icepts[1]=="")){ 
      showNotification("All items with factor loadings to be freely estimates should be freely estimated in subsequent models.",type="error")   
    }else if ((loads[1]!="") &(sum(is.na(match(loads,icepts)))>0)){
       showNotification("All items with factor loadings to be freely estimates should be freely estimated in subsequent models.",type="error") 
    }else{
      if (input$usepsa){
        tout<-lmean(psads,input$group,items,loads,icepts,input$means)
        referent<-levels(as.factor(psads[,input$group]))[1]
        latentoutt<-capture.output(lmean(psads,input$group,items,loads,icepts,input$means))
        latentoutt<-latentoutt[-c((length(latentoutt)-(12+2*nrow(tout$out3))):length(latentoutt))]
      } else {
        tout<-lmean(datau,input$group,items,loads,icepts,input$means)
        referent<-levels(as.factor(datau[,input$group]))[1]
        latentoutt<-capture.output(lmean(datau,input$group,items,loads,icepts,input$means))
        latentoutt<-latentoutt[-c((length(latentoutt)-(12+2*nrow(tout$out3))):length(latentoutt))]
      }
      output$latenttxt<-renderText({old<-options(width=172);on.exit(options(old))
                               paste(latentoutt,collapse="\n")})
      output$latentbut <- downloadHandler(
        filename = function() {
        "LATENT.csv"
      },
      content = function(file) {
        write.csv(tout$models,file,row.names=TRUE)
      }
      )
      output$latentbut2 <- downloadHandler(
        filename = function() {
        "LATENTMEANS.csv"
      },
      content = function(file) {
        write.csv(tout$out3,file,row.names=FALSE)
      }
      )
     output$latentmodbut <- downloadHandler(
       filename = function() {
         "StructuralInvarianceModel.txt"
      },
      content = function(file) {
        writeLines(latentoutt,file)
      }
      )
      dt<-datatable(tout$models,rownames=TRUE,options=list(scrollX=TRUE)) %>%  
              formatRound(columns=c(1,3:8,10:15),digits=3)
      output$latenttab<-renderDT(dt)
      dt2<-datatable(tout$out3,rownames=FALSE,
              caption=paste("Latent Mean Differences from Scalar Model. ",input$group," = ",referent," used as referent"),
              options=list(scrollX=TRUE,pageLength=6)) %>% 
              formatRound(columns=c(3:ncol(tout$out3)),digits=3)
      output$latenttab2<-renderDT(dt2)
      shinyjs::enable("latentbut")
      shinyjs::enable("latentmodbut")
      shinyjs::enable("latentbut2")
    }
  }

})

}

Try the calms package in your browser

Any scripts or data that you put into this service are public.

calms documentation built on Aug. 28, 2025, 9:08 a.m.

R Package Documentation

rdrr.io home R language documentation Run R code online

Browse R Packages

CRAN packages Bioconductor packages R-Forge packages GitHub packages

We want your feedback!

Note that we can't provide technical support on individual packages. You should contact the package authors for that.
GitHub issue tracker
ian@mutexlabs.com
Personal blog

 
Embedding an R snippet on your website

Add the following code to your website.

For more information on customizing the embed code, read Embedding Snippets.

Close