#  Copyright 2016 Annamaria Guolo (University of Padova) 
#  Permission to use, copy, modify and distribute this software and
#  its documentation, for any purpose and without fee, is hereby granted,
#  provided that:
#  1) this copyright notice appears in all copies and
#  2) the source is acknowledged through a citation to the paper
#     Guolo A. (2016). A double SIMEX approach for bivariate random-effects meta-analysis of diagnostic accuracy studies. Submitted.
#  The Authors make no representation about the suitability of this software
#  for any purpose.  It is provided "as is", without express or implied warranty

## parameter vector theta=c(mu.eta, mu, sigma2.eta, sigma2.xi, rho)
## vector of information xx = eta.obs, xi.obs, var.etaobs, var.xiobs)

library(mvtnorm)
library(far)
simex.results <- function(TP, FN, TN, FP, P=NULL, N=NULL, lambda=c(0.0, 0.5, 1.0, 1.5, 2.0), B=100, extr.function='quadratic', lambda.first.avoid=FALSE){
  ans <- list()
  P <- TP + FN
  N <- TN + FP
  data <- data.frame(TP, P, FP, N)
  n <- NROW(data)
  sp.obs <- se.obs <- eta.obs <- xi.obs <- var.eta <- var.xi <- rep(NA, n)
  for(i in 1:n){
    sp.obs[i] <- 1-data$FP[i]/data$N[i]
    se.obs[i] <- data$TP[i]/data$P[i]
    var.eta[i] <- 1/(data$TP[i]) +
      1/(data$P[i] - data$TP[i])
    var.xi[i] <- 1/(data$FP[i]) +
      1/(data$N[i] - data$FP[i])
    if(sp.obs[i]==1 | sp.obs[i]==0 | is.na(sp.obs[i])){
      sp.obs[i] <- 1 - (data$FP[i]+0.5)/(data$N[i]+1)
      var.xi[i] <- 1/(data$FP[i]+0.5) +
        1/(data$N[i]-data$FP[i]+0.5)
    }
    if(se.obs[i]==1 | se.obs[i]==0 | is.na(se.obs[i])){
      se.obs[i] <- (data$TP[i]+0.5)/(data$P[i]+1)
      var.eta[i] <- 1/(data$TP[i]+0.5) +
        1/(data$P[i]-data$TP[i]+0.5)
    }
    eta.obs[i] <- log(se.obs[i]/(1-se.obs[i]))
    xi.obs[i] <- log( (1-sp.obs[i])/sp.obs[i] )
  }
  data <- data.frame(eta.obs, xi.obs, var.eta, var.xi)
  colnames(data) <- c('eta.obs', 'xi.obs', 'var.eta', 'var.xi')
  p <- 5 ## model with no covariates  
  u <- list(NULL)
  for(b in 1:B){
    this.u <- rmvnorm(nrow(data), c(0,0), matrix(c(1,0,0,1), 2, 2))
    u[[b]] <- orthonormalization(this.u, basis=FALSE) ## generate NON-IID pseudo-errors
    colnames(u[[b]]) <- c('u1', 'u2')
  }
  hess.fn <- function(theta, data){
    mu.eta <- theta[1]
    mu.xi <- theta[2]
    sigma2.eta <- theta[3]
    sigma2.xi <- theta[4]
    rho <- theta[5]
    var.xi <- sigma2.xi
    var.eta <- sigma2.eta
    hess <- matrix(0.0, ncol=p, nrow=p)
    for(i in 1:n){
      eta <- data[i,1]
      xi <- data[i,2]
      zeta <- ((xi-mu.xi)^2)/var.xi + ((eta-mu.eta)^2)/var.eta - 2*rho*(xi-mu.xi)*(eta-mu.eta)/sqrt(var.xi*var.eta)
      zeta.eta <- -2*(eta-mu.eta)/var.eta +2*rho*(xi-mu.xi)/sqrt(var.eta*var.xi)
      zeta.xi <- -2*(xi-mu.xi)/var.xi + 2*rho*(eta-mu.eta)/sqrt(var.eta*var.xi)
      zeta.sigma2eta <- -((eta-mu.eta)^2)/(var.eta^2) -2*rho*(xi-mu.xi)*(eta-mu.eta)*(-0.5)/sqrt(var.xi)/(sqrt(var.eta)^3)
      zeta.sigma2xi <- -((xi-mu.xi)^2)/(var.xi^2) -2*rho*(xi-mu.xi)*(eta-mu.eta)*(-0.5)/sqrt(var.eta)/(sqrt(var.xi)^3)
      zeta.rho <- -2*(xi-mu.xi)*(eta-mu.eta)/sqrt(var.xi*var.eta)
      zeta.rhorho <- 0.0
      zeta.etaeta <- 2/var.eta
      zeta.xixi <- 2/var.xi
      zeta.etaxi <- -2*rho/sqrt(var.eta*var.xi)
      zeta.etarho <- 2*(xi-mu.xi)/sqrt(var.eta*var.xi)
      zeta.xirho <- 2*(eta-mu.eta)/sqrt(var.eta*var.xi)
      zeta.sigma2etarho <- (eta-mu.eta)*(xi-mu.xi)/sqrt(var.eta^3*var.xi)
      zeta.sigma2xirho <- (eta-mu.eta)*(xi-mu.xi)/sqrt(var.eta*var.xi^3)
      zeta.etasigma2eta <- 2*(eta-mu.eta)/(var.eta^2) - 0.5*2*rho*(xi-mu.xi)/sqrt(var.eta^3*var.xi)
      zeta.etasigma2xi <- -0.5*2*rho*(xi-mu.xi)/sqrt(var.eta*var.xi^3)
      zeta.xisigma2eta <- -0.5*2*rho*(eta-mu.eta)/sqrt(var.eta^3*var.xi)
      zeta.xisigma2xi <- 2*(xi-mu.xi)/(var.xi^2) - 0.5*2*rho*(eta-mu.eta)/sqrt(var.eta*var.xi^3)
      zeta.sigma2etasigma2eta <- -(-2)*(eta-mu.eta)^2/(var.eta^3) -0.5*(-2*rho*(eta-mu.eta)*(xi-mu.xi))*(-3/2)/sqrt(var.xi*var.eta^5)
      zeta.sigma2xisigma2xi <- -(-2)*(xi-mu.xi)^2/(var.xi^3) -0.5*(-2*rho*(eta-mu.eta)*(xi-mu.xi))*(-3/2)/sqrt(var.eta*var.xi^5)
      zeta.sigma2etasigma2xi <- -0.5*(-2*rho*(eta-mu.eta)*(xi-mu.xi))*(-1/2)/sqrt(var.eta^3*var.xi^3)
      hess[1,1] <- hess[1,1] - 0.5*zeta.etaeta/(1-rho^2)
      hess[2,2] <- hess[2,2] - 0.5*zeta.xixi/(1-rho^2)
      hess[1,2] <- hess[2,1] <- hess[1,2] - 0.5*zeta.etaxi/(1-rho^2)
      hess[1,5] <- hess[5,1] <- hess[1,5] -0.5*zeta.etarho/(1-rho^2) - rho*zeta.eta/((1-rho^2)^2)
      hess[2,5] <- hess[5,2] <- hess[2,5] -0.5*zeta.xirho/(1-rho^2) - rho*zeta.xi/((1-rho^2)^2)
      hess[1,3] <- hess[3,1] <- hess[1,3] -0.5*zeta.etasigma2eta/(1-rho^2)
      hess[1,4] <- hess[4,1] <- hess[1,4] - 0.5*zeta.etasigma2xi/(1-rho^2)
      hess[2,3] <- hess[3,2] <- hess[2,3] -0.5*zeta.xisigma2eta/(1-rho^2)
      hess[2,4] <- hess[4,2] <- hess[2,4] -0.5*zeta.xisigma2xi/(1-rho^2)
      hess[3,3] <- hess[3,3] - 0.5/(-var.eta^2) -0.5*zeta.sigma2etasigma2eta/(1-rho^2)
      hess[4,4] <- hess[4,4] - 0.5/(-var.xi^2) -0.5*zeta.sigma2xisigma2xi/(1-rho^2)
      hess[3,4] <- hess[4,3] <- hess[3,4] - 0.5*zeta.sigma2etasigma2xi/(1-rho^2)
      hess[3,5] <- hess[5,3] <- hess[3,5] - 0.5*zeta.sigma2etarho/(1-rho^2) - rho*zeta.sigma2eta/((1-rho^2)^2)
      hess[4,5] <- hess[5,4] <- hess[4,5] - 0.5*zeta.sigma2xirho/(1-rho^2) - rho*zeta.sigma2xi/((1-rho^2)^2)
      hess[5,5] <- hess[5,5] + 1/(1-rho^2)+2*rho^2/((1-rho^2)^2) -0.5*zeta.rhorho/(1-rho^2) -rho*zeta.rho/((1-rho^2)^2) - (zeta+rho*zeta.rho)/((1-rho^2)^2) -4*rho^2*zeta/((1-rho^2)^3)
    }
    return(hess)
  }
  compute.hessian <- function(these.data){ 
    hessiano <- hess.fn(these.data$theta.k, data=these.data$data.k)
    return(solve(-hessiano))
  }
  adding.error <- function(x, this.lambda){
    ## vector of information x= c(eta.obs, xi.obs, var.etaobs, var.xiobs, u1b, u2b)
    A <- matrix(c(as.numeric(x[3]), 0, 0, as.numeric(x[4])), ncol=2, nrow=2)
    B <- matrix(x[c(5,6)], ncol=1)
    matrix(x[1:2], ncol=1) + sqrt(this.lambda)*(chol(A)%*%B)
  }
  simulate.data.vector <- function(this.u, this.lambda){
    v <- cbind(data, this.u)
    v.k <- t(apply(v, 1, adding.error, this.lambda=this.lambda))
    v.k <- as.data.frame(v.k)
    colnames(v.k) <- c('y.added','x.added')
    return(v.k)
  }
  simex.results.lambda <- function(this.lambda){
    ## simulation step for fixed lambda=this.lambda
    all.data.k <- lapply(u, simulate.data.vector, this.lambda=this.lambda)
    all.theta.k.mm <- lapply(all.data.k, function(x) c(mean(x[,1]), mean(x[,2]), var(x[,1])*(n-1)/n, var(x[,2])*(n-1)/n, cor(x[,1], x[,2])))
    theta.k <- do.call(rbind, all.theta.k.mm)  
    all.data <- mapply(list, data.k=all.data.k, theta.k=all.theta.k.mm, SIMPLIFY = FALSE)
    all.theta.var <- lapply(all.data, compute.hessian)
    var.theta.k <- do.call(rbind, lapply(all.theta.var, function(x)(as.vector(x))))
    ## take only the not NA values, if present
    index <- which(!is.na(apply(var.theta.k,1,sum)))
    theta.k <- theta.k[index,]
    var.theta.k <- var.theta.k[index,]
    ## average of the B values of theta.k and var.theta.k for fixed lambda
    theta.lambda <- apply(theta.k, 2, mean)
    var.theta.k <- matrix(apply(var.theta.k, 2, mean), ncol=p)
    var.theta.k2 <- var(theta.k)
    return(list(theta.lambda=theta.lambda, var.lambda=var.theta.k - var.theta.k2))
  }
  if(lambda.first.avoid)
    lambda <- lambda[-1]
  theta.sx <- var.sx <- matrix(0.0, nrow=length(lambda), ncol=p)
  var.sx.complete <- array(0.0, dim=c(length(lambda), p, p))
  colnames(theta.sx) <- colnames(var.sx) <- c('mu.eta', 'mu.xi', 'sigma2.eta', 'sigma2.xi', 'rho')
  if(!lambda.first.avoid){
    theta.mm <- c(mean(data[,1]), mean(data[,2]), var(data[,1])*(n-1)/n, var(data[,2])*(n-1)/n, cor(data[,1], data[,2]))
    theta.sx[1,] <- theta.mm 
    hessiano0 <- hess.fn(theta.mm, data=data)
    var.sx[1,] <- diag(solve(-hessiano0))
    var.sx.complete[1,,] <- solve(-hessiano0)
  }
  if(lambda.first.avoid)
    start <- 1
  else
    start <- 2
  for(i in start:length(lambda)){
    values <- simex.results.lambda(lambda[i])
    theta.sx[i,] <- values[[1]]
    var.sx[i,] <- diag(values[[2]])
    var.sx.complete[i,,] <- values[[2]]
  }
  ## extrapolation step
  extr.theta <- matrix(0.0, ncol=p, nrow=1)
  extr.var <- matrix(0.0, ncol=p, nrow=1)
  extr.var.complete <- matrix(0.0, ncol=p, nrow=p)
  for( j in 1:p ){
    if(extr.function=='linear')
      extrapolation.theta <- lm(theta.sx[,j] ~ lambda)
    else ## quadratic function
      extrapolation.theta <- lm(theta.sx[,j] ~ lambda+I(lambda^2))
    extr.theta[1,j] <- predict(extrapolation.theta, newdata = data.frame(lambda = -1))
    extrapolation.var <- lm(var.sx[,j] ~ lambda+I(lambda^2))
    extr.var[1,j] <- predict(extrapolation.var, newdata = data.frame(lambda = -1))
  }
  diag(extr.var.complete) <- extr.var
  for(j in 1:(p-1)){
    values <- var.sx.complete[,j,j+1]
    if(extr.function=='linear')
      extrapolation.var.complete <- lm(values ~ lambda)    
    else
      extrapolation.var.complete <- lm(values ~ lambda+I(lambda^2))    
    extr.var.complete[j,j+1] <- extr.var.complete[j+1,j] <- predict(extrapolation.var.complete, newdata = data.frame(lambda = -1))
  }
  colnames(extr.theta) <- c('mu.eta', 'mu.xi', 'var.eta', 'var.xi', 'rho')
  ans$theta <- extr.theta
  colnames(extr.var) <- c('mu.eta', 'mu.xi', 'var.eta', 'var.xi', 'rho')
  ans$se <- sqrt(extr.var)
  rownames(extr.var.complete) <- colnames(extr.var.complete) <- c('mu.eta', 'mu.xi', 'var.eta', 'var.xi', 'rho')
  ans$var.matrix <- extr.var.complete
  rownames(theta.sx) <- lambda
  ans$all.theta <- theta.sx
  ans$lambda <- lambda
  ans$extr.function <- extr.function
  class(ans) <- "simex.results"
  return(ans)
}

print.simex.results <- function(x, digits = max(3L, getOption("digits") - 3L), ...){

    cat("\nSimex estimate:\n")
    tab <- matrix(NA, nrow=2, ncol=5)
    tab[1,] <- x$theta
    tab[2,] <- x$se
    rownames(tab) <- c('Estimate', 'Std.Err.')
    colnames(tab) <- c('mu.eta', 'mu.xi', 'var.eta', 'var.xi', 'rho')
    print.default(format(tab, digits = digits), print.gap = 2L, quote = FALSE)

    cat("\nSimex estimated variance/covariance matrix:\n")
    tab <- x$var.matrix
    rownames(tab) <- colnames(tab) <- c('mu.eta', 'mu.xi', 'var.eta', 'var.xi', 'rho')
    print.default(format(tab, digits = digits), print.gap = 2L, quote = FALSE)

    cat("\nValues of lambda:\n", format(x$lambda, 1), "\n")
    cat("\nExtrapolation function:", x$extr.function)

}