R/simMLgvar.R

In graphicalVAR: Graphical VAR for Experience Sampling Data

rewire <- function(x,p,directed){
  if (missing(directed)){
    directed <- !all(x == t(x))
  }
  
  if (directed){
    ind <- diag(1,ncol(x)) != 1
  } else {
    ind <- upper.tri(x)
  }
  
  # Current edges:
  curEdges <- which(x!=0 & ind, arr.ind=TRUE)
  
  # Select to rewire:
  toRewire <- which(runif(nrow(curEdges)) < p)
  
  for (i in seq_along(toRewire)){
    curZeros <- which(x==0 & ind, arr.ind=TRUE)
    dest <- sample(seq_len(nrow(curZeros)),1)
    
    x[curZeros[dest,1],curZeros[dest,2]] <- x[curEdges[toRewire[i],1],curEdges[toRewire[i],2]]
    x[curEdges[toRewire[i],1],curEdges[toRewire[i],2]] <- 0
    
    if (!directed){
      x[curZeros[dest,2],curZeros[dest,1]] <- x[curEdges[toRewire[i],2],curEdges[toRewire[i],1]]
      x[curEdges[toRewire[i],2],curEdges[toRewire[i],1]] <- 0
    }
  }
  
  return(x)
}

simMLgvar <- function(
  nTime,
  nVar,
  nPerson,
  propPositive = 0.5,
  kappaRange = c(0.25,0.5), #c(0.5,1),
  betaRange = c(0.25,0.5),
  betweenRange = c(0.25,0.5),
  rewireWithin = 0,
  betweenVar = 1,
  withinVar = .25,
  temporalOffset = 2
){
  repeat{
    
    # Obtain true signed fixed structures:
    trueKappa <- as.matrix(igraph::get.adjacency(igraph::watts.strogatz.game(1,nVar,1,0)))
    trueKappa[upper.tri(trueKappa)] <- trueKappa[upper.tri(trueKappa)] *  sample(c(-1,1),sum(upper.tri(trueKappa)),TRUE,prob=c(propPositive,1-propPositive))
    # Symmetrize:
    trueKappa[lower.tri(trueKappa)] <- t(trueKappa)[lower.tri(trueKappa)]  
    
    # Temporal effects:
    trueBeta <- diag(1,nVar)
    for (i in 1:nVar){
      trueBeta[(i+(temporalOffset-1))%%nVar+1,i ] <- sample(c(-1,1),1,propPositive)
    }
    
    # Between subjects:
    trueBetween <- as.matrix(igraph::get.adjacency(igraph::watts.strogatz.game(1,nVar,1,1)))
    trueBetween[upper.tri(trueBetween)] <- trueBetween[upper.tri(trueBetween)] *  sample(c(-1,1),sum(upper.tri(trueBetween)),TRUE,prob=c(propPositive,1-propPositive))
    # Parameterize:
    trueBetween[upper.tri(trueBetween)] <- runif(sum(upper.tri(trueBetween)),betweenRange[1],betweenRange[2]) * trueBetween[upper.tri(trueBetween)]
    # Symmetrize:
    trueBetween[lower.tri(trueBetween)] <- t(trueBetween)[lower.tri(trueBetween)]  
    
    # Add diagonal:
    # diag(trueBetween) <- 1
    I <- diag(nrow(trueBetween))
    
    # Check them all:
    evK <- round(eigen(trueKappa)$values,10)
    evB <- round(eigen(trueBeta)$values,10)
    evBet <- round(eigen(I - trueBetween)$values,10)
    
    if (all(evBet > 0)){
      break
    }
    
    
  }
  # Simulate means:
  Sigma <- cov2cor(solve(I - trueBetween))
  D <- diag(sqrt(betweenVar),nVar)
  Means <- mvtnorm::rmvnorm(nPerson,sigma = D%*%Sigma%*%D)
  
  # Simulate for every subject:
  SubjectData <- lapply(1:nPerson,function(i){
    try <- 1
    maxtry <- 10
    repeat{
      kappa <- trueKappa
      kappa[upper.tri(kappa)] <- runif(sum(upper.tri(kappa)),kappaRange[1],kappaRange[2]) * kappa[upper.tri(kappa)]
      # Symmetrize:
      kappa[lower.tri(kappa)] <- t(kappa)[lower.tri(kappa)]  
      diag(kappa) <- 1
      
      # Temporal:
      beta <- trueBeta * runif(nVar^2, betaRange[1], betaRange[2])
      # diag(beta) <- Vmin
      
      # Rewire:
      kappa <- rewire(kappa,rewireWithin)
      beta <- rewire(beta,rewireWithin)
      
      evK <- eigen(kappa)$values
      evB <- eigen(beta)$values
      
      while(any(Re(evB)^2 + Im(evB)^2 > 1)){
        warning("Shrinking parameters")
        beta <- 0.95*beta
        evB <- eigen(beta)$values
      }
      
      
      if (all(evK > 0) & all(Re(evB)^2 + Im(evB)^2 < 1)){
        break
      }
      
      try <- try + 1
      if (try > maxtry){
        stop("Maximum number of tries reached.")
      }
    }
    
    D <- diag(sqrt(withinVar), nVar)
    Delta <- diag(1/sqrt(diag(solve(kappa))))
    kappa <- solve(D)%*%solve(Delta)%*%kappa%*%solve(Delta)%*%solve(D)
    # Simulate data:
    Data <- as.data.frame(graphicalVARsim(nTime,beta,kappa,mean = Means[i,]))
    Data$ID <- i
    
    # Return:
    return(list(
      kappa=kappa,
      beta=beta,
      PCC = computePCC(kappa),
      PDC = computePDC(beta,kappa),
      data=Data
    ))
  })
  
  # Compute fixed effects:
  fixedKappa <- Reduce("+",lapply(SubjectData,"[[","kappa")) / nPerson
  fixedBeta <- Reduce("+",lapply(SubjectData,"[[","beta")) / nPerson
  
  # Aggregate data:
  allData <- do.call(rbind,lapply(SubjectData,"[[","data"))
  
  Results <- list(
    data = allData,
    fixedKappa = fixedKappa,
    fixedPCC = computePCC(fixedKappa),
    fixedBeta = fixedBeta,
    fixedPDC = computePDC(fixedBeta,fixedKappa),
    between = trueBetween,
    means=Means,
    personData = SubjectData,
    idvar = "ID",
    vars = names(allData)[names(allData)!="ID"]
  )
  
  class(Results) <- "simMLgvar"
  return(Results)
}