#--------------------------------------------------------------------------------
# Name:         myfunctions_SOD.r
# Purpose:      Modules (functions) called by the main script
# Author:       Francesco Tonini
# Email:        ftonini84@gmail.com
# Created:      01/07/2015
# Copyright:    (c) 2015 by Francesco Tonini
# License:      GNU General Public License (GPL)
# Software:     Tested successfully using R version 3.0.2 (http://www.r-project.org/)
#-----------------------------------------------------------------------------------------------------------------------

addalpha <- function(colors, alpha=1.0) {
  r <- col2rgb(colors, alpha=T)
  # Apply alpha
  r[4,] <- alpha*255
  r <- r/255.0
  return(rgb(r[1,], r[2,], r[3,], r[4,]))
}

cauchy.weight <- function(rs, d, scale, gamma = NULL) {

  #univariate Cauchy
  #f(x) = 1 / (pi * scale * (1 + (d/scale)^2))

  #bivariate Cauchy from http://en.wikipedia.org/wiki/Cauchy_distribution
  #f(x) = (1/2*pi) * (scale / (p[,1] + p[,2] + scale^2)^1.5)

  if(is.null(scale)) stop('Parameter scale needs to be specified')

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)
  m[ceiling(ny/2), ceiling(nx/2)] <- 1

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  dist <- as.matrix(distance(r))
  #p <- xyFromCell(r, 1:ncell(r))^2   #use this and comment 'dist' if using bivar Cauchy

  if (length(scale) == 1) {
    if (!is.null(gamma)) stop('The parameter gamma has to be NULL when using a single Cauchy pdf')

    #using PDF
    #half-cauchy: f(x) = 2/pi * (scale/(r^2 + scale^2))  #where scale is the median disp distance here...
    m <- 2/pi * (scale/(dist^2 + scale^2))

    #using bivariate cauchy from http://en.wikipedia.org/wiki/Cauchy_distribution
    #m <- (1/2*pi) * (scale / (p[,1] + p[,2] + scale^2)^1.5)
    #m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

    #sum of weights should add up to 1
    #m / sum(m)
    m

  }else{   #Cauchy mixture

    if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf')
    if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
    scale1 <- scale[1]
    scale2 <- scale[2]

    m <- (gamma * 2/pi * (scale[1]/(dist^2 + scale[1]^2)) ) + ( (1-gamma) * 2/pi * (scale[2]/(dist^2 + scale[2]^2)) )

    #using bivariate cauchy from http://en.wikipedia.org/wiki/Cauchy_distribution
    #m <- gamma * ((1/2*pi) * (scale1 / (p[,1] + p[,2] + scale1^2)^1.5)) + (1-gamma) * ((1/2*pi) * (scale2 / (p[,1] + p[,2] + scale2^2)^1.5))
    #m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

    #sum of weights should add up to 1
    m / sum(m)

  }

}

gauss.weight <- function(rs, d, sigma=NULL, alpha=NULL) {

  #bivariate Gaussian filter, according to http://en.wikipedia.org/wiki/Gaussian_filter
  #f(x) = 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2))

  #two-parameter dispersal kernel as defined in Clark, J.S., 1998. Why trees migrate so fast [...]
  #f(x) = ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(d/alpha)^c  )

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  dist <- as.matrix(distance(r))
  #p <- xyFromCell(r, 1:ncell(r))^2   #use this and comment 'dist' if using bivar Gauss

  #using Clark, J.S., 1998
  if (length(alpha) != 1) stop('The parameter alpha must be a single number (average distance)')
  if (is.null(alpha)) stop('The parameter alpha must be specified (average distance)')

  c <- 2
  m <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dist/alpha)^c  )
  m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

  #using bivariate filter
  #if (length(sigma) != 1) stop('The parameter sigma must be a single number')
  #if (is.null(sigma)) stop('The parameter sigma must be specified')
  #m <- 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2))
  #m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

  #sum of weights should add up to 1
  m / sum(m)

}

exp.weight <- function(rs, d, alpha) {

  #two-parameter dispersal kernel as defined in Clark, J.S., 1998. Why trees migrate so fast [...]
  #f(x) = ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(d/alpha)^c  )

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  dist <- as.matrix(distance(r))

  #using Clark, J.S., 1998
  if (length(alpha) != 1) stop('The parameter alpha must be a single number (average distance)')
  if (is.null(alpha)) stop('The parameter alpha must be specified (average distance)')

  c <- 1
  m <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dist/alpha)^c  )
  m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

  #sum of weights should add up to 1
  m / sum(m)

}

Kernel.gen <- function(x, d, type = c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), scale = NULL, gamma = NULL, sigma = NULL, alpha = NULL){

  type <- match.arg(type)
  x <- res(x)

  if (type == 'Cauchy'){
    cauchy.weight(x, d, scale)
  }else if (type =='Cauchy Mixture'){
    cauchy.weight(x, d, scale, gamma)
  }else if (type =='Exponential'){
    exp.weight(x, d, alpha = alpha)
  }else if (type == 'Gauss'){
    gauss.weight(x, d, alpha = alpha)
  }

}

WindKernel.gen <- function(x, d, mu, kappa){

  rs <- res(x)

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  r[ceiling(ny/2), ceiling(nx/2)] <- 1

  dir <- direction(r, from=TRUE)
  dir[ceiling(ny/2), ceiling(nx/2)] <- 0

  m <- as.matrix(dvm(dir, mu, kappa))

  #sum of weights should add up to 1
  #m / sum(m)
  m

}

distGen <- function(n, type = c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), mean = NULL, sd = NULL, scale = NULL, gamma=NULL) {

  type <- match.arg(type)

  if (type == 'Cauchy'){

    dist <- abs(rcauchy(n, scale = scale))

  }else if (type =='Cauchy Mixture'){

    if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
    if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf!')
    if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
    f <- sample(1:2, n, replace=TRUE, prob=c(gamma, 1-gamma))
    dist <- abs(sapply(f, FUN=function(x) if(x==1) rcauchy(1, scale = scale[1]) else if (x==2) rcauchy(1, scale = scale[2])))

  }else if (type =='Exponential'){

    if (is.null(mean)) stop('The parameter mean must be specified when using an Exponential pdf!')
    dist <- rexp(n, rate = 1/mean)

  }else if (type == 'Gauss'){

    if (is.null(mean) | is.null(sd)) stop('The parameters mean and standard deviation (sd) must be specified when using an Gaussian pdf!')
    dist <- abs(rnorm(n, mean = mean, sd = sd))

  }

  return(dist)

}

#use Von Mises pdf to generate angular data
angleGen <- function(n, mean=0, k=0){

  #mean: mean direction in radians of the von Mises distribution
  #k: concentration parameter of the von Mises distribution. Small k --> large variance; large k --> small variance
  #if(k>0) theta <- rvm(n, mean, k) else
  theta <- runif(n, 0, 360)
  return(theta)

}

findRowPos <- function(x, w){

  nrow <- nrow(HI.raster) - nearest.raster.point(x[1], x[2], w)[[1]] + 1
  return(nrow)

}

findColPos <- function(x, w){

  ncol <- nearest.raster.point(x[1], x[2], w)[[2]]
  return(ncol)

}

spores.count <- function(x, y){

  sum(x[1] == y[,1] & x[2] == y[,2])

}

#Within each infected cell (I > 0) draw random number of infections ~Poisson(lambda=rate of spore production) for each infected host.
#Take SUM for total infections produced by each cell.

new.infections.gen <- function(x, rate, clim=NULL){

    if(is.null(clim)) x <- rpois(x,lambda=rate) else x <- rpois(x,lambda=rate * clim)

    x <- sum(x)
    return(x)

}

myFocal.fun <- function(u, v, ngb){

  spores <- getValuesFocal(u, ngb=ngb)
  spores[is.na(spores)] <- 0
  prob <- c(t(v))

  new.I <- apply(spores, MARGIN = 1, FUN = function(x) ifelse(any(x>0), x %*% prob, 0))

  return(new.I)

}

radialDisp <- function(xyAOIPos, AOI_owin){

  #generate dispersal distances and angles from user-defined pdf
  distance <- distGen(n = sum(spores.lst), type = 'Cauchy', scale=20.57, gamma=0.9947)
  theta <- angleGen(n = sum(spores.lst))

  #set of new xy coords of dispersed spores
  x.new <- rep(x[spores.lst>0], spores.lst[spores.lst>0]) + sin(theta) * distance
  y.new <- rep(y[spores.lst>0], spores.lst[spores.lst>0]) + cos(theta) * distance

  #remove/ignore xy coords falling outside study area
  condx <- which(x.new < extent(HI.raster)[1] | x.new > extent(HI.raster)[2])
  condy <- which(y.new < extent(HI.raster)[3] | y.new > extent(HI.raster)[4])

  x.new <- x.new[-unique(c(condx,condy))]
  y.new <- y.new[-unique(c(condx,condy))]

  #get index (position) of cells in study area containing new xy coords of dispersed spores
  yPos <- apply(cbind(x.new,y.new), 1, FUN=findRowPos, AOI_owin)
  xPos <- apply(cbind(x.new,y.new), 1, FUN=findColPos, AOI_owin)

  #create list of spore counts (spores in each cell after dispersal)
  new.spores.lst <- apply(xyAOIPos, 1, FUN=spores.count, cbind(xPos, yPos))

  return(new.spores.lst)

}

SporeDisp <- function(x, S, I, W=NULL, rs, rtype=c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), mean = NULL, sd = NULL, scale = NULL, gamma=NULL,
                      wtype=c('Uniform', 'VM'), wdir=c('N','NE','E','SE','S','SW','W','NW'), kappa=NULL){

  out <- list()

  rtype <- match.arg(rtype) #radial distribution type
  wtype <- match.arg(wtype) #wind distribution type

  #LOOP THROUGH EACH CELL of the input matrix 'x' (this should be the study area)
  for(row in 1:nrow(x)){

    for(col in 1:ncol(x)){

      if(x[row,col] > 0){  #if [row,col] > 0 disperse spores from it

        for(sp in 1:x[row,col]){

          ##GENERATE DISTANCES
          if (rtype=='Cauchy'){
            if(is.null(scale)) stop('Kernel of type "Cauchy" requires a scale parameter!')
            dist <- abs(rcauchy(1, scale = scale))
          }else if (rtype=='Cauchy Mixture'){
            if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
            if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf!')
            if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
            f <- sample(1:2, 1, prob=c(gamma, 1-gamma))
            if(f == 1) dist <- abs(rcauchy(1, scale = scale[1])) else dist <- abs(rcauchy(1, scale = scale[2]))
          }else if (rtype =='Exponential'){
            if (is.null(mean)) stop('The parameter mean must be specified when using an Exponential pdf!')
            dist <- rexp(1, rate = 1/mean)
          }else if (rtype == 'Gauss'){
            if (is.null(mean) | is.null(sd)) stop('The parameters mean and standard deviation (sd) must be specified when using an Gaussian pdf!')
            dist <- abs(rnorm(1, mean = mean, sd = sd))
          }

          ##GENERATE ANGLES
          if (wtype=='Uniform'){
            theta <- runif(1, -pi, pi)
          }else if(wtype=='VM'){
            if(is.null(kappa) | kappa <= 0) stop('kappa must be greater than zero!')
            #Check predominant windDir
            if(wdir == 'N') {
              theta <- rvm(1, mean = 0 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'NE'){
              theta <- rvm(1, mean = 45 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'E'){
              theta <- rvm(1, mean = 90 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'SE'){
              theta <- rvm(1, mean = 135 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'S'){
              theta <- rvm(1, mean = 180 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'SW'){
              theta <- rvm(1, mean = 225 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'W'){
              theta <- rvm(1, mean = 270 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'NW'){
              theta <- rvm(1, mean = 315 * (pi/180), kappa)  #kappa=concentration
            }
          }

          #distance in cell counts
          #distc <- round(dist / res.win)

          row0 <- row - round((dist * cos(theta)) / rs)
          col0 <- col + round((dist * sin(theta)) / rs)

          if (row0 < 1 | row0 > nrow(x)) next     ## outside the region ##
          if (col0 < 1 | col0 > ncol(x)) next     ## outside the region ##

          if(S[row0, col0] > 0){
            PropS <- S[row0, col0] / (S[row0, col0] + I[row0, col0])
            U <- runif(1)
            if(!is.null(W)) Prob <- PropS * W[row0, col0] else Prob <- PropS    #added weather

            if (U < Prob){
              I[row0, col0] <- I[row0, col0] + 1
              S[row0, col0] <- S[row0, col0] - 1
            }
          }#ENF IF

        }#END FOR LOOP OVER ALL SPORES WITHIN CURRENT CELL

      }#END IF

    }
  }#END LOOP OVER ALL CELLS

  out$I <- I
  out$S <- S

  return(out)

}

SporeDisp2 <- function(x, S, I, W=NULL, rs, rtype=c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), mean = NULL, sd = NULL, scale = NULL, gamma=NULL,
                       wtype=c('Uniform', 'VM'), wdir=c('N','NE','E','SE','S','SW','W','NW'), kappa=NULL){

  out <- list()

  rtype <- match.arg(rtype) #radial distribution type
  wtype <- match.arg(wtype) #wind distribution type

  #LOOP THROUGH EACH CELL of the input matrix 'x' (this should be the study area)
  for(row in 1:nrow(x)){

    for(col in 1:ncol(x)){

      if(x[row,col] > 0){  #if [row,col] > 0 disperse spores from it

        ##GENERATE DISTANCES ALL AT ONCE
        if (rtype=='Cauchy'){
          if(is.null(scale)) stop('Kernel of type "Cauchy" requires a scale parameter!')
          dist <- abs(rcauchy(x[row,col], scale = scale))
        }else if (rtype=='Cauchy Mixture'){
          if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
          if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf!')
          if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
          f <- sample(1:2, x[row,col], prob=c(gamma, 1-gamma))
          dist <- ifelse(f == 1, abs(rcauchy(1, scale = scale[1])), abs(rcauchy(1, scale = scale[2])))
        }else if (rtype =='Exponential'){
          if (is.null(mean)) stop('The parameter mean must be specified when using an Exponential pdf!')
          dist <- rexp(x[row,col], rate = 1/mean)
        }else if (rtype == 'Gauss'){
          if (is.null(mean) | is.null(sd)) stop('The parameters mean and standard deviation (sd) must be specified when using an Gaussian pdf!')
          dist <- abs(rnorm(x[row,col], mean = mean, sd = sd))
        }

        ##GENERATE ANGLES ALL AT ONCE
        if (wtype=='Uniform'){
          theta <- runif(x[row,col], -pi, pi)
        }else if(wtype=='VM'){
          if(is.null(kappa) | kappa <= 0) stop('kappa must be greater than zero!')
          #Check predominant windDir
          if(wdir == 'N') {
            theta <- rvm(x[row,col], mean = 0 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'NE'){
            theta <- rvm(x[row,col], mean = 45 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'E'){
            theta <- rvm(x[row,col], mean = 90 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'SE'){
            theta <- rvm(x[row,col], mean = 135 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'S'){
            theta <- rvm(x[row,col], mean = 180 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'SW'){
            theta <- rvm(x[row,col], mean = 225 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'W'){
            theta <- rvm(x[row,col], mean = 270 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'NW'){
            theta <- rvm(x[row,col], mean = 315 * (pi/180), kappa)  #kappa=concentration
          }
        }

        #distance in cell counts
        #distc <- round(dist / res.win)

        row0 <- row - round((dist * cos(theta)) / rs)
        col0 <- col + round((dist * sin(theta)) / rs)

        bool <- ifelse(row0 < 1 | row0 > nrow(x) | col0 < 1 | col0 > ncol(x), 1, 0)

        ## outside the region ##
        if(any(bool==1)){
          row0 <- row0[-which(bool==1)]
          col0 <- col0[-which(bool==1)]
        }

        #if all spores fall outside region continue loop to next cell
        if (length(row0) == 0 | length(col0) == 0) next

        ##LOOP THROUGH ROW0 and COL0 TO ADD DISPERSED SPORES
        for(i in 1:length(row0)){
          if(S[row0[i], col0[i]] > 0){
            PropS <- round(S[row0[i], col0[i]] / (S[row0[i], col0[i]] + I[row0[i], col0[i]]), 2)
            U <- runif(1)
            if(!is.null(W)) Prob <- PropS * W[row0[i], col0[i]] else Prob <- PropS    #added weather
            if (U < Prob){
              I[row0[i], col0[i]] <- I[row0[i], col0[i]] + 1
              S[row0[i], col0[i]] <- S[row0[i], col0[i]] - 1
            }#ENF IF
          }#ENF IF
        }#END LOOP OVER DISP SPORES FROM CURRENT SOURCE CELL

      }#END IF

    }
  }#END LOOP OVER ALL CELLS

  out$I <- I
  out$S <- S

  return(out)

}

randomU <- function(x, y, z){

  out <- list()

  if(z > 0 & x > 0){

    currentPropS <- round( z / (z + y), 2)

    for (i in 1:x){
      r <- runif(1)
      if (r < currentPropS){
        y <- y + 1
        z <- z - 1
        currentPropS <- round( z / (z + y), 2)
      }
    }

  }

  out$I <- y
  out$S <- z

  return(out)

}

buffer.areas <- function(x, rs, width.row, width.col){

  z <- matrix(x, ncol=ncol(rs), byrow=T)
  buffer.col <- matrix(NA, nrow=nrow(rs), ncol=floor((width.col - 1)/2))
  z <- cbind(buffer.col, z, buffer.col)
  buffer.row <- matrix(NA, ncol=ncol(z), nrow=floor((width.row - 1)/2))
  z <- rbind(buffer.row, z, buffer.row)

  return(z)

}

kernel2D <- function(x, d){

  rs <- res(x)
  if(d <= res(x)[1] | d <= res(x)[2]) stop('d must be >= grain of study area')

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  probKernel <- matrix(NA, ncol=nx, nrow=ny)
  probKernel[ceiling(ny/2), ceiling(nx/2)] <- 1

  return(probKernel)

}

kernel2DToDistance <- function(x, r){

  rs <- res(r)

  xr <- (ncol(x) * rs[1]) / 2
  yr <- (nrow(x) * rs[2]) / 2
  rast <- raster(x, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')

  z <- as.matrix(distance(rast))

  return(z)

}

dispFunction <- function(bkgr, dst, type=c('Cauchy','Cauchy Mixture','Gauss',"Exponential"), c=NULL, scale=NULL, gamma=NULL, sd=NULL, rate=NULL){

  type <- match.arg(type)

  hw_col <- floor(ncol(dst)/2)
  hw_row <- floor(nrow(dst)/2)

  if(is.null(c)) stop('c must be specified in the dispersal function!')
  if(c != 2 & c > 1) stop('c must be either <= 1 or = 2')

  #Start moving the kernel over all cells of study area. BUT only run dispersal on top of source cells (cells with bkgr)
  for(row in 1:nrow(bkgr)){

    for(col in 1:ncol(bkgr)){

      if(!is.na(bkgr[row,col]) & bkgr[row,col] > 0) {

        #************************
        #RADIAL DISPERSAL
        #************************

        #sample a value for alpha using a radial dispersal pdf (this step is necessary to add stochasticity)
        if(type == 'Cauchy'){
          if(c > 1) stop('for type == Cauchy the value of c must be < 1')
          #sample alpha from chosen distribution of interest
          alpha <- abs(rcauchy(1, location=0, scale=scale))
        }else if(type == 'Cauchy Mixture'){
          if(c > 1) stop('for type == "Cauchy" the value of c must be < 1')
          if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
          if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
          f <- sample(1:2, 1, prob=c(gamma, 1-gamma))
          if(f==1) alpha <- abs(rcauchy(1, location=0, scale = scale[1])) else if (f==2) alpha <- abs(rcauchy(1, location=0, scale = scale[2]))
        }else if(type == 'Gauss'){
          if(c != 2) stop('for type = "Gauss" the value of c must be = 2')
          alpha <- abs(rnorm(1, location=0, sd=sd))
        }else if(type == 'Exponential'){
          if(c != 1) stop('for type = "Exponential" the value of c must be = 1')
          alpha <- rexp(1, rate=1/rate)
        }

        #now we can calculate the kernel weights using the value of alpha and set of distances from central source cell
        kernelWt <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dst/alpha)^c  )  ##CHECK IF THIS NEEDS TO BE CONVERTED INTO ANOTHER LOOP IN C++

        #sum of weights should add up to 1
        Wt <- kernelWt/sum(kernelWt)

        #MULTIPLY THE SPORES IN THE SOURCE CELL BY EACH VALUE IN DISP KERNEL
        #spores_disp <- round(bkgr[row,col] * Wt)
        spores_disp <- bkgr[row,col] * Wt

        bkgr[(row-hw_row):(row+hw_row), (col-hw_col):(col+hw_col)] <- bkgr[(row-hw_row):(row+hw_row), (col-hw_col):(col+hw_col)] + spores_disp

      } #END IF

    }
  } #END LOOP OVER EACH CELL INSIDE STUDY BUFFERED STUDY AREA

  return(round(bkgr))
}

infectFun <- function(bkgr, S, I){

  out <- list()

  #LOOP OVER EACH CELL OF STUDY AREA AND FOR EACH NON-ZERO SPORE CELL (dispersed spores) RUN THE PROBABILISTIC
  #LOOP TO SEE HOW MANY SPORES TURN INTO AN INFECTION
  for(row in 1:nrow(bkgr)){
    for(col in 1:ncol(bkgr)){

      if(!is.na(S[row,col]) & S[row,col] > 0 & bkgr[row,col] > 0){
        currentPropS <- round(S[row,col] / (S[row,col] + I[row,col]), 2)
        for(spNbr in 1:bkgr[row,col]){
          U <- runif(1)
          if (U < currentPropS){
            I[row,col] <- I[row,col] + 1
            S[row,col] <- S[row,col] - 1
            currentPropS <- round( S[row,col] / (S[row,col] + I[row,col]), 2)
          }
        } #END LOOP OVER EACH SPORE IN CELL [row,col]
      } #ENF IF

    }
  }

  out$S <- S
  out$I <- I
  return(out)

}

climGen <- function(ls, start, end, Wrank, scn=NA){

  #CASE 1: no future weather needed
  if(is.na(scn) & end <= last_yr){
    ls <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)  #use only the raster files matching the years of interest
    ls.stack <- stack(ls)
    #CASE 2: RANDOM future weather scenario
  }else if(scn == 'random'){
    if(end <= last_yr) stop('you specified a future weather scenario BUT the end year is not a future year!')
    yrs <- sample(weather_rank[,1], size = end - last_yr, replace = T)
    ls_1 <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)
    ls_2 <- unlist(lapply(yrs, FUN=function(x){grep(as.character(x), ls, value=TRUE)}))
    ls <- c(ls_1, ls_2)
    ls.stack <- stack(ls)
    #CASE 3: UPPER 50% (favorable) future weather scenario
  }else if(scn == 'favorable'){
    if(end <= last_yr) stop('you specified a future weather scenario BUT the end year is not a future year!')
    yrs <- sample(weather_rank[1:9,1], size = end - last_yr, replace = T)
    ls_1 <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)
    ls_2 <- unlist(lapply(yrs, FUN=function(x){grep(as.character(x), ls, value=TRUE)}))
    ls <- c(ls_1, ls_2)
    ls.stack <- stack(ls)
    #CASE 4: LOWER 50% (unfavorable) future weather scenario
  }else{
    if(end <= last_yr) stop('you specified a future weather scenario BUT the end year is not a future year!')
    yrs <- sample(weather_rank[10:18, 1], size = end - last_yr, replace = T)
    ls_1 <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)
    ls_2 <- unlist(lapply(yrs, FUN=function(x){grep(as.character(x), ls, value=TRUE)}))
    ls <- c(ls_1, ls_2)
    ls.stack <- stack(ls)
  }

  return(ls.stack)

}


\title{Miscellaneous Mathematical Functions}\name{MathFun}\alias{abs}\alias{sqrt}\keyword{math}\description{
  \code{abs(x)} computes the absolute value of x, \code{sqrt(x)} computes the
  (principal) square root of x, \eqn{\sqrt{x}}.% Details for complex x are below

  The naming follows the standard for computer languages such as C or Fortran.
}\usage{
abs(x)
sqrt(x)
}\arguments{
  \item{x}{a numeric or \code{\link{complex}} vector or array.}
}\details{
  These are \link{internal generic} \link{primitive} functions: methods
  can be defined for them individually or via the
  \code{\link[=S3groupGeneric]{Math}} group generic.  For complex
  arguments (and the default method), \code{z}, \code{abs(z) ==
  \link{Mod}(z)} and \code{sqrt(z) == z^0.5}.

  \code{abs(x)} returns an \code{\link{integer}} vector when \code{x} is
  \code{integer} or \code{\link{logical}}.
}\section{S4 methods}{
  Both are S4 generic and members of the
  \code{\link[=S4groupGeneric]{Math}} group generic.
}\references{
  Becker, R. A., Chambers, J. M. and Wilks, A. R. (1988)
  \emph{The New S Language}.
  Wadsworth & Brooks/Cole.
}\seealso{
  \code{\link{Arithmetic}} for simple, \code{\link{log}} for logarithmic,
  \code{\link{sin}} for trigonometric, and \code{\link{Special}} for
  special mathematical functions.

  \sQuote{\link{plotmath}} for the use of \code{sqrt} in plot annotation.
}\examples{
require(stats) # for spline
require(graphics)
xx <- -9:9
plot(xx, sqrt(abs(xx)),  col = "red")
lines(spline(xx, sqrt(abs(xx)), n=101), col = "pink")


##
## A mechanistic combined toxicokinetic–toxicodynamic (TK/TD) and growth
## model for the aquatic macrophytes Lemna spp. as published by
## Schmitt et al. (2013), DOI: 10.1016/j.ecolmodel.2013.01.017
##
## Parts of the implementation were commented out for reasons of brevity.
##

#library(deSolve)       # Library with ODE-solver
#library(FME)

# This script contains the following functions:

#   calcgrowth(timepoints, vars, param, filenames, graph)   -  To be called for simulation run
#   growthmodel(timepoints, vars, param)                    -  Calls ODE-solver (Called by calcgrowth)

#   growth_ode(t,vars,param)                                -  M O D E L - E Q U A T I O N S !!!!!
#     Supporting functions:
#     P_T(P_up,MolWeight, actTemp)     Temperature dependence of permeability
#     f_R(Rad,k_0,a_k)                 -|
#     f_T(Temp,Topt,Tmax,Tmin)         -|
#     f_T_resp(Temp,t_ref,Q10)         -|
#     f_P(C_P, CP50, a_P, KiP)         -|--  Functions to calculate dependence factors for growth rate
#     f_N(C_N, CN50, a_N, KiN)         -|
#     f_BM(BM, BM50)                   -|
#     f_E(b,EC50,Emax,C_active)        -|
#
#   prepare_param(param,filenames)                           - Loads tables from filenames and includes them in parameter list
#   modeval(result,eff_frac,t_recov)                         -  Calculates endpoint on population level from results

#  For Calculation:     calcgrowth(timepoints, vars, param, filenames,graph=T)

#------- Main function for simulation run --------------------------------------
calcgrowth <- function(timepoints, vars, param, filenames,graph,...)
# !!! CALCGROWTH allways calculates control and treated population !!!
#
# Input:
#  - timepoints: vector with timepoints for output
#  - vars      : named vector with variables of the model
#  - param     : list with parameter values
#  - filenames : vector with names (incl. path) to fiels to be loaded
#  - graph     : logical T/F with/without graphical output
#
# Output:
#  - Dataframe with columes: Time, Dry Biomass Control, Dry Biomass treated, Effect(%),
#                           FrondNo Contro, FrondNo treated, int. Concentration, int. Effect
#
{
# Are data provided as tables? If yes read files and replace parameter value by table
#filenames<-filenames[filenames!='']
#if (length(filenames)!=0) {
#   param <- prepare_param(param, filenames)
#   }

# simulate with effect
result <- growthmodel(timepoints=timepoints, vars=vars,param=param,...)
result$E <- NULL
result$FrondNo <- result[,"BM"]/param$mass_per_frond
# control simulation
#param_cont <- param
#param_cont$Conc <- 0    # Prepare control simulation
#result_cont <- growthmodel(timepoints=timepoints, vars=vars,param=param_cont)

#out<-cbind(   Time          =result[,"time"],
#              Control       =result_cont[,"BM"],
#              Treated       =result[,"BM"],
#              Effect        =(result_cont[,"BM"]-result[,"BM"])/result_cont[,"BM"]*100,
#              FrondNo_Cont  =result_cont[,"BM"]/param$mass_per_frond,
#              FrondNo_Treat =result[,"BM"]/param$mass_per_frond,
#              M_int         =result[,"M_int"],
#              C_int         =result[,"C_int"],
#              Eff_int       =result[,"E"]
#              )

# prepare plot if wanted
#if(graph){
#  windows()
#  plot(out[,'Time'],out[,'Control'],type = "l",xlab='Time [d]',ylab='Biomass [g_dw/m?')
#  lines(out[,'Time'],out[,'Treated'],type = "l",col="red")
#  if (!is.null(param$obsdat)) {points(param$obsdat)}
#  }

return(result)
}

#------ Function that calls ODE-solver -----------------------------------------
growthmodel <- function(timepoints, vars, param, hmax=.1) {
with(as.list(c(vars,param)),{

#plot(0,0,xlim=c(0,max(timepoints)),ylim=c(0,200))

# Solve ODE
out <- as.data.frame(deSolve::ode(y = vars, times = timepoints, func = growth_ode, parms = param, hmax=hmax))
#colnames(out)[4] <- 'C_int'

# Conversion: internal mass -> internal concentration
out[,'C_int'] <- out[,'M_int']/(out[,'BM']*param$BMw2BMd)

return(out)
})
}

# ************  M O D E L - E Q U A T I O N S **********************************
# ODE System and related equations
growth_ode <- function(t,vars,param){
# vars (= Variables of the model) contains:
# BM        [g/m?]      Biomass (is converted into No of individuals at the end
# E         (Toxic)     Effect = Factor on growth rate  (Range: 0 - 1)
# M_int     [?g]        Mass of toxicant in biomass

# Parameters and their units:

#      - Fate of biomass -
#k_phot_fix  T/F         If True k_phot_max is not changed by environmental factors
#k_phot_max  [1/d]       Photosynthesis rate
#k_resp   [1/d]       Respiration rate
#k_loss   [1/d]       Some rate of loss (e.g. Flow rate)
#
#      - Effect -
#Conc     [any]      Concentration of toxicant (may also be a table)
#TDMod    ['direct' or 'delayed'] Kind of model to be used
#Emax     [-]         maximum Effect
#EC50     [same as conc. data]      Midpoint of effect curve
#b        [-]         Slope of effect curve
#k_E_in   [1/d]       Rate of effect effect increase (delayed TD model)
#k_E_out  [1/d]       Rate of effect effect decline
#
#       - Toxicokinetics -
#P_up     [cm/d]      Permeability for uptake
#AperBM   [cm?/g_dw]  A_leaf / d_leaf = 1/d_leaf (for circular disc, d=0.05 cm)
#Kbm      []          Biomass(fw):water partition coefficient
#P_Temp   T/F         Switch for temperature dependence of cuticle permeability
#MolWeight [g/mol]    Molmass of molecule (determines Q10_permeability)
#
#      - Others -
#mass_per_frond     [g_dw/frond]  Dryweight per frond
#BMw2BMd            [g_fresh/g_dry]  Fresh- / dryweight
#
#      - Temperatur dependence -
# k_photrowth  (!!values depend on temp. dependence of k_resp!!)
#Temp     [?C]        Current temperature (may also be a table)
#Tmin     [?C]        Minimum growth temperature
#Tmax     [?C]        Maximum growth temperature
#Topt     [?C]        Optimum growth temperature
#
# k_resp
#t_ref     Temperature at which k_resp is effective
#Q10
#
#
#      - Light dependence (linear dependence on global radiation (see Hodgeson 1969)
#Rad 	    [kJ/m?/d]  Radiation  (may also be given as table)
#k_0     	[1/d]      Intercept of linear part
#a_k     	[(1/d)/(kJ/m?/d)]        Slope of linear part
#
#
#      - Phosphorus dependence (Hill like dependence) -
#C_P      [mg/L]       Phosporus concentration in water
#CP50     [mg/L]       P-conc. where growth rate is halfened   [Ref. F 0191, data re-evaluated with Hill-Model]
#a_P      []            Hill coefficient                       [Ref. F 0191, data re-evaluated with Hill-Model]
#KiP      [mg/L]       P-inhibition constant for very high P-conc.   [Ref. F 0191]
#
#      - Nitrogen dependence (Hill like dependence) -
#C_N      [mg/L]       Nitrogen concentration in water
#CN50     [mg/L]       N-conc. where growth rate is halfened   [Ref. F 0191, data re-evaluated with Hill-Model]
#a_N      []            Hill coefficient                       [Ref. F 0191, data re-evaluated with Hill-Model]
#KiN      [mg/L]       n-inhibition constant for very high P-conc.   [Ref. F 0191]
#
#      - Density dependence -
#BM50     [g_dw/m?]             Cut off BM   [Ref. F 0191]
#

# Default values
TDMod = 'direct'
k_E_in=100
k_E_out=100

with(as.list(c(vars,param)),{
# Determine actual values at timepoints t from tables
if(!is.null(dim(Conc))) {
  actConc <- approx(Conc,y=NULL,t,rule=2)     # Linear interpolation if is table
  actConc <- actConc$y
}
else
  {actConc <- Conc}

if(!is.null(dim(Temp))) {
  actTemp <- approx(Temp,y=NULL,t,rule=2)     # Linear interpolation if is table
  actTemp <- actTemp$y }
else
  {actTemp <- Temp}

if(!is.null(dim(Rad))) {
  actRad <- approx(Rad,y=NULL,t,rule=2)     # Linear interpolation if is table
  actRad <- actRad$y }
else {
  if(Rad>0){actRad <- Rad}
  else{actRad <- calcRad(t,Lat)}
  }

#points(t,BM)

# Calculate internal toxicant concentrations from amount in biomass
BM_fresh <- BM*BMw2BMd
C_int <- M_int/BM_fresh
C_int_u <- abs(C_int/Kbm)   # Unbound internal concentration

# Calculate effective growth rate
if(!k_phot_fix){
  k_phot_eff <- k_phot_max * f_R(actRad, k_0, a_k)
  k_phot_eff <- k_phot_eff * f_T(actTemp,Topt,Tmax,Tmin)
  k_phot_eff <- k_phot_eff * f_P(C_P, CP50, a_P, KiP) * f_N(C_N, CN50, a_N, KiN)
  k_phot_eff <- k_phot_eff * f_BM(BM, BM50)
  k_resp_eff <- k_resp*f_T_resp(actTemp,t_ref,Q10)
}else{
  k_phot_eff <- k_phot_max
  k_resp_eff <- k_resp
}

# Consider toxic effect
f_Eff <- f_E(b,EC50,Emax,C_int_u)
if(TDMod=='delayed'){f_Eff <- E}  # delayed effects could be considered
k_phot_eff <- k_phot_eff*f_Eff

# Biomass
dBMdt <- BM*(k_phot_eff-k_resp_eff-k_loss)
# let population extinct if less than one frond/m?
if(BM<5*mass_per_frond){dBMdt <- 0}

# Effect  (this is the delayed TD model)
dEdt <- k_E_in*f_E(b,EC50,Emax,C_int_u) - k_E_out * E

# TK part: Internal amount of toxicant
P_up_eff = P_up
if(P_Temp){P_up_eff = P_T(P_up,MolWeight, actTemp)}   # Temperature dependence of permeability
dM_intdt <- P_up_eff*AperBM*BM*(actConc-C_int_u) - C_int*BM_fresh*(k_resp_eff+k_loss)

return(list(c(dBMdt, dEdt, dM_intdt)))
})
}

# Calculation of temperature dependent permeability
P_T <- function(P_up,MolWeight, actTemp)
{
Eact <- 0.307*MolWeight/1.4+95          # Activation energy
Q10perm <- exp(10*Eact/0.008314/300^2)   # see Baur Publication 7
return(P_up * Q10perm^((actTemp-20)/10))
}

# Functions for calculating reduction factors for growth rate

# Light
f_R <- function(actRad, k_0, a_k)
{
photfac <- a_k*actRad + k_0
if(photfac >1){photfac=1}
return(photfac)
}

# Temperature
# effect on k_phot
f_T <- function(actTemp,Topt,Tmax,Tmin)
{
Tx<-Tmax
if(actTemp<=Topt){Tx<-Tmin}
return(exp(-2.3*((actTemp-Topt)/(Tx-Topt))^2))
}
# effect on k_resp
f_T_resp <- function(actTemp,t_ref,Q10)
{
Q10^((actTemp-t_ref)/10)
}

# Phosphorus
f_P <- function(C_P, CP50, a_P, KiP)
{
C_P^a_P/(C_P^a_P + CP50^a_P) * KiP/(KiP + C_P)
}

# Nitrogen
f_N <- function(C_N, CN50, a_N, KiN)
{
C_N^a_N/(C_N^a_N + CN50^a_N)* KiN/(KiN + C_N)
}

# Biomass (crowding)
f_BM <- function(BM, BM50)
{
fact<-(BM50 - BM)/BM50
return(fact)
}

# Effect
f_E <- function(b,EC50,Emax,C_active)
{
1-Emax*C_active^b/(EC50^b+C_active^b)
}

#******************************************************************************

#------- Function for reading input files --------------------------------------
# prepare_param <- function(param,filenames)
# # Reads files with input information and add respective tables to parameters
# {
# nam <- names(filenames)
# for (i in (1:NROW(nam))) {
#   nam_i <- nam[i]
#   content <- read.delim(filenames[i], header=T)
#   if(sum(nam_i=='Data_file')>0) {param$obsdat <- content}
#     else {param$obsdat = NULL}
#   if(sum(nam_i=='Conc_file')>0) {param$Conc <- content}
#   if(sum(nam_i=='Temperature_file')>0) {param$Temp <- content}
#   if(sum(nam_i=='Irradiation_file')>0) {param$Rad <- content}
#   }
# return(param)
# }

#------- Evaluation of simulation results --------------------------------------
#modeval <- function(result,control,eff_frac,t_recov){
# Calculates: Maximum Effect, Period of Effect (Time to Recovery) and Effect remaining after t_recov
# Input:
#   result:   Biomass treated
#   control:  Biomass control
#   eff_frac: Maximum relativ deviation from control that is NO effect
#   t_recov:  Time after onset of effect at which remaining effect is determined
#
# Output:
#   MaxEff:     Maximum Effect (%control)
#   E_trecov:   Effect remaining at t_recov after onset
#   t_recov:    Period of Effect (time between onset and disappearence)
#   AuEffCurve: Area under effect curve
#
#
# n_times <- NROW(result)
#
# calcEff <- (control[,'BM']-result[,'BM'])/control[,'BM'] # effect as fraction
#
# # Initialisation of variables
# maxeff_tot<-0
# maxeff_rec<-0
# maxeff<-0
# maxeff_tot_r<-0
# maxeff_rec_r<-0
# maxeff_r<-0
# teff_max<-0
# teff_max_tot<-0
# teff_max_r<-0
# teff_max_tot_r<-0
# AuEC <- 0
# AuEC_tot <- 0
#
# # Evaluation on basis of accumulated values
# t1<-0
# t2<-0
# t1_r<-0
# t2_r<-0
# for (i in (1:n_times)) {
# # do evaluation for biomass
#    if(calcEff[i]>eff_frac){
#       if(t1==0){t1<-result[i,'time']}
#       t2<-result[i,'time']
#       if(calcEff[i]>maxeff){maxeff<-calcEff[i]}    # determin Max. Effect
#       if((t2-t1)>t_recov && calcEff[i]>maxeff_rec){maxeff_rec<-calcEff[i]}
#       if((t2-t1)>teff_max){teff_max<-(t2-t1)}    # determin period of effect
#       AuEC <- AuEC+(calcEff[i]+calcEff[i-1])/(2*(result[i,'time']-result[i-1,'time']))  # determine area under effect curve
#       }
#    else{
#       if(maxeff>maxeff_tot){maxeff_tot<-maxeff}
#       if(teff_max>teff_max_tot){teff_max_tot<-teff_max}
#       if(AuEC>AuEC_tot){AuEC_tot<-AuEC}
#       maxeff<-0
#       teff_max<-0
#       t1<-0
#       t2<-0
#       }
#   }
#
# # repeat this in order to capture effects at end of calculation period
# if(t2>0 && calcEff[i]>maxeff_rec){maxeff_rec<-calcEff[i]}
# if(maxeff>maxeff_tot){maxeff_tot<-maxeff}
#
#
# result <- c(
# MaxEff        =  maxeff_tot*100, # Maximum Effect (%control)
# E_trecov      =  maxeff_rec,     # Effect remaining at t_recov after onset
# t_recov       =  teff_max_tot,   # Period of Effect (time between onset and disappearence)
# AuEffCurve    =  AuEC_tot)       # Area under effect curve
#
# return(result)
# }


# --- Day 1: Report Repair ---
# After saving Christmas five years in a row, you've decided to take a vacation
# at a nice resort on a tropical island. Surely, Christmas will go on without
# you.
#
# The tropical island has its own currency and is entirely cash-only. The gold
# coins used there have a little picture of a starfish; the locals just call
# them stars. None of the currency exchanges seem to have heard of them, but
# somehow, you'll need to find fifty of these coins by the time you arrive so
# you can pay the deposit on your room.
#
# To save your vacation, you need to get all fifty stars by December 25th.
#
# Collect stars by solving puzzles. Two puzzles will be made available on each
# day in the Advent calendar; the second puzzle is unlocked when you complete
# the first. Each puzzle grants one star. Good luck!
#
# Before you leave, the Elves in accounting just need you to fix your expense
# report (your puzzle input); apparently, something isn't quite adding up.
#
# Specifically, they need you to find the two entries that sum to 2020 and then
# multiply those two numbers together.
#
# For example, suppose your expense report contained the following:
#
# 1721
# 979
# 366
# 299
# 675
# 1456
#
# In this list, the two entries that sum to 2020 are 1721 and 299. Multiplying
# them together produces 1721 * 299 = 514579, so the correct answer is 514579.
#
# Of course, your expense report is much larger. Find the two entries that sum
# to 2020; what do you get if you multiply them together?

x <- scan("input.txt", 0)
for (i in seq(along = x)) {
  j <- which(x[i] + x == 2020)
  if (length(j) > 0) {
    print(x[i] * x[j])
    quit()
  }
}


# this is the modelfile for joint meta-analysis
# for humerus and femur data
# treating the studies as parallel designs
#

model {

#### Both tests, complete crosstabs for TPR and FPR: group 1
    for(k1 in 1:K.G1) {

        # observational part of the model
        # x and p order is 11 10 01 00
        # first humerus, second femur

        #                  1          2           3           4        5         6
        # eta.xi order is eta1 (hum) eta2 (fem)  eta3 (jtpr) xi1 (hum) xi2 (fem) xi3 (jfpr)
        #

        x.down.11.G1[k1] ~ dbin(p.down.11.G1[k1], N.down.G1[k1])
        x.down.1dot.G1[k1] ~ dbin(p.down.1dot.G1[k1], N.down.G1[k1])
        x.down.dot1.G1[k1] ~ dbin(p.down.dot1.G1[k1], N.down.G1[k1])

        # p11.DOWN <-ilogit(eta3)
        p.down.11.G1[k1] <- ilogit(eta.xi.G1[k1,3])
        # Sensitivity for test 1 (humerus)
        p.down.1dot.G1[k1] <- ilogit(eta.xi.G1[k1,1])
        # Sensitivity for test 2 (femur)
        p.down.dot1.G1[k1] <- ilogit(eta.xi.G1[k1,2])

        # p11.NODOWN
        x.nodown.11.G1[k1] ~ dbin(p.nodown.11.G1[k1], N.nodown.G1[k1])
        x.nodown.1dot.G1[k1] ~ dbin(p.nodown.1dot.G1[k1], N.nodown.G1[k1])
        x.nodown.dot1.G1[k1] ~ dbin(p.nodown.dot1.G1[k1], N.nodown.G1[k1])

        # p11.nodown <-ilogit(eta3)
        p.nodown.11.G1[k1] <- ilogit(eta.xi.G1[k1,6])
        # Sensitivity for test 1 (humerus)
        p.nodown.1dot.G1[k1] <- ilogit(eta.xi.G1[k1,4])
        # Sensitivity for test 2 (femur)
        p.nodown.dot1.G1[k1] <- ilogit(eta.xi.G1[k1,5])

        # structural part of the model
        eta.xi.G1[k1, 1:6] ~dmnorm(Eta.Xi[1:6], Omega[1:6,1:6])

    }

    for(k4 in 1:K.G4) {
        # observational part of the model
        x.down.dot1.G4[k4] ~ dbin(p.down.dot1.G4[k4], N.down.G4[k4])
        x.nodown.dot1.G4[k4] ~ dbin(p.nodown.dot1.G4[k4], N.nodown.G4[k4])

        p.down.dot1.G4[k4] <- ilogit(eta.xi.G4[k4, 1])
        p.nodown.dot1.G4[k4] <- ilogit(eta.xi.G4[k4, 2])

        # structural part of the model
        eta.xi.G4[k4, 1:2] ~ dmnorm(Eta.Xi.G4[1:2], Omega.G4[1:2, 1:2])
    }

    # prior for mean -- independent vague priors suffice
    #                -- otherwise, mvnormal with vague Wishart
    Eta.Xi[1] ~ dnorm(mu0[1], prec.mu0[1])
    Eta.Xi[2] ~ dnorm(mu0[2], prec.mu0[2])
    Eta.Xi[3] ~ dnorm(mu0[3], prec.mu0[3])
    Eta.Xi[4] ~ dnorm(mu0[4], prec.mu0[4])
    Eta.Xi[5] ~ dnorm(mu0[5], prec.mu0[5])
    Eta.Xi[6] ~ dnorm(mu0[6], prec.mu0[6])

    # S is a diagonal matrix of sd's
    S[1,1] ~ dunif(s.lower[1], s.upper[1])  # or use inverse gamma
    S[2,2] ~ dunif(s.lower[2], s.upper[2])
    S[3,3] ~ dunif(s.lower[3], s.upper[3])
    S[4,4] ~ dunif(s.lower[4], s.upper[4])
    S[5,5] ~ dunif(s.lower[5], s.upper[5])
    S[6,6] ~ dunif(s.lower[6], s.upper[6])

    for(r1 in 1:5) {
        for(c1 in (r1+1):6) {
            S[r1,c1] <- 0
            S[c1,r1] <- 0
        }
    }

    # LL' = U'U is the cholesky decomposition of the correlation matrix (L=U')
    L[1,1] <- 1
    L[1,2] <- 0
    L[1,3] <- 0
    L[1,4] <- 0
    L[1,5] <- 0
    L[1,6] <- 0

    L[2,1] <- cos(phi.21)
    L[2,2] <- sin(phi.21)
    L[2,3] <- 0
    L[2,4] <- 0
    L[2,5] <- 0
    L[2,6] <- 0

    L[3,1] <- cos(phi.31)
    L[3,2] <- cos(phi.32)*sin(phi.31)
    L[3,3] <- sin(phi.32)*sin(phi.31)
    L[3,4] <- 0
    L[3,5] <- 0
    L[3,6] <- 0

    L[4,1] <- cos(phi.41)
    L[4,2] <- cos(phi.42)*sin(phi.41)
    L[4,3] <- cos(phi.43)*sin(phi.42)*sin(phi.41)
    L[4,4] <- sin(phi.43)*sin(phi.42)*sin(phi.41)
    L[4,5] <- 0
    L[4,6] <- 0

    L[5,1] <- cos(phi.51)
    L[5,2] <- cos(phi.52)*sin(phi.51)
    L[5,3] <- cos(phi.53)*sin(phi.52)*sin(phi.51)
    L[5,4] <- cos(phi.54)*sin(phi.53)*sin(phi.52)*sin(phi.51)
    L[5,5] <- sin(phi.54)*sin(phi.53)*sin(phi.52)*sin(phi.51)
    L[5,6] <- 0

    L[6,1] <- cos(phi.61)
    L[6,2] <- cos(phi.62)*sin(phi.61)
    L[6,3] <- cos(phi.63)*sin(phi.62)*sin(phi.61)
    L[6,4] <- cos(phi.64)*sin(phi.63)*sin(phi.62)*sin(phi.61)
    L[6,5] <- cos(phi.65)*sin(phi.64)*sin(phi.63)*sin(phi.62)*sin(phi.61)
    L[6,6] <- sin(phi.65)*sin(phi.64)*sin(phi.63)*sin(phi.62)*sin(phi.61)

    phi.21 ~ dunif(chol.r.lower[1], chol.r.upper[1])
    phi.31 ~ dunif(chol.r.lower[2], chol.r.upper[2])
    phi.32 ~ dunif(chol.r.lower[3], chol.r.upper[3])
    phi.41 ~ dunif(chol.r.lower[4], chol.r.upper[4])
    phi.42 ~ dunif(chol.r.lower[5], chol.r.upper[5])
    phi.43 ~ dunif(chol.r.lower[6], chol.r.upper[6])
    phi.51 ~ dunif(chol.r.lower[7], chol.r.upper[7])
    phi.52 ~ dunif(chol.r.lower[8], chol.r.upper[8])
    phi.53 ~ dunif(chol.r.lower[9], chol.r.upper[9])
    phi.54 ~ dunif(chol.r.lower[10], chol.r.upper[10])
    phi.61 ~ dunif(chol.r.lower[11], chol.r.upper[11])
    phi.62 ~ dunif(chol.r.lower[12], chol.r.upper[12])
    phi.63 ~ dunif(chol.r.lower[13], chol.r.upper[13])
    phi.64 ~ dunif(chol.r.lower[14], chol.r.upper[14])
    phi.65 ~ dunif(chol.r.lower[15], chol.r.upper[15])

    R <- L %*% t(L)
    Tau <- S %*% R %*% S
    Omega <- inverse(Tau)

    # Omega.G4 and Eta.Xi.G4
    # I <- diag(rep(1,6))
    # P.G4 <- I[,c(2, 5, 1, 3, 4, 6)]
    Omega.G4 <- t(P.G4) %*% Omega %*% P.G4
    Eta.Xi.G4 <- Eta.Xi %*% P.G4

    # Data to report
    tpr.hum <- ilogit(Eta.Xi[1])
    tpr.fem <- ilogit(Eta.Xi[2])
    jtpr <- ilogit(Eta.Xi[3])
    fpr.hum <- ilogit(Eta.Xi[4])
    fpr.fem <- ilogit(Eta.Xi[5])
    jfpr <- ilogit(Eta.Xi[6])

    diff.tpr <- tpr.hum - tpr.fem
    diff.fpr <- fpr.hum - fpr.fem

    or.tpr <- exp(Eta.Xi[1]-Eta.Xi[2])
    or.fpr <- exp(Eta.Xi[4]-Eta.Xi[5])

    diff.eta <- Eta.Xi[1]-Eta.Xi[2]
    diff.xi <- Eta.Xi[4]-Eta.Xi[5]

}


argmax <- function(x) {
  which.max(x)
}

first_layer <- function(agent_loglikelihoods, alphas, is_argmax, cs) {

  T = dim(agent_loglikelihoods)[2]
  n_agents = dim(agent_loglikelihoods)[1]
  pi_t = matrix(1, length(alphas), n_agents) / n_agents
  prob = array(0, dim=c(T, length(alphas), n_agents))
  loglikehood = matrix(0, length(alphas), T)

  for (t in 1:T) {
    for (j in 1:length(alphas)) {
      alpha = alphas[j]
      if (is_argmax) {
        pi_t[j, ] = alpha * pi_t[j, ]
        p = rep(0, length(pi_t[j, ]))
        p[argmax(pi_t[j, ])] = 1
        prob[t, j, ] = p
        loglikehood[j, t] = sum(agent_loglikelihoods[ , t] * p)
        pi_t[j, ] = pi_t[j, ] + agent_loglikelihoods[ , t]
      }
      else {
        pi_t[j, ] = (pi_t[j, ]^alpha + cs) / (sum(pi_t[j, ]^alpha) + cs)  # pi_t|t-1
        prob[t, j, ] = pi_t[j, ]
        loglikehood[j, t] = log(sum(exp(agent_loglikelihoods[ , t]) * pi_t[j, ]))
        pi_t[j, ] = pi_t[j, ] * exp(agent_loglikelihoods[ , t])
        pi_t[j, ] = pi_t[j, ] / sum(pi_t[j])  # pi_t|t
      }
    }
  }
  return(list("loglikehood"=loglikehood, "prob"=prob))
}

second_layer <- function(loglikehood, deltas, is_argmax) {
  T = dim(loglikehood)[2]
  res_weights = array(0, dim=c(length(deltas), T, dim(loglikehood)[1]))
  res_likelihoods = matrix(0, length(deltas), T)

  for (i in 1:length(deltas)) {
    delta = deltas[i]
    weights = matrix(0, T, dim(loglikehood)[1])
    momentum = rep(0,T)
    csum = matrix(0, T, dim(loglikehood)[1])
    for (t in 1:T) {
      if (is_argmax) {
        p = rep(0, dim(loglikehood)[1])
        if (t==1) {
          p[argmax(csum[t, ])] = 1
        }
        else {
          p[argmax(csum[t-1, ])] = 1
        }
        weights[t, ] = p
        momentum[t] = log(sum(exp(loglikehood[ , t]) * p))
      }
      else {
        if (t==1) {
          m = 0
          p = exp(csum[t, ] - log(sum(exp(csum[t, ] - m))) - m)
        }
        else {
          m = max(csum[t-1, ])
          p = exp(csum[t-1, ] - log(sum(exp(csum[t-1, ] - m))) - m)
        }
        weights[t, ] = p
        momentum[t] = log(sum(exp(loglikehood[ , t]) * p))
      }
      if (t==1) {
        csum[t, ] = loglikehood[ , t]
      }
      else {
        csum[t, ] = delta * csum[t-1, ] + loglikehood[ , t]
      }
    }
    res_likelihoods[i, ] = momentum
    res_weights[i, , ] = weights
  }
  return(list("res_likelihoods"=res_likelihoods, "res_weights"=res_weights))
}

ldf <- function(agent_loglikelihoods, levels, discount_factors, activation_functions, c=10^(-20)) {

  alphas = discount_factors
  is_argmax = activation_functions[1] == "argmax"
  res = first_layer(agent_loglikelihoods, alphas, is_argmax, c)
  loglikehood = res$loglikehood
  prob = res$prob

  if (levels == 2) {
    deltas = discount_factors
    is_argmax = activation_functions[2] == "argmax"
    res = second_layer(loglikehood, deltas, is_argmax)
    momentum = res$res_likelihoods
    param_weights = res$res_weights
    weights = array(0, dim=c(length(deltas), dim(forecasts_lik)[2], dim(forecasts_lik)[1]))
    for (k in 1:length(deltas)) {
      for (i in 1:dim(param_weights)[2]) {
        weights[k, i, ] = apply(t(prob[i, , ]) * param_weights[k, i, ],1,sum)
      }
    }
    list("logscores"=momentum , "weights"=weights, "params_weights"=param_weights)
  }
  else{
    list("logscores"=loglikehood , "weights"=prob, "params_weights"=NULL)
  }

}

forecasts_lik = t(matrix(c(
  c(-2.302585093, -4.605170186, -4.605170186, -1.609437912, -4.605170186, -1.771956842, -1.609437912, -1.386294361,
   -1.386294361, -2.302585093, -1.386294361),
  c(-0.916290732, -1.203972804, -1.609437912, -2.995732274, -4.605170186, -2.302585093, -4.828313737, -1.386294361,
   -1.609437912, -2.991548932, -0.801038303),
  c(-2.302585093, -3.688879454, -3.688879454, -1.897119985, -2.9, -2.302585093, -4.1, -1.1, -0.1, -1.4,
   -1.897119985),
  c(-4.605170186, -4.605170186, -4.605170186, -4.605170186, -4.605170186, -0.9, -4.605170186, -0.510825624,
   -0.287682072, -1.491654877, -1.897119985),
  c(-1.203972804, -1.203972804, -1.290984181, -2.302585093, -4.605170186, -1, -4.605170186, -1.049822124,
   -2.302585093, -2.995732274, -0.597837001)), nrow=11, ncol=5))
discount_factors = c(1, 0.5)

res = ldf(forecasts_lik, 1, discount_factors, c("softmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-24.54868304, -21.48288988))) < 10^(-8))
res = ldf(forecasts_lik, 1, discount_factors, c("argmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-24.57489777, -25.00121507))) < 10^(-8))
res = ldf(forecasts_lik, 2, discount_factors, c("softmax", "softmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-22.13047414, -22.23379625))) < 10^(-8))
res = ldf(forecasts_lik, 2, discount_factors, c("argmax", "argmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-25.87418075, - 24.27844848))) < 10^(-8))


##################################################################################################################
#########  WHO Child Growth Standards                                                                        #####
#########  Department of Nutrition for Health and Development                                                #####
#########  World Health Organization                                                                         #####
#########  Last modified on 07/10/2013     -     Developed using R version 3.0.1 (2013-05-16)                #####
#########  This code corcerns the restricted approach for the prevalences, i.e. the calculation of the       #####
#########  prevalences takes into account only records with all z-scores valid (non-missing) for the first   #####
#########  four indicators: weight-for-age, length/height-for-age, weight-for-length/height and BMI-for-age. #####
#########  Note: this analysis provides results only for these four indicators.                              #####
##################################################################################################################
##################################################################################################################

##################################################################################################################
#########  Function for calculating the z-scores and prevalences for a nutritional survey                    #####
##################################################################################################################

########################################################################
#### Auxiliar functions
########################################################################

#############################################################################
##### Prevalence calculation for the upper bound and corresponding 95% C.I.
#############################################################################

#### With oedema (only for weight-for-length/height and bmi-for-age)

prevph <- function(a,x,w,f) {
   f<-as.character(f)
   ph <- sum((x > a)*w,na.rm=T)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T))+(1/(2*sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)))
   vec <- c(rounde(sum(((!is.na(x)) | (f=="y"))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), ph+aux)*100,digits=1))
   return(vec)
   }

#############################################################################
##### Prevalence calculation for the lower bound and corresponding 95% C.I.
#############################################################################

#### Without oedema (for length/height-for-age)

prevnh.L <- function(a,x,w) {
   ph <- sum((x < a)*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum((!is.na(x))*w,na.rm=T))+(1/(2*sum((!is.na(x))*w,na.rm=T)))
   vec <- c(rounde(sum((!is.na(x))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), ph+aux)*100,digits=1))
   return(vec)
   }

#### With oedema  (for all weight-related indicators)

prevnh <- function(a,x,w,f) {
   f<-as.character(f)
   ph <- sum((x < a | f=="y")*w,na.rm=T)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T))+(1/(2*sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)))
   vec <- c(rounde(sum(((!is.na(x)) | (f=="y"))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), ph+aux)*100,digits=1))
   return(vec)
   }

###########################################
#### Weighted mean  and standard deviation
###########################################

wmean <- function(x,w) { return(rounde(sum(x*w,na.rm=T)/sum(w[!is.na(x)]),digits=2) )  }

wsd <- function(x,w) {
   mh <- sum(x*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   sdh<-ifelse(length(x[!is.na(x)])>0,rounde(sqrt(sum(((x-mh)^2)*w,na.rm=T)/(sum((!is.na(x))*w,na.rm=T) - 1)),digits=2),NA)
   return( sdh )
   }

######################################################################################
#### Rounding function - SPlus rounding function uses the nearest even number rule
######################################################################################

rounde <- function(x,digits=0) {
	expo<-10^digits
	return(ifelse(abs(x*expo) - floor(abs(x*expo)) < 0.5, sign(x*expo) * floor(abs(x*expo)), sign(x*expo) * (floor(abs(x*expo)) + 1))/expo)
}

######################################################################################
### Function for calulating individual Length-for-age z-scores
######################################################################################

calc.zlen<-function(mat,lenanthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i])) {

		l.val<-lenanthro$l[lenanthro$age==mat$age.days[i] & lenanthro$sex==mat$sex[i]]
		m.val<-lenanthro$m[lenanthro$age==mat$age.days[i] & lenanthro$sex==mat$sex[i]]
		s.val<-lenanthro$s[lenanthro$age==mat$age.days[i] & lenanthro$sex==mat$sex[i]]
		mat$zlen[i]<-(((mat$clenhei[i]/m.val)^l.val)-1)/(s.val*l.val)

	}	else mat$zlen[i]<- NA

}
return(mat)
}

######################################################################################
### Function for calulating individual Weight-for-age z-scores
######################################################################################

calc.zwei<-function(mat,weianthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$oedema[i]!="y") {

		l.val<-weianthro$l[weianthro$age==mat$age.days[i] & weianthro$sex==mat$sex[i]]
		m.val<-weianthro$m[weianthro$age==mat$age.days[i] & weianthro$sex==mat$sex[i]]
		s.val<-weianthro$s[weianthro$age==mat$age.days[i] & weianthro$sex==mat$sex[i]]

		mat$zwei[i]<-(((mat$weight[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zwei[i]) & mat$zwei[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zwei[i]<- 3+((mat$weight[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zwei[i]) & mat$zwei[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zwei[i]<- (-3)+((mat$weight[i]-sd3neg)/sd23neg)
						}

		} else mat$zwei[i]<-NA
}
return(mat)
}

######################################################################################
### Function for calulating individual Weight-for-length/height z-scores
######################################################################################

calc.zwfl<-function(mat,wflanthro,wfhanthro){

for(i in 1:length(mat$age.days)) {

	mat$zwfl[i]<-NA

       if(mat$oedema[i]!="y") {

		if( (!is.na(mat$age.days[i]) & mat$age.days[i]<731) | (is.na(mat$age.days[i]) & !is.na(mat$l.h[i]) & (mat$l.h[i]=="l" | mat$l.h[i]=="L")) | (is.na(mat$age.days[i]) & is.na(mat$l.h[i]) & !is.na(mat$clenhei[i]) & mat$clenhei[i]<87) ) {

			if(!is.na(mat$clenhei[i]) & mat$clenhei[i]>=45 & mat$clenhei[i]<=110) {

			### Interpolated l,m,s values

			low.len<-trunc(mat$clenhei[i]*10)/10
          upp.len<-trunc(mat$clenhei[i]*10+1)/10
			diff.len<-(mat$clenhei[i]-low.len)/0.1

			if(diff.len>0) {
			l.val<-wflanthro$l[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]+diff.len*( wflanthro$l[wflanthro$length==upp.len & wflanthro$sex==mat$sex[i]]-wflanthro$l[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]] )
			m.val<-wflanthro$m[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]+diff.len*( wflanthro$m[wflanthro$length==upp.len & wflanthro$sex==mat$sex[i]]-wflanthro$m[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]] )
			s.val<-wflanthro$s[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]+diff.len*( wflanthro$s[wflanthro$length==upp.len & wflanthro$sex==mat$sex[i]]-wflanthro$s[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]] )
			} else {
				l.val<-wflanthro$l[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]
				m.val<-wflanthro$m[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]
				s.val<-wflanthro$s[wflanthro$length==low.len & wflanthro$sex==mat$sex[i]]
			}

			mat$zwfl[i]<-(((mat$weight[i]/m.val)^l.val)-1)/(s.val*l.val)
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]>3) {
							sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
							sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
							mat$zwfl[i]<- 3+((mat$weight[i]-sd3pos)/sd23pos)
						}
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]<(-3)) {
							sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
							sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
							mat$zwfl[i]<- (-3)-((sd3neg-mat$weight[i])/sd23neg)
							}
				}
			}

			else 		if( (!is.na(mat$age.days[i]) & mat$age.days[i]>=731) | (is.na(mat$age.days[i]) & !is.na(mat$l.h[i]) & (mat$l.h[i]=="h" | mat$l.h[i]=="H"))  | (is.na(mat$age.days[i]) & is.na(mat$l.h[i]) & !is.na(mat$clenhei[i]) & mat$clenhei[i]>=87) ) {

			if(!is.na(mat$clenhei[i]) & mat$clenhei[i]>=65 & mat$clenhei[i]<=120) {

			### Interpolated l,m,s values

			low.len<-trunc(mat$clenhei[i]*10)/10
          		upp.len<-trunc(mat$clenhei[i]*10+1)/10
			diff.len<-(mat$clenhei[i]-low.len)/0.1

			if(diff.len>0) {
			l.val<-wfhanthro$l[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]+diff.len*( wfhanthro$l[wfhanthro$height==upp.len & wfhanthro$sex==mat$sex[i]]-wfhanthro$l[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]] )
			m.val<-wfhanthro$m[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]+diff.len*( wfhanthro$m[wfhanthro$height==upp.len & wfhanthro$sex==mat$sex[i]]-wfhanthro$m[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]] )
			s.val<-wfhanthro$s[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]+diff.len*( wfhanthro$s[wfhanthro$height==upp.len & wfhanthro$sex==mat$sex[i]]-wfhanthro$s[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]] )
          } else {
			l.val<-wfhanthro$l[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]
			m.val<-wfhanthro$m[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]
			s.val<-wfhanthro$s[wfhanthro$height==low.len & wfhanthro$sex==mat$sex[i]]
			}

			mat$zwfl[i]<-(((mat$weight[i]/m.val)^l.val)-1)/(s.val*l.val)
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]>3) {
							sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
							sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
							mat$zwfl[i]<- 3+((mat$weight[i]-sd3pos)/sd23pos)
							}
			if(!is.na(mat$zwfl[i]) & mat$zwfl[i]<(-3)) {
							sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
							sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
							mat$zwfl[i]<- (-3)-((sd3neg-mat$weight[i])/sd23neg)
							}
				}
			}
		}

		if(!is.na(mat$age.day[i]) & mat$age.days[i]>1856) mat$zwfl[i]<-NA

}

return(mat)
}

######################################################################################
### Function for calulating individual BMI-for-age z-scores
######################################################################################

calc.zbmi<-function(mat,bmianthro){

for(i in 1:length(mat$age.days)) {

	if(!is.na(mat$age.days[i]) & mat$oedema[i]!="y") {

		l.val<-bmianthro$l[bmianthro$age==mat$age.days[i] & bmianthro$sex==mat$sex[i]]
		m.val<-bmianthro$m[bmianthro$age==mat$age.days[i] & bmianthro$sex==mat$sex[i]]
		s.val<-bmianthro$s[bmianthro$age==mat$age.days[i] & bmianthro$sex==mat$sex[i]]

		mat$zbmi[i]<-(((mat$cbmi[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zbmi[i]) & mat$zbmi[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zbmi[i]<- 3+((mat$cbmi[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zbmi[i]) & mat$zbmi[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zbmi[i]<- (-3)+((mat$cbmi[i]-sd3neg)/sd23neg)
						}

		} else mat$zbmi[i]<-NA

}

return(mat)
}

###################################################################################
#### Main function starts here: igrowup
###################################################################################

###############################################################################################################################################
#### This function can be used to:
#### 1. Calculate the z-scores for the indicators: length/height-for-age, weight-for-age, weight-for-legnth/height and body mass index-for-age
####    The output file with z-scores values is exported the file to an Excel spreadsheet (see readme file);
#### 2. Calculate the prevalence rates of stunting, underweight, wasting and overweight, and z-scores means and standard deviations. Results
####    are exported to an Excel spreadsheet, displayed by age group.
###############################################################################################################################################

#############################################################################
##### Function for calculating the z-scores for all indicators
#############################################################################

igrowup.restricted <- function(FileLab="Temp",FilePath="C:\\Documents and Settings",mydf,sex,age,age.month=F,weight,lenhei,measure=rep(NA,dim(mydf)[1]),
              oedema=rep("n",dim(mydf)[1]),sw=rep(1,dim(mydf)[1])) {

#############################################################################
###########   Calculating the z-scores for all indicators
#############################################################################

   old <- options(warn=(-1))

   sex.x<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(sex))])
   age.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(age))])
   weight.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(weight))])
   lenhei.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(lenhei))])
   if(!missing(measure)) lorh.vec<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(measure))]) else lorh.vec<-as.character(measure)
   if(!missing(oedema)) oedema.vec<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(oedema))]) else oedema.vec<-oedema
   if(!missing(sw))	sw<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(sw))])	else sw<-as.double(sw)
   sw<-ifelse(is.na(sw),0,sw)

	sex.vec<-NULL

	if(age.month) age.vec<-rounde(age.x*30.4375) else age.vec<-rounde(age.x)
	lenhei.vec<-ifelse((!is.na(age.vec) & age.vec<731 & !is.na(lorh.vec) & (lorh.vec=="h" | lorh.vec=="H")),lenhei.x+0.7,#
		  ifelse((!is.na(age.vec) & age.vec>=731 & !is.na(lorh.vec) & (lorh.vec=="l" | lorh.vec=="L")),lenhei.x-0.7,lenhei.x))

   sex.vec<-ifelse(!is.na(sex.x) & (sex.x=="m" | sex.x=="M" | sex.x=="1"),1,ifelse(!is.na(sex.x) & (sex.x=="f" | sex.x=="F" | sex.x=="2"),2,NA))

   lorh.vec<-ifelse(is.na(lorh.vec) | lorh.vec=="l" | lorh.vec=="L" | lorh.vec=="h" | lorh.vec=="H",lorh.vec,NA)

   oedema.vec<-ifelse(oedema.vec=="n" | oedema.vec=="N","n",ifelse(oedema.vec=="y" | oedema.vec=="Y","y","n"))

   mat<-cbind.data.frame(age.x,as.integer(age.vec),as.double(sex.vec),weight.x,lenhei.x,lorh.vec,lenhei.vec,oedema.vec,sw,stringsAsFactors=F)
	names(mat)<-c("age","age.days","sex","weight","len.hei","l.h","clenhei","oedema","sw")

	mat$cbmi<-mat$weight/((lenhei.vec/100)^2)
	mat$zlen<-NULL
	mat$flen<-NULL
	mat$zwei<-NULL
	mat$fwei<-NULL
	mat$zwfl<-NULL
	mat$fwfl<-NULL
	mat$zbmi<-NULL
	mat$fbmi<-NULL

#############################################################################
###########   Calculating the z-scores for all indicators
#############################################################################

cat("Please wait while calculating z-scores...\n")

### Length-for-age z-score

mat<-calc.zlen(mat,lenanthro)

### Weight-for-age z-score

mat<-calc.zwei(mat,weianthro)

### Weight-for-length/height z-score

mat<-calc.zwfl(mat,wflanthro,wfhanthro)

### BMI-for-age z-score

mat<-calc.zbmi(mat,bmianthro)

#### Rounding the z-scores to two decimals

			mat$zlen<-rounde(mat$zlen,digits=2)
			mat$zwei<-rounde(mat$zwei,digits=2)
			mat$zwfl<-rounde(mat$zwfl,digits=2)
			mat$zbmi<-rounde(mat$zbmi,digits=2)

#### Flagging z-score values for individual indicators

			mat$flen<-ifelse(abs(mat$zlen) > 6,1,0)
			mat$fwei<-ifelse(mat$zwei > 5 | mat$zwei < (-6),1,0)
			mat$fwfl<-ifelse(abs(mat$zwfl) > 5,1,0)
			mat$fbmi<-ifelse(abs(mat$zbmi) > 5,1,0)

mat<-cbind.data.frame(mydf,mat[,-c(1,3:6,8:9)])

###################################################################################################
######### Export data frame with z-scores and flag variables
###################################################################################################

assign("matz",mat,envir = .GlobalEnv)

write.table(matz, file=paste(FilePath,"\\",FileLab,"_z_rc.csv",sep=""),na="",row.names = FALSE,sep=",",quote = TRUE)

cat(paste("Z-scores calculated and exported to ",FilePath,"\\",FileLab,"_z_rc.csv\n\n",sep=""))

#######################################################################################################
#### Calculating prevalences and summary statistics.
#######################################################################################################

if(any(sw <0)) stop("Negative weights are not allowed and program will stop. Prevalence tables will not be produced.")

mat.out<-mat

################################
#### Creating age group variable
################################

mat.out$sw.vec<-sw
mat.out$sex.vec<-as.double(sex.vec)
mat.out$oedema.vec<-as.character(oedema.vec)

if(age.month) mat.out$agegr <- ifelse(!is.na(age.x) & age.x<6,0,ifelse(!is.na(age.x) & age.x<12,6,#
                     ifelse(!is.na(age.x) & age.x<24,12,ifelse(!is.na(age.x) & age.x<36,24,#
                     ifelse(!is.na(age.x) & age.x<48,36,ifelse(!is.na(age.x) & age.x<61,48,NA)  )))))

else mat.out$agegr <- ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<6,0,ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<12,6,#
                     ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<24,12,ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<36,24,#
                     ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<48,36,ifelse(!is.na(mat.out$age.days) & mat.out$age.days/30.4375<61,48,NA)  )))))

##############################################
#### Make z-score as missing if it is flagged
##############################################

mat.out$zlen<-ifelse(!is.na(mat.out$flen) & mat.out$flen!=0,NA,mat.out$zlen)
mat.out$zwei<-ifelse(!is.na(mat.out$fwei) & mat.out$fwei!=0,NA,mat.out$zwei)
mat.out$zwfl<-ifelse(!is.na(mat.out$fwfl) & mat.out$fwfl!=0,NA,mat.out$zwfl)
mat.out$zbmi<-ifelse(!is.na(mat.out$fbmi) & mat.out$fbmi!=0,NA,mat.out$zbmi)

mat.out<-mat.out[!is.na(mat.out$zlen) & !is.na(mat.out$zwei) & !is.na(mat.out$zwfl) & !is.na(mat.out$zbmi),]
if(dim(mat.out)[1]==0) stop("\n\nNo non-missing z-score values are available for calculating prevalences with the restricted approach. Program will stop!\n\n.")

##############################################
#### Include all levels of age group variable
##############################################

mat.aux<-as.data.frame(cbind(array(rep(NA,((dim(mat.out)[2]-1)*6)),dim=c(6,(dim(mat.out)[2]-1)) ),c(0,6,12,24,36,48)))
names(mat.aux)<-names(mat.out)
mat.out<-rbind(mat.out,mat.aux)

##############################################################################################
#### Make Oedema variable to be "n" if age greater than 60 completed months (>=61 months).
#### This is beacuse children with oedema counts in the prevalence even if z-score is missing
#### for weight related indicators.
##############################################################################################

mat.out$oedema.vec<-ifelse((!is.na(mat.out$age.days) & mat.out$age.days/30.4375>=61) | mat.out$oedema.vec=="NA","n",mat.out$oedema.vec)

#####################################################################################################################################################
#### Creating matrix with estimated prevalences, confidence intervals, and means and standard deviations of z-scores and exporting it to Excel file.
#####################################################################################################################################################

cat("\nPlease wait while calculating prevalences and z-score summary statistics...\n")

#### Sexes combined

#### % < -3 SD for all the indicators
mat<- t(cbind.data.frame(#
       prevnh(-3,mat.out$zwei,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-3,mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-3, z$zlen, z$sw.vec)),#
       prevnh(-3,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-3,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zbmi, z$sw.vec, z$oedema.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh(-2,mat.out$zwei,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-2,mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-2, z$zlen, z$sw.vec)),#
       prevnh(-2,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-2,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +1 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(1,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(1, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(1,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(1, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +2 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(2,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(2,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +3 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(3,mat.out$zwfl,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(3,mat.out$zbmi,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(3, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out$zwei,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zwei,z$sw.vec)),#
       wmean(mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zlen,z$sw.vec)),#
       wmean(mat.out$zwfl,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zwfl,z$sw.vec)),#
       wmean(mat.out$zbmi,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zbmi,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out$zwei,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zwei,z$sw.vec)),#
       wsd(mat.out$zlen,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zlen,z$sw.vec)),#
       wsd(mat.out$zwfl,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zwfl,z$sw.vec)),#
       wsd(mat.out$zbmi,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zbmi,z$sw.vec)))))

####################################################################################################################
##### Exporting matrix to Excel file

mat[1:14,8]<-mat[1:14,17]
mat[1:14,9]<-mat[1:14,18]
mat[1:14,10:18]<-array(rep("",126),dim=c(14,9))
rm(mat1)
mat1<-rbind.data.frame(c("Set 1:","Sexes","combined",rep("",15)),c("Weight","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[1:7,],#
                       c("Length","/height","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[8:14,],#
                       c("Weight","-for-","length","/height",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[15:21,],#
                       c("BMI","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[22:28,])

for(j in 1:dim(mat1)[2]) mat1[,j]<-ifelse(mat1[,j]=="NA" | mat1[,j]=="NaN","",mat1[,j])

mat1<-cbind.data.frame(c("",rep(c(""," Age"," 0-60"," 0-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),4)),mat1)

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

##### For boys and girls

for(i in 1:2) {

mat.out.sex<-mat.out[!is.na(mat.out$sex.vec) & mat.out$sex.vec==i,]

mat.aux<-as.data.frame(cbind(array(rep(NA,((dim(mat.out.sex)[2]-1)*6)),dim=c(6,(dim(mat.out.sex)[2]-1)) ),c(0,6,12,24,36,48)))
names(mat.aux)<-names(mat.out.sex)
mat.out.sex<-rbind.data.frame(mat.out.sex,mat.aux )
mat.out.sex$oedema.vec<-ifelse((!is.na(mat.out.sex$age.days) & mat.out.sex$age.days/30.4375>=61) | mat.out.sex$oedema.vec=="NA","n",mat.out.sex$oedema.vec)

#### % < -3 SD for all the indicators
mat<-t(cbind.data.frame(#
       prevnh(-3,mat.out.sex$zwei,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-3,mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-3, z$zlen, z$sw.vec)),#
       prevnh(-3,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-3,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zbmi, z$sw.vec, z$oedema.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh(-2,mat.out.sex$zwei,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zwei, z$sw.vec, z$oedema.vec)),#
       prevnh.L(-2,mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-2, z$zlen, z$sw.vec)),#
       prevnh(-2,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevnh(-2,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +1 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(1,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(1, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(1,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(1, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +2 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(2,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(2, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(2,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(2, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +3 SD for weight-for-length/height and bmi-for-age
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       array(rep(NA,28),dim=c(4,7)),#
       array(rep(NA,28),dim=c(4,7)),#
       prevph(3,mat.out.sex$zwfl,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(3, z$zwfl, z$sw.vec, z$oedema.vec)),#
       prevph(3,mat.out.sex$zbmi,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(3, z$zbmi, z$sw.vec, z$oedema.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out.sex$zwei,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zwei,z$sw.vec)),#
       wmean(mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zlen,z$sw.vec)),#
       wmean(mat.out.sex$zwfl,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zwfl,z$sw.vec)),#
       wmean(mat.out.sex$zbmi,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zbmi,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out.sex$zwei,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zwei,z$sw.vec)),#
       wsd(mat.out.sex$zlen,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zlen,z$sw.vec)),#
       wsd(mat.out.sex$zwfl,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zwfl,z$sw.vec)),#
       wsd(mat.out.sex$zbmi,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zbmi,z$sw.vec)))))

####################################################################################################################
##### Exporting matrix to Excel file

mat[1:14,8]<-mat[1:14,17]
mat[1:14,9]<-mat[1:14,18]
mat[1:14,10:18]<-array(rep("",126),dim=c(14,9))

mat2<-rbind.data.frame(c(paste("Set ",i+1,":",sep=""),c("Males","Females")[i],rep("",16)),c("Weight","-for-","age",rep("",15)),#
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[1:7,],#
                       c("Length","/height","-for-","age",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","Mean","SD","","", "","","", "","","", ""),mat[8:14,],#
                       c("Weight","-for-","length","/height",rep("",14)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[15:21,],#
                       c("BMI","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[22:28,])

for(j in 1:dim(mat2)[2]) mat2[,j]<-ifelse(mat2[,j]=="NA" | mat2[,j]=="NaN","",mat2[,j])

mat2<-cbind.data.frame(c("",rep(c("","Age"," 0-60"," 0-5"," 6-11"," 12-23"," 24-35"," 36-47"," 48-60"),4)),mat2)

names(mat2)<-names(mat1)

mat1<-rbind(mat1,mat2)

}    #### End of loop for sex

###################################################################################################################
######### Export table with prevalence values and their confidence intervals, and mean and SD of the z-scores
###################################################################################################################

assign("matprev",mat1,envir = .GlobalEnv)

write.table(matprev, file=paste(FilePath,"\\",FileLab,"_prev_rc.csv",sep=""),na=" ",row.names = FALSE,col.names=F,sep=",",quote = TRUE)

cat(paste("Prevalences and z-score summary statistics calculated and exported to ",FilePath,"\\",FileLab,"_prev_rc.csv\n",sep=""))

on.exit(options(old))

invisible()

}   #### End of function igrowup.standard


#' Function that creates a skewed sinusoidal growth rate (GR) curve
#' from a list of parameters
#'
#' Takes the specified parameters for amplitude, period, phase, average value
#' and skewness factor as well as the number of years specified and the time
#' interval. It then creates a skewed sinusoid based on the boundary conditions.
#' The skewness factor (\code{G_skw}) determines whether the sinusoid is skewed
#' towards the front (\code{G_skw < 50}) or the back of the annual peak in
#' growth rate (\code{G_skw > 50}).
#' Used as intermediate step during iterative modeling.
#'
#' @param G_par List of four parameters describing (in order) amplitude
#' (\code{G_amp}; in micrometer/day), period (\code{G_per}; in days), phase
#' (\code{G_pha} in day of the year), average growth rate (\code{G_av}; in
#' micrometer/day) and the skewness factor (\code{G_skw} between 0 and 100)
#' @param years Length of the preferred sinusoid in number of years (defaults
#' to 1)
#' @param t_int Time interval of sinusoidal record (in days)
#' @return A matrix containing columns for time (in days) and GR
#' (in micrometer/day)
#' @references
#'   \doi{10.1016/j.palaeo.2017.09.034}
#' @examples
#' # Set parameters
#' G_amp <- 20
#' G_per <- 365
#' G_pha <- 100
#' G_av <- 15
#' G_skw <- 70
#' G_par <- c(G_amp, G_per, G_pha, G_av, G_skw)
#' # Run GR model function
#' GR <- growth_rate_curve(G_par, 1, 1)
#' @export
growth_rate_curve <- function(G_par, # Function to create growth rate as function of time based on parameters
    years = 1, # Default number of years of the record = 1
    t_int = 1 # Default time interval = 1 day
    ){

    G_amp <- G_par[1] # Seasonal range in Growth rate (um/d)
    G_per <- G_par[2] # Period of growth rate seasonality (days)
    G_pha <- G_par[3] # Timing of peak in growth rate (day of the year)
    G_av <- G_par[4] # Annual average growth rate (um/d)
    G_skw <- G_par[5] # Skewness factor in growth rate sinusoid (-)

    t <- seq(0, G_per, t_int) # Define time axis based on the number of days in a year and the time interval

    GR <- rep(NA, length(t)) # Create empty growth rate vector
    # Build GR vector piece by piece based on parameters
    # Check if t is between the time of maximum growth and the subsequent time of minimum growth but before the peak, add one period's length if it is
    if(length(t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t < G_pha)]) > 0){ # Catch "replacement has length zero" errors
        GR[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t < G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t < G_pha)] + G_per - G_pha + (G_per * (100 - G_skw) / 50)/4) / (G_per * (100 - G_skw) / 50))
    }
    # Check if t is between the time of maximum growth and the subsequent time of minimum growth but still after the peak
    if(length(t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t >= G_pha)]) > 0){ # Catch "replacement has length zero" errors
        GR[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t >= G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) < (G_per * (100 - G_skw) / 100)) & (t >= G_pha)] - G_pha + (G_per * (100 - G_skw) / 50)/4) / (G_per * (100 - G_skw) / 50))
    }
    # Check if t is between the time of maximum growth and the previous time of minimum growth but still before the peak, subtract one period's length if it is
    if(length(t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t > G_pha)]) > 0){
        GR[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t > G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t > G_pha)] - G_per - G_pha + (G_per * G_skw / 50)/4) / (G_per * G_skw / 50))
    }
    if(length(t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t <= G_pha)]) > 0){
        GR[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t <= G_pha)] <- G_av + G_amp/2 * sin(2 * pi * (t[(((t - G_pha) %% G_per) >= (G_per * (100 - G_skw) / 100)) & (t <= G_pha)] - G_pha + (G_per * G_skw / 50)/4) / (G_per * G_skw / 50))
    }
    # Replace negative growth rates with zeroes
    GR[GR < 0] <- 0
    # Multiply t and GR with number of years
    if(years > 1){
        t <- c(t, rep(t[-1], years - 1) + rep(seq(365, 365 * (years - 1), 365), each = 365))
        GR <- c(GR, rep(GR[-1], years - 1))
    }
    # Collate results and export
    res <- cbind(t, GR)
    return(res)
}


#############
# ARS for the sampling of beta_a0 in GMM and IGMM
############
# TODO: What about this package?
# http://www.inside-r.org/packages/cran/Runuran/docs/ars.new
library(ars)

# function
beta.f_y <-function(y, S, W){

  F <- dim(W)[1]
  R <- dim(S)[3]

  sum_SW <- 0
  for (r in 1:R){
    Sr <- S[,,r]
    Sr <- as.matrix(Sr) # compatibility with one-dimensional case
    sum_SW <- sum_SW + log(det(Sr)*det(W)) - sum(diag(Sr%*%W))
  }

  sum_gamma <- 0
  for (d in 1:F){
    sum_gamma <- sum_gamma + lgamma((exp(y)+d-F)/2)
  }
  r <- y
  r <-  r - R*sum_gamma
  r <-  r - F/(2*(exp(y)-F+1))
  r <-  r - (3/2)*log(exp(y)-F+1)
  r <-  r + ((R*exp(y)*F)/2)*(y - log(2))
  r <-  r + (exp(y)/2)*sum_SW

  return(r)
}

# first derivative function
beta.f_y_prima <- function(y, S, W){

  F <- dim(W)[1]
  R <- dim(S)[3]

  sum_SW <- 0
  for (r in 1:R){
    Sr <- S[,,r]
    Sr <- as.matrix(Sr) # compatibility with one-dimensional case
    sum_SW <- sum_SW + log(det(Sr)*det(W)) - sum(diag(Sr%*%W))
  }

  sum_digamma <- 0
  for (d in 1:F){
    sum_digamma <- sum_digamma + digamma((exp(y)+d-F)/2)
  }
  r <- 1
  r <-  r - R*exp(y)*0.5*sum_digamma
  r <-  r + exp(y)*F/(2*((exp(y)-F+1))^2)
  r <-  r - (3/2)*exp(y)/(exp(y)-F+1) + (R*F*exp(y))/2 +  R*F*exp(y)*(y-log(2))/2
  r <-  r + (exp(y)/2)*sum_SW

  return(r)
}

# Wrapper for ARS function
ars.sample_beta_a0 <- function(S, W, init=4){

  # make it compatible with the one-dimensional case
  # in case we want to use this version for both
  # the multi and the uni-dimensional
  init <- log(init)
  if (is.matrix(W)){
     lb <- TRUE
     xlb <- log(dim(W)[1]-0.9)
     xpoints <- c(max(xlb, init-10), init, init+10)
   }
  # in case of computational issues (W with lots of decimals and too close to 0), truncate W
  y <- tryCatch(ars2.beta(1, beta.f_y, beta.f_y_prima, x=xpoints, lb=lb, xlb=xlb, S=S, W=W),
                error=function(e){
                  print(e);
                  ars2.beta(1, beta.f_y, beta.f_y_prima, x=xpoints, lb=lb, xlb=xlb, S=S, W=signif(W,1))})
  exp(y)
}

###############################################################################
# Hack ARS function so that it returns the ifault codes and not just print them
# so that we can handle it like an exception
###############################################################################

ars2.beta <- function (n = 1, f, fprima, x = c(-4, 1, 4), ns = 100, m = 3,
                  emax = 64, lb = FALSE, ub = FALSE, xlb = 0, xub = 0, ...)
{
  mysample <- rep(0, n)
  iwv <- rep(0, ns + 7)
  rwv <- rep(0, 6 * (ns + 1) + 9)
  hx <- f(x, ...)
  hpx <- fprima(x, ...)
  initial <- .C("initial_", as.integer(ns), as.integer(m),
                as.double(emax), as.double(x), as.double(hx), as.double(hpx),
                as.integer(lb), as.double(xlb), as.integer(ub), as.double(xub),
                ifault = as.integer(0), iwv = as.integer(iwv), rwv = as.double(rwv))
  if (initial$ifault == 0) {
    h <- function(x) f(x, ...)
    hprima <- function(x) fprima(x, ...)
    for (i in 1:n) {
      sample <- .C("sample_", as.integer(initial$iwv),
                   as.double(initial$rwv), h, hprima, new.env(),
                   beta = as.double(0), ifault = as.integer(0))
      if (sample$ifault == 0) {
        if (i < ns) {
          x <- c(x, sample$beta)
          h <- function(x) f(x, ...)
          hprima <- function(x) fprima(x, ...)
        }
        mysample[i] <- sample$beta
      }
      else {
        cat("\nError in sobroutine sample_...")
        cat("\nifault=", sample$ifault, "\n")
        stop(paste("\nError in sobroutine sample_...", sample$ifault))
      }
    }
  }
  else {
    cat("\nError in sobroutine initial_...")
    cat("\nifault=", initial$ifault, "\n")
    cat("\nx:", x)
    cat("\nfprima:", fprima(x,...))
    cat("\nf:", f(x,...))
    stop(paste("\nError in sobroutine initial_...", initial$ifault))
  }
  return(mysample)
}

environment(ars2.beta) <- environment(ars)

# test:
# multidimensional works fine

# W <- diag(2)*26
# S <- array(NA, dim=c(10,2,2))
#for (i in 1:10){
#  S[i,,] <- rWishart(1, 2, solve(2*W))
#}
# sample_beta_a0(S,W)
#
# W <- diag(2)*26
# S <- array(NA, dim=c(10,2,2))
#for (i in 1:10){
#  S[i,,] <- 2*diag(2)*1/26 # exactly the expectancy
#}
# sample_beta_a0(S,W)
#
#

############################################
# Debug with this

# Problematics
# s <- c(0.00589706, 0.00566612,  0.00505162,  0.00458974)
# w <- 202.159996343
#
# s <-  c(0.00495562,  0.00501441,  0.00484268,  0.005048)
# w <-  193.110366286
#
# W <- as.matrix(w)
# S <- array(NA, dim=c(length(s),1,1))
# S[,,] <- s
# x <- seq(-5,5, by=0.5)
#
# sample_beta_a0(s,w)
#
# plot(x, f_y(x, S, W))
# plot(x, f_y_prima(x, S, W))
#
# f_y_prima(c(-10,-4,4,25,100,300), S, W)

######################################################"""
S <- array(NA, dim=c(1, 1, 1))


#' Function to return (a + b)*(a + b)
#' Takes in numeric a and b as input.
#' @param a numeric value
#' @param b a numeric value added after b
#' @return The output of the function
#' @export
#' @examples
#' calculation_2(2,3)
#' calculation_2(5,8)

calculation_2 <- function(a,b) {
  output <- a^2 + 2*a*b + b^2
  output
}


## AUROC2
## Area under ROC type 2 curve
## translated from matlab script type2roc.m by Fleming & Lau (2014)
## taken from
## https://github.com/smfleming/meta_dots/blob/master/type2roc.m
## authored: Steve Fleming 2012

calculate_auroc2 <- function(corrects, subjectiveRatings, numRatings) {
  ratings <- rev(c(1:numRatings))

  hits <- function(x) {subjectiveRatings==x & corrects}
  falsealarms <- function(x) {subjectiveRatings==x & abs(corrects-1)}

  type2hits_list <- lapply(ratings,hits)
  type2falsealarms_list <- lapply(ratings,falsealarms)

  type2hits_listsums <- 0.5 + sapply(type2hits_list,sum)
  type2falsealarms_listsums <- 0.5 + sapply(type2falsealarms_list,sum)

  H2s <- type2hits_listsums / sum(type2hits_listsums)
  FA2s <- type2falsealarms_listsums / sum(type2falsealarms_listsums)

  cumulative_H2s <- c(0,cumsum(H2s))
  cumulative_FA2s <- c(0, cumsum(FA2s))

  k <- function(i) {(cumulative_H2s[i+1] - cumulative_FA2s[i])^2 - (cumulative_H2s[i] - cumulative_FA2s[i+1])^2}
  ## k(i) = (cum_H2(c+1) - cum_FA2(c))^2 - (cum_H2(c) - cum_FA2(c+1))^2;

  ks <- sapply(rev(ratings), k)

  aoc <- 0.5 + 0.25*sum(ks)
  return(aoc)
}


####################################################################################
# mwc_2way(fit, v1, v2)
#
# Description
# -----------
# Take a fitted model and two panel dimensions, and return a revised estimate of
# the parameter covariance matrix clustered on each of the dimensions, as in
# Cameron, Gelbach & Miller 2006
#
# Arguments
# ---------
#       fit             Fitted model
#       v1,2            Panel dimensions on which to cluster
#
####################################################################################

mwc_2way <- function(fit, v1, v2){

    # give proper names, attributes etc. to return matrix
    retvar <- robcov(fit, v1)$var
    retvar[,] <- 0

    # list factors and interactions to cluster on and the corresponding signs
    clustervars <- list(v1,
                        v2,
                        interaction(v1,v2))
    signs <- c(1,1,-1)

    for(i in 1:NROW(signs)){

        curclusvar <- clustervars[[i]]
        cursign <- signs[i]

        # calculate a finite-clusters inflation factor
        D <- NROW(unique(curclusvar))
        inflator <- D/(D-1)

        retvar <- retvar + cursign*inflator*robcov(fit, curclusvar)$var

    }

    return(retvar)
}

####################################################################################
# mwc_3way(fit, v1, v2, v3)
#
# Description
# -----------
# Take a fitted model and three panel dimensions, and return a revised estimate of
# the parameter covariance matrix clustered on each of the dimensions, as in
# Cameron, Gelbach & Miller 2006
#
# Arguments
# ---------
#       fit             Fitted model
#       v1,2,3          Panel dimensions on which to cluster
#
####################################################################################

mwc_3way <- function(fit, v1, v2, v3){

    # give proper names, attributes etc. to return matrix
    retvar <- robcov(fit, v1)$var
    retvar[,] <- 0

    # list factors and interactions to cluster on and the corresponding signs
    clustervars <- list(v1,
                        v2,
                        v3,
                        interaction(v1,v2),
                        interaction(v2,v3),
                        interaction(v1,v3),
                        interaction(v1,v2,v3))
    signs <- c(1,1,1,-1,-1,-1,1)

    for(i in 1:NROW(signs)){

        curclusvar <- clustervars[[i]]
        cursign <- signs[i]

        # calculate a finite-clusters inflation factor
        D <- NROW(unique(curclusvar))
        inflator <- D/(D-1)

        retvar <- retvar + cursign*inflator*robcov(fit, curclusvar)$var

    }

    return(retvar)
}