R/mlGraphicalVAR.R

In graphicalVAR: Graphical VAR for Experience Sampling Data

# Multi-level like graphical VAR:
  
mlGraphicalVAR <- function(
  data,
  vars,
  beepvar,
  dayvar,
  idvar,
  scale = TRUE,
  centerWithin = TRUE,
  gamma = 0.5, # Gamma used in glasso in qgraph
  verbose = TRUE,
  subjectNetworks = TRUE, # Or a vector of which subjects to use!
  lambda_min_kappa_fixed = 0.001,
  lambda_min_beta_fixed = 0.001,
  lambda_min_kappa = 0.05,
  lambda_min_beta = lambda_min_kappa,
  lambda_min_glasso = 0.01,
  ... # Args sent to graphicalVAR
){
  if (missing(idvar)) stop("'idvar' must be assigned")
  
  # Prep data:
  dataPrepped <- tsData(data,vars=vars,beepvar=beepvar,dayvar=dayvar,idvar=idvar,scale=scale,centerWithin=centerWithin)
  
  if (verbose){
    message("Estimating fixed networks")
  }
  
  # Fixed effects:
  ResFixed <- graphicalVAR(dataPrepped, lambda_min_kappa = lambda_min_kappa_fixed, lambda_min_beta = lambda_min_beta_fixed, gamma=gamma,...)
  
  # Between-subjects:
  if (verbose){
    message("Estimating between-subjects network")
  }
  meansData <- dataPrepped$data_means
  meansData <- meansData[,names(meansData) != idvar]
  meansData <- meansData[rowMeans(is.na(meansData))!=1,]
  ResBetween <- qgraph::EBICglasso(cov(meansData),nrow(meansData),gamma,returnAllResults = TRUE,lambda.min.ratio=lambda_min_glasso)
  
  # Computing model per person:
 
  
  IDs <- unique(dataPrepped$data[[idvar]])
  idResults <- list()
  if (!identical(subjectNetworks,FALSE)){
    if (isTRUE(subjectNetworks)){
      subjectNetworks <- IDs
    }
    
    if (verbose){
      message("Estimating subject-specific networks")
      pb <- txtProgressBar(max=length(subjectNetworks),style=3)
    }
    for (i in seq_along(subjectNetworks)){
      capture.output({idResults[[i]] <- try(suppressWarnings(graphicalVAR(dataPrepped$data[dataPrepped$data[[idvar]] == subjectNetworks[i],],
                                                          vars=dataPrepped$vars,
                                                          beepvar=dataPrepped$beepvar,
                                                          dayvar=dataPrepped$dayvar,
                                                          idvar=dataPrepped$idvar,
                                                          scale = scale,
                                                          lambda_min_kappa=lambda_min_kappa,
                                                          lambda_min_beta=lambda_min_beta,
                                                          gamma=gamma,
                                                          centerWithin = centerWithin,...,verbose = FALSE)))})
      if (verbose){
        setTxtProgressBar(pb,i)
      }
      if (is(idResults[[i]], "try-error")){
        idResults[[i]] <- list()
      }
    }   
    if (verbose){
      close(pb)
    }
  } else {
    idResults <- lapply(seq_along(IDs),function(x)list())
  }
  

  
  # Aggregate results:
  Results <- list(fixedPCC = ResFixed$PCC, 
                  fixedPDC = ResFixed$PDC,
                  fixedResults = ResFixed,
                  betweenNet = ResBetween$optnet,
                  betweenResults = ResBetween,
                  ids = IDs,
                  subjectPCC = lapply(idResults, '[[', 'PCC'),
                  subjectPDC = lapply(idResults, '[[', 'PDC'),
                  subjecResults = idResults)
  class(Results) <- "mlGraphicalVAR"
  return(Results)
}