############################################################################

# 1. Installation of the packages needed to run the code

if (!("numDeriv" %in% .packages(all.available = TRUE)))
  install.packages("numDeriv")

if (!("remotes" %in% .packages(all.available = TRUE)))
  install.packages("remotes")

if (packageVersion("metafor") < '3.5.2')
  remotes::install_github("wviechtb/metafor")

############################################################################

# 2. Specification of the values to be taken by each of the factors in the simulation

## the type of moderator variables included in the scale model ("Qm" = qualitative
## moderator, "Cm" = continuous moderator)
moderator <- c("Qm", "Cm")

## number of primary studies included in the meta-analysis
primary_studies <- seq(10, 100, 10)

## average sample size of the primary studies
average_sample <- c(30, 50, 100)

## tau2 values
tau2 <- c(0.01, 0.02, 0.04, 0.08, 0.16, 0.32, 0.64)

## replicates for each simulation condition
Rep <- 1000

## number of cores to use for parallel processing
cores <- 60

############################################################################

# 3. Simulation

if (!file.exists("1.MA_data"))
  dir.create("1.MA_data")

if (!file.exists("2.LSM_fitting"))
  dir.create("2.LSM_fitting")

if (!file.exists("3.Results"))
  dir.create("3.Results")

all.conds <- expand.grid(moderator=moderator, k=primary_studies, N=average_sample, tau2.1=tau2, tau2.2=tau2)
all.conds <- all.conds[all.conds$tau2.2 >= all.conds$tau2.1,]
all.conds <- all.conds[order(all.conds$moderator, all.conds$k, all.conds$N, all.conds$tau2.1, all.conds$tau2.2),]
rownames(all.conds) <- NULL

#all.conds <- all.conds[1:4,] # to test with a small number of conditions

simfun <- function(h, Rep, all.conds) {

  library(metafor)

  cond <- all.conds[h,]

  # set values of m, k, N, tau2.1, and tau2.2 based on the hth row from all.conds
  m <- cond$moderator
  k <- cond$k
  N <- cond$N

  tau2.1 <- cond$tau2.1
  tau2.2 <- cond$tau2.2

  a0 <- log(tau2.1)
  a1 <- log(tau2.2) - log(tau2.1)

  ic_ML_null   <- 0
  ic_ML        <- 0
  ic_ML_hess   <- 0
  ic_ML_PL     <- 0
  ic_REML_null <- 0
  ic_REML      <- 0
  ic_REML_hess <- 0
  ic_REML_PL   <- 0

  MA_data <- matrix(nrow=k*Rep*5, ncol=8)
  colnames(MA_data) <- c("i", "Study", "Moderator", "Delta", "Estimate", "N_exp", "N_ctrl", "Sampling_variance")

  LSM_fitting <- matrix(nrow=Rep*5, ncol=31)
  colnames(LSM_fitting) <- c("i", "predtau2.1_ML", "predtau2.2_ML", "predtau2.1_REML", "predtau2.2_REML",
    "a0_ML", "SEa0_ML", "a1_ML", "SEa1_ML", "a0_REML", "SEa0_REML", "a1_REML", "SEa1_REML",
    "WTub_a1_ML", "WTlb_a1_ML", "WTub_a1_REML", "WTlb_a1_REML",
    "PLub_a1_ML", "PLlb_a1_ML", "PLub_a1_REML", "PLlb_a1_REML",
    "WTpval_a0_ML", "WTpval_a1_ML", "WTpval_a0_REML", "WTpval_a1_REML",
    "LRpval_ML", "LRpval_REML",
    "PERMpval_a0_ML", "PERMpval_a1_ML", "PERMpval_a0_REML", "PERMpval_a1_REML")

  i <- 1 # counter for iterations without problems
  j <- 0 # counter for actually run iterations

  while (i <= Rep) {

    j <- j + 1

    # simulate the moderator and true effect sizes

    if (m == "Qm") {
      Moderator <- rep(c(0,1), each = k/2)
      Delta <- rnorm(k, 0.5, ifelse(Moderator==0, sqrt(tau2.1), sqrt(tau2.2)))
    }

    if (m == "Cm") {
      Moderator <- runif(k, 0, 1)
      taus2 <- exp(a0 + a1*Moderator)
      Delta <- rnorm(k, 0.5, sqrt(taus2))
    }

    # simulate the sample sizes

    if (N == 30)  {N_exp <- rep(c(12,16,18,20,84),  (k/5))/2}
    if (N == 50)  {N_exp <- rep(c(32,36,38,40,104), (k/5))/2}
    if (N == 100) {N_exp <- rep(c(82,86,88,90,154), (k/5))/2}

    N_ctrl <- N_exp

    # simulate the estimates and sampling variances

    nn                <- (N_exp * N_ctrl) / (N_exp + N_ctrl)
    dfs               <- N_exp + N_ctrl - 2
    raw_estimate      <- rt(k, df=dfs, ncp=Delta*sqrt(nn)) / sqrt(nn)
    correction        <- gamma(dfs/2) / (sqrt(dfs/2) * gamma((dfs-1)/2))
    Estimate          <- correction * raw_estimate
    aa                <- correction^2 * dfs / (dfs - 2)
    Sampling_variance <- (1/nn) + (1 - 1/aa) * Estimate^2

    # fit all models and get the PL confidence intervals

    lsm_null_ML   <- suppressWarnings(try(rma(Estimate, Sampling_variance, scale = ~ 1, method="ML"), silent=TRUE))
    lsm_ML        <- suppressWarnings(try(rma(Estimate, Sampling_variance, scale = ~ Moderator, method="ML", control=list(alpha.min=c(-10,-11), alpha.max=c(1,11))), silent=TRUE))
    lsm_null_REML <- suppressWarnings(try(rma(Estimate, Sampling_variance, scale = ~ 1), silent=TRUE))
    lsm_REML      <- suppressWarnings(try(rma(Estimate, Sampling_variance, scale = ~ Moderator, control=list(alpha.min=c(-10,-11), alpha.max=c(1,11))), silent=TRUE))

    # save information about non-convergence, non-available SEs, and non-available PL CI bounds
    # if any problems arise, set ok to FALSE so that the iteration will be restarted below

    ok <- TRUE

    if (inherits(lsm_null_ML, "try-error")) {
      ok <- FALSE
      ic_ML_null <- ic_ML_null + 1
    }

    if (inherits(lsm_ML, "try-error")) {
      ok <- FALSE
      ic_ML <- ic_ML + 1
    }

    if (inherits(lsm_ML, "try-error") || is.na(lsm_ML$se.alpha[2])) {
      ok <- FALSE
      ic_ML_hess <- ic_ML_hess + 1
    }

    if (inherits(lsm_ML, "try-error")) {
      PL_a1_ML <- list(random = c(NA,NA,NA)) # if model did not converge, just set 'random' to three NAs so code below works
    } else {
      PL_a1_ML <- suppressWarnings(try(confint(lsm_ML, alpha=2), silent=TRUE))
    }

    if (is.na(PL_a1_ML$random[2]) || is.na(PL_a1_ML$random[3])) {
      ok <- FALSE
      ic_ML_PL <- ic_ML_PL + 1
    }

    if (!inherits(lsm_ML, "try-error")) {
      if (is.na(lsm_ML$se.alpha[2])) {
        perm_ML <- list(pval.alpha = c(NA,NA))
      } else {
        perm_ML <- permutest(lsm_ML, progbar=FALSE, skip.beta=TRUE)
      }
    }

    if (inherits(lsm_null_REML, "try-error")) {
      ok <- FALSE
      ic_REML_null <- ic_REML_null + 1
    }

    if (inherits(lsm_REML, "try-error")) {
      ok <- FALSE
      ic_REML <- ic_REML+ 1
    }

    if (inherits(lsm_REML, "try-error") || is.na(lsm_REML$se.alpha[2])) {
      ok <- FALSE
      ic_REML_hess <- ic_REML_hess + 1
    }

    if (inherits(lsm_REML, "try-error")) {
      PL_a1_REML <- list(random = c(NA,NA,NA)) # if model did not converge, just set 'random' to three NAs so code below works
    } else {
      PL_a1_REML <- suppressWarnings(try(confint(lsm_REML, alpha=2), silent=TRUE))
    }

    if (is.na(PL_a1_REML$random[2]) || is.na(PL_a1_REML$random[3])) {
      ok <- FALSE
      ic_REML_PL <- ic_REML_PL + 1
    }

    if (!inherits(lsm_REML, "try-error")) {
      if (is.na(lsm_REML$se.alpha[2])) {
        perm_REML <- list(pval.alpha = c(NA,NA))
      } else {
        perm_REML <- permutest(lsm_REML, progbar=FALSE, skip.beta=TRUE)
      }
    }

    # add simulated data to MA_data
    MA_data[((j-1)*k+1):(j*k),] <- cbind(j, 1:k, Moderator, Delta, Estimate, N_exp, N_ctrl, Sampling_variance)

    if (inherits(lsm_ML, "try-error")) {
      predtau2.1_ML  <- NA
      predtau2.2_ML  <- NA
      a0_ML          <- NA
      SEa0_ML        <- NA
      a1_ML          <- NA
      SEa1_ML        <- NA
      WTlb_a1_ML     <- NA
      WTub_a1_ML     <- NA
      WTpval_a0_ML   <- NA
      WTpval_a1_ML   <- NA
      LRpval_ML      <- NA
      PERMpval_a0_ML <- NA
      PERMpval_a1_ML <- NA
    } else {
      # Tau2 estimates
      preds.ML      <- predict(lsm_ML, newscale=c(0,1), transf=exp)
      predtau2.1_ML <- preds.ML$pred[1]
      predtau2.2_ML <- preds.ML$pred[2]
      # Scale coefficients estimates
      a0_ML         <- lsm_ML$alpha[1,1]
      SEa0_ML       <- lsm_ML$se.alpha[1]
      a1_ML         <- lsm_ML$alpha[2,1]
      SEa1_ML       <- lsm_ML$se.alpha[2]
      # Wald-type confidence intervals
      WTlb_a1_ML    <- max(-11,lsm_ML$ci.lb.alpha[2])
      WTub_a1_ML    <- min( 11,lsm_ML$ci.ub.alpha[2])
      # p-values from Wald-type and Likelihoood-ratio tests
      WTpval_a0_ML  <- lsm_ML$pval.alpha[1]
      WTpval_a1_ML  <- lsm_ML$pval.alpha[2]
      if (inherits(lsm_null_ML, "try-error")) {
        LRpval_ML   <- NA
      } else {
        LRpval_ML   <- anova(lsm_ML, lsm_null_ML)$pval
      }
      # p-values from permutation tests
      PERMpval_a0_ML <- perm_ML$pval.alpha[1]
      PERMpval_a1_ML <- perm_ML$pval.alpha[2]
    }

    if (inherits(lsm_REML, "try-error")) {
      predtau2.1_REML  <- NA
      predtau2.2_REML  <- NA
      a0_REML          <- NA
      SEa0_REML        <- NA
      a1_REML          <- NA
      SEa1_REML        <- NA
      WTlb_a1_REML     <- NA
      WTub_a1_REML     <- NA
      WTpval_a0_REML   <- NA
      WTpval_a1_REML   <- NA
      LRpval_REML      <- NA
      PERMpval_a0_REML <- NA
      PERMpval_a1_REML <- NA
    } else {
      # Tau2 estimates
      preds.REML      <- predict(lsm_REML, newscale=c(0,1), transf=exp)
      predtau2.1_REML <- preds.REML$pred[1]
      predtau2.2_REML <- preds.REML$pred[2]
      # Scale coefficients estimates
      a0_REML         <- lsm_REML$alpha[1,1]
      SEa0_REML       <- lsm_REML$se.alpha[1]
      a1_REML         <- lsm_REML$alpha[2,1]
      SEa1_REML       <- lsm_REML$se.alpha[2]
      # Wald-type confidence intervals
      WTlb_a1_REML    <- max(-11, lsm_REML$ci.lb.alpha[2])
      WTub_a1_REML    <- min( 11, lsm_REML$ci.ub.alpha[2])
      # p-values from Wald-type and Likelihoood-ratio tests
      WTpval_a0_REML  <- lsm_REML$pval.alpha[1]
      WTpval_a1_REML  <- lsm_REML$pval.alpha[2]
      if (inherits(lsm_null_REML, "try-error")) {
        LRpval_REML   <- NA
      } else {
        LRpval_REML   <- anova(lsm_REML, lsm_null_REML)$pval
      }
      # p-values from permutation tests
      PERMpval_a0_REML <- perm_REML$pval.alpha[1]
      PERMpval_a1_REML <- perm_REML$pval.alpha[2]
    }

    # Profile-likelihood confidence intervals
    PLlb_a1_ML   <- PL_a1_ML$random[2]
    PLub_a1_ML   <- PL_a1_ML$random[3]
    PLlb_a1_REML <- PL_a1_REML$random[2]
    PLub_a1_REML <- PL_a1_REML$random[3]

    LSM_fitting[j,] <- c(j, predtau2.1_ML, predtau2.2_ML, predtau2.1_REML, predtau2.2_REML,
                         a0_ML, SEa0_ML, a1_ML, SEa1_ML, a0_REML, SEa0_REML, a1_REML, SEa1_REML,
                         WTub_a1_ML, WTlb_a1_ML, WTub_a1_REML, WTlb_a1_REML,
                         PLub_a1_ML, PLlb_a1_ML, PLub_a1_REML, PLlb_a1_REML,
                         WTpval_a0_ML, WTpval_a1_ML, WTpval_a0_REML, WTpval_a1_REML,
                         LRpval_ML, LRpval_REML,
                         PERMpval_a0_ML, PERMpval_a1_ML, PERMpval_a0_REML, PERMpval_a1_REML)

    if (ok) {
      i <- i + 1
    } else {
      next # if not ok, start a new iteration, j.
    }

  }

  dataName <- paste0("1.MA_data/", sprintf("%s_k_%g_N_%g_tau2_%g_vs_%g.csv", m, k, N, tau2.1, tau2.2))
  write.table(MA_data, dataName, row.names=FALSE, sep=";")

  dataName <- paste0("2.LSM_fitting/", sprintf("LSM_%s_k_%g_N_%g_tau2_%g_vs_%g.csv", m, k, N, tau2.1, tau2.2))
  write.table(LSM_fitting, dataName, row.names=FALSE, sep=";")

  return(c(
  j,
  ic_ML_null / j,
  ic_ML / j,
  ic_ML_hess / j,
  ic_ML_PL / j,
  ic_REML_null / j,
  ic_REML / j,
  ic_REML_hess / j,
  ic_REML_PL / j,
  mean(LSM_fitting[,"predtau2.1_ML"] - tau2.1, na.rm=TRUE),
  mean(LSM_fitting[,"predtau2.2_ML"] - tau2.2, na.rm=TRUE),
  mean(LSM_fitting[,"predtau2.1_REML"] - tau2.1, na.rm=TRUE),
  mean(LSM_fitting[,"predtau2.2_REML"] - tau2.2, na.rm=TRUE),
  mean(LSM_fitting[,"a0_ML"] - a0, na.rm=TRUE),
  mean(LSM_fitting[,"a1_ML"] - a1, na.rm=TRUE),
  mean(LSM_fitting[,"a0_REML"] - a0, na.rm=TRUE),
  mean(LSM_fitting[,"a1_REML"] - a1, na.rm=TRUE),
  mean((LSM_fitting[,"a0_ML"] - a0)^2, na.rm=TRUE),
  mean((LSM_fitting[,"a1_ML"] - a0)^2, na.rm=TRUE),
  mean((LSM_fitting[,"a0_REML"] - a0)^2, na.rm=TRUE),
  mean((LSM_fitting[,"a1_REML"] - a0)^2, na.rm=TRUE),
  mean(LSM_fitting[,"WTub_a1_ML"] - LSM_fitting[,"WTlb_a1_ML"], na.rm=TRUE),
  mean(LSM_fitting[,"WTub_a1_REML"] - LSM_fitting[,"WTlb_a1_REML"], na.rm=TRUE),
  mean(LSM_fitting[,"PLub_a1_ML"] - LSM_fitting[,"PLlb_a1_ML"], na.rm=TRUE),
  mean(LSM_fitting[,"PLub_a1_REML"] - LSM_fitting[,"PLlb_a1_REML"], na.rm=TRUE),
  mean(a1 < LSM_fitting[,"WTub_a1_ML"] & a1 > LSM_fitting[,"WTlb_a1_ML"], na.rm=TRUE),
  mean(a1 < LSM_fitting[,"WTub_a1_REML"] & a1 > LSM_fitting[,"WTlb_a1_REML"], na.rm=TRUE),
  mean(a1 < LSM_fitting[,"PLub_a1_ML"] & a1 > LSM_fitting[,"PLlb_a1_ML"], na.rm=TRUE),
  mean(a1 < LSM_fitting[,"PLub_a1_REML"] & a1 > LSM_fitting[,"PLlb_a1_REML"], na.rm=TRUE),
  mean(LSM_fitting[,"WTpval_a0_ML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"WTpval_a1_ML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"WTpval_a0_REML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"WTpval_a1_REML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"LRpval_ML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"LRpval_REML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"PERMpval_a0_ML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"PERMpval_a1_ML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"PERMpval_a0_REML"] < 0.05, na.rm=TRUE),
  mean(LSM_fitting[,"PERMpval_a1_REML"] < 0.05, na.rm=TRUE)))

}

time.start <- proc.time()

library(parallel)

cl <- makePSOCKcluster(cores)

res <- clusterApplyLB(cl, seq_len(nrow(all.conds)), simfun, Rep=Rep, all.conds=all.conds)
res <- do.call(rbind, res)

time.end <- proc.time()
print(unname(time.end - time.start)[3] / 60 / 60)

############################################################################

colnames(res) <- c("iter.computed",
"icr_ML_null", "icr_ML", "icr_ML_hess", "icr_ML_PL",
"icr_REML_null", "icr_REML", "icr_REML_hess", "icr_REML_PL",
"bias_predtau2.1_ML", "bias_predtau2.2_ML",
"bias_predtau2.1_REML", "bias_predtau2.2_REML",
"bias_a0_ML", "bias_a1_ML",
"bias_a0_REML", "bias_a1_REML",
"MSE_a0_ML", "MSE_a1_ML",
"MSE_a0_REML", "MSE_a1_REML",
"width_WT_a1_ML", "width_WT_a1_REML",
"width_PL_a1_ML", "width_PL_a1_REML",
"cov.p_WT_a1_ML", "cov.p_WT_a1_REML",
"cov.p_PL_a1_ML", "cov.p_PL_a1_REML",
"sig_rate_WT_a0_ML", "sig_rate_WT_a1_ML",
"sig_rate_WT_a0_REML", "sig_rate_WT_a1_REML",
"sig_rate_LR_ML", "sig_rate_LR_REML",
"sig_rate_PERM_a0_ML", "sig_rate_PERM_a1_ML",
"sig_rate_PERM_a0_REML", "sig_rate_PERM_a1_REML")

stopCluster(cl)

results <- cbind(all.conds, res)
#results

write.table(results, "3.Results/Results.csv", row.names=FALSE, sep=";")
save(results, file="3.Results/Results.rdata")

############################################################################