1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
computePCC <- function(x)
{
  x <- -cov2cor(x)
  diag(x) <- 0
  x <- as.matrix(forceSymmetric(x))
  return(x)
}

computePDC <- function(beta,kappa){
  sigma <- solve(kappa)
  t(beta / sqrt(diag(sigma) %o% diag(kappa) + beta^2))
}

graphicalVAR <-
function(
  data, # A n by p data frame containing repeated measures
  nLambda = 50, # Either single value or vector of two corresponding to c(kappa, beta)
  verbose = TRUE,
  gamma = 0.5,
  lambda_beta,
  lambda_kappa, maxit.in = 100, maxit.out = 100
  ){
  
  # Check input:
  if (is.data.frame(data)){
    data <- as.matrix(data)
  }
 
  stopifnot(is.matrix(data))
  
  

  
  Nvar <- ncol(data)
  Ntime <- nrow(data)

  # Center data:
  data <- scale(data, TRUE, FALSE)
  
  # Compute current and lagged data:
  data_c <- data[-1,,drop=FALSE]
  data_l <- data[-nrow(data),,drop=FALSE]
  
  # Generate lambdas (from SparseTSCGM package):
  if (missing(lambda_beta) | missing(lambda_kappa)){
    lams <- SparseTSCGM_lambdas(data_l, data_c, nLambda)
    if (missing(lambda_beta)){
      lambda_beta <- lams$lambda_beta
    }
    if (missing(lambda_kappa)){
      lambda_kappa <- lams$lambda_kappa
    }
  }
  
  Nlambda_beta <- length(lambda_beta)
  Nlambda_kappa <- length(lambda_kappa)
  
  
  # Expand lambda grid:
  lambdas <- expand.grid(kappa = lambda_kappa, beta = lambda_beta)
  Estimates <- vector("list", nrow(lambdas))
  
  ### Algorithm 2 of Rothmana, Levinaa & Ji Zhua
  if (verbose){
    pb <- txtProgressBar(0, nrow(lambdas), style = 3) 
  }
  for (i in seq_len(nrow(lambdas))){
    Estimates[[i]] <- Rothmana(data_l, data_c, lambdas$beta[i],lambdas$kappa[i], gamma=gamma,maxit.in=maxit.in, maxit.out = maxit.out)
   if (verbose){
     setTxtProgressBar(pb, i)
   } 
  }
  if (verbose){
    close(pb)
  }
#   
#   logandbic <- LogLik_and_BIC(data_l, data_c, Estimates)
#   lambdas$bic <- logandbic$BIC
#   lambdas$loglik <- logandbic$logLik
  lambdas$ebic <- sapply(Estimates,'[[','EBIC')
  # Which minimal BIC:
  min <- which.min(lambdas$ebic)
  Results <- Estimates[[min]]

  # Standardize matrices (Wild et al. 2010)
  # partial contemporaneous correlation (PCC) 
  Results$PCC <- computePCC(Results$kappa)
  Results$PDC <- computePDC(Results$beta, Results$kappa)  

  Results$path <- lambdas
  Results$labels <- colnames(data)

  colnames(Results$beta) <- rownames(Results$beta) <- colnames(Results$kappa) <- rownames(Results$kappa) <-
  colnames(Results$PCC) <- rownames(Results$PCC) <- colnames(Results$PDC) <- rownames(Results$PDC) <-
  Results$labels
Results$gamma <- gamma

  class(Results) <- "graphicalVAR"
  
  return(Results)
}