library(CHNOSZ)

calc_bdot <- function(T){
  # Calculate bdot parameter at a given temperature.

  # GB notes:
  # The equation used by dbcreate to approximate the curve in Fig 3
  # of Helgeson 1969 results in numbers that are close to, but not
  # exactly the same as those in data0.jus:

  # Bdot parameter grid:
  #  0.0376   0.0443   0.0505   0.0529   0.0479   0.0322   0.0000   0.0000  # from dbcreate
  #  0.0374   0.0430   0.0460   0.0470   0.0470   0.0340   0.0000   0.0000  # from data0.jus

  # Close but not exact! data0.jus is closer to what is depicted in Fig 3 of Helgeson 1969.
  # Not sure what other equation to use, though. Will keep the dbcreate equation for now.
  # TODO: look into alternative equations.

  b1 <-  0.0374
  b2 <-  1.3569e-4
  b3 <-  2.6411e-7
  b4 <- -4.6103e-9

  result <- b1 + b2*T + b3*(T-25.0)^2 + b4*(T-25.0)^3

  return(ifelse(T >= 300, 0, result))

}

fill_data0_head <- function(data0_template, db, grid_temps, grid_press, water_model){

  data0_template <- paste(data0_template, collapse="\n")

  # make sure the TP grid is in the correct form, esp. for single TP values
  grid_temps <- unlist(grid_temps)
  grid_press <- unlist(grid_press)
  grid_temps_original <- grid_temps
  if(length(grid_temps) == 1){
    grid_temps <- grid_temps + 0:7 # only the first T value is valid, but this is needed for EQ3
    grid_press <- rep(grid_press, 8)
  }

  # calculate debye huckel a and b parameters for the grid
  if(length(grid_temps_original) == 8){
    A_DH_grid <- unlist(water("A_DH", T=273.15+grid_temps, P=grid_press))
    B_DH_grid <- unlist(water("B_DH", T=273.15+grid_temps, P=grid_press)*10^-8)
  }else if(length(grid_temps_original) == 1){
    A_DH_grid <- unlist(water("A_DH", T=273.15+grid_temps[1], P=grid_press[1]))
    A_DH_grid <- c(A_DH_grid, rep(0, 7))
    B_DH_grid <- unlist(water("B_DH", T=273.15+grid_temps[1], P=grid_press[1])*10^-8)
    B_DH_grid <- c(B_DH_grid, rep(0, 7))
  }

  # format grid values
  grid_temps_f <- as.character(format(round(grid_temps, 4), nsmall = 4, scientific=F))
  grid_press_f <- as.character(format(round(grid_press, 4), nsmall = 4, scientific=F))
  A_DH_grid_f <- as.character(format(round(A_DH_grid, 4), nsmall = 4, scientific=F))
  B_DH_grid_f <- as.character(format(round(B_DH_grid, 4), nsmall = 4, scientific=F))

  # calculate bdot parameter
  if(length(grid_temps_original) == 1){
    bdot_grid_f <- c(as.character(format(round(calc_bdot(grid_temps[1]), 4), nsmall = 4, scientific=F)), rep("0.0000", 7))
  }else{
    bdot_grid_f <- as.character(format(round(calc_bdot(grid_temps), 4), nsmall = 4, scientific=F))
  }

  # cco2 (coefficients for the drummond (1981) polynomial)
  # GB note: might not change with T or P?
  # Examination of various data0 files seems to indicate that DBcreate does not change these values.

  # Calculate the "log k for eh reaction" grid.
  # From eq. 9 in EQPT (version 7.0) user manual, part 2, by Wolery:
  if(length(grid_temps_original) == 8){
    logK_Eh_vals <- subcrt(c("H2O", "O2", "e-", "H+"),
                           c(-2, 1, 4, 4),
                           c("liq", "gas", "aq", "aq"),
                           T=grid_temps,
                           P=round(grid_press, 9),
                           exceed.rhomin=TRUE,
                           exceed.Ttr=TRUE)$out$logK
  }else if(length(grid_temps_original) == 1){
    logK_Eh_vals <- subcrt(c("H2O", "O2", "e-", "H+"),
                           c(-2, 1, 4, 4),
                           c("liq", "gas", "aq", "aq"),
                           T=grid_temps[1],
                           P=round(grid_press[1], 9),
                           exceed.rhomin=TRUE,
                           exceed.Ttr=TRUE)$out$logK
    logK_Eh_vals <- c(logK_Eh_vals, rep(0, 7))
  }

  logk_grid_f <- as.character(format(round(logK_Eh_vals, 4), nsmall = 4))

  tempgrid <- c("     ")
  presgrid <- c("     ")
  A_DHgrid <- c("     ")
  B_DHgrid <- c("     ")
  bdotgrid <- c("     ")
  logkgrid <- c("     ")
  for(i in 1:8){
      if(i == 5){
          tempgrid <- c(tempgrid, "\n     ")
          presgrid <- c(presgrid, "\n     ")
          A_DHgrid <- c(A_DHgrid, "\n     ")
          B_DHgrid <- c(B_DHgrid, "\n     ")
          bdotgrid <- c(bdotgrid, "\n     ")
          logkgrid <- c(logkgrid, "\n     ")
      }
      tempgrid <- c(tempgrid, paste0(paste(rep(" ", 10-nchar(grid_temps_f[i])), collapse=""), grid_temps_f[i]))
      presgrid <- c(presgrid, paste0(paste(rep(" ", 10-nchar(grid_press_f[i])), collapse=""), grid_press_f[i]))
      A_DHgrid <- c(A_DHgrid, paste0(paste(rep(" ", 10-nchar(A_DH_grid_f[i])), collapse=""), A_DH_grid_f[i]))
      B_DHgrid <- c(B_DHgrid, paste0(paste(rep(" ", 10-nchar(B_DH_grid_f[i])), collapse=""), B_DH_grid_f[i]))
      bdotgrid <- c(bdotgrid, paste0(paste(rep(" ", 10-nchar(bdot_grid_f[i])), collapse=""), bdot_grid_f[i]))
      logkgrid <- c(logkgrid, paste0(paste(rep(" ", 10-nchar(logk_grid_f[i])), collapse=""), logk_grid_f[i]))

  }
  tempgrid <- paste(tempgrid, collapse="")
  presgrid <- paste(presgrid, collapse="")
  A_DHgrid <- paste(A_DHgrid, collapse="")
  B_DHgrid <- paste(B_DHgrid, collapse="")
  bdotgrid <- paste(bdotgrid, collapse="")
  logkgrid <- paste(logkgrid, collapse="")

  # insert minimum and maximum temperature values into data0 template
  temp_min_max_insertlines <- "\nTemperature limits \\(degC\\)\n.*\ntemperatures\n"
  t_min <- min(grid_temps)
  t_max <- max(grid_temps)
  t_min_f <- as.character(format(round(t_min, 4), nsmall = 4, scientific=F))
  t_max_f <- as.character(format(round(t_max, 4), nsmall = 4, scientific=F))
  t_min_max <- paste0(paste(rep(" ", 10-nchar(t_min_f)), collapse=""), t_min_f)
  t_min_max <- paste0(t_min_max, paste(rep(" ", 10-nchar(t_max_f)), collapse=""), t_max_f)
  t_min_max <- paste0("     ", t_min_max)
  data0_template <- sub(temp_min_max_insertlines, paste0("\nTemperature limits (degC)\n", t_min_max, "\ntemperatures\n"), data0_template)

  # insert temperature grid values into data0 template
  tempgrid_insertlines <- "\ntemperatures\n.*\npressures\n"
  data0_template <- sub(tempgrid_insertlines, paste0("\ntemperatures\n", tempgrid, "\npressures\n"), data0_template)

  # insert pressure grid values into data0 template
  presgrid_insertlines <- "\npressures\n.*\ndebye huckel a \\(adh\\)\n"
  data0_template <- sub(presgrid_insertlines, paste0("\npressures\n", presgrid, "\ndebye huckel a (adh)\n"), data0_template)

  # insert Debeye Huckel A and B parameter values into data0 template
  A_DHgrid_insertlines <- "\ndebye huckel a \\(adh\\)\n.*\ndebye huckel b \\(bdh\\)\n"
  data0_template <- sub(A_DHgrid_insertlines, paste0("\ndebye huckel a (adh)\n", A_DHgrid, "\ndebye huckel b (bdh)\n"), data0_template)
  B_DHgrid_insertlines <- "\ndebye huckel b \\(bdh\\)\n.*\nbdot\n"
  data0_template <- sub(B_DHgrid_insertlines, paste0("\ndebye huckel b (bdh)\n", B_DHgrid, "\nbdot\n"), data0_template)

  # insert bdot grid values into data0 template
  bdotgrid_insertlines <- "\nbdot\n.*\ncco2"
  data0_template <- sub(bdotgrid_insertlines, paste0("\nbdot\n", bdotgrid, "\ncco2"), data0_template)

  # insert logk (eh) grid values into data0 template
  logkgrid_insertlines <- "\nlog k for eh reaction\n.*\n\\+-+\nbdot parameters"
  logkgrid_end_insert <- "\n+--------------------------------------------------------------------\nbdot parameters"
  data0_template <- sub(logkgrid_insertlines, paste0("\nlog k for eh reaction\n", logkgrid, logkgrid_end_insert), data0_template)

  # modify the data0 header lines
  desc <- "data0.%s\nWater model: %s\nTP points: %s"
  min_desc <- "data0.min\nminimal working data0 file"
  data0_template <- sub(min_desc, sprintf(desc, db, water_model, length(grid_temps_original)), data0_template)

  return(data0_template) # returns a single string

}


# !#/bin/R
# Program: Calculates LIML regression with applied Bekker variances.
# Author: Nicholas Potter
# Date: 11/15/2011
#
# Using KLEIN data set (from http://econ413.wustl.edu/benchmarks/klein.xls,
# should give the following results:
# Var	Coef	Std Err	Bekker
# C	17.1477	2.04537	2.07396
# P	-.22251	.224230	.235078
# P(-1)	.396027	.192943	.202107
# W	.822559	.061549	.061756
###########
require(foreign)
data_raw = read.csv("/Users/potterzot/data/test/klein.csv")
data = data_raw[complete.cases(data_raw),]

Y = as.matrix(cbind(data$CX, data$C))
#Instrumented
X = matrix(Y[,2])
#Dependent variable
y = matrix(Y[,1])
#Instruments
Z = as.matrix(cbind(data$TM, data$W2, data$G, data$TX))
#Exogenous non-instrumented variables
W = as.matrix(cbind(1, data$P, data$W))

# Define our dimensions
N = nrow(X)
K = ncol(Z)
L = ncol(W)

# Weight vector
# weights = as.matrix(cbind(data$f_wt_totsvy))
weights = as.matrix(W[,1])
wt = diag(N) %*% weights
wt = as.matrix(diag(N))

#
I = diag(N)

Pw = W %*% solve(t(W) %*% wt %*% W) %*% t(W) %*% wt
Mw = I - Pw
# Regression of Y on W
Yp = Mw %*% Y
# Regression of Z on W
Zp = Mw %*% Z
# Regression of X on W
Xp = Mw %*% X
# Regression on Z_hat (by Yp in YMY)
Pz_bar = Zp %*% solve(t(Zp) %*% wt %*% Zp) %*% t(Zp) %*% wt
Mzp = I - Pz_bar
YY = t(Yp) %*% wt %*% Yp
YMY = t(Yp) %*% wt %*% Mzp %*% Yp
YPY = YY - YMY

# Omega from mroz with no constant should be [0, -42; -42, 569512]
Omega = YMY/(N-K-L)

A = YY / YMY
eigenvalues = eigen(A)
kliml = min(eigenvalues$val)
err = solve(t(Xp) %*% (I - kliml * Mzp) %*% Xp)
B0 = err %*% (t(Xp) %*% (I - kliml * Mzp) %*% Yp)
B1 = (YY[1,2] - kliml*YMY[1,2]) / (YY[2,2] - kliml*YMY[2,2])

# Bekker coefficients
ak = K/N
al = L/N
h1 = ak/(1-ak)
h2 = ak*(1-al)/(1-ak-al)

G = matrix(c(1, B1, 0, 1), 2,2)
Sigma = t(G) %*% solve(Omega) %*% G

#Lambda. mroz data with no constant should give us [0,-10.7; -10.7, 48216)
Lambda = t(G) %*% ((YPY/N)-ak*Omega) %*% G
Lambda2 = (t(Xp) %*% Pz_bar %*% Xp)/N - ak*Omega[2,2]
# Error variance - May or may not correctly account for exogenous variables
s2 = t(Yp[,1]-Xp*B1) %*% (Yp[,1]-Xp*B1)/(N-L)
J = N*(crossprod(Omega[1,2]) - Omega[2,2]*B1*Omega[1,2] - t(Omega[1,2])*t(B1)*Omega[2,2] + Omega[2,2]*B1*t(B1)*Omega[2,2])/(Omega[1,1] - 2*Omega[1,2]*B1 + t(B1)*Omega[2,2]*B1)
v_std = s2 * err
v_michal = Sigma[1,1]/Lambda[2,2] + h1*(det(Sigma)/Lambda[2,2]^2)
#v_imbens = v_std*(1+h1*(solve()*solve(Sigma)))
v_imbens2 = s2*crossprod(err,(t(Xp) %*% Pz_bar %*% Xp-(kliml-1) %*% J)) %*% err
v_robust = v_std

se_std = sqrt(v_std)
se_michal = sqrt(v_michal)
se_imbens = sqrt(v_imbens)
se_robust = sqrt(v_robust)


#' Calculate a zoom given a bounding box
#'
#' Calculate a zoom given a bounding box
#'
#' calc_zoom can calculate a zoom based on either (1) a data frame with longitude and latitude variables, (2) a longitude range and latitude range, or (3) a bounding box.  the specification for (1) is identical to that of most R functions, for (2) simply put in a longitude range into lon and a latitude range into lat, and for (3) put the bounding box in for the lon argument.
#'
#' @param lon longitude, see details
#' @param lat latitude, see details
#' @param data (optional) a data frame containing lon and lat as variables
#' @param adjust number to add to the calculated zoom
#' @param f argument to pass to make_bbox
#' @export
#' @seealso \code{\link{make_bbox}}
#' @examples
#' \dontrun{
#'
#' # data specification
#' calc_zoom(lon, lat, wind)
#'
#'
#' # range specification
#" lon_range <- extendrange( wind$lon )
#" lat_range <- extendrange( wind$lat )
#' calc_zoom(lon_range, lat_range)
#'
#'
#' # box specification
#' box <- make_bbox(lon, lat, data = crime)
#' calc_zoom(box)
#'
#' }
#'
calc_zoom <- function(lon, lat, data, adjust = 0, f = .05){

  if(!missing(adjust)) stopifnot(is.integer(adjust))

  # compute lon_range and lat_range for all specifications
  if(missing(data)){  # either ranges or a box

  	if(missing(lat)){ # a box
  	  bbox <- lon
  	  errorString <-
  	    "if specifying a bounding box, the format should match that of make_bbox."
  	  if(length(bbox) != 4) stop(errorString, call. = FALSE)
  	  if(!all(names(bbox) == c("left", "bottom", "right", "top")))
  	    stop(errorString, call. = FALSE)
      lon_range <- bbox[c("left", "right")]
      lat_range <- bbox[c("bottom", "top")]

  	} else { # ranges
  	  if(length(lon) != 2 || length(lat) != 2 || !is.numeric(lon) || !is.numeric(lat))
  	    stop("if specifying ranges, they both must be of length 2 and numeric.")

      lon_range <- sort(lon)
      lat_range <- sort(lat)
  	}

  } else { # data argument is specified
    lon <- data[,deparse(substitute(lon))]
    lat <- data[,deparse(substitute(lat))]
    bbox <- make_bbox(lon, lat, f = f)
    lon_range <- bbox[c("left", "right")]
    lat_range <- bbox[c("bottom", "top")]
  }

  lonlength <- diff(lon_range)
  latlength <- diff(lat_range)
  zoomlon <- ceiling(log2(360 * 2/lonlength))
  zoomlat <- ceiling(log2(180 * 2/latlength))
  zoom <- max(zoomlon, zoomlat)

  zoom + adjust
}


# calculate long-term observed temperature change by latitude
# using UDel, GISS, and ERSST 1900-2014
#  get UDel data at http://climate.geog.udel.edu/~climate/html_pages/Global2014/air_temp_2014.tar.gz (233MB file)
#  get ERSST data at https://www1.ncdc.noaa.gov/pub/data/cmb/ersst/v4/ascii/ (used a small bash loop)
#  get GISS https://data.giss.nasa.gov/gistemp/
# at 2x2° (aggregate UDel to 2x2, ERSST already there, GISS already there)

library(reshape2)

############################################################
# Read in UDel ascii files and average by 2x2° within years
############################################################

# find files
files <- list.files('data/udel/air_temp_2014')

# extract years
m <- regexpr('[[:digit:]]{4}', files)
years <- as.numeric(regmatches(files, m))

# extract the data and average to 2x2
tempsarray = array(data=NA, dim=c(90, 180, length(files))) # giant array stack of all temperature data (lat, lon, year)
	dimnames(tempsarray)[[1]] = seq(-89, 89, by=2)
	dimnames(tempsarray)[[2]] = seq(-179, 179, by=2)
	dimnames(tempsarray)[[3]] = years

tmpl <- expand.grid(lat=seq(-89, 89, by=2), lon=seq(-179, 179, by=2)) # template with all lats and lons

for(i in 1:length(files)){ # for each file
	print(files[i])
	x <- read.table(paste('data/udel/air_temp_2014/', files[i], sep=''), header=FALSE)
	names(x) <- c('lon', 'lat', 'jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec')

	# add 2x2 grid indicators
	x$longrid <- floor(x$lon/2)*2+1
	x$latgrid <- floor(x$lat/2)*2+1

	# average within years
	x$ave <- rowMeans(x[,c('jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec')])

	# average within 2x2 grids
	x2 <- aggregate(list(ave = x$ave), by=list(lat=x$latgrid, lon=x$longrid), FUN=mean)

	# add missing lat/lons
	x3 <- merge(tmpl, x2, all.x=TRUE)

	# reshape
	x4 <- melt(x3, id.vars=c('lat', 'lon'), measure.vars=c('ave'))
	x5 <- acast(x4, lat ~ lon) # easy with reshape2!

	# add to tempsarray
	tempsarray[,,i] = x5
}

	# quick look
	dim(tempsarray)
	summary(tempsarray)
	image(t(tempsarray[,,1])) # looks great!
	image(t(tempsarray[,,100])) # looks great!
	tempsarray['1','-61',110] # tropics
	tempsarray['-89','-99',110] # antarctic
	tempsarray['89','-99',110] # arctic: missing
	tempsarray['65','-121',110] # northern canada
		dimnames(tempsarray)[[3]][110] # 2009

	range(tempsarray['-89','-97',], na.rm=TRUE) # antarctic: always cold
	range(tempsarray['65','-121',], na.rm=TRUE) # northern canada
	range(tempsarray['1','-61',], na.rm=TRUE) # tropics: warm

# Write out
save(tempsarray, file=paste('data/udel/udel2x2ann_', years[1], '_', max(years), '.rdata', sep=''))

##############################################################
# Read in GISS netcdf files (already at 2x2) and calculate annual average
##############################################################
require(ncdf4)

# get data from 2x2 grid
	# read in
n = nc_open('data/gisstemp/gistemp250.nc') # Open the netCDF file
# print(n) # get information about the file format

inarray = ncvar_get(n, 'tempanomaly') # dim order: 180 lon x 90 lat x 1651 time (observations are monthly, time measured in days since Jan 1, 1800). 0 lon is at date line.
	# dim(inarray)
dimnames(inarray)[[1]] <- ncvar_get(n, 'lon')
dimnames(inarray)[[2]] <- ncvar_get(n, 'lat')
dimnames(inarray)[[3]] <- paste(rep(1880:2017, rep(12,138)), formatC(1:12, width=2, flag=0), sep='-')[1:dim(inarray)[3]]

nc_close(n)

	# annual average
	# reshape so month a separate dimension
temp <- melt(inarray, varnames=c('lon', 'lat', 'time'), value.name='lst')
temp$year <- as.numeric(substr(temp$time, 1, 4))
temp$mo <- as.numeric(substr(temp$time, 6, 7))
temp2 <- acast(temp[temp$year %in% 1900:2014,], lat ~ lon ~ year ~ mo, value.var='lst') # dim order: lat x lon x year x mo
years <- as.numeric(dimnames(temp2)[[3]])

	# average
tempsarray <- apply(temp2, MARGIN=c(1,2,3), FUN=mean)

	# Write out
save(tempsarray, file=paste('data/gisstemp/giss2x2ann_', years[1], '_', max(years), '.rdata', sep=''))

# get data from zonal average
n = nc_open('data/gisstemp/zonmap.nc')
print(n)
gisslat <- ncvar_get(n, 'temperature') # dim order: 1404 time (monthly 1900-2017) x 46 lat
colnames(gisslat) <- ncvar_get(n, 'lat')
rownames(gisslat) <- paste(rep(1900:2017, rep(12,118)), formatC(1:12, width=2, flag=0), sep='-')[1:nrow(gisslat)]

nc_close(n)

##############################################################
# Read in ERSST ascii files (already at 2x2)
##############################################################

# find files
files <- list.files('data/ersstv4/ersst_ascii/')

# extract years
m <- regexpr('[[:digit:]]{4}', files)
years <- as.numeric(regmatches(files, m))

# extract the data (lat/lons are grid centers)
tempsarray = array(data=NA, dim=c(89, 180, length(files))) # giant array stack of all temperature data (lat, lon, year).
	dimnames(tempsarray)[[1]] = seq(-88, 88, by=2)
	dimnames(tempsarray)[[2]] = seq(0, 358, by=2) # so grid extent is -1 to 359 (not 0 to 360)
	dimnames(tempsarray)[[3]] = years

for(i in 1:length(files)){ # for each file
	print(files[i])
	thisfile = paste('data/ersstv4/ersst_ascii/', files[i], sep='')
	x <- read.fwf(thisfile, widths=rep(6,89)) # library(readr) has a faster function
	x[x == -9999] = NA # mask out land
	x = x/100 # temperatures stored at degC * 100

	thisarray = array(data=NA, dim=c(89, 180, 12)) # array stack of temperature data (lat, lon, month).
	for(j in 1:12){ # for each month in this file
		theselines = (180*j-179):(180*j) # one month is 180 longitude lines
		thisarray[,,j] = t(as.matrix(x[theselines,]))
	}
	tempsarray[,,i] <- apply(thisarray, MARGIN=c(1,2), FUN=mean)
}

	# quick look
	dim(tempsarray)
	image(t(tempsarray[,,110]))
	tempsarray[45,90,110] # middle of the pacific
	tempsarray[1,90,110] # antarctic
	tempsarray[89,90,110] # arctic

# Write out
save(tempsarray, file=paste('data/ersstv4/ersst2x2ann_', years[1], '_', max(years), '.rdata', sep=''))

####################################
# Calculate warming global average
####################################
# read in data from earlier
load('data/udel/udel2x2ann_1900_2014.rdata') # tempsarray
	udel <- tempsarray
load('data/ersstv4/ersst2x2ann_1900_2014.rdata')
	ersst <- tempsarray

# read in GISS zonal average for comparison
giss <- read.csv('data/gisstemp/GLB.Ts.csv', skip=1, na.strings='***') #J.D has annual mean

# average, weighted by grid size
# see https://gis.stackexchange.com/questions/29734/how-to-calculate-area-of-1-x-1-degree-cells-in-a-raster
	# lst
f0 <- (as.numeric(dimnames(udel)[[1]])-1)*pi/180
f1 <- (as.numeric(dimnames(udel)[[1]])+1)*pi/180
l0 <- as.numeric(dimnames(udel)[[2]])[1]*pi/180 # all the same, so just use the first
l1 <- as.numeric(dimnames(udel)[[2]])[2]*pi/180
R <- 6371 # earth radius in km
wgt <- (sin(f1) - sin(f0)) * (l1 - l0) * R^2 # grid sizes in km for each latitudinal band
wgt <- matrix(wgt, byrow=FALSE, nrow=length(wgt), ncol=dim(udel)[2]) # matrix of weights

lstave <- apply(udel, MARGIN=3, FUN=weighted.mean, w=wgt, na.rm=TRUE)

	# sst
f0 <- (as.numeric(dimnames(ersst)[[1]])-1)*pi/180 # grid cell boundaries in radians
f1 <- (as.numeric(dimnames(ersst)[[1]])+1)*pi/180
l0 <- as.numeric(dimnames(ersst)[[2]])[1]*pi/180 # all the same, so just use the first
l1 <- as.numeric(dimnames(ersst)[[2]])[2]*pi/180
R <- 6371 # earth radius in km
wgt <- (sin(f1) - sin(f0)) * (l1 - l0) * R^2 # grid sizes in km for each latitudinal band
wgt <- matrix(wgt, byrow=FALSE, nrow=length(wgt), ncol=dim(ersst)[2]) # matrix of weights

sstave <- apply(ersst, MARGIN=3, FUN=weighted.mean, w=wgt, na.rm=TRUE)

# rates of warming (linear regression)
lstmod <- lm(I(lstave-lstclim) ~ as.numeric(names(lstave)))
sstmod <- lm(I(sstave-sstclim) ~ as.numeric(names(sstave)))
gissmod <- lm(J.D ~ Year, data=giss[giss$Year %in% 1901:2012,])

	# quick plot
	lstclim <- mean(lstave[as.numeric(names(lstave)) %in% 1961:1990]) # 1961-1990 climatology for plotting
	sstclim <- mean(sstave[as.numeric(names(sstave)) %in% 1961:1990]) # 1961-1990 climatology for plotting

	plot(as.numeric(names(lstave)), lstave-lstclim, type='l', ylim=c(-1,1), col='green')
	lines(as.numeric(names(sstave)), sstave-sstclim, col='blue')
	with(giss[giss$Year %in% 1900:2014,], lines(Year, J.D, col='dark green'))
	abline(h=0, lty=3)

	abline(lstmod, col='green', lty=2)
	abline(sstmod, col='blue', lty=2)
	abline(gissmod, col='dark green', lty=2)

# rates of warming (difference)
mean(lstave[as.numeric(names(lstave)) %in% 2005:2014]) - mean(lstave[as.numeric(names(lstave)) %in% 1900:1919])
mean(sstave[as.numeric(names(sstave)) %in% 2005:2014]) - mean(sstave[as.numeric(names(sstave)) %in% 1900:1919])

####################################
# Calculate warming by latitude
####################################
# read in annual gridded data from earlier
load('data/udel/udel2x2ann_1900_2014.rdata') # tempsarray
	udel <- tempsarray
load('data/ersstv4/ersst2x2ann_1900_2014.rdata')
	ersst <- tempsarray
load('data/gisstemp/giss2x2ann_1900_2014.rdata')
	giss <- tempsarray

# read in GISS lat averages (monthly)
n = nc_open('data/gisstemp/zonmap.nc')
gisslat <- ncvar_get(n, 'temperature') # dim order: 1404 time (monthly 1900-2017) x 46 lat
colnames(gisslat) <- ncvar_get(n, 'lat')
rownames(gisslat) <- paste(rep(1900:2017, rep(12,118)), formatC(1:12, width=2, flag=0), sep='-')[1:nrow(gisslat)]

# latitudinal average warming (1995-2014 minus 1900-1919)
	# UDel lst
udelwarm <- apply(udel[,,96:115], MARGIN=c(1,2), FUN=mean) - apply(udel[,,1:20], MARGIN=c(1,2), FUN=mean) # warming by grid cell
udelwarmave <- rowMeans(udelwarm, na.rm=TRUE) # mean across grid cells in a lat band
udelwarmsd <- apply(udelwarm, MARGIN=1, FUN=sd, na.rm=TRUE) # SD across grid cells in a lat band
udlats <- as.numeric(names(udelwarmave)) # extract latitudes

	# ERSST sst
ersstwarm <- apply(ersst[,,96:115], MARGIN=c(1,2), FUN=mean) - apply(ersst[,,1:20], MARGIN=c(1,2), FUN=mean)
ersstwarmave <- rowMeans(ersstwarm, na.rm=TRUE)
ersstwarmsd <- apply(ersstwarm, MARGIN=1, FUN=sd, na.rm=TRUE)
erlats <- as.numeric(names(ersstwarmave))

	# GISS
gisswarm <- apply(giss[,,96:115], MARGIN=c(1,2), FUN=mean, na.rm=TRUE) - apply(giss[,,1:20], MARGIN=c(1,2), FUN=mean, na.rm=TRUE)
gisswarmave <- rowMeans(gisswarm, na.rm=TRUE)
gisswarmsd <- apply(gisswarm, MARGIN=1, FUN=sd, na.rm=TRUE)
gslats <- as.numeric(names(gisswarmave))

	# GISS zonal average lst (no SD possible from zonal average)
gisszonewarmave <- apply(gisslat[1141:1380,], MARGIN=2, FUN=mean) - apply(gisslat[1:240,], MARGIN=2, FUN=mean) # warming by lat band
gszonelats <- as.numeric(names(gisszonewarmave))

# write out
write.csv(data.frame(lat=udlats, warm=udelwarmave, sd=udelwarmsd), file='temp/lstwarmlat.csv', row.names=FALSE)
write.csv(data.frame(lat=gslats, warm=gisswarmave, sd=gisswarmsd), file='temp/lstwarmlat_giss.csv', row.names=FALSE)
write.csv(data.frame(lat=gszonelats, warm=gisszonewarmave), file='temp/lstwarmlat_gisszone.csv', row.names=FALSE)
write.csv(data.frame(lat=erlats, warm=ersstwarmave, sd=ersstwarmsd), file='temp/sstwarmlat.csv', row.names=FALSE)

###########################
# plots
###########################
lstwarmlat <- read.csv('temp/lstwarmlat.csv')
sstwarmlat <- read.csv('temp/sstwarmlat.csv')
lstwarmlatgiss <- read.csv('temp/lstwarmlat_giss.csv')
lstwarmlatgisszone <- read.csv('temp/lstwarmlat_gisszone.csv')

# warming (1995-2014 minus 1900-1919) by latitude
	cols <- c('#b2df8a', '#1f78b4', '#222222') # land, ocean, GISS
	cols2 <- c('#b2df8a55', '#1f78b455', '#22222255') # land, ocean partially transparent
	lw <- 2 # line width

	i.1 <- complete.cases(lstwarmlat) & lstwarmlat$lat < -66.25 # for polygon plotting
	i.2 <- complete.cases(lstwarmlat) & lstwarmlat$lat > -52.75 # for polygon plotting
	i2.1 <- complete.cases(lstwarmlatgiss) & lstwarmlatgiss$lat < -66.25 # for polygon plotting
	i2.2 <- complete.cases(lstwarmlatgiss) & lstwarmlatgiss$lat > -52.75 # for polygon plotting
	i3 <- complete.cases(sstwarmlat)

	quartz(w=4,h=4)
	plot(0, 0, xlab='Latitude (°N)', ylab='Historical warming (°C)', ylim=c(-1.5,3.5), xlim=c(-90,90), type='n') # just to set it up
	with(lstwarmlat[i.1,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[1], border=NA))
	with(lstwarmlat[i.2,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[1], border=NA))
	with(lstwarmlatgiss[i2.1,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[3], border=NA))
	with(lstwarmlatgiss[i2.2,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[3], border=NA))
	with(sstwarmlat[i3,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[2], border=NA))
	with(lstwarmlat, lines(lat, warm, col=cols[1], lwd=lw))
	with(lstwarmlatgiss, lines(lat, warm, col=cols[3], lwd=lw))
	with(sstwarmlat, lines(lat, warm, col=cols[2], lwd=lw))

	with(lstwarmlatgisszone, lines(lat, warm, col='black', lwd=1, lty=2))


# two way ANOVA

# R assumes data files are in row-column format
# ratweight2.txt is in that format

rat <- read.table('ratweight2.txt',header=T, as.is=T)

# I prefer to read columns as is and explicitly convert
#  those I want to factors.  That avoids much confusion
#  when a column of numbers is to be considered a factor.
# others are very comfortable with the default behaviour

# the reshape package provides a way to transpose and reshape
#  data.  I still find it easier to manipulate data in SAS
#  because you have access to a data programming language

# convert amount and type to factors
rat$amount.f <- as.factor(rat$amount)
rat$type.f <- as.factor(rat$type)

rat.lm <- lm(gain~amount.f + type.f + amount.f:type.f, data=rat)

# the : indicates the interaction between two factors

# the * indicates all main effects and interactions

rat.lm2 <- lm(gain~amount.f*type.f, data=rat)

# fits exactly the same model.

# print out the anova table
anova(rat.lm)

# aov() is a wrapper to lm() that adds useful info for ANOVA models

rat.aov <- aov(gain~amount.f + type.f + amount.f:type.f, data=rat)

# you can get the anova table
summary(rat.aov)  # or anova(rat.aov)

# R's facilities for 'beyond the ANOVA table' are limited

# you can get tables of marginal means and their se's

model.tables(rat.aov, se=T, type='means')
# model.tables does not work for lm() results

# and differences among pairs and adjusted p-values
#  using Tukey's HSD

TukeyHSD(rat.aov)

# se.contrast() provides a way to get the se of a contrast
# but it doesn't give you the estimate of that contrast!!
# you have to compute that by hand????
# If someone knows something to the contrary, please let me know

# I don't know any equivalent of the SAS 'slice'.

# more importantly, and hence, NOTE and HUGE warning:
#  All the R functions work best (sometimes only work)
#   when  the data is balanced!!!!

# when the data is unbalanced, R's built-in functions
#   don't work well

# R reports type I (sequential) SS.
# You can get type III SS by specifically requesting
#  an orthogonal set of contrasts (e.g. contr.helmert,
#  see contrasts for how to change the contrast),
#  then using drop1()

# model.tables() reports some sort of marginal mean,
#  but it is not the average of cell means

# model.tables() is completely misleading
#   if you are missing a cell in a factorial design,
#  the marginal means are not estimable, but
#    model.tables() still reports something!!

# TukeyHSD() has the same problem
#  Worse, it doesn't even give you a warning that the
#    design is unbalanced.

# My sense is that you can get R to provide valid answers to questions,
#  but you have to work at it and you have to know a lot of details
#    (e.g. choice of constrast matrices)
#  Who would know that you have to reset the default contrasts
#    to get valid type III tests?
#  This is especially true if you want answers that go beyond the ANOVA
#   table.  You have to work very hard to get those sorts of answers
#   from R.  SAS makes everything much easier.

# If anyone has information to the contrary,
#  especially for unbalanced data, please let me know.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/ratweight.r


#' Continuous Boyce Index (CBI) with weighting
#'
#' This function calculates the Continuous Boyce Index (CBI), a measure of model accuracy for presence-only test data.
#' @param pres Numeric vector. Predicted values at presence sites.
#' @param contrast Numeric vector. Predicted values at absence/background sites.
#' @param numBins Positive integer. Number of (overlapping) bins into which to divide predictions.
#' @param binWidth Positive numeric. Size of a bin. Each bin will be \code{binWidth * (max - min)} where \code{max} and \code{min}. If \code{autoWindow} is \code{FALSE} (the default) then \code{min} is 0 and \code{max} is 1. If \code{autoWindow} is \code{TRUE} then \code{min} and \code{max} are the maximum and minimum value of all predictions in the background and presence sets (i.e., not necessarily 0 and 1).
#' @param presWeight Numeric vector same length as \code{pres}. Relative weights of presence sites. The default is to assign each presence a weight of 1.
#' @param contrastWeight Numeric vector same length as \code{contrast}. Relative weights of background sites. The default is to assign each presence a weight of 1.
#' @param autoWindow Logical. If \code{FALSE} calculate bin boundaries starting at 0 and ending at 1 + epsilon (where epsilon is a very small number to assure inclusion of cases that equal 1 exactly). If \code{TRUE} (default) then calculate bin boundaries starting at minimum predicted value and ending at maximum predicted value.
#' @param method Character. Type of correlation to calculate. The default is \code{'spearman'}, the Spearman rank correlation coefficient used by Boyce et al. (2002) and Hirzel et al. (2006), which is the traditional CBI. In contrast, \code{'pearson'} or \code{'kendall'} can be used instead.  See [stats::cor()] for more details.
#' @param dropZeros Logical. If TRUE then drop all bins in which the frequency of presences is 0.
#' @param graph Logical. If TRUE then plot P vs E and P/E versus bin.
#' @param na.rm Logical. If \code{TRUE} then remove any presences and associated weights and background predictions and associated weights with \code{NA}s.
#' @param bg Same as \code{contrast}. Included for backwards compatibility. Ignored if \code{contrast} is not \code{NULL}.
#' @param bgWeight Same as \code{contrastWeight}. Included for backwards compatibility. Ignored if \code{contrastWeight} is not \code{NULL}.
#' @param ... Other arguments (not used).
#' @return Numeric value.
#' @details CBI is the Spearman rank correlation coefficient between the proportion of sites in each prediction class and the expected proportion of predictions in each prediction class based on the proportion of the landscape that is in that class. Values >0 indicate the model's output is positively correlated with the true probability of presence.  Values <0 indicate it is negatively correlated with the true probability of presence.
#' @references Boyce, M.S., Vernier, P.R., Nielsen, S.E., and Schmiegelow, F.K.A.  2002.  Evaluating resource selection functions.  \emph{Ecological Modeling} 157:281-300)
#' @references Hirzel, A.H., Le Lay, G., Helfer, V., Randon, C., and Guisan, A.  2006.  Evaluating the ability of habitat suitability models to predict species presences.  \emph{Ecological Modeling} 199:142-152.
#' @seealso \code{\link[stats]{cor}}, \code{\link{fpb}}, \code{\link{aucWeighted}}, \code{link[enmSdm]{contBoyce2x}}
#' @examples
#' set.seed(123)
#' pres <- sqrt(runif(100))
#' contrast <- runif(1000)
#' contBoyce(pres, contrast)
#' contBoyce2x(pres, contrast)
#' presWeight <- c(rep(1, 10), rep(0.5, 90))
#' contBoyce(pres, contrast, presWeight=presWeight)
#' contBoyce2x(pres, contrast, presWeight=presWeight)
#' \donttest{
#' # compare stability of CBI calculated with ecospat.boyce() in ecospat package
#' library(ecospat)
#' set.seed(123)
#' results <- data.frame()
#' for (perform in c(1, 1.5, 2)) {
#' 	for (i in 1:30) {
#'
#'    pres <- runif(100)^(1 / perform)
#'    contrast <- runif(1000)
#'
#'    cbi_enmSdm <- contBoyce(pres, contrast)
#'    cbi_ecospat <- ecospat.boyce(contrast, pres, PEplot=FALSE)$Spearman.cor
#'
#'    results <- rbind(
#'      results,
#'      data.frame(
#'        performance = rep(perform, 2),
#'        method = c('enmSdm', 'ecospat'),
#'        cbi = c(cbi_enmSdm, cbi_ecospat)
#'      )
#'    )
#'
#' 	}
#'
#' }
#'
#' results$performance[results$performance == 1] <- 'poor'
#' results$performance[results$performance == 1.5] <- 'OK'
#' results$performance[results$performance == 2] <- 'good'
#'
#' results$category <- paste0(results$method, '\n', results$performance)
#'
#' par(mfrow=c(1, 2))
#' boxplot(cbi ~ category,
#' 	data=results,
#' 	ylab='CBI',
#' 	main='CBI of poor, OK, and good models',
#' 	border=c(rep('darkred', 3),
#' 	rep('darkblue', 3))
#' )
#' plot(results$cbi,
#' 	pch=rep(c(21, 22, 23, 24), each=2),
#' 	contrast=ifelse(results$method == 'ecospat', 'darkred', 'cornflowerblue'),
#' 	main='Pairs of CBIs',
#' 	ylab='CBI'
#' )
#' legend('bottomright', fill=c('darkred', 'cornflowerblue'), legend=c('ecospat', 'enmSdm'))
#' }
#' @export

contBoyce <- function(
  pres,
  contrast,
  numBins = 101,
  binWidth = 0.1,
  presWeight = rep(1, length(pres)),
  contrastWeight = rep(1, length(contrast)),
  autoWindow = TRUE,
  method = 'spearman',
  dropZeros = TRUE,
  graph = FALSE,
  na.rm = FALSE,
  bg = NULL,
  bgWeight = NULL,
  ...
) {

  if (missing(contrast) & !is.null(bg)) contrast <- bg
  if (missing(contrastWeight) & !is.null(bgWeight)) contrastWeight <- bgWeight

  # if all NAs
  if (all(is.na(pres)) | all(is.na(contrast)) | all(is.na(presWeight)) | all(is.na(contrastWeight))) return(NA)

  # catch errors
  if (length(presWeight) != length(pres)) stop('You must have the same number of presence predictions and presence weights ("pres" and "presWeight").')
  if (length(contrastWeight) != length(contrast)) stop('You must have the same number of absence/background predictions and absence/background weights ("contrast" and "contrastWeight").')

  # # remove NAs
  # if (na.rm) {

  # cleanedPres <- omnibus::naOmitMulti(pres, presWeight)
  # pres <- cleanedPres[[1]]
  # presWeight <- cleanedPres[[2]]

  # cleanedContrast <- omnibus::naOmitMulti(contrast, contrastWeight)
  # contrast <- cleanedContrast[[1]]
  # contrastWeight <- cleanedContrast[[2]]

  # }

  # right hand side of each class (assumes max value is >0)
  lowest <- if (autoWindow) { min(c(pres, contrast), na.rm=na.rm) } else { 0 }
  highest <- if (autoWindow) { max(c(pres, contrast), na.rm=na.rm) + omnibus::eps() } else { 1 + omnibus::eps() }

  windowWidth <- binWidth * (highest - lowest)

  lows <- seq(lowest, highest - windowWidth, length.out=numBins)
  highs <- seq(lowest + windowWidth + omnibus::eps(), highest, length.out=numBins)

  ##########
  ## MAIN ##
  ##########

  ## initiate variables to store predicted/expected (P/E) values
  freqPres <- freqContrast <- rep(NA, length(numBins))

  ### tally proportion of test presences/background sites in each class
  for (countClass in 1:numBins) {

    # number of presence predictions in this class
    presInBin <- pres >= lows[countClass] & pres < highs[countClass]
    presInBin <- presInBin * presWeight
    freqPres[countClass] <- sum(presInBin, na.rm=na.rm)

    # number of background predictions in this class
    bgInBin <- contrast >= lows[countClass] & contrast < highs[countClass]
    bgInBin <- bgInBin * contrastWeight
    freqContrast[countClass] <- sum(bgInBin, na.rm=na.rm)

  } # next predicted value class

  # mean bin prediction
  meanPred <- rowMeans(cbind(lows, highs))

  # add small number to each bin that has 0 background frequency but does have a presence frequency > 0
  if (any(freqPres > 0 & freqContrast == 0)) {
    smallValue <- min(0.5 * c(presWeight[presWeight > 0], contrastWeight[contrastWeight > 0]))
    freqContrast[freqPres > 0 & freqContrast == 0] <- smallValue
  }

  # remove classes with 0 presence frequency
  if (dropZeros && 0 %in% freqPres) {
    zeros <- which(freqPres == 0)
    meanPred[zeros] <- NA
    freqPres[zeros] <- NA
    freqContrast[zeros] <- NA
  }

  # remove classes with 0 background frequency
  if (any(0 %in% freqContrast)) {
    zeros <- which(freqContrast == 0)
    meanPred[zeros] <- NA
    freqPres[zeros] <- NA
    freqContrast[zeros] <- NA
  }

  P <- freqPres / sum(presWeight, na.rm=TRUE)
  E <- freqContrast / sum(contrastWeight, na.rm=TRUE)
  PE <- P / E

  # plot
  if (graph) {
    par(mfrow=c(1, 2))
    lims <- c(0, max(P, E, na.rm=TRUE))
    plot(E, P, col='white', xlab='Expected', ylab='Predicted', main='P/E\nNumbered from lowest to highest class', xlim=lims, ylim=lims)
    text(E, P, labels=1:numBins, col=1:20)
    plot(meanPred, PE, type='l', xlab='Mean Prediction in Bin', ylab='P/E Ratio', main='CBI\nNumbered from lowest to highest class')
    text(meanPred, PE, labels=1:numBins, col='blue')
  }

  # remove NAs
  out <- omnibus::naOmitMulti(meanPred, PE)
  meanPred <- out[[1]]
  PE <- out[[2]]

  # calculate continuous Boyce index (cbi)
  cbi <- stats::cor(x=meanPred, y=PE, method=method)
  cbi

}


#' MLE for the Zero-truncated Poisson Lognormal mixture distribtuion
#'
#' `ztplnmMLE` fits the Zero-truncated Poisson lognormal mixture distribution
#' to data and estimates parameters mean `mu`, standard deviation `sig` and
#' mixture weight `theta` in the lognormal distribution.
#'
#' The function searches the maximum likelihood estimators of mean vector `mu`,
#' standard deviation vector `sig` and mixture weight vector `theta` using the
#' optimization procedures in \code{\link{nlminb}}.
#'
#' @param n a vector of counts
#' @param K number of components
#' @param lower_mu,upper_mu numeric values of lower and upper bounds for mean of
#' the variables's natural logarithm.
#' @param lower_sig,upper_sig numeric values of lower and upper bounds for
#' standard deviation of the variables's natural logarithm
#' @param lower_theta,upper_theta numeric values of lower and upper bounds for
#'  mixture weights.
#' @param type1 logical; if TRUE, Use type 1 ztpln else use type 2.
#' @param message mean of lognormal distribution in sample 3.
#' @return \item{convergence}{An integer code. 0 indicates successful
#' convergence.}
#' @return \item{iterations}{Number of iterations performed.}
#' @return \item{message}{A character string giving any additional information
#' returned by the optimizer, or NULL. For details, see PORT documentation.}
#' @return \item{evaluation}{Number of objective function and gradient function
#'  evaluations}
#' @return \item{mu}{Maximum likelihood estimates of mu}
#' @return \item{sig}{Maximum likelihood estimates of sig}
#' @return \item{theta}{Maximum likelihood estimates of theta}
#' @return \item{loglik}{loglikelihood}
#' @examples
#' y <- rztplnm(100, c(1, 10), c(2, 1), c(0.2, 0.8))
#' ztplnmMLE(y)
#' @export
ztplnmMLE <- function(n,
                      K = 2,
                      lower_mu = rep(0, K),
                      upper_mu = rep(log(max(n)), K),
                      lower_sig = rep(0.001, K),
                      upper_sig = rep(10, K),
                      lower_theta = rep(0.001, K),
                      upper_theta = rep(0.999, K),
                      type1 = TRUE,
                      message = FALSE) {

  if (K == 1) {warning("`ztplnMLE` is faster for K = 1")}

  n <- n[n > 0]
  max_abund <- log(max(n))

  if (message) {
    sink("/dev/null")  # now suppresses
    fit0 <- try(mixtools::normalmixEM(log(n), k = K, maxrestart = 20))
    sink()
  } else {
    fit0 <- try(mixtools::normalmixEM(log(n), k = K, maxrestart = 20))
  }

  # set initial values using normalmixEM for better convergence
  if (class(fit0) == "try-error") {
    params <- c(rep(1, 2 * K), rep(1 / K, K))
  } else {
    params <- c(fit0$mu, fit0$sig, fit0$lambda)
  }

  loglik <- function(params, n) {
    mu <- params[1:K]
    sig <- params[(K + 1):(2 * K)]
    theta <- params[(2 * K + 1):(3 * K)]
    theta <- theta / sum(theta)
    if (type1) {
      lik <- do_dztplnm(n, mu, sig, theta)
    } else lik <- do_dztplnm2(n, mu, sig, theta)
    return(-sum(log(lik), na.rm = TRUE))
  }

  fit <- try(nlminb(start = params, # inital parameters
                    loglik, # function to be minimized (i.e., -logLike)
                    gradient = NULL,
                    lower = c(lower_mu, lower_sig, lower_theta),
                    upper = c(upper_mu, upper_sig, upper_theta),
                    n = n,
                    TRUE))

  fit$mu <- fit$par[1:K]
  fit$sig <- fit$par[(K + 1):(2 * K)]
  theta <- fit$par[(2 * K + 1):(3 * K)]
  fit$theta <- theta / sum(theta)
  fit$par <- NULL
  fit$loglik <- -fit$objective
  fit$objective <- NULL
  return(fit)
}


subroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror)

# The segment k1->k2 is a diagonal of a quadrilateral
# with a vertex at j (the point being added to the
# triangulation).  If the LOP is not satisfied, swap
# it for the other diagonal.
# Called by addpt.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
logical shdswp

# If vertices k1 and k2 are not connected there is no diagonal to swap.
# This could happen if vertices j, k1, and k2 were colinear, but shouldn't.
call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror)
if(nerror > 0) return
if(!shdswp) return

# Get the other vertex of the quadrilateral.
call pred(k,k1,k2,nadj,madj,ntot,nerror) # If these aren't the same, then
if(nerror > 0) return
call succ(kk,k2,k1,nadj,madj,ntot,nerror) # there is no other vertex.
if(nerror > 0) return
if(kk!=k) {
        shdswp = .false.
        return
}

# Check whether the LOP is satisified; i.e. whether
# vertex k is outside the circumcircle of vertices j, k1, and k2
call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror)
if(nerror > 0) return

# Do the actual swapping.
if(shdswp) {
        call delet(k1,k2,nadj,madj,ntot,nerror)
	if(nerror > 0) return
	call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps)
	if(nerror > 0) return
}
return
end


library(bivpois) # loading of bivpois library
data(ex4.ita91)  # loading ex4.ita91 data from bivpois library
#
# formula for modeling of lambda1 and lambda2
form1 <- ~c(team1,team2)+c(team2,team1)
xtemp<-readline(prompt = "Press Enter to Continue")
#
# Model 1: Double Poisson
ex4.m1<-lm.bp( g1~1, g2~1, l1l2=form1, zeroL3=TRUE, data=ex4.ita91)
#
# Models 2-5: bivariate Poisson models
ex4.m2<-lm.bp(g1~1,g2~1, l1l2=form1, data=ex4.ita91)
ex4.m3<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team1, data=ex4.ita91)
ex4.m4<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team2, data=ex4.ita91)
ex4.m5<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team1+team2, data=ex4.ita91)
#
# Model 6: Zero Inflated Model
ex4.m6 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=0)
#
# Models 7-11: Diagonal Inflated Bivariate Poisson Models
ex4.m7 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, distribution='geometric' )
ex4.m8 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=1)
ex4.m9 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=2)
ex4.m10<-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=3)
ex4.m11<-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, distribution='poisson' )
#
# Models 12: Diagonal Inflated Double Poisson Model
ex4.m12 <- lm.dibp( g1~1,g2~1, l1l2=form1, data=ex4.ita91, distribution='poisson', zeroL3=TRUE )
# --------------------------------------------------------------------------

#
# --------------------------------------------------------------------------
# monitoring parameters for model 1: Dbl Poisson
ex4.m1$coef		# all parameters
ex4.m1$beta1		# model parameters for lambda1
ex4.m1$beta2		# model parameters for lambda2.
			# All are the same as in beta1 except the intercept
ex4.m1$beta2[1]		# Intercpept for lambda2.
ex4.m1$beta2[1]-ex4.m1$beta2[2]	# estimated home effect

-sum(ex4.m1$coef[ 2:18]) # estimating the effect for 18th level of attack (team1..team2) [Verona]
-sum(ex4.m1$coef[19:35]) # estimating the effect for 18th level of defence(team2..team1) [Verona]
xtemp<-readline(prompt = "Press Enter to Continue")
#
# --------------------------------------------------------------------------
# monitoring parameters for model 2: Biv Poisson (lamdba1, lambda2, constant lamdba3)
#
#
# monitoring parameters for model 1: Dbl Poisson
ex4.m2$beta1		# model parameters for lambda1
ex4.m2$beta2		# model parameters for lambda2.
			# All are the same as in beta1 except the intercept
ex4.m2$beta3		# model parameters for lambda3. Here beta3 has only the intercept
ex4.m2$beta2[1]		# Intercpept for lambda2.
ex4.m2$beta2[1]-ex4.m2$beta2[2]	# estimated home effect

-sum(ex4.m2$coef[ 2:18]) # estimating the effect for 18th level of attack (team1..team2) [Verona]
-sum(ex4.m2$coef[19:35]) # estimating the effect for 18th level of defence(team2..team1) [Verona]
xtemp<-readline(prompt = "Press Enter to Continue")
#
# --------------------------------------------------------------------------

# --------------------------------------------------------------------------
# monitoring parameters for model 8: Biv Poisson with Dis(1) diagonal distribution
#
#
# monitoring parameters for model 1: Dbl Poisson
ex4.m8$beta1		# model parameters for lambda1
ex4.m8$beta2		# model parameters for lambda2.
			# All are the same as in beta1 except the intercept
ex4.m8$beta3		# model parameters for lambda3. Here beta3 has only the intercept
ex4.m8$beta2[1]		# Intercpept for lambda2.
ex4.m8$beta2[1]-ex4.m8$beta2[2]	# estimated home effect

-sum(ex4.m8$coef[ 2:18]) # estimating the effect for 18th level of attack (team1..team2) [Verona]
-sum(ex4.m8$coef[19:35]) # estimating the effect for 18th level of defence(team2..team1) [Verona]

ex4.m8$beta3		 # parameters for lambda3 (here the intercept)
exp(ex4.m8$beta3)	 # lambda3 (here constant)
ex4.m8$diagonal.distribution # printing details for the diagonal distribution
ex4.m8$p		 # mixing proportion
ex4.m8$theta		 # printing theta parameters
xtemp<-readline(prompt = "Press Enter to Continue")
#
# --------------------------------------------------------------------------

# --------------------------------------------------------------------------
# monitoring parameters for model 8: Biv Poisson with Dis(1) diagonal distribution
#
#
ex4.m8$diagonal.distribution            # printing details for the diagonal distribution
round(ex4.m8$beta1,2)		        # model parameters for lambda1
round(ex4.m8$beta2[1],2)		# Intercpept for lambda2.
round(ex4.m8$beta2[1]-ex4.m8$beta2[2],2)# estimated home effect
#
# estimating the effect for 18th level of attack (team1..team2) [Verona]
round(-sum(ex4.m8$coef[ 2:18]),2)
# estimating the effect for 18th level of defence(team2..team1) [Verona]
round(-sum(ex4.m8$coef[19:35]),2)
#
ex4.m8$beta3		 # parameters for lambda3 (here the intercept)
exp(ex4.m8$beta3)	 # lambda3 (here constant)
ex4.m8$p		 # mixing proportion
ex4.m8$theta		 # printing theta parameters
#
# --------------------------------------------------------------------------


##' Calculate risk ratios for mass testing in Slovakia
##'
##' @return alist of two lists: "figures" (containing Fig. 2a and 2b in the manuscript) and "tables" (containing the total prevalence risk ratios in pilot regions ("pilot") and those regions that had two rounds of testing ("nation")
##' @importFrom dplyr filter rowwise mutate select
##' @importFrom tidyr pivot_longer separate pivot_wider
##' @importFrom ggplot2 ggplot aes geom_errorbar geom_point xlab scale_color_brewer scale_y_continuous position_dodge coord_flip theme_classic theme ylab geom_hline scale_color_manual scale_x_discrete
##' @importFrom scales percent
##' @importFrom epitools epitab
##' @export
risk_ratios <- function() {
  ret_fig <- list()
  ret_rr <- list()

  ms.tst %>%
    filter(pilot == T) %>%
    rowwise() %>%
    mutate(pRR_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("upper")],
           pRR_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")],
           pRR_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(county, pRR_12, pRR.lo_12, pRR.hi_12, pRR_23, pRR.lo_23, pRR.hi_23, pRR_13, pRR.lo_13, pRR.hi_13) -> pRR_pilot

  ret_fig[["b"]] <- pRR_pilot %>%
    pivot_longer(c(-county)) %>%
    separate(name, c("name", "round"), "_") %>%
    pivot_wider(names_from = name, values_from = value) %>%
    ggplot(aes(x=county, y=1-pRR, ymin=1-pRR.lo, ymax=1-pRR.hi, color = round)) +
    geom_errorbar(width = 0.0, position = position_dodge(width = 0.3)) +
    geom_point(position = position_dodge(width = 0.3)) +
    xlab("\n\n\n\n") + ylab("Reduction in prevalence\n(1 - prevalence risk ratio)") +
    scale_color_brewer(palette = "Dark2",
                       name = "Comparisons",
                       labels = c("pilot vs round 1", "pilot vs round 2", "round 1 vs 2")) +
    scale_y_continuous(labels = scales::percent,
                       breaks = c(0,.25,.5,.75,1),
                       limits = c(0,1)) +
    coord_flip() +
    theme_classic() +
    theme(legend.position = c(.15,.7))

  ## pilot prevalence RR overall
  ms.tst %>%
    filter(pilot == T) %>%
    select(attendance_1, attendance_2, attendance_3, positive_1, positive_2, positive_3) %>%
    summarise_all(sum) %>%
    mutate(pRR_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("upper")],
           pRR_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")],
           pRR_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(pRR_12, pRR.lo_12, pRR.hi_12, pRR_23, pRR.lo_23, pRR.hi_23, pRR_13, pRR.lo_13, pRR.hi_13) -> pRR_pilot_sum
  ret_rr[["pilot"]] <- 1-pRR_pilot_sum %>% round(2)

  ## mass test prevalence RR by county
  ms.tst %>%
    filter(!is.na(positive_2) & !is.na(positive_3) & !is.na(attendance_2) & !is.na(attendance_3)) %>%
    rowwise() %>%
    mutate(pRR = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(county, region, pRR, pRR.lo, pRR.hi) -> pRR_mass
  ret_rr[["county"]] <- pRR_mass

  ms.tst %>%
    filter(!is.na(positive_2) & !is.na(positive_3) & !is.na(attendance_2) & !is.na(attendance_3)) %>%
    select(positive_2, attendance_2, positive_3, attendance_3) %>%
    summarise_all(sum) %>%
    mutate(pRR = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(pRR, pRR.lo, pRR.hi) %>%
    mutate(county = "Overall")-> pRR_mass_sum
  ret_rr[["all"]] <- 1-(pRR_mass_sum %>% select(-county)) %>% round(2)

  ret_fig[["a"]] <- pRR_mass %>%
    ggplot(aes(x=interaction(region,county,lex.order = T), y=1-pRR, ymin=1-pRR.lo, ymax=1-pRR.hi, color = region)) +
    geom_hline(yintercept = 1-pRR_mass_sum$pRR, alpha=.7, color="red") +
    geom_hline(yintercept = 1-pRR_mass_sum$pRR.lo, alpha=.5, color="red", lty="dotted") +
    geom_hline(yintercept = 1-pRR_mass_sum$pRR.hi, alpha=.5, color="red", lty="dotted") +
    geom_errorbar(width = 0.0) +
    geom_point() +
    xlab("") + ylab("Reduction in prevalence between mass testing rounds\n(1 - prevalence risk ratio)") +
    scale_color_manual(values = c("#636363","#3182bd","#969696","#6baed6","#bdbdbd","#9ecae1","#d9d9d9"),
                       name = "Region") +
    scale_y_continuous(labels = scales::percent,
                       limits = c(0,1)) +
    scale_x_discrete(labels = make_labels) +
    coord_flip() +
    theme_classic() +
    theme(legend.position = c(.15,.85))

  return(list(figures = ret_fig, tables = ret_rr))
}


#  James Rekow

abdListCreator = function(M = 40, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                          thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                          interSmplMult = 0.01, intTime = 100, lambda = 0, returnParams = FALSE,
                          conGraph = NULL){

  #  ARGS: M - number of samples
  #        N - number of bacterial species in each sample
  #        iStrength - interaction strength. In range [0, 1]. Describes how strongly the bacterial species
  #                    within each individual sample interact with each other. Higher value indicates a
  #                    greater degree of interaction
  #        univ - universality. In range [0, 1]. Describes how similar the underlying dynamics governing
  #               the time evolution of the bacterial species are in different samples. At univ = 1 the
  #               dynamics are identical in each sample. This determines the variance in the growth
  #               rate vector and interaction matrix of each sample
  #        sigmaMax - maximum standard deviation of elements in the interaction matrix describing
  #                   the bacterial dynamics of a sample. Every sample in a cohort has the same
  #                   value of sigmaMax (e.g. it is a property of the whole cohort). Universality
  #                   acts like a scaling factor being multiplied by sigmaMax when determing sd of
  #                   elements in the interaction matrix. Although universality also effects the
  #                   variance of the growth rate vectors, while sigmaMax does not
  #        thresholdMult - determines the cutoff at which changes are considered small steps. When
  #                        integrating samples if eucidean length of the change in the abundance
  #                        vector during one times step is less than the threshold value then that
  #                        change is considered a small step. If there are 5 consecutive small steps in
  #                        a row the system is assumed to be at equilibrium, and the integration step is
  #                        terminated
  #        maxSteps - maximum number of steps allowed in integration step. If the integration has not
  #                   been completed after this many steps the current abundance vector is returned
  #        tStep - time step in the integration step
  #        interSmplMult - the fraction of a sample's abundances that get transmitted
  #                        upon contact with another sample. Transmission is bi-directional
  #                        and does not deplete the abundance of the dog from which it is
  #                        transmitted
  #        intTime - total time during the interaction step. Unrelated to tStep
  #        lambda - rate parameter for the exponentially distributed wait times between interactions
  #        returnParams - if TRUE grList and imatList will also be returned
  #        conGraph - "connectivity graph". Vertices represent samples and edges connect
  #                   samples that can interact
  #
  #  RETURNS: abdList - a list of length M containing the integrated and interacted (if lambda > 0)
  #                     numerical abundance vectors of length N from a single cohort
  #
  #  NOTE: typical non-zero value for lambda is 0.5 - 0.15. Expected value of waiting time is 1 / rate

  library(igraph)
  source("cohortCreator.r")
  source("eulerIntegrate.r")
  source("intraCohortInteraction.r")

  #  give a warning if conGraph is supplied but there are no interactions
  if(lambda == 0 && (!is.null(conGraph))){
    warning("Changing the cohort connectivity (conGraph) will have no effect if
            there are no interactions.")
  } #  end if

  #  used to determine if the system is near equilibrium
  threshold = {thresholdMult * tStep} ^ 2

  #  define integrator function to apply eulerIntegrate with desired parameter vals
  integrator = function(smpl){
    return(eulerIntegrate(smpl, threshold = threshold, maxSteps = maxSteps, tStep = tStep))
  } #  end integrator function

  #  create cohort and abundance list
  chrt = cohortCreator(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax)
  abdList = lapply(chrt, integrator)

  #  simulate intra-cohort interaction if lambda > 0
  if(lambda > 0){

    #  update the abundances of each sample in the cohort
    for(i in 1:M){
      chrt[[i]][[1]] = abdList[[i]]
    } #  end for

    #  simulate intra-cohort interactions
    abdList = intraCohortInteraction(chrt, M = M, N = N, lambda = lambda, threshold = threshold,
                                     maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                     interSmplMult= interSmplMult, conGraph = conGraph)

  } #  end if

  #  if returnParams is TRUE return grList and imatList along with abdList
  if(returnParams){

    grList = lapply(chrt, "[[", 2)
    imatList = lapply(chrt, "[[", 3)

    return(list(abdList, grList, imatList))

  } #  end if returnParams

  #  default is to only return abdList
  else{
    return(abdList)
  } #  end else

} #  end abdListCreator function


# Function to fit discrete heavy tail functions
# Mostly using poweRlaw package
#
fit_dis_heavy_tail <- function (data_set,xmins,options.output)
{
  require(fitdistrplus)

  n <- length(unique(data_set))
  n_models <- 6
  # List of models
  model_list = list(list(model=vector("list", length=0),
                         GOF=vector("list", length=0),
                         xmin_estimation=vector("list", length=0),
                         uncert_estimation=vector("list", length=0),
                         k=0,
                         LL=0,
                         n=n,
                         AICc=0,
                         delta_AICc=0,
                         AICc_weight=0,
                         model_name=character(0),
                         model_set=character(0)))
  fit_ht <- rep(model_list,n_models)
  dim(fit_ht) <- c(n_models)

  # Declare models
  #
  # Discrete power law
  fit_ht[[1]]$model <- displ$new(data_set)
  fit_ht[[1]]$k <- 1
  # Discrete log-normal
  fit_ht[[2]]$model <- dislnorm$new(data_set)
  fit_ht[[2]]$k <- 2
  # Discrete exponential
  fit_ht[[3]]$model <- disexp$new(data_set)
  fit_ht[[3]]$k <- 1
  # Poisson
  fit_ht[[4]]$model <- dispois$new(data_set)
  fit_ht[[4]]$k <- 1
  # power law with exponential cutoff
  fit_ht[[5]]$model <- ""
  fit_ht[[5]]$k <- 2
  # Uniform
  fit_ht[[6]]$model <- ""
  fit_ht[[6]]$k <- 1

  # Estimate Xmin with complete data_set for power law model
  #
  if(xmins>1) {
    fit_ht[[1]]$xmin_estimation <- estimate_xmin(fit_ht[[1]]$model,
                                                 xmins = 1:xmins,
                                                 pars = NULL,
                                                 xmax = max(data_set))
    fit_ht[[1]]$model$setXmin(fit_ht[[1]]$xmin_estimation)
  } else {
    fit_ht[[1]]$model$setXmin(1)

  }

  model_names <- c("Power", "LogNorm","Exp","Poisson","PowerExp","Uniform")

  AICc_weight <- matrix( nrow = n_models, ncol = 1,
                         dimnames = list(model_names))

  delta_AICc <- AICc_weight
  GOF <- delta_AICc
  aic_min=Inf
  norm_aic_weight=0

  for (i in 1:(n_models))
  {
      # Set cut-off (x_min)
      fit_ht[[i]]$model$xmin <- fit_ht[[1]]$model$xmin

      # Correct n with xmin
      fit_ht[[i]]$n <-length(data_set[data_set>=fit_ht[[1]]$model$xmin])

      # Fit models
      #            PowerExp is different!!!!!!!!!
      #
      if(i<5){
        fit_ht[[i]]$model$setPars(estimate_pars(fit_ht[[i]]$model))
        #
        # Get Loglikelihood
        fit_ht[[i]]$LL <- dist_ll(fit_ht[[i]]$model)
      } else if(i==5) {
        # Fit Power Exponential (not poweRlaw package)
        #
        fit_ht[[i]]$model<- discpowerexp.fit(data_set,fit_ht[[1]]$model$xmin)
        #
        # Get Loglikelihood
        fit_ht[[i]]$LL <- fit_ht[[i]]$model$loglike
      } else if(i==6) {
        # Fit Power Exponential (not poweRlaw package)
        #
        fit_ht[[i]]$model<- max(data_set)
        teta<- max(data_set)
        #
        # Get Loglikelihood
        fit_ht[[i]]$LL <- log(teta^(-length(data_set)))
      }

      #
      # Get Loglikelihood
      LL <- fit_ht[[i]]$LL
      k <- fit_ht[[i]]$k

      # Compute AICc
      #
      fit_ht[[i]]$AICc <- (2*k-2*LL)+2*k*(k+1)/(n-k-1)
      aic_min <- min(aic_min,fit_ht[[i]]$AICc)
      fit_ht[[i]]$model_name <- model_names[i]
  }

  for (i in 1:n_models){
    delta_AICc[i] <- fit_ht[[i]]$AICc - aic_min
    fit_ht[[i]]$delta_AICc <- delta_AICc[i]
    norm_aic_weight <- norm_aic_weight + exp(-0.5*fit_ht[[i]]$delta_AICc)
  }

  # Akaike weigths and dataframe with parameters
  #
  daf<-data.frame()

  for (i in 1:n_models){
    AICc_weight[i]  <- exp(-0.5*fit_ht[[i]]$delta_AICc)/norm_aic_weight
    fit_ht[[i]]$AICc_weight <- AICc_weight[i]
    if(i<5){
      daf <- rbind(daf,data.frame(ModelNames=model_names[i],
                                  par1=fit_ht[[i]]$model$pars[1],
                                  par2=fit_ht[[i]]$model$pars[2],
                                  xmin=fit_ht[[1]]$model$getXmin(),
                                  n=fit_ht[[i]]$n,
                                  AICc=fit_ht[[i]]$AICc,Delta_AICc=delta_AICc[i],AICc_weight=AICc_weight[i]))
    } else if(i==5){
      daf <- rbind(daf,data.frame(ModelNames=model_names[i],
                                  par1=-fit_ht[[i]]$model$exponent,
                                  par2=fit_ht[[i]]$model$rate,
                                  xmin=fit_ht[[1]]$model$getXmin(),
                                  n=fit_ht[[i]]$n,
                                  AICc=fit_ht[[i]]$AICc,Delta_AICc=delta_AICc[i],AICc_weight=AICc_weight[i]))
    }else if(i==6){
      daf <- rbind(daf,data.frame(ModelNames=model_names[i],
                                  par1=fit_ht[[i]]$model,
                                  par2= NA,
                                  xmin=fit_ht[[1]]$model$getXmin(),
                                  n=fit_ht[[i]]$n,
                                  AICc=fit_ht[[i]]$AICc,Delta_AICc=delta_AICc[i],AICc_weight=AICc_weight[i]))

    }
  }

  # Plots
  #
  if (options.output$ploting){
    #setwd(options.output$resultsDir)

    require(RColorBrewer)
    colp <-brewer.pal(8,"Dark2")
    fnam <-paste0(options.output$data_set_name, "_xmin",fit_ht[[1]]$model$xmin,".png")
    png(filename=fnam, res=300,units = "mm", height=200, width=200,bg="white")
    po <-plot(fit_ht[[1]]$model,xlab="Degree",ylab="log[P(X > x)]",main=options.output$data_set_name)
    for (i in 1:n_models){
      if(i<5) {
        lines(fit_ht[[i]]$model, col=colp[i])
      } else if(i==5) {
        est1 <- fit_ht[[i]]$model
        est1$xmin <- fit_ht[[1]]$model$xmin
        x <- sort(unique(data_set))
        x <- x[x>=est1$xmin]
        shift <- max(po[po$x>=est1$xmin,]$y)
        y <- ppowerexp(x,est1$xmin,est1$exponent,est1$rate,lower.tail=F)*shift
        lines(x,y,col=colp[i])
      } else if(i==6) {
        est1 <- fit_ht[[i]]$model
        xmin <- fit_ht[[1]]$model$xmin
        x <- sort(unique(data_set))
        x <- x[x>=xmin]
        shift <- max(po[po$x>=xmin,]$y)
        y <- 1-((x - xmin+1)/(est1-xmin+1)*shift)
        lines(x,y,col=colp[i])
      }
  }

    legend("topright",model_names,bty="n",col=colp,lty=c(1,1,1,1),cex=1)
    dev.off()
  }

  return(list(fitted_models=fit_ht,da_fit=daf))

}

fit_ht_dplyr_helper <-function(df,xmin=1){
  opt.output$data_set_name <- unique(df$Network)
  temp <-fit_dis_heavy_tail(df$Degree,xmin,opt.output)
  temp <-data.frame(temp$da_fit)
  temp$Network <- unique(df$Network)
  return(temp)
}

# Plot of frequencies of patch sizes with fitted continuous heavy tail functions
# x: data
# fit_ht_df : dataframe with fitted parameters
#
freq_plot_con_ht <- function(x,fit_ht,tit="") # PLOT ALL FROM X=1 ?????????????????
{
  require(dplyr)
  require(ggplot2)
  xx <-as.data.frame(table(x))
  xx$x <- as.numeric(as.character(xx$x))
  ff <- filter(fit_ht,ModelNames=="PowerExp")
  if(nrow(ff)>0){
    xmin <- ff$xmin
    xx$pexp <-dpowerexp(xx$x,1,ff$par1,ff$par2)
  } else {
    xx$pexp<-0
  }
  ff <- filter(fit_ht,ModelNames=="Power")
  xmin <- ff$xmin
  xx$pow  <-dpareto(xx$x,xmin,ff$par1)

  ff <- filter(fit_ht,ModelNames=="Exp")
  xx$exp  <-dexp(xx$x,ff$par1)

  xx <-mutate(xx,pexp=ifelse(x<xmin,NA,pexp),pow=ifelse(x<xmin,NA,pow),
              exp=ifelse(x<xmin,NA,exp),
              Freq=Freq/sum(Freq))

  minFreq <- min(xx$Freq) - 0.5*min(xx$Freq)
  minFreq <- ifelse(minFreq<0,0,minFreq)
  g <- ggplot(xx, aes(y=Freq,x=x)) +  theme_bw() + geom_point(alpha=0.3) +
    coord_cartesian(ylim=c(1,min(minFreq)))+
    scale_y_log10() +scale_x_log10() + ylab("Frequency") + xlab("Degree") +ggtitle(tit)

  mc <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")

  g <- g + geom_line(aes(y=pow,x=x,colour="P.law")) +
#    geom_line(aes(y=pexp,x=x,colour="P.law with\nexp. cutoff"))+
    geom_line(aes(y=exp,x=x,colour="Exp."))+
    scale_colour_manual(values=mc,name="")

  fil <- gsub(" ", "", tit, fixed = TRUE)
  fil <- paste0(fil,".png")
  if(tit=="")
    print(g)
  else
    ggsave(fil,plot=g,width=6,height=4,units="in",dpi=600)

}

# Calculates The Corrected Akaike Criterion
# k: number of parameters
# n: number of points
# mdl1,2: fitted nonlinear models
#
Akaike_criterion<-function(k,n,mdl1,mdl2,names)
{
  Akaike <-data.frame(Model=names, AICc=0)
  Akaike$AICc[1] <- 2*k - 2* logLik(mdl1) + 2*k*(k+1)/(n-k-1)
  Akaike$AICc[2] <- 2*k - 2* logLik(mdl2) + 2*k*(k+1)/(n-k-1)
  Akaike$Delta <- Akaike$AICc - min(Akaike$AICc)
  return(Akaike)
}

# Function to plot CCDF of fitted continuous heavy tail functions using ggplo2
#
# x: data
# fit_ht : dataframe with fitted parameters
# tit: file name to save graph
# fit_ht1: second set of parameters to superimpose in the same graph

cdfplot_displ_exp <- function(x,fit_ht,tit="",xmax=0)
{
  require(poweRlaw)
  require(viridis)
  m <- displ$new(x)
  tP <- plot(m,draw=F)
  require(ggplot2)
  require(dplyr)

  ff <- filter(fit_ht,ModelNames=="Power")
  xmin <- ff$xmin

  tP1 <- cdfplot_conpl_exp_helper(x,tP,fit_ht,xmin)

  #tP2 <-filter(tP2, powl>= min(tP$Rank))
  #tP1 <-filter(tP1, powl>= min(tP$Rank))

  #mc <- c("#E69F00", "#56B4E9", "#009E73","#F0E442", "#0072B2","#D55E00", "#CC79A7")
  # Brewer
  #mc <- c("#d7191c","#fdae61","#abd9e9","#2c7bb6")

  g <- ggplot(tP, aes(x=x,y=y)) +  theme_bw() + geom_point(alpha=0.3) +
    coord_cartesian(ylim=c(1,min(tP$y)))+
    scale_y_log10() +scale_x_log10() + ylab("log[P(X > x)]") + xlab("Degree") #+ggtitle(tit)
  if(xmax>0) {
    g<-g + xlim(0,xmax+1) + scale_x_log10()
  }
  brk<-unique(tP1$model)
  g <- g + geom_line(data=tP1,aes(y=powl,x=psize,colour=model)) +
    #scale_colour_discrete(name="",breaks=brk)
    #scale_colour_manual(values=mc,name="",breaks=brk)
    #scale_colour_brewer(type="dark2",palette=7,name="",breaks=brk)
    scale_colour_viridis(discrete = TRUE)

  fil <- gsub(" ", "", tit, fixed = TRUE)
  fil <- paste0(fil,".png")
  if(tit=="")
    print(g)
  else
    ggsave(fil,plot=g,width=6,height=4,units="in",dpi=600)

}

cdfplot_conpl_exp_helper <- function(x,tP,fit_ht,xmin,mode="gt")
{
  x1 <- unique(x)

  # Select model and generate a data frame
  #
  ff <- filter(fit_ht,ModelNames=="PowerExp")

  if(mode=="gt") {
    x1 <- x1[x1>=xmin]
    shift <- max(filter(tP,x>=xmin)$y)
  } else {
    x1 <- x1[x1<xmin]
    #xmin<-1
    #shift <-1
    # First select lower subset the change to the Xmin of this subset
    xmin <- ff$xmin
    shift <- max(filter(tP,x>=xmin)$y)
  }

  tP2 <- data_frame(psize=x1, powl=ppowerexp(x1,xmin,ff$par1,ff$par2,lower.tail=F)*shift,model="PowerExp")

  ff <- filter(fit_ht,ModelNames=="Power")
  m <- displ$new(x)
  m$setPars(ff$par1)
  m$setXmin(xmin)
  tP1 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="Power")

  ff <- filter(fit_ht,ModelNames=="Exp")
  m <- disexp$new(x)
  m$setPars(ff$par1)
  m$setXmin(xmin)
  tP3 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="Exp")

  ff <- filter(fit_ht,ModelNames=="LogNorm")
  m <- dislnorm$new(x)
  m$setPars(c(ff$par1,ff$par2))
  m$setXmin(xmin)
  tP4 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="LogNorm")

  ff <- filter(fit_ht,ModelNames=="Poisson")
  m <- dispois$new(x)
  m$setPars(c(ff$par1,ff$par2))
  m$setXmin(xmin)
  tP5 <- data_frame(psize=x1,powl=dist_cdf(m,x1,lower_tail=F)*shift,model="Poisson")
  tP1 <- bind_rows(tP1,tP2,tP3,tP4,tP5)
}

# Complementary cumulative distribution plot using base graphics and poweRlaw package
#
ccdf_base_plot_ht <- function(fit_ht,data_set,netName=""){
    # Plots
  #

    require(RColorBrewer)
    colp <-brewer.pal(8,"Dark2")
    if(netName!="") {
        fnam <-paste0(netName, "_xmin",fit_ht[1]$xmin,".png")
        png(filename=fnam, res=300,units = "mm", height=200, width=200,bg="white")
    }

    po <-plot(fit_ht[1]$model,xlab="Degree",ylab="log[P(X > x)]",main=options.output$data_set_name)
    for (i in 1:n_models){
      if(i!=n_models) {
        lines(fit_ht[[i]]$model, col=colp[i])
      } else {
        est1 <- fit_ht[[i]]$model
        x <- sort(unique(data_set))
        x <- x[x>=est1$xmin]
        shift <- max(po[po$x>=est1$xmin,]$y)
        y <- ppowerexp(x,est1$xmin,est1$exponent,est1$rate,lower.tail=F)*shift
        lines(x,y,col=colp[i])
      }
    }

    legend("topright",model_names,bty="n",col=colp,lty=c(1,1,1,1),cex=1)
    if(netName!="") dev.off()
}


REBOL [
	System: "REBOL [R3] Language Interpreter and Run-time Environment"
	Title: "REBOL 3 Mezzanine: Math"
	Rights: {
		Copyright 2012 REBOL Technologies
		REBOL is a trademark of REBOL Technologies
	}
	License: {
		Licensed under the Apache License, Version 2.0
		See: http://www.apache.org/licenses/LICENSE-2.0
	}
]

mod: func [
	"Compute a nonnegative remainder of A divided by B."
	; In fact the function tries to find the remainder,
	; that is "almost non-negative"
	; Example: 0.15 - 0.05 - 0.1 // 0.1 is negative,
	; but it is "almost" zero, i.e. "almost non-negative"
	[catch]
	a [number! money! time!]
	b [number! money! time!] "Must be nonzero."
	/local r
] [
	; Compute the smallest non-negative remainder
	all [negative? r: a // b   r: r + b]
	; Use abs a for comparisons
	a: abs a
	; If r is "almost" b (i.e. negligible compared to b), the
	; result will be r - b. Otherwise the result will be r
	either all [a + r = (a + b)  positive? r + r - b] [r - b] [r]
]

modulo: func [
	{Wrapper for MOD that handles errors like REMAINDER. Negligible values (compared to A and B) are rounded to zero.}
	;[catch]
	a [number! money! time!]
	b [number! money! time!] "Absolute value will be used"
	/local r
] [
	; Coerce B to a type compatible with A
	any [number? a  b: make a b]
	; Get the "accurate" MOD value
	r: mod a abs b
	; If the MOD result is "near zero", w.r.t. A and B,
	; return 0--the "expected" result, in human terms.
	; Otherwise, return the result we got from MOD.
	either any [a - r = a   r + b = b] [make r 0] [r]
]

sign?: func [
	"Returns sign of number as 1, 0, or -1 (to use as multiplier)."
	number [number! money! time!]
][
	case [
		positive? number [1]
		negative? number [-1]
		true [0]
	]
]

minimum-of: func [
	{Finds the smallest value in a series}
	series [series!] {Series to search}
	/skip {Treat the series as records of fixed size}
	size [integer!]
	/local spot
][
	size: any [size 1]
	if 1 > size [cause-error 'script 'out-of-range size]
	spot: series
	forskip series size [
		if lesser? first series first spot [spot: series]
	]
	spot
]

maximum-of: func [
	{Finds the largest value in a series}
	series [series!] {Series to search}
	/skip {Treat the series as records of fixed size}
	size [integer!]
	/local spot
][
	size: any [size 1]
	if 1 > size [cause-error 'script 'out-of-range size]
	spot: series
	forskip series size [
		if greater? first series first spot [spot: series]
	]
	spot
]


# model : y = b0 + b1x1 + b2x2 + b3x3 +e
#x1 = 1 if system 2 is used, x1 = 0 otherwise
#x2 = 1 if system 3 is used, x2 = 0 otherwise
#x3 = 1 if system 4 is used, x3 = 0 otherwise
u1=7
u2=9
u3=6
u4=15
b0=u1
b1=u2-u1
b2=u3-u1
b3=u4-u1
print(b0)
print(b1)
print(b2)
print(b3)


### Racing Diffusion Model

### Single accumulator

# pigt, digt, rwaldt Copyright (C) 2013  Trisha Van Zandt distributed with:
# Logan, Van Zandt, Verbruggen, and Wagenmakers (2014).  On the ability to
# inhibit thought and action: General and special theories of an act of control.
# Psychological Review.

# Comments and changes added by Andrew Heathcote and Gabriel Tillman

rWald <- function(n, B, v, A)
  # random deviate function for single acumulator
{
  rwaldt <- function(n, k, l, tiny = 1e-6) {
    # random sample of n from a Wald (or Inverse Gaussian)
    # k = criterion, l = rate, assumes sigma=1 Browninan motion
    # about same speed as statmod rinvgauss

    rlevy <- function(n = 1, m = 0, c = 1) {
      if (any(c < 0))
        stop("c must be positive")
      c / qnorm(1 - runif(n) / 2) ^ 2 + m
    }

    flag     <- l > tiny
    x        <- rep(NA, times = n)
    x[!flag] <- rlevy(sum(!flag), 0, k[!flag] ^ 2)
    mu       <- k / l
    lambda   <- k ^ 2
    y        <- rnorm(sum(flag)) ^ 2
    mu.0     <- mu[flag]
    lambda.0 <- lambda[flag]
    x.0      <- mu.0 + mu.0 ^ 2 * y / (2 * lambda.0) -
      sqrt(4 * mu.0 * lambda.0 * y + mu.0 ^ 2 * y ^ 2) * mu.0 /
      (2 * lambda.0)

    z             <- runif(length(x.0))
    test          <- mu.0 / (mu.0 + x.0)
    x.0[z > test] <- mu.0[z > test] ^ 2 / x.0[z > test]
    x[flag]       <- x.0
    x[x < 0]      <- max(x)
    x
  }

  # Act as if negative v never terminates, cluge to do single accumulator
  # case by passing negative v
  if (length(v) != n)
    v <- rep(v, length.out = n)
  if (length(B) != n)
    B <- rep(B, length.out = n)
  if (length(A) != n)
    A <- rep(A, length.out = n)

  # Kluge to return -Inf for negative rates, so can implment one accumulator case
  out      <- numeric(n)
  ok       <- v > 0
  nok      <- sum(ok)
  bs       <- B[ok] + runif(nok, 0, A[ok])
  out[ok]  <- rwaldt(nok, k = bs, l = v[ok])
  out[!ok] <- Inf
  out
}

dWald <- function(t, v, B, A)
  # density for single accumulator
{
  digt <- function(t, k = 1, l = 1, a = .1, tiny = 1e-10) {
    # pdf of inverse gaussian at t with k +/- a/2 uniform variability
    # returns digt.0 if a<1e-10

    digt.0 <- function(t, k = 1, l = 1) {
      # pdf of inverse gaussian at t with no k variability
      # much faster than statmod's dinvgauss funciton

      lambda <- k ^ 2
      l0     <- l == 0
      e      <- numeric(length(t))
      if (any(!l0)) {
        mu     <- k[!l0] / l[!l0]
        e[!l0] <-
          -(lambda[!l0] / (2 * t[!l0])) * (t[!l0] ^ 2 / mu ^ 2 - 2 * t[!l0] / mu  + 1)
      }
      if (any(l0))
        e[l0]   <- -.5 * lambda[l0] / t[l0]
      x         <- exp(e + .5 * log(lambda) - .5 * log(2 * t ^ 3 * pi))
      x[t <= 0] <- 0
      x
    }

    options(warn = -1)
    if (length(k) != length(t))
      k <- rep(k, length.out = length(t))
    if (length(l) != length(t))
      l <- rep(l, length.out = length(t))
    if (length(a) != length(t))
      a <- rep(a, length.out = length(t))

    tpos <- t <= 0

    atiny    <- a <= tiny & !tpos
    a[atiny] <- 0

    ltiny        <- (l <= tiny) & !atiny & !tpos
    notltiny     <- (l > tiny) & !atiny & !tpos
    l[l <= tiny] <- 0
    x            <- numeric(length(t))

    # No threshold variability
    if (any(atiny))
      x[atiny] <- digt.0(t = t[atiny], k = k[atiny], l = l[atiny])

    # Threshold variability
    if (any(!atiny)) {
      if (any(notltiny)) {
        # rate non-zero

        sqr.t   <- sqrt(t[notltiny])

        term.1a <-
          -(a[notltiny] - k[notltiny] + t[notltiny] * l[notltiny]) ^ 2 / (2 * t[notltiny])
        term.1b <-
          -(a[notltiny] + k[notltiny] - t[notltiny] * l[notltiny]) ^ 2 / (2 * t[notltiny])
        term.1  <-
          (exp(term.1a) - exp(term.1b)) / sqrt(2 * pi * t[notltiny])

        term.2a <- log(.5) + log(l[notltiny])
        term.2b <-
          2 * pnorm((-k[notltiny] + a[notltiny]) / sqr.t + sqr.t * l[notltiny]) -
          1
        term.2c <-
          2 * pnorm((k[notltiny] + a[notltiny]) / sqr.t - sqr.t * l[notltiny]) -
          1
        term.2d <- term.2b + term.2c
        term.2  <- exp(term.2a) * term.2d

        term.3  <- term.1 + term.2
        term.4  <- log(term.3) - log(2) - log(a[notltiny])
        x[notltiny] <- exp(term.4)
      }

      if (any(ltiny)) {
        # rate zero
        log.t    <- log(t[ltiny])
        term.1   <- -.5 * (log(2) + log(pi) + log.t)
        term.2   <- (k[ltiny] - a[ltiny]) ^ 2 / (2 * t[ltiny])
        term.3   <- (k[ltiny] + a[ltiny]) ^ 2 / (2 * t[ltiny])
        term.4   <- (exp(-term.2) - exp(-term.3))
        term.5   <- term.1 + log(term.4) - log(2) - log(a[ltiny])
        x[ltiny] <- exp(term.5)
      }

    }

    x[x < 0 | is.nan(x)] <- 0
    x
  }

  out      <- numeric(length(t))
  ok       <- v > 0
  out[ok]  <- digt(t[ok],
                   k = B[ok] + A[ok] / 2,
                   l = v[ok],
                   a = A[ok] / 2)
  out[!ok] <- 0
  out
}

# # Check density and normalization

# # Without Starting Point Variability
# par(mfrow=c(1,2))
# n=1e6; A=0; v=2; B=1
# integrate(dWald,lower=0,upper=Inf,A=A,v=v,B=B)
# sim <- rWald(n=n,A=A,v=v,B=B)
# bad <- sim>10; mean(bad) # if this is large the check isnt valid
# dns <- density(sim[!bad])
# x <- dns$x[dns$x>0]
# d <- dWald(x,A=A,v=v,B=B)
# plot(dns)
# lines(x,d,col="red")

# # With Starting Point Variability
# n=1e6; A=1; v=2; B=1
# integrate(dWald,lower=0,upper=Inf,A=A,v=v,B=B)
# sim <- rWald(n=n,A=A,v=v,B=B)
# bad <- sim>10; mean(bad) # if this is large the check isnt valid
# dns <- density(sim[!bad])
# x <- dns$x[dns$x>0]
# d <- dWald(x,A=A,v=v,B=B)
# plot(dns)
# lines(x,d,col="red")

pWald <- function(t, v, B, A)
  # cumulative density for single accumulator
{
  pigt <- function(t, k = 1, l = 1, a = .1, tiny = 1e-10) {
    # cdf of inverse gaussian at t with k +/- a/2 uniform variability
    # returns pigt.0 if a<=0

    pigt.0 <- function(t, k = 1, l = 1) {
      # cdf of inverse gaussian at t with no k variability
      # much faster than statmod's pinvgauss funciton

      mu       <- k / l
      lambda   <- k ^ 2
      e        <- exp(log(2 * lambda) - log(mu))
      add      <- sqrt(lambda / t) * (1 + t / mu)
      sub      <- sqrt(lambda / t) * (1 - t / mu)
      p.1      <- 1 - pnorm(add)
      p.2      <- 1 - pnorm(sub)
      x        <- exp(e + log(p.1)) + p.2

      x[t < 0] <- 0
      x
    }

    options(warn = -1)
    if (length(k) != length(t))
      k  <- rep(k, length.out = length(t))
    if (length(l) != length(t))
      l  <- rep(l, length.out = length(t))
    if (length(a) != length(t))
      a  <- rep(a, length.out = length(t))

    tpos <- t <= 0

    atiny    <- a <= tiny & !tpos
    a[atiny] <- 0

    ltiny        <- (l <= tiny) & !atiny & !tpos
    notltiny     <- (l > tiny) & !atiny & !tpos
    l[l <= tiny] <- 0

    x <- numeric(length(t))

    # No threshold variability
    if (any(atiny))
      x[atiny] <- pigt.0(t[atiny], k[atiny], l[atiny])

    # Threshold variability
    if (any(!atiny)) {
      if (any(notltiny)) {
        # rate non-zero

        log.t   <- log(t[notltiny])
        sqr.t   <- sqrt(t[notltiny])

        term.1a <- .5 * log.t - .5 * log(2 * pi)
        term.1b <-
          exp(-((k[notltiny] - a[notltiny] - t[notltiny] * l[notltiny]) ^ 2 / t[notltiny]) /
                2)
        term.1c <-
          exp(-((k[notltiny] + a[notltiny] - t[notltiny] * l[notltiny]) ^ 2 / t[notltiny]) /
                2)
        term.1  <- exp(term.1a) * (term.1b - term.1c)

        term.2a <- exp(2 * l[notltiny] * (k[notltiny] - a[notltiny]) +
                         log(pnorm(-(
                           k[notltiny] - a[notltiny] + t[notltiny] * l[notltiny]
                         ) / sqr.t)))
        term.2b <- exp(2 * l[notltiny] * (k[notltiny] + a[notltiny]) +
                         log(pnorm(-(
                           k[notltiny] + a[notltiny] + t[notltiny] * l[notltiny]
                         ) / sqr.t)))
        term.2  <- a[notltiny] + (term.2b - term.2a) / (2 * l[notltiny])

        term.4a <-
          2 * pnorm((k[notltiny] + a[notltiny]) / sqr.t - sqr.t * l[notltiny]) -
          1
        term.4b <-
          2 * pnorm((k[notltiny] - a[notltiny]) / sqr.t - sqr.t * l[notltiny]) -
          1
        term.4c <-
          .5 * (t[notltiny] * l[notltiny] - a[notltiny] - k[notltiny] + .5 / l[notltiny])
        term.4d <-
          .5 * (k[notltiny] - a[notltiny] - t[notltiny] * l[notltiny] - .5 / l[notltiny])
        term.4  <- term.4c * term.4a + term.4d * term.4b

        x[notltiny] <- (term.4 + term.2 + term.1) / (2 * a[notltiny])
      }

      if (any(ltiny)) {
        # rate zero
        sqr.t   <- sqrt(t[ltiny])
        log.t   <- log(t[ltiny])
        term.5a <- 2 * pnorm((k[ltiny] + a[ltiny]) / sqr.t) - 1
        term.5b <- 2 * pnorm(-(k[ltiny] - a[ltiny]) / sqr.t) - 1
        term.5  <-
          (-(k[ltiny] + a[ltiny]) * term.5a - (k[ltiny] - a[ltiny]) * term.5b) /
          (2 * a[ltiny])

        term.6a <-
          -.5 * (k[ltiny] + a[ltiny]) ^ 2 / t[ltiny] - .5 * log(2) - .5 * log(pi) + .5 *
          log.t - log(a[ltiny])
        term.6b <-
          -.5 * (k[ltiny] - a[ltiny]) ^ 2 / t[ltiny] - .5 * log(2) - .5 * log(pi) + .5 *
          log.t - log(a[ltiny])
        term.6 <- 1 + exp(term.6b) - exp(term.6a)

        x[ltiny] <- term.5 + term.6
      }

    }

    x[x < 0 | is.nan(x)] <- 0
    x
  }

  out <- numeric(length(t))
  ok <- v > 0
  out[ok] <- pigt(t[ok],
                  k = B[ok] + A[ok] / 2,
                  l = v[ok],
                  a = A[ok] / 2)
  out[!ok] <- 0
  out

}

# # Check cumulative density
# par(mfrow=c(1,2))
#
# n=1e6; A=0; v=2; B=1
# sim <- rWald(n=n,A=A,v=v,B=B)
# probs=1:990/1000
# qs <- quantile(sim,probs=probs)
# cd <- pWald(qs,A=A,v=v,B=B)
# plot(qs,probs,type="l")
# lines(qs,cd,col="red")
#
# n=1e6; A=1; v=2; B=1
# sim <- rWald(n=n,A=A,v=v,B=B)
# probs=1:990/1000
# qs <- quantile(sim,probs=probs)
# cd <- pWald(qs,A=A,v=v,B=B)
# plot(qs,probs,type="l")
# lines(qs,cd,col="red")

### Race model

rWaldRace <- function(n, v, B, A, t0, gf = 0, return.ttf = FALSE)
  # random function for Wald race.
{
  B[B < 0] <- 0 # Protection for negatives
  A[A < 0] <- 0
  n_v      <- ifelse(is.null(dim(v)), length(v), dim(v)[1])
  ttf      <- matrix(t0 + rWald(n * n_v, B = B, v = v, A = A), nrow = n_v)
  if (return.ttf)
    return(ttf)
  resp <- apply(ttf, 2, which.min)
  out  <-
    data.frame(RT = ttf[cbind(resp, 1:n)], R = apply(ttf, 2, which.min))

  if (gf[1] > 0) {
    is.gf <- as.logical(rbinom(dim(out)[1], 1, gf))
    out$RT[is.gf] <- NA
    out$R[is.gf] <- 1
  }

  out
}

n1Wald <- function(dt, v, B, A, t0, gf = 0)
  # Generates defective PDF for responses on node=1, dt (decison time) is a vector of times
{
  B[B < 0] <- 0 # Protection for negatives
  A[A < 0] <- 0
  n_acc <- ifelse(is.null(dim(v)), length(v), dim(v)[1])
  if (is.null(dim(dt)))
    dt <- matrix(rep(dt, each = n_acc), nrow = n_acc)
  dt <- dt - t0

  is.go <- !is.na(dt[1, ])
  n.go <- sum(is.go)

  if (!is.matrix(v))
    v <- matrix(rep(v, n.go), nrow = n_acc)
  if (!is.matrix(B))
    B <- matrix(rep(B, n.go), nrow = n_acc)
  if (!is.matrix(A))
    A <- matrix(rep(A, n.go), nrow = n_acc)

  # Winner
  dt[1, is.go] <-
    (1 - gf[1]) * dWald(dt[1, is.go], A = A[1, ], v = v[1, ], B = B[1, ])
  if (n_acc > 1)
    for (i in 2:n_acc)
      dt[1, is.go] <-
    dt[1, is.go] * (1 - pWald(dt[i, is.go], A = A[i, ], v = v[i, ], B = B[i, ]))

  dt[1, !is.go] <- gf[1]

  dt[1, ]
}

#### Alternative Code

# Code here was written by Gabriel Tillman. Simplified
# the density and probability function, while allowing for the specification
# of the diffusion coefficient (i.e., d). The diffusion coeffient parameter
# is available for the dwald_alt function but not the pwald_alt function.
# Still working on math for that, when start point variability is included.

dwald_alt <- function(t, v, b, A, d) {
  if(A==0) A <- 1e-5
  s = (1 / sqrt(t)) / d
  alpha = (b - A - (t * v)) / (t * s)
  beta  = (b - (t * v)) / (t * s)
  1 / A * (-v * pnorm(alpha) + s * dnorm(alpha) +
             v * pnorm(beta) - s * dnorm(beta))
}

pwald_alt <- function(t, v, b, A) {
  require(pracma)
  if(A==0) A <- 1e-5
  B = b - A
  (
    A / 2 + 0.3989422804014327 * (exp(1) ^ (-((B - t * v) ^ 2 / (2 * t))) -
        exp(1) ^ (-((A + B - t * v) ^ 2 / (2 * t)))) *
      t ^ 0.5 + 0.5 * (B - 0.5 / v - t * v) *
      (-1 + erfc((-(B / sqrt(t)) + sqrt(t) * v) / sqrt(2))) +
      0.5 * (-A - B + 0.5 / v + t * v) * (-1 + erfc((-((A + B) / sqrt(t)) +
                                                       sqrt(t) * v) /
        sqrt(2))) + ((-(1 / 2)) * exp(1) ^ (2 * B * v) *
                       erfc((B + t * v) / (sqrt(2) * sqrt(t))) +
                       (1 / 2) * exp(1) ^ (2 * (A + B) * v) *
                       erfc((A + B + t * v) / (sqrt(2) * sqrt(t)))) /
      (2 * v)) / A
}

# Check dwald_alt integrates to 1
# With Starting Point Variability
# n=1e6; A=0; v=2; B=1
# integrate(dwald_alt,lower=0,upper=Inf,A=A,v=v,b=B+A,d=1)
# sim <- rWald(n=n,A=A,v=v,B=B)
# bad <- sim>10; mean(bad) # if this is large the check isnt valid
# dns <- density(sim[!bad])
# x <- dns$x[dns$x>0]
# d <- dWald(x,A=A,v=v,B=B)
# plot(dns)
# lines(x,d,col="red")

# Check pwald_alt density
# n=1e6; A=0; v=2; B=1
# sim <- rWald(n=n,A=A,v=v,B=B)
# probs=1:990/1000
# qs <- quantile(sim,probs=probs)
# cd <- pwald_alt(qs,A=A,v=v,b=B+A)
# plot(qs,probs,type="l")
# lines(qs,cd,col="red")


#######################################
# Research Methods for Global Studies #
# R demo - class 5	                  #
#######################################

# More on random numbers and chaos: Logistic Map example
n = 5000
r = 3.9
x1 = .5
x = rep(NA, n)
x[1] = x1
for(i in 1:(n-1)){
  x[i+1] = r*x[i]*(1-x[i])
}
plot(x, type="l")

plot(x, jitter(rep(1, n), 10), pch=19, cex=.5, col="#0000ff22")

hist(x)

dx = density(x)
plot(dx)
points(x, jitter(rep(1, n), 10), pch=19, cex=.5, col="#0000ff22")
lines(dx)

# Coin flips
c = rbinom(10, 1, .5)
mean(c)

c = rbinom(100, 100, .5)
hist(c)

# Sampling
pop = x
plot(density(pop))
mean(pop)
var(pop)
sd(pop)
quantile(pop, c(.05, .5, .95))

s = sample(pop, 10, replace=TRUE)
mean(s)
var(s)

s_means = sapply(1:10000, function(i) mean(sample(pop, 50, replace=TRUE)))
plot(density(s_means))

mean(s_means)
mean(pop)
var(s_means)
var(pop)


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('longit')
knitr::read_chunk('~/doc/rms/Longitudinal/shared.R')

## ----spaghetti,h=5,w=7,ps=7,cap='Time profiles for individual subjects, stratified by study site and dose'----
require(rms)
options(prType='latex')    # for model print, summary, anova
getHdata(cdystonia)
attach(cdystonia)

# Construct unique subject ID
uid <- with(cdystonia, factor(paste(site, id)))

# Tabulate patterns of subjects' time points
table(tapply(week, uid,
             function(w) paste(sort(unique(w)), collapse=' ')))

# Plot raw data, superposing subjects
xl <- xlab('Week'); yl <- ylab('TWSTRS-total score')
ggplot(cdystonia, aes(x=week, y=twstrs, color=factor(id))) +
       geom_line() + xl + yl + facet_grid(treat ~ site) +
       guides(color=FALSE) # Fig. (*\ref{fig:longit-spaghetti}*)

## ----quartiles,cap='Quartiles of \\co{TWSTRS} stratified by dose',w=5,h=4-----
# Show quartiles
require(data.table)
cdystonia <- data.table(cdystonia)
cdys <- cdystonia[, j=as.list(quantile(twstrs, (1 : 3)/4)),
                  by = list(treat, week)]
cdys <- upData(cdys, rename=c('25%'='Q1', '50%'='Q2', '75%'='Q3'), print=FALSE)
ggplot(cdys, aes(x=week, y=Q2)) + xl + yl + ylim(0, 70) +
  geom_line() + facet_wrap(~ treat, nrow=2) +
  geom_ribbon(aes(ymin=Q1, ymax=Q3), alpha=0.2)   # Fig. (*\ref{fig:longit-quartiles}*)

## ----e------------------------------------------------------------------------
baseline <- subset(data.frame(cdystonia,uid), week == 0,
                   -week)
baseline <- upData(baseline, rename=c(twstrs='twstrs0'),
                   print=FALSE)
followup <- subset(data.frame(cdystonia,uid), week > 0,
                   c(uid,week,twstrs))
rm(uid)
both     <- merge(baseline, followup, by='uid')

dd       <- datadist(both)
options(datadist='dd')

## ----k------------------------------------------------------------------------
require(nlme)
cp <- list(corCAR1,corExp,corCompSymm,corLin,corGaus,corSpher)
z  <- vector('list',length(cp))
for(k in 1:length(cp)) {
  z[[k]] <- gls(twstrs ~ treat * rcs(week, 3) +
                rcs(twstrs0, 3) + rcs(age, 4) * sex, data=both,
                correlation=cp[[k]](form = ~week | uid))
}
anova(z[[1]],z[[2]],z[[3]],z[[4]],z[[5]],z[[6]])

## ----l,results='asis'---------------------------------------------------------
a <- Gls(twstrs ~ treat * rcs(week, 3) + rcs(twstrs0, 3) +
         rcs(age, 4) * sex, data=both,
         correlation=corCAR1(form=~week | uid))
a

## ----variogram,cap='Variogram, with assumed correlation pattern superimposed'----
v <- Variogram(a, form=~ week | uid)
plot(v)  # Figure (*\ref{fig:longit-variogram}*)

## ----resid,h=6,w=7.5,cap='Three residual plots to check for absence of trends in central tendency and in variability.  Upper right panel shows the baseline score on the $x$-axis.  Bottom left panel shows the mean $\\pm 2\\times$SD.  Bottom right  panel is the QQ plot for checking normality of residuals from the GLS fit.',scap='Residual plots for GLS model'----
both$resid <- r <- resid(a); both$fitted <- fitted(a)
yl <- ylab('Residuals')
p1 <- ggplot(both, aes(x=fitted, y=resid)) + geom_point() +
      facet_grid(~ treat) + yl
p2 <- ggplot(both, aes(x=twstrs0, y=resid)) + geom_point()+yl
p3 <- ggplot(both, aes(x=week, y=resid)) + yl + ylim(-20,20) +
      stat_summary(fun.data="mean_sdl", geom='smooth')
p4 <- ggplot(both, aes(sample=resid)) + stat_qq() +
      geom_abline(intercept=mean(r), slope=sd(r)) + yl
gridExtra::grid.arrange(p1, p2, p3, p4, ncol=2)   # Figure (*\ref{fig:longit-resid}*)

## ----anova,results='asis',w=3.25,h=2.25,cap='Results of \\fu{anova} from generalized least squares fit with continuous time AR1 correlation structure.  As expected, the baseline version of $Y$ dominates.',scap='ANOVA for GLS model'----
plot(anova(a))     # Figure (*\ref{fig:longit-anova}*)

## ----pleffects,h=5,w=7,cap='Estimated effects of time, baseline TWSTRS, age, and sex'----
ylm <- ylim(25, 60)
p1 <- ggplot(Predict(a, week, treat, conf.int=FALSE),
             adj.subtitle=FALSE, legend.position='top') + ylm
p2 <- ggplot(Predict(a, twstrs0), adj.subtitle=FALSE) + ylm
p3 <- ggplot(Predict(a, age, sex), adj.subtitle=FALSE,
             legend.position='top') + ylm
gridExtra::grid.arrange(p1, p2, p3, ncol=2)   # Figure (*\ref{fig:longit-pleffects}*)

## ----o,results='asis'---------------------------------------------------------
summary(a)  # Shows for week 8

## ----p------------------------------------------------------------------------
# To get results for week 8 for a different reference group
# for treatment, use e.g. summary(a, week=4, treat='Placebo')

# Compare low dose with placebo, separately at each time
k1 <- contrast(a, list(week=c(2,4,8,12,16), treat='5000U'),
                  list(week=c(2,4,8,12,16), treat='Placebo'))
options(width=80)
print(k1, digits=3)

## ----q------------------------------------------------------------------------
# Compare high dose with placebo
k2 <- contrast(a, list(week=c(2,4,8,12,16), treat='10000U'),
                  list(week=c(2,4,8,12,16), treat='Placebo'))
print(k2, digits=3)

## ----contrasts,h=3,w=5.5,cap='Contrasts and 0.95 confidence limits from GLS fit'----
k1 <- as.data.frame(k1[c('week', 'Contrast', 'Lower', 'Upper')])
p1 <- ggplot(k1, aes(x=week, y=Contrast)) + geom_point() +
      geom_line() + ylab('Low Dose - Placebo') +
      geom_errorbar(aes(ymin=Lower, ymax=Upper), width=0)
k2 <- as.data.frame(k2[c('week', 'Contrast', 'Lower', 'Upper')])
p2 <- ggplot(k2, aes(x=week, y=Contrast)) + geom_point() +
      geom_line() + ylab('High Dose - Placebo') +
      geom_errorbar(aes(ymin=Lower, ymax=Upper), width=0)
gridExtra::grid.arrange(p1, p2, ncol=2)   # Figure (*\ref{fig:longit-contrasts}*)

## ----nomogram,h=5,w=6,cap='Nomogram from GLS fit.  Second axis is the baseline score.',scap='Nomomgram from GLS fit.'----
n <- nomogram(a, age=c(seq(20, 80, by=10), 85))
plot(n, cex.axis=.55, cex.var=.8, lmgp=.25)  # Figure (*\ref{fig:longit-nomogram}*)