Confirmatory LVCA interface. Requires multivar package which is in development.

global.R

library("qgraph")
library('multivar')
library('lavaan')
library("shinyIncubator")
library("shiny")
library("foreign")

BFreport <- function(x)
{
  if (x > 10000)
  {
    return("> 10,000")
  }
  if (x < 0.0001)
  {
    return("< 0.0001")
  }
  
  return(format(round(x,4), digits = 4,  scientific = FALSE))
}

curCounter <<- 0
curOutput <<- NULL
ModelList <<- list()
curModel <<- NULL
# 
# # Simulated data ##
# 
# Ng <- 1
# Ni <- 4
# Np <- 20
# pkg <- 'lavaan'
# 
# latNets <- simVARnetsRandom(Ng, Ni, edgeProb = 0.4)
# Graphs <- constructPersGraphs( Np, 30, latNets, ErrorSD = 0.1, NuMinorRange=c(0,0), NuMajorRange=c(1,1))
# Data <- sampleVARs( Graphs$persGraphs , 30)
# 
# 
# ### ANALYZE ###
# 
# ####
# # Group membership:
# # nuGroups <- apply(Graphs$Nu, 1, function(x)which.max(x))
# nuGroups <- sample(1:2, Np, TRUE)
# 
# ### Cast data in long format:
# for (i in 1:Np) colnames(Data[[i]]) <- LETTERS[1:Ni]
# longData <- do.call(rbind, mapply(d=Data,p=1:Np,g=nuGroups,FUN=function(d,p,g) cbind(id = p, time = 1:nrow(d), group = g, d), SIMPLIFY=FALSE))

server.R

shinyServer(function(input, output) {
  #   
  #   # Data import:
    Dataset <- reactive({
      if (is.null(input$files)) {
        # User has not uploaded a file yet
        return(data.frame())
      }
      
      Dataset <- read.spss(input$files$datapath, to.data.frame =TRUE)
      return(Dataset)
    })
# #   
#   Dataset <- reactive({
#     #     if (is.null(input$files)) {
#     #       # User has not uploaded a file yet
#     #       return(data.frame)
#     #     }      
#     #     
#     #     read.spss(input$files$datapath, to.data.frame =TRUE)
#     as.data.frame(longData)
#   })
#   
  
  # Select variables:
  output$varselect <- renderUI({
    if (identical(Dataset(), '') || identical(Dataset(),data.frame())) return(NULL)

    # Variable selection:
    selectInput("vars", "Measured variables:",
                names(Dataset()), names(Dataset())[which(sapply(Dataset(), mode)=='numeric')],  multiple =TRUE)            
  })
  
  # ID variables:
  output$idvar <- renderUI({
    if (identical(Dataset(), '') || identical(Dataset(),data.frame())) return(NULL)
    # Variable selection:
   
  selectInput("idvar", "ID Variable:",
                names(Dataset()),'id', multiple = FALSE)            
  })
  
  # Time variables:
  output$timevar <- renderUI({
    if (identical(Dataset(), '') || identical(Dataset(),data.frame())) return(NULL)
    # Variable selection:
    selectInput("timevar", "Time Variable:",
                names(Dataset()),  multiple = FALSE)            
  })
  
  # Group variables:
  output$groupvars <- renderUI({
    if (identical(Dataset(), '') || identical(Dataset(),data.frame())) return(NULL)
    # Variable selection:
    selectInput("groupvars", "Grouping variables:",
                names(Dataset()),  multiple = TRUE)            
  })
  
  # Matrix:
  output$matrix  <- renderUI({
    mat <- as.data.frame(matrix(1,length(input$vars),length(input$vars)))
    rownames(mat) <- colnames(mat) <- input$vars
    matrixInput('adj','Adjacency matrix:',mat)
  })
    
    output$includeids <- renderUI({
      if (identical(Dataset(), '') || identical(Dataset(),data.frame())) return(NULL)
      
      # Variable selection:
      selectInput("ids", "Include IDs:",
                  unique(Dataset()[[input$idvar]]), unique(Dataset()[[input$idvar]]),  multiple =TRUE)            
    })
    
    output$includetime <- renderUI({
      if (identical(Dataset(), '') || identical(Dataset(),data.frame())) return(NULL)
      
      # Variable selection:
      selectInput("times", "Include time-points:",
                  unique(Dataset()[[input$timevar]]), unique(Dataset()[[input$timevar]]),  multiple =TRUE)            
    })
  
  output$adjplot <- renderPlot({
    if (!is.null(input$adj) && !any(dim(input$adj)==0))  qgraph(input$adj, weighted = FALSE, labels = input$vars, directed = TRUE, diag = TRUE)
  })
  
  # Show model:
  output$showmodel <- renderUI({
    
    Output()
    
    # Variable selection:
    if (length(ModelList) > 0)
    {
      selectInput("modselect", "Show model:",
                  names(ModelList),  multiple = FALSE, curModel)             
    } else return(NULL)
  })
  
  # Compare to:
  output$compare <- renderUI({
    
    Output()
    
    # Variable selection:
    if (length(ModelList) > 0)
    {
      selectInput("compto", "Compare to model:",
                  names(ModelList),  multiple = FALSE)             
    } else return(NULL)
  })
  
  
  
  ### Analysis:
  Output <- reactive({
    
    if (curCounter < as.numeric(input$counter))
    {
      curCounter <<- as.numeric(input$counter)
      Include <- Dataset()[[input$timevar]] %in% input$times &  Dataset()[[input$idvar]] %in% input$ids
      ModelList[[input$modname]] <<- groupVAR(Dataset()[Include,], vars = input$vars, id.var = input$idvar, group.vars = input$groupvars, time.var = input$timevar, adjacency = as.matrix(input$adj))        
      curModel <<- input$modname
      #       return(ModelList[[curModel]]) 
    }
    
    if (is.null(input$vars) | is.null(input$idvar) |  is.null(input$timevar) | is.null(input$modselect))
    {
      return(NULL)
    }
    
    return(ModelList[[input$modselect]])
  })
  
  #   
  #   
  #   # Reactive output window (plot or table)
  #   output$window <- renderUI({
  #     if (input$outtype ==  "plot")
  #     {
  #       plotOutput("plot",'100%','600px')
  #     } else if (input$outtype ==  'test')
  #     {
  #       tableOutput("test")
  #     } else 
  #     {
  #       tableOutput("fit")
  #     }
  #   })
  
  output$graph <- renderPlot({
#     if (input$show == 'Weights graphs') 
#     {
      plot(Output()) 
#     } else {
#       plot(Output(), values = 'sig', legend = TRUE)
#     }
  },width='auto',height='auto')
    
    
    
    output$download <- downloadHandler(
      filename = 'LVCAoutput.pdf',
      content = function(con) {
        
        pdf(con)
        plot(Output(), panel = FALSE)
        dev.off()
        
      })
    
  
  output$parlist <- renderTable({
#     mats <- extractParFit(Output()$Model$Results)
#     
#     Vars <- rownames(mats$latGraphs[[1]]$est)
#     
#     if (length(mats$latGraphs)==1) names <- '' else  names <- sapply(seq_along(mats$latGraphs), function(i)paste0(colnames(Output()$ClusterInfo$clusterDF),': ', Output()$ClusterInfo$clusterDF[i,], collapse = " - "))
#     
#     Table <- do.call(rbind,lapply(seq_along(mats$latGraphs), function(i){
#       x <- mats$latGraphs[[i]]
#       
#       data.frame(
#         Cluster = names[i],
#         From = rep(Vars, times = length(Vars)),
#         To = rep(Vars, each = length(Vars)),
#         est = round(c(x$est),3),
#         se = round(c(x$se),3),
#         z = round(c(x$z),3),
#         p.value = c(x$pvalue)
#       )}))
#     
#     Table$p.value.Bonf <- pmin(Table[['p.value']] * nrow(Table), 1)
#     
#     Table$significance <- sapply(sapply(Table$p.value.Bonf,function(x){
#       x[is.na(x)] <- 1
#       sum(x < c(0.001,0.01,0.05))+1
#     }),switch,'','*','**','***')
#     
#     Table$p.value.Bonf <- round(Table$p.value.Bonf,3)
#     Table$p.value <- round(Table$p.value,3)
#     
# #     Table[is.na(Table)] <- ''
#     return(Table)
    groupVARestimates(Output())
  })
  
  
  # Plotting window:
  output$window <- renderUI({
    if (!is.null(Output())) 
    {  
      if (input$show != 'Parameter Estimates')
      {
        Ng <- length(Output()$Model$latGraphs)
#         sig <- input$show=='Significance graphs'
        
        # Weight is 1000, height (1000/Ng) / (sig * 1.4)
        plotOutput('graph', width = 1000, height = (1000/Ng))
      } else {
        tableOutput('parlist')
      } 
    } else return(NULL)
  })
  
  output$test <- renderTable({
    if (!is.null(Output()))
    {
      #       object <- Output()
      #       Ng <- max(object$ClusterInfo$membership)
      #       
      #       if (Ng == 1)
      #       {
      #         return(NULL)
      #       } else {
      #         
      #         # ANOVA #
      #         SingleNetwork <- object$Null$Result
      #         MultipleNetworks <- object$Model$Result
      #         
      #         aov <- anova(SingleNetwork, MultipleNetworks)
      #         
      #         return(aov)
      #       }
      
      if (input$modselect == input$compto) return(NULL)
      
      a <- ModelList[[input$modselect]]$Model$Result
      b <- ModelList[[input$compto]]$Model$Result
      aov <- anova(a, b)
      rownames(aov)[rownames(aov)=='a'] <- input$modselect
      rownames(aov)[rownames(aov)=='b'] <- input$compto
      
      B <- exp(-1 * (aov$BIC[2] - aov$BIC[1]) / 2)
      aov[['approx BF']] <- c('',BFreport(B))
      
      return(aov)
    }
  })
  
  
  output$fit <- renderTable({
    if (!is.null(Output()))
    {
      #         object <- Output()
      #         Ng <- max(object$ClusterInfo$membership)
      #         
      #         if (Ng == 1)
      #         {
      #           fitTable <- data.frame(SingleNetwork = fitMeasures(object$Model$Result) )
      #         } else {
      #           fitTable <- cbind(SingleNetwork = round(fitMeasures(object$Null$Result),3),
      #                             MultipleNetworks = round(fitMeasures(object$Model$Result),3))
      #         }
      #         return(fitTable)
      fits <- do.call(cbind,lapply(ModelList, function(x)fitMeasures(x$Model$Result)))
      names(fits) <- names(ModelList)
      return(fits)
      
    }
  })
  
  #   
  #   
  #   ## Download data:
  #   output$downloadData <- downloadHandler(
  #     filename = 'qgraph.pdf',
  #     content = function(con) {
  #       if (length(input$vars)==0)
  #       {
  #         plot.new()
  #         return(NULL)
  #       } else if (length(input$vars)==1)
  #       {
  #         corMat <- matrix(1,1,1)
  #       } else {
  #         corMat <- cor(Dataset()[,input$vars])
  #       }
  #       
  #       Groups <- grep('group\\d+',names(input),value=TRUE)
  #       Groups <- lapply(Groups, function(g) match(input[[g]],input$vars)  )
  #       if (length(Groups)==1 && length(Groups[[1]]) == length(input$vars)) Groups <- NULL
  #       
  #       args <- gsub(',+$','',gsub('\n',',',input$args))
  #       Args <- eval(parse(text=paste('list(',args,')')))
  #       class(Args) <- 'qgraph'
  #       
  #       pdf(con)
  #       qgraph(corMat, weighted = TRUE, maximum = 1, groups = Groups, layout = input$layout, Args)
  #       dev.off()
  #     })
    
    

  
})

ui.R

shinyUI(pageWithSidebar(
  
  # Header:
  headerPanel("Confirmatory Latent VAR Component Analysis"),
  
  # Input in sidepanel:
  sidebarPanel(
    # Input:
    fileInput("files", "Upload SPSS file:"),
    
    # Variable selection:
    htmlOutput("varselect"),
    
    htmlOutput("idvar"),
    
    htmlOutput("timevar"),
    
    htmlOutput("groupvars"),
    
    htmlOutput("includeids"),
    
    htmlOutput("includetime"),
    
    textInput("modname","Model name:","Model"),
    
     htmlOutput('matrix'),
    
    plotOutput("adjplot",'100%'),
#     matrixInput('adj','Adjacency matrix:',matrix(1,0,0)),
    br(),
    #     actionButton("run","Run")    
    actionButton("counter","Run LVCA analysis"),
    
    br(),
    
    htmlOutput("showmodel"),
    
    htmlOutput("compare")
    
  ),
  #     downloadLink('downloadData', 'Download PDF')
  
  # Main:
  mainPanel(
    downloadLink('download', 'Download Graphs'),
    
    radioButtons("show", "Show:",
                 c('Graphs','Parameter Estimates')) ,
    

    
    htmlOutput("window"),
    
    #     radioButtons("outtype", "Show:",
    #                  list("Plot" = "plot",
    #                       "Difference test" = "test",
    #                       "Fit measures" = "fit")
#     plotOutput("plot",'100%','600px'),
    
    p('Difference test:'),
    
    tableOutput("test"),
    
    p('Fit measures:'),
    
    tableOutput("fit")
    
  )
))