#### Calculate Topographic Relief Alteration
#### Christopoulos Konstantinos
### Load Required Packages
 ## Ipak Function by Steven Worthington
  # https://gist.github.com/stevenworthington
ipak <- function(pkg){
    new.pkg <- pkg[!(pkg %in% installed.packages()[, "Package"])]
    if (length(new.pkg))
        install.packages(new.pkg, dependencies = TRUE)
    sapply(pkg, require, character.only = TRUE)
}

ipak(c("raster","SDMTools","maptools","scatterplot3d"))

#########################################################
#########################################################
### DATA
 ## CHANGE THESE:
  # FROM HERE
setwd("C:/") # Path with files here
Initial_State <- raster("state_0") # Initial Raster
Final_State <- raster("state_1") # Final Raster
Boundaries <-  readShapePoly("boundary.shp") # Boundary Raster
  # TO HERE
#########################################################
#########################################################

### Collect required spatial data
state_0 <- Initial_State
state_1 <- Final_State
slope_state_0 <- terrain(state_0, opt='slope', unit='degrees', neighbors=8)
slope_state_1 <- terrain(state_1, opt='slope', unit='degrees', neighbors=8)
aspect_state_0 <- terrain(state_0, opt='aspect', unit='degrees', neighbors=8)
aspect_state_1 <- terrain(state_1, opt='aspect', unit='degrees', neighbors=8)

elevation_points_0 <- rasterToPoints(state_0)
elevation_points_1 <- rasterToPoints(state_1)
slope_points_0 <- rasterToPoints(slope_state_0)
slope_points_1 <- rasterToPoints(slope_state_1)
aspect_points_0 <- rasterToPoints(aspect_state_0)
aspect_points_1 <- rasterToPoints(aspect_state_1)

data_elev <- as.data.frame(cbind(elevation_points_0, elevation_points_1[,3]))
colnames(data_elev) <-c("x","y","state_0","state_1")
data_slope <- as.data.frame(cbind(slope_points_0, slope_points_1[,3]))
colnames(data_slope) <-c("x","y","state_0","state_1")
data_aspect <- as.data.frame(cbind(aspect_points_0, aspect_points_1[,3]))
colnames(data_aspect) <-c("x","y","state_0","state_1")

### Plots
 ## Raster Elevation
  # Fig.1
par(mfrow = c(1,2))
plot(state_0,
     main = "Initial State",
     xlab = "", ylab = "")
lines(Boundaries, col = "red", lwd = 2)
contour(state_0, add = T)

plot(state_1,
     main = "Final State")
lines(Boundaries, col = "red", lwd = 2)
contour(state_1, add = T)

 ## Raster Slope
  # Fig.2
par(mfrow = c(1,2))
plot(slope_state_0,
     main = "Initial State",
     xlab = "", ylab = "")
lines(Boundaries, col = "red", lwd = 2)

plot(slope_state_1,
     main = "Final State")
lines(Boundaries, col = "red", lwd = 2)

 ## Raster Aspect
  # Fig.3
par(mfrow = c(1,2))
plot(aspect_state_0,
     main = "Initial State",
     xlab = "", ylab = "")
lines(Boundaries, col = "red", lwd = 2)

plot(aspect_state_1,
     main = "Final State")
lines(Boundaries, col = "red", lwd = 2)

 ## Elevation Comparison
  # Fig.4
par(mfrow = c(1,2))
scatterplot3d(
  data_elev$x, data_elev$y, data_elev$state_0,
  color = "darkgreen", pch = ".",
  col.axis = "blue", col.grid = "lightblue",
  xlab = "X", ylab = "Y", zlab = "Z",
  main = "Initial State"
)
scatterplot3d(
  data_elev$x, data_elev$y, data_elev$state_1,
  color = "red", pch = ".",
  col.axis = "blue", col.grid = "lightblue",
  xlab = "X", ylab = "Y", zlab = "Z",
  main = "Final State"
)

  # Fig.5
par(mfrow = c(1,1))
plot(
  data_elev$state_0,data_elev$state_1,
  pch = 0, cex = 0.2, col = "red2",
  main = "Elevation Comparison #2",
  xlab = "Initial State Elevation (m)",
  ylab = "Final State Elevation (m)",
  xlim = c(60,180),ylim = c(60,180)
)
abline(0, 1, lwd = 1, col = "blue")

  # Fig.6
plot(
  data_elev$state_0,
  pch = ".", cex = 1.2, col = "darkgreen",
  main = "Elevation Comparison #3",
  xlab = "Index",
  ylab = "Elevation (m)",
  ylim = c(50,185)
)
points(data_elev$state_1, pch = ".", cex = 1.2, col = "red2")
mdl_1 = lm(data_elev$state_0 ~ poly(seq(1,nrow(data_elev)), 3, raw = TRUE))
mdl_2 = lm(data_elev$state_1 ~ poly(seq(1,nrow(data_elev)), 3, raw = TRUE))
lines(predict(mdl_1), lwd = 2, col = "darkgreen")
lines(predict(mdl_2), lwd = 2, col = "red2")

  # Fig.7
plot(
  data_elev$state_1 - data_elev$state_0,
  pch = "x", cex = 0.8, col = "gray25",
  main = "Elevation Comparison #4",
  xlab = "Index",
  ylab = "Δ Elevation = Final - Initial (m)"
)

   # Volume Difference
volume <-
  sum((data_elev$state_1 - data_elev$state_0) * (xres(state_0) * yres(state_0)))
add_text <- sprintf("The Volume Difference is: %s", volume, "m^3")
mtext(paste(
  "The Volume Difference is: ",round(volume, digits = 0), "cubic meters"
),
col = "red")

 ## Slope Comparison
  # Fig.8
plot(
  data_slope$state_0,
  pch = ".", cex = 1.2, col = "darkgreen",
  main = "Slope Comparison",
  xlab = "Index",
  ylab = "Slope (Deg)",
  ylim = c(0,50)
)
points(data_slope$state_1, pch = ".", cex = 1.2, col = "red2")
mdl_1 = lm(data_slope$state_0 ~ poly(seq(1,nrow(data_slope)), 3, raw = TRUE))
mdl_2 = lm(data_slope$state_1 ~ poly(seq(1,nrow(data_slope)), 3, raw = TRUE))
lines(predict(mdl_1), lwd = 2, col = "darkgreen")
lines(predict(mdl_2), lwd = 2, col = "red2")

 ## Aspect Comparison
  # Fig.9
plot(
  data_aspect$state_0,
  pch = ".", cex = 1.2, col = "darkgreen",
  main = "Aspect Comparison",
  xlab = "Index",
  ylab = "Aspect (Deg)",
  ylim = c(0,360)
)
points(data_aspect$state_1, pch = ".", cex = 1.2, col = "red2")
mdl_1 = lm(data_aspect$state_0 ~ poly(seq(1,nrow(data_aspect)), 3, raw =
                                        TRUE))
mdl_2 = lm(data_aspect$state_1 ~ poly(seq(1,nrow(data_aspect)), 3, raw =
                                        TRUE))
lines(predict(mdl_1), lwd = 2, col = "darkgreen")
lines(predict(mdl_2), lwd = 2, col = "red2")

### Remove unwanted variables from memory
rm(list=ls()[! ls() %in% c("data_elev", "data_slope", "data_aspect")])

### Calculate Indexes for DoTRA
 ## Landform Index (LI)
var_elev_0 <- var(data_elev$state_0)
var_elev_1 <- var(data_elev$state_1)
cov_elev <- cov(data_elev$state_0,data_elev$state_1)

LI <- (var_elev_0 + var_elev_1 - 2 * cov_elev) /
      (var_elev_0 + var_elev_1)

LI <- round(LI, digits=2)

 ## Altitude Index (AI)
Δ_mean_elev <- mean(data_elev$state_0) - mean(data_elev$state_1)

Δ_elev_0_mean_elev_2 <- (data_elev$state_0 -
						 mean(data_elev$state_0))**2
Δ_elev_1_mean_elev_2 <- (data_elev$state_0 -
						 Δ_mean_elev -
						 mean(data_elev$state_0))**2

AI <- (sqrt(sum(Δ_elev_1_mean_elev_2)) /
       sqrt(sum(Δ_elev_0_mean_elev_2)) - 1) * 100

AI <- round(AI, digits=0)

 ## Slope Index (SI)
Δ_slope <- data_slope$state_0 - data_slope$state_1
Δ_slope_abs_90 <- abs(Δ_slope)/90

SI <- mean(Δ_slope_abs_90)

SI <- round(SI, digits=2)

 ## Aspect Index (AsI)
reduct360to180 <- function(x) {
    ifelse(x < 180, x, x-360)
}

reduct360to180_aspect_0 <- reduct360to180(data_aspect$state_0)
reduct360to180_aspect_1 <- reduct360to180(data_aspect$state_1)

Δ_red360to180_aspect <- abs(reduct360to180_aspect_0 - reduct360to180_aspect_1)

reduct360to180_2 <- function(x) {
    ifelse(x < 180, x, 360-x)
}

red360to180_Δ_red360to180_aspect <- reduct360to180_2(Δ_red360to180_aspect)

AsI <- mean(red360to180_Δ_red360to180_aspect/180)

AsI <- round(AsI, digits=2)

 ## Category of Landform Index (LI_c)
if (0<=LI & LI<=0.15){
    LI_c <- "Class 1"
	} else if (0.16<=LI & LI<=0.25){
	LI_c <- "Class 2"
	} else if (0.26<=LI & LI<=0.35){
	LI_c <- "Class 3"
	} else if (0.36<=LI & LI<=0.45){
	LI_c <- "Class 4"
	} else if (0.46<=LI & LI<=0.55){
	LI_c <- "Class 5"
	} else if (0.56<=LI & LI<=0.65){
	LI_c <- "Class 6"
	} else if (0.66<=LI & LI<=0.75){
	LI_c <- "Class 7"
	} else if (0.76<=LI & LI<=0.85){
	LI_c <- "Class 8"
	} else if (0.86<=LI & LI<=0.95){
	LI_c <- "Class 9"
	} else {
	LI_c <- "Class 10"
}

 ## Category of Altitude Index (AI_c)
if (0<=AI & AI<=10){
    AI_c <- "Class 1"
	} else if (11<=AI & AI<=20){
	AI_c <- "Class 2"
	} else if (21<=AI & AI<=30){
	AI_c <- "Class 3"
	} else if (31<=AI & AI<=40){
	AI_c <- "Class 4"
	} else if (41<=AI & AI<=50){
	AI_c <- "Class 5"
	} else if (51<=AI & AI<=60){
	AI_c <- "Class 6"
	} else if (61<=AI & AI<=70){
	AI_c <- "Class 7"
	} else if (71<=AI & AI<=80){
	AI_c <- "Class 8"
	} else if (81<=AI & AI<=90){
	AI_c <- "Class 9"
	} else {
	AI_c <- "Class 10"
}

 ## Adjusted Landform Index(ALI)
ALI <- as.numeric(gsub("[^0-9]", "", LI_c, ""))/10 * 0.8 +
	   as.numeric(gsub("[^0-9]", "", AI_c, ""))/10 * 0.2

 ## Category of Adjusted Landform Index (ALI_c)
ALI_c <- paste("Class",round(ALI * 10, digits=0))

 ## Category of Slope Index (SI_c)
if (0<=SI & SI<=0.05){
    SI_c <- "Class A"
	} else if (0.06<=SI & SI<=0.15){
	SI_c <- "Class B"
	} else if (0.16<=SI & SI<=0.30){
	SI_c <- "Class C"
	} else if (0.31<=SI & SI<=0.60){
	SI_c <- "Class D"
	} else {
	SI_c <- "Class E"
}

 ## Category of Aspect Index (AsI_c)
if (0<=AsI & AsI<=0.25){
    AsI_c <- "Class A"
	} else if (0.26<=AsI & AsI<=0.50){
	AsI_c <- "Class B"
	} else if (0.51<=AsI & AsI<=0.75){
	AsI_c <- "Class C"
	} else {
	AsI_c <- "Class D"
}

### Calculate Degree of Topographic Relief Alteration (DoTRA)
 ## DoTRA
Parameters <- c(
"Class A#Class A#Class 1","Class A#Class A#Class 2","Class A#Class A#Class 3",
"Class A#Class A#Class 4","Class A#Class A#Class 5","Class A#Class A#Class 6",
"Class A#Class A#Class 7","Class A#Class A#Class 8","Class A#Class A#Class 9",
"Class A#Class A#Class 10","Class A#Class B#Class 1","Class A#Class B#Class 2",
"Class A#Class B#Class 3","Class A#Class B#Class 4","Class A#Class B#Class 5",
"Class A#Class B#Class 6","Class A#Class B#Class 7","Class A#Class B#Class 8",
"Class A#Class B#Class 9","Class A#Class B#Class 10","Class A#Class C#Class 1",
"Class A#Class C#Class 2","Class A#Class C#Class 3","Class A#Class C#Class 4",
"Class A#Class C#Class 5","Class A#Class C#Class 6","Class A#Class C#Class 7",
"Class A#Class C#Class 8","Class A#Class C#Class 9","Class A#Class C#Class 10",
"Class A#Class D#Class 1","Class A#Class D#Class 2","Class A#Class D#Class 3",
"Class A#Class D#Class 4","Class A#Class D#Class 5","Class A#Class D#Class 6",
"Class A#Class D#Class 7","Class A#Class D#Class 8","Class A#Class D#Class 9",
"Class A#Class D#Class 10","Class B#Class A#Class 1","Class B#Class A#Class 2",
"Class B#Class A#Class 3","Class B#Class A#Class 4","Class B#Class A#Class 5",
"Class B#Class A#Class 6","Class B#Class A#Class 7","Class B#Class A#Class 8",
"Class B#Class A#Class 9","Class B#Class A#Class 10","Class B#Class B#Class 1",
"Class B#Class B#Class 2","Class B#Class B#Class 3","Class B#Class B#Class 4",
"Class B#Class B#Class 5","Class B#Class B#Class 6","Class B#Class B#Class 7",
"Class B#Class B#Class 8","Class B#Class B#Class 9","Class B#Class B#Class 10",
"Class B#Class C#Class 1","Class B#Class C#Class 2","Class B#Class C#Class 3",
"Class B#Class C#Class 4","Class B#Class C#Class 5","Class B#Class C#Class 6",
"Class B#Class C#Class 7","Class B#Class C#Class 8","Class B#Class C#Class 9",
"Class B#Class C#Class 10","Class B#Class D#Class 1","Class B#Class D#Class 2",
"Class B#Class D#Class 3","Class B#Class D#Class 4","Class B#Class D#Class 5",
"Class B#Class D#Class 6","Class B#Class D#Class 7","Class B#Class D#Class 8",
"Class B#Class D#Class 9","Class B#Class D#Class 10","Class C#Class A#Class 1",
"Class C#Class A#Class 2","Class C#Class A#Class 3","Class C#Class A#Class 4",
"Class C#Class A#Class 5","Class C#Class A#Class 6","Class C#Class A#Class 7",
"Class C#Class A#Class 8","Class C#Class A#Class 9","Class C#Class A#Class 10",
"Class C#Class B#Class 1","Class C#Class B#Class 2","Class C#Class B#Class 3",
"Class C#Class B#Class 4","Class C#Class B#Class 5","Class C#Class B#Class 6",
"Class C#Class B#Class 7","Class C#Class B#Class 8","Class C#Class B#Class 9",
"Class C#Class B#Class 10","Class C#Class C#Class 1","Class C#Class C#Class 2",
"Class C#Class C#Class 3","Class C#Class C#Class 4","Class C#Class C#Class 5",
"Class C#Class C#Class 6","Class C#Class C#Class 7","Class C#Class C#Class 8",
"Class C#Class C#Class 9","Class C#Class C#Class 10","Class C#Class D#Class 1",
"Class C#Class D#Class 2","Class C#Class D#Class 3","Class C#Class D#Class 4",
"Class C#Class D#Class 5","Class C#Class D#Class 6","Class C#Class D#Class 7",
"Class C#Class D#Class 8","Class C#Class D#Class 9","Class C#Class D#Class 10",
"Class D#Class A#Class 1","Class D#Class A#Class 2","Class D#Class A#Class 3",
"Class D#Class A#Class 4","Class D#Class A#Class 5","Class D#Class A#Class 6",
"Class D#Class A#Class 7","Class D#Class A#Class 8","Class D#Class A#Class 9",
"Class D#Class A#Class 10","Class D#Class B#Class 1","Class D#Class B#Class 2",
"Class D#Class B#Class 3","Class D#Class B#Class 4","Class D#Class B#Class 5",
"Class D#Class B#Class 6","Class D#Class B#Class 7","Class D#Class B#Class 8",
"Class D#Class B#Class 9","Class D#Class B#Class 10","Class D#Class C#Class 1",
"Class D#Class C#Class 2","Class D#Class C#Class 3","Class D#Class C#Class 4",
"Class D#Class C#Class 5","Class D#Class C#Class 6","Class D#Class C#Class 7",
"Class D#Class C#Class 8","Class D#Class C#Class 9","Class D#Class C#Class 10",
"Class D#Class D#Class 1","Class D#Class D#Class 2","Class D#Class D#Class 3",
"Class D#Class D#Class 4","Class D#Class D#Class 5","Class D#Class D#Class 6",
"Class D#Class D#Class 7","Class D#Class D#Class 8","Class D#Class D#Class 9",
"Class D#Class D#Class 10","Class E#Class A#Class 1","Class E#Class A#Class 2",
"Class E#Class A#Class 3","Class E#Class A#Class 4","Class E#Class A#Class 5",
"Class E#Class A#Class 6","Class E#Class A#Class 7","Class E#Class A#Class 8",
"Class E#Class A#Class 9","Class E#Class A#Class 10","Class E#Class B#Class 1",
"Class E#Class B#Class 2","Class E#Class B#Class 3","Class E#Class B#Class 4",
"Class E#Class B#Class 5","Class E#Class B#Class 6","Class E#Class B#Class 7",
"Class E#Class B#Class 8","Class E#Class B#Class 9","Class E#Class B#Class 10",
"Class E#Class C#Class 1","Class E#Class C#Class 2","Class E#Class C#Class 3",
"Class E#Class C#Class 4","Class E#Class C#Class 5","Class E#Class C#Class 6",
"Class E#Class C#Class 7","Class E#Class C#Class 8","Class E#Class C#Class 9",
"Class E#Class C#Class 10","Class E#Class D#Class 1","Class E#Class D#Class 2",
"Class E#Class D#Class 3","Class E#Class D#Class 4","Class E#Class D#Class 5",
"Class E#Class D#Class 6","Class E#Class D#Class 7","Class E#Class D#Class 8",
"Class E#Class D#Class 9","Class E#Class D#Class 10")

Parameters_Values <- c(
  0.08,0.12,0.15,0.18,0.22,0.25,0.28,0.32,0.35,0.38,0.17,0.20,0.23,0.27,0.30,
  0.33,0.37,0.40,0.43,0.47,0.25,0.28,0.32,0.35,0.38,0.42,0.45,0.48,0.52,0.55,
  0.33,0.37,0.40,0.43,0.47,0.50,0.53,0.57,0.60,0.63,0.11,0.14,0.18,0.21,0.24,
  0.28,0.31,0.34,0.38,0.41,0.19,0.23,0.26,0.29,0.33,0.36,0.39,0.43,0.46,0.49,
  0.28,0.31,0.34,0.38,0.41,0.44,0.48,0.51,0.54,0.58,0.36,0.39,0.43,0.46,0.49,
  0.53,0.56,0.59,0.63,0.66,0.15,0.18,0.22,0.25,0.28,0.32,0.35,0.38,0.42,0.45,
  0.23,0.27,0.30,0.33,0.37,0.40,0.43,0.47,0.50,0.53,0.32,0.35,0.38,0.42,0.45,
  0.48,0.52,0.55,0.58,0.62,0.40,0.43,0.47,0.50,0.53,0.57,0.60,0.63,0.67,0.70,
  0.23,0.26,0.29,0.33,0.36,0.39,0.43,0.46,0.49,0.53,0.31,0.34,0.38,0.41,0.44,
  0.48,0.51,0.54,0.58,0.61,0.39,0.43,0.46,0.49,0.53,0.56,0.59,0.63,0.66,0.69,
  0.48,0.51,0.54,0.58,0.61,0.64,0.68,0.71,0.74,0.78,0.34,0.38,0.41,0.44,0.48,
  0.51,0.54,0.58,0.61,0.64,0.43,0.46,0.49,0.53,0.56,0.59,0.63,0.66,0.69,0.73,
  0.51,0.54,0.58,0.61,0.64,0.68,0.71,0.74,0.78,0.81,0.59,0.63,0.66,0.69,0.73,
  0.76,0.79,0.83,0.86,0.89
)

DoTRA_table <- cbind(Parameters,Parameters_Values)
DoTRA_key <- paste (SI_c,AsI_c,ALI_c, sep = "#")
DoTRA <- as.numeric(DoTRA_table[grep(DoTRA_key, DoTRA_table),2])

 ## Category of DoTRA (DoTRA_c)
if (0<=DoTRA & DoTRA<=0.15){
    DoTRA_c <- "Very Low"
	} else if (0.17<=DoTRA & DoTRA<=0.25){
	DoTRA_c <- "Low"
	} else if (0.26<=DoTRA & DoTRA<=0.40){
	DoTRA_c <- "Intermediate"
	} else if (0.41<=DoTRA & DoTRA<=0.58){
	DoTRA_c <- "High"
	} else {
	DoTRA_c <- "Very High"
}

### Remove unwanted variables from memory
rm(list=ls()[! ls() %in% c("LI","AI","SI","AsI","LI_c","AI_c","ALI",
                           "ALI_c","SI_c","AsI_c","DoTRA","DoTRA_c")])

### Print DoTRA and it's indexes
msg_00 <- sprintf("LI:  %s %s",LI, LI_c)
msg_01 <- sprintf("\nAI:    %s %s",AI, AI_c)
msg_02 <- sprintf("\nSI:  %s %s",SI, SI_c)
msg_03 <- sprintf("\nAsI: %s %s",AsI, AsI_c)
msg_04 <- sprintf("\nALI: %s %s\n",ALI, ALI_c)

msg_1 <- sprintf(" The Degree of Topographic Relief Alteration is: %s", DoTRA)
msg_2 <- sprintf("\n  It is characterized as: %s\n", DoTRA_c)
cat(msg_00,msg_01,msg_02,msg_03,msg_04,msg_1,msg_2)


library(npowerPrioR)
source("../Gaussian/data_Gaussian.r")

gs.data <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = 1
)

###
get_l_a0_gaussian <- function(y0, n0, alpha0, beta0, m0, k0, a_0){
  nstar <- a_0 * n0
  ybar <- mean(y0)
  s <- mean( (y0-ybar)^2 )
  kappa_n <- k0 + nstar
  alpha_n <- alpha0 + nstar/2
  beta_n <- beta0 + .5 * (nstar * s +  (k0 * nstar * (ybar - m0)^2 )/kappa_n )
  ans <- lgamma(alpha_n)-lgamma(alpha0)
  ans <- ans + alpha0 * log(beta0) - alpha_n * log(beta_n)
  ans <- ans + .5 *( log(k0) - log(kappa_n) )-nstar/2 * log(2*pi)
  return(ans)
}
############
l_a0 <- function(x) {
  get_l_a0_gaussian(
    y0 = gs.data$y0,
    n0 = gs.data$N0,
    alpha0 = gs.data$alpha0,
    beta0 = gs.data$beta0,
    m0 = gs.data$mu0,
    k0 = gs.data$kappa0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
########

maxA <- 1
prior <- stan_model("../Gaussian/stan/simple_Gaussian_prior.stan")

# direct method
J <- 20
epsilon <- 0.05

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior, eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10,
                                       stan.list = gs.data, pars = c("mu", "sigma"))
)

# VR2018
Delta.a <- 0.01
a0s.vr2018 <- seq(0, maxA, by = Delta.a)

vr2018.time <- system.time(
  vr2018.estimates <-  create_lc_df_derivOnly(a0_grid = a0s.vr2018,
                              compiled.model.prior = prior,
                              stan.list = gs.data, pars = c("mu", "sigma") )
)

write.csv(vr2018.estimates$result,
          file = "Gaussian_VR2018.csv", row.names = FALSE)
adaptive.time
vr2018.time
###
## Now the approximations
adapt.gam <-  mgcv::gam(lc_a0 ~ s(a0, k = J), data = adaptive.ca0.estimates$result)
vr2018.estimates$result$la0_est <- cumsum(vr2018.estimates$result$deriv_lc) * Delta.a

## Finally, comparisons

K <- 20000
pred.a0s <- seq(0, maxA, length.out = K)

true.la0s <- l_a0(pred.a0s)

adaptive.preds <- predict(adapt.gam, newdata = data.frame(a0 = pred.a0s))

vr2018.preds <- approx(x = vr2018.estimates$result$a0,
                          y =  vr2018.estimates$result$la0_est,
                          xout =  pred.a0s)

plot(vr2018.preds, type = "l", lwd = 5,
     col = 3,
     xlab = expression(a[0]), ylab = "Log-normalising constant")
lines(pred.a0s, adaptive.preds, col = 2, lwd = 5)
lines(pred.a0s, true.la0s, lwd = 5, lty = 2, add = TRUE)
legend(x = "topleft", legend =  c("GAM", "VR2018", "True"),
       col = c(2, 3, 1), lwd  = 2, lty = c(1, 1, 2), bty = 'n')

preds.list <- list(
  adaptive = adaptive.preds,
  VR2018 = vr2018.preds$y
)

ntrue.la0s <- true.la0s

lapply(preds.list, function(pred) sqrt(mean( ( pred- ntrue.la0s)^2 )) )
lapply(preds.list, function(pred) mean( abs( pred- ntrue.la0s) ))


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);

  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b8;
real b9;
real b10;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u+b8*((1-exp(-n/b10))/(n/b10))+b9*((1-exp(-n/b10))/(n/b10)-exp(-n/b10))+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.028,0.01);
b8 ~ normal(0.05,0.01);
b9 ~ normal(0.05,0.01);
b10 ~ normal(0.05,0.01);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covid19modelrisk/output/forecast")

##  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
  y=read.csv("COVID-19_confirmed__US.csv")
##  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

setwd("./covid19modelrisk/output/model_with_E")

###########
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_GM.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_IT.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_JP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_SP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_UK.csv")
  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_US.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_AU.csv")

################
  E=E[,4]
##  E=E[,5]

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.028,b8=0.05,b9=0.05,b10=0.05,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)


#ddirch covariate selection based on DIC scores.
#clear environment, load packages.
rm(list=ls())
library(runjags)

#### generate pseudo data. ####
#2 informative covariates, an informative intercept, 1 uninformative covariate.
set.seed(1234)
n.obs <- 200
x1 <- runif(n.obs,20,40)
x2 <- runif(n.obs, 2, 4)
x3 <- runif(n.obs,100,110)
#x4 <- runif(n.obs,100,110)
intercept <- rep(1, n.obs)
y1 <- x1*0.5 + x2*3 + 5 + rnorm(n.obs)
y2 <- rep(10, length(y1))
y <- as.matrix(data.frame(y1,y2))
y <- y / rowSums(y)
x <- as.matrix(data.frame(intercept,x1,x2,x3))

#### Define simples ddirch JAGS model. ####
jags.model = "
model {
  #parameter priors for each species.
  alpha ~ dnorm(0, 1.0E-3)
  for(i in 1:N.preds){
    x.mm[i,1] <- 0
    for (j in 2:N.spp) {
      x.mm[i,j] ~ dnorm(0, 1.0E-3)
    }
  }

  #mean center all predictors (except intercept).
  for(i in 1:N){
    x.center[i,1] <- 1
    for(j in 2:N.preds){
      x.center[i,j] <- x[i,j] - mean(x[,j])
    }
  }

  #save mean values for back transforming intercept values.
  for(j in 1:N.preds){x.center.save[j] <- mean(x[,j])}

  #fit species abundances as a linear combination of predictors and parameters.
  for(i in 1:N){
    for(j in 1:N.spp){
      log(a0[i,j]) <- alpha + inprod(x.mm[,j], x.center[i,])
    }
    y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
  }

  #map to original parameterization, assuming first column of predictors is intercept.
  for (j in 1:N.spp) {
    x.m[1,j] <- alpha + x.mm[1,j] - inprod(x.mm[2:N.preds,j], x.center.save[2:N.preds])
    for (i in 2:N.preds){
      x.m[i,j] <- x.mm[i,j]
    }
  }
} #close model loop.
"
#### define model for fixed parameters ####
fix.model = "
model{
  #mean center all predictors (except intercept).
  for(i in 1:N){
    x.center[i,1] <- 1
    for(j in 2:N.preds){
      x.center[i,j] <- x[i,j] - mean(x[,j])
    }
  }

  #fit species abundances as a linear combination of predictors and parameters.
  for(i in 1:N){
    for(j in 1:N.spp){
      log(a0[i,j]) <- alpha + inprod(x.mm[,j], x.center[i,])
    }
    y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
  }
} #close model loop.
"

#### fit JAGS model, get deviance and pD ####
jags.data <- list(y=y,x=x,N.preds = ncol(x), N.spp=ncol(y), N = nrow(y))
jags.out <- run.jags(model = jags.model, data = jags.data, adapt=100,burnin=300,sample=300,n.chains=3, monitor = c('x.mm','alpha','deviance'))
jags.sum <- summary(jags.out)
jags.dev <- jags.sum[grep('deviance', rownames(jags.sum)),][4]
jags.mm  <- jags.sum[grep('x.mm'    , rownames(jags.sum)),][,4]
jags.alp <- jags.sum[grep('alpha'   , rownames(jags.sum)),][4]
#convert jags.mm to matrix of mean values
dim(jags.mm) <- c(ncol(x),ncol(y))
#get pD with fix model.
pD.data <- list(y=y,x=x,N.preds = ncol(x), N = nrow(y), N.spp = ncol(y), alpha = jags.alp, x.mm = jags.mm)
pD.model <- run.jags(model = fix.model, data = pD.data, adapt=100,burnin=300,sample=300,n.chains=3, monitor = c('deviance'))
pD.sum   <- summary(pD.model)
pD       <- pD.sum[3]
dic      <- 2*jags.dev - pD

#### leave one predictor out at a time, calculate dic. ####
jags.compare.dic   <- list()
jags.compare.sum   <- list()
for(i in 2:ncol(x)){
  new.x <- x[,-i]
  jd <- list(y=y,x=new.x,N.preds = ncol(new.x), N.spp=ncol(y), N = nrow(y))
  jags.out <- run.jags(model = jags.model, data = jd, adapt=100,burnin=300,sample=300,n.chains=3, monitor = c('x.mm','alpha','deviance'))
  jags.sum <- summary(jags.out)
  jags.dev <- jags.sum[grep('deviance', rownames(jags.sum)),][ 4]
  jags.mm  <- jags.sum[grep('x.mm'    , rownames(jags.sum)),][,4]
  jags.alp <- jags.sum[grep('alpha'   , rownames(jags.sum)),][ 4]
  #convert jags.mm to matrix of mean values
  dim(jags.mm) <- c(ncol(new.x),ncol(y))
  #get pD with fix model.
  pD.data <- list(y=y,x=new.x,N.preds = ncol(new.x), N = nrow(y), N.spp = ncol(y), alpha = jags.alp, x.mm = jags.mm)
  pD.model <- run.jags(model = fix.model, data = pD.data, adapt=100,burnin=300,sample=300,n.chains=3, monitor = c('deviance'))
  pD.sum   <- summary(pD.model)
  pD       <- pD.sum[3]
  jags.compare.dic[[i-1]] <- 2*jags.dev - pD
  jags.compare.sum[[i-1]] <- jags.sum
}
jags.compare.dic <- unlist(jags.compare.dic)
names(jags.compare.dic) <- colnames(x[,2:ncol(x)])

#### which model improves DIC the most? ####
#dic says don't you dare remove x1 or x2. Supports removing x3 by 2-3 points.
dic
jags.compare.dic

#### Testing with function. ####
source('NEFI_functions/covariate_selection_JAGS.r')
test <- covariate_selection_JAGS(y=y,x=x)

#### plotting y vs preditor relationships. ####
#just to prove- plot y as a function x1-x3
par(mfrow = c(ncol(x)-1,ncol(y)))
for(i in 2:4){
  plot(y[,1] ~ x[,i], main = paste0('y1 ~ x',i))
  abline(lm(y[,1] ~ x[,i]), lwd =2 , col = 'green')
  plot(y[,2] ~ x[,i], main = paste0('y2 ~ x',i))
  abline(lm(y[,2] ~ x[,i]), lwd =2 , col = 'green')
}


#' c2f
#'
#' Convert celsius to fahrenheit.
#'
#' @param x A vector of temperature values in celsius
#' @return A vector of fahrenheit values
#'
#' @export
#'
#'
#'

c2f <- function(x) {
  F = (x * 9/5) + 32
  return(F)
}


123 + 456

123 - 456

123 * 456

123 / 456

pi

x = 12345
print(x)

x <- 123
x

x = 255
sqrt(x)

sqrt(123)

x = 123
log(x)

sin(pi/2)

y = 3:7
print(y)

z = c(1, 2, 5, 4, 7)
print(z)

sqrt(z)

print(z + 1.0)

length(z)

sum(z)

mean(z)

z[1]

z[2:4]


valoreX <- 5
alfa <- 0.0081

domanda2_1 <- 9
domanda2_2 <- 5

teta <- 1 - sqrt(alfa)

prX <- function(x){

  if( x >= 1 ){

    return(teta*(1-teta)^(x-1))

  } else{

    return(0)

  }

}

print(teta)

prIntersezione <- 0

for( i in domanda2_2:domanda2_1 ){

  prIntersezione <- prIntersezione + prX(i)

}

prCondizionante <- 1

for( i in 1:(domanda2_2-1) ){

  prCondizionante <- prCondizionante - prX(i)

}

print(prIntersezione/prCondizionante)
print(prIntersezione/alfa)


#' Wrapper for generating a summary set
#'
#' Allows arbitrary sample overlap
#'
#' @param beta_gx Array of true effects on x
#' @param beta_gy Array of true effects on y
#' @param af Array of effect allele frequencies
#' @param n_gx Sample size of g-x association
#' @param n_gy Sample size of g-y association
#' @param n_overlap Number of overlapping samples
#' @param cor_xy Observational correlation between x and y
#' @param prev_y Disease prevalence of y. Default = NA (in which case treated as continuous)
#' @param sigma_x SD of x. Default=1
#' @param sigma_y SD of y. Default=1
#'
#' @export
#' @return Data frame of summary statistics for x and y
summary_set <- function(beta_gx, beta_gy, af, n_gx, n_gy, n_overlap, cor_xy, prev_y=NA, sigma_x=1, sigma_y=1)
{
  stopifnot(length(beta_gy) == length(beta_gx))
  stopifnot(length(af) == length(beta_gx))
  stopifnot(all(af < 1 & af > 0))
  stopifnot(cor_xy <= 1 & cor_xy >= -1)
  stopifnot(n_overlap <= min(n_gx, n_gy))

  nsnp <- length(beta_gx)

  if(n_overlap == 0)
  {
    bhat_gx <- generate_gwas_ss(params=dplyr::tibble(beta=beta_gx, af=af, snp=1:nsnp), nid=n_gx, vy=sigma_x^2)
    bhat_gy <- generate_gwas_ss(params=dplyr::tibble(beta=beta_gy, af=af, snp=1:nsnp), nid=n_gy, vy=sigma_y^2)
    dat <- merge_exp_out(bhat_gx, bhat_gy)
    return(dat)
  }

  G_prob <- cbind(af^2, 2*af*(1-af), (1-af)^2)

  if(!is.na(prev_y))
  {
    myfunc <- function(af, Gamma0, Gamma1, prev)
    {
      af^2 * stats::plogis(Gamma0 + Gamma1 * 2) + 2 * af * (1 - af) * stats::plogis(Gamma0 + Gamma1) + (1 - af)^2 * stats::plogis(Gamma0) - prev
    }

    Gamma0 <- numeric(nsnp)
    for(i in 1:nsnp)
    {
      Gamma0[i] <- stats::uniroot(myfunc, Gamma1=beta_gy[i], af=af[i], prev=prev_y, lower=-10, upper=10)$root
    }

    var_gy <- asymp_var_logistic(n_gy, G_prob, Gamma0, beta_gy)
    var_gx <- asymp_var_linear(n_gx, G_prob, sigma=sigma_x)
    cov_gx_gy <- asymp_cov_linear_logistic(n_overlap, n_gx, n_gy, G_prob, cor_xy=cor_xy, sigma=sigma_x, Gamma_0=Gamma0, Gamma_1=beta_gy, prev=prev_y)
  }

  var_gy <- asymp_var_linear(n_gy, G_prob, sigma=sigma_y)
  var_gx <- asymp_var_linear(n_gx, G_prob, sigma=sigma_x)
  cov_gx_gy <- asymp_cov_linear_linear(n_overlap, n_gx, n_gy, G_prob, sigma_x=sigma_x, sigma_y=sigma_y,cor_xy=cor_xy)

  cov_array <- array(dim=c(2, 2, nsnp))
  cov_array[1,1,] <- var_gx
  cov_array[2,1,] <- cov_gx_gy
  cov_array[1,2,] <- cov_array[2,1,]
  cov_array[2,2,] <- var_gy

  summary_stats <- apply(cov_array, 3, function(x)
  {
    MASS::mvrnorm(n=1, mu=c(0,0), Sigma=x)
  })

  summary_stats <- t(summary_stats + rbind(beta_gx, beta_gy))

  dat <- dplyr::tibble(
    SNP = 1:nsnp,
    id.exposure="X",
    id.outcome="Y",
    exposure="X",
    outcome="Y",
    beta.exposure = summary_stats[,1],
    beta.outcome = summary_stats[,2],
    se.exposure = sqrt(var_gx),
    se.outcome = sqrt(var_gy),
    fval.exposure = (beta.exposure/se.exposure)^2,
    fval.outcome = (beta.outcome/se.outcome)^2,
    pval.exposure = pf(fval.exposure, df1=1, df2=n_gx-1, lower.tail=FALSE),
    pval.outcome = pf(fval.outcome, df1=1, df2=n_gy-1, lower.tail=FALSE),
    eaf.exposure = af,
    eaf.outcome = af,
    mr_keep=TRUE
  )
  return(dat)
}

## calculate asymptotic version of (X^t W X)
asymp_var_logistic <- function(n,G_prob,Gamma_0,Gamma_1){
  N <- length(Gamma_0)
  disease_probs <- stats::plogis(outer(Gamma_0,c(1,1,1)) +  outer(Gamma_1,c(0,1,2)))
  diag_weights <- disease_probs*(1-disease_probs)

  a <- n*apply(G_prob*diag_weights,1,sum)
  b <- n*apply(G_prob*diag_weights*matrix(rep(c(0,1,2),N),byrow=TRUE,nrow=N),1,sum)
  c <-  b
  d <- n*apply(G_prob*diag_weights*matrix(rep(c(0,1,4),N),byrow=TRUE,nrow=N),1,sum)

  ##  invert matrix and take element for Gamma1
  return(a/(a*d-b*c))

}

asymp_var_linear <- function(n,G_prob,sigma=1){
  N <- nrow(G_prob)

  a <- n*apply(G_prob,1,sum)
  b <- n*apply(G_prob*matrix(rep(c(0,1,2),N),byrow=TRUE,nrow=N),1,sum)
  c <-  b
  d <- n*apply(G_prob*matrix(rep(c(0,1,4),N),byrow=TRUE,nrow=N),1,sum)

  ##  invert matrix and take element for Gamma1
  return(a/(a*d-b*c)*sigma^2)

}

asymp_cov_linear_linear <- function(n_overlap,n_gx,n_gy,G_prob,sigma_x=1,sigma_y=1,cor_xy=.5){
  N <- nrow(G_prob)
    cov_xy <- cor_xy*sigma_x*sigma_y

  a <- apply(G_prob,1,sum)
  b <- apply(G_prob*matrix(rep(c(0,1,2),N),byrow=TRUE,nrow=N),1,sum)
  c <-  b
  d <- apply(G_prob*matrix(rep(c(0,1,4),N),byrow=TRUE,nrow=N),1,sum)

  ##  invert matrix and take element for Gamma1
  return(n_overlap*(a/(a*d-b*c))*cov_xy/(n_gx*n_gy))

}

asymp_cov_linear_logistic <- function(n_overlap,n_gx,n_gy,G_prob,cor_xy=0,sigma=1,Gamma_0,Gamma_1,prev=0.01){
  N <- length(Gamma_0)
  cov_xy <- cor_xy*sigma*sqrt(prev*(1-prev))
  disease_probs <- stats::plogis(outer(Gamma_0,c(1,1,1)) +  outer(Gamma_1,c(0,1,2)))
  diag_weights <- disease_probs*(1-disease_probs)

  a <- apply(G_prob*diag_weights,1,sum)
  b <- apply(G_prob*diag_weights*matrix(rep(c(0,1,2),N),byrow=TRUE,nrow=N),1,sum)
  c <-  b
  d <- apply(G_prob*diag_weights*matrix(rep(c(0,1,4),N),byrow=TRUE,nrow=N),1,sum)

  ##  invert matrix and take element for Gamma1
  return(n_overlap*(a/(a*d-b*c))*cov_xy/(n_gx*n_gy))

}


cat("MCMC functions\n")
#   MCMC;
##  Set up MCMC;
### Parameter bookkeeping;
logit <- function(x){
  exp(x)/(1+exp(x))
}
invlogit <- function(x){
  x[which(x==0)] <- 10^(-16)
  x[which(x==1)] <- 1-10^(-16)
  log(x/(1-x))
}

# this new admlink is much faster.
admlink <- function(i,dat,span){
  link <- as.numeric(dat[i]-dat>=span[1] & dat[i]-dat<span[2] &
                     (1:length(dat))<i)
  return(link)
}

transfpar <- function(par) c(par[1],exp(par[2:3]))
invtransfpar <- function(par) c(par[1],log(par[2:3]))

makelinklist <- function(par,tdata){
  mat <- sapply(1:length(tdata),
         function(x) admlink(x,timedata,
           c(-par[1],length(probtab(transfpar(par)))-1-par[1])))
  return(t(mat))
}

nupdate <- function(ll){
  vec <- apply(ll,1,function(x) length(x[x==1]))
  return(vec)
}

### Distribution;
normpdf <- function(x,m,s){
  dnorm(x,mean=m,sd=s)
}

gammapdf <- function(x,r,l){
  dgamma(x,shape=r,scale=l)
}

dirchpdf <- function(p,u){
  z <- prod(gamma(u))/gamma(sum(u))
  return(prod(p^(u-1))/z)
}

linkdirchpdf <- function(p,u,link){
  prob <- p[link==1]
  value <- u[link==1]
  if (length(prob)==0) {return(1)}
  return(dirchpdf(prob,value))
}

normalize <- function(pvec){
  if (sum(pvec)==0) {return(pvec)}
  return(pvec/sum(pvec))
}

### Random sample generators
gammarnd <- function(theta){
  rgamma(1,shape=theta[1],scale=theta[2])
}

gammamixrnd <- function(theta){
  ifelse(rbinom(1,1,theta[1]),gammarnd(exp(theta[2],exp(theta[3]))),
                              gammarnd(exp(theta[4],exp(theta[5]))))
}

dirchrand <- function(u){
  vec<-sapply(1:length(u),function(x) rgamma(1,shape=u[x],scale=1))
  vec<-normalize(vec)
  return(vec)
}

genuni <- function(lw,up){
  runif(1,min=lw,max=up)
}

### Likelihood functions;
ilik <- function(k,tmdat,theta,pvec){
  sum(probij(k,c(1:length(tmdat)),transfpar(theta),tmdat)*pvec)
}

mlvec <- function(k,tmdat,tpvec,theta){
  tmp <- probij(k,c(1:length(tmdat)),transfpar(theta),tmdat)*tpvec
  Max <- max(tmp)
  posmax <- which(tmp==Max)
  nul <- rep(0,length(tmdat))
  tmp <- nul
  tmp[posmax] <- 1
  if (Max==0) {return(nul)} else {return(normalize(tmp))}
}

initvec <- function(k,tmdat,tpvec,theta){
  tmp <- probij(k,c(1:length(tmdat)),transfpar(theta),tmdat)*tpvec
  Max <- max(tmp)
  posmax <- which(tmp==Max)
  nul <- rep(0,length(tmdat))
  tmp <- nul
  tmp[posmax] <- 1
  if (Max==0) {return(nul)} else {
    return(normalize(tmp+rgamma(1,shape=4,scale=0.004)))}
}

### Priors

thetaprior <- function(transftheta){
  tmp <- sapply(1:length(ltppars[,1]),
    function(x) normpdf(transftheta[x],ltppars[x,1],ltppars[x,2]))
  return(prod(tmp))
}

pmatprior <- function(pmat,link){
  tmp[i] <- sapply(1:length(pmppars),
    function(x) linkdirchpdf(pmat[x],pmppars[x],link[x]))
  return(prod(tmp))
}

typeprior <- function(typepvec){
  dirchpdf(typepvec,tppriorpars)
}

### Posterior
post <- function(dat,transftheta,link,pmat){
  tmp <- sapply(1:length(pmat[,1]),
    function(x) ilik(x,dat,transftheta,link[x,]*pmprior[x,]*pmat[x,]))
  return(thetaprior(transftheta)*prod(tmp[which(tmp!=0)]))
}

logpost <- function(dat,transftheta,link,pmat){
  tmp <- sapply(1:length(pmat[,1]),
    function(x) ilik(x,dat,transftheta,link[x,]*pmprior[x,]*pmat[x,]))
  return(log(thetaprior(transftheta))+sum(log(tmp[which(tmp!=0)])))
}
### Generate candidate parameter values
dthcand <- function(){
  tmp <- sapply(1:length(ltppars[,1]),
    function(x) ifelse(sigth[x]==0,0,rnorm(1,0,sigth[x])))
  return(tmp)
}

candtheta <- function(){
  oldtheta+dthcand()
}

dpcand <- function(){
  matrix(rnorm(length(pmppars[1,])^2,0,sigp),nrow=length(pmppars[1,]))
}

candpmat <- function(){
  t(apply(logit(invlogit(oldpmat)+dpcand())*linklist,1,normalize))
}

typecand <- function(){
  tmp <- sapply(1:length(sigtp),function(x) rnorm(1,0,sigtp[x]))
  return(tmp)
}

candtpmat <- function(){
  normalize(logit(invlogit(oldvec)+typecand()))
}

upd.theta <- function(sigth){
  if (sum(sigth)>0) {
    newtheta <- candtheta()
    linklist <- makelinklist(newtheta,timedata)*typemat
  } else{
    newtheta <- oldtheta
  }
  return(newtheta)
}

upd.typemat <- function(updtype,typemat){
  if (updtype!=0){
    if (tu==0){
      newtypes <- mctype1(oldtypes,freqtype)
      typemat <- mctypemat(newtypes)
      tu <- updtype
    } else{
      tu <- tu-1
    }
  }
  return(typemat)
}

upd.pmat <- function(sigp){
  if(sigp!=0){
    newpmat <- candpmat()
  }else{
    newpmat <- oldpmat
  }
  return(newpmat)
}

### Adaptive rejection sampling (Metropolis-Hastings)
btest <- function(sk){
  newtheta <- upd.theta(sigth)
  typemat <- upd.typemat(updtype,typemat)
  newpmat <- upd.pmat(sigp)
  newlogpost <- logpost(timedata,newtheta,linklist*typemat,newpmat)
  while(!is.finite(newlogpost)){
    newtheta <- upd.theta(sigth)
    typemat <- upd.typemat(updtype,typemat)
    newpmat <- upd.pmat(sigp)
    newlogpost <- logpost(timedata,newtheta,linklist*typemat,newpmat)
  }
  logratio <- newlogpost - oldlogpost
  # cat(" ",logratio," ")
  if (exp(logratio)>=genuni(0,1)){
    oldlogpost <<- newlogpost
    logoldpost <<- -2*oldlogpost
    if (updtype!=0){
      oldtypes <<- newtypes
    }
    oldtheta <<- newtheta
    oldpmat <<- newpmat
    acc <<- acc+1
  } else{rej <<- rej+1}
  if (sk==iterskip){
    inc()
    sk <- 1
  } else{sk <- sk+1}
  return(sk)
}

inc <- function(){
  posttrail[[length(posttrail)+1]] <<- logoldpost
  #pmtrail[[length(pmtrail)+1]] <<- oldpmat
  if (updtype!=0){
    typetrail[[length(typetrail)+1]] <<- oldtypes
  }
  if (sum(sigth)>0){
    thetatrail[[length(thetatrail)+1]] <<- oldtheta
  }
}

gentimes <- function(r){
  oldperc <- 0;
  progbar(0,r);
  for (j in 1:r){
    sk <- btest(sk)
    if (pmpost>logoldpost){
      pmpost <<- logoldpost
      pmth <<- oldtheta
      pmpv <<- oldpmat
      pmtp <<- oldtypes
    }
    newperc <- round(100*j/r);
    if(newperc - oldperc >= 2){
      progbar(j,r);
      oldperc <- newperc;
    }
  }
  cat("\n")
}

burnin <- function(mclist,intro){
  choose <- seq(from=intro,to=length(mclist),by=1)
  return(mclist[choose])
}

thinning <- function(mclist,thinskip){
  choose <- seq(from=1,to=length(mclist),by=thinskip)
  return(mclist[choose])
}

progbar <- function(j,r){
  prgri <- round(100*j/r);
  star <- round(50*j/r); spce <- 50 - star;
  bsp <- ifelse(prgri<10,2,3);
  if(j!=0) cat(rep("\b",52+bsp),sep="");
  cat("|",sep="");
  cat(rep("*",star),sep="");
  cat(rep(" ",spce),sep="");
  cat("|",sep="");
  cat(prgri,"%",sep="");
}


### set of simple functions for computing simpler alpha diversity metrics

#' @name alpha_diversity
#' @aliases richness
#' @aliases simpson
#' @aliases shannon
#' @title Compute alpha diversity metrics
#'
#' Note that the Simpson index here is the probability that two individuals randomly drawn will
#' be of the same taxon, and thus gets larger as diveristy *decreases*.
#' @rdname alpha_diversity
#' @param x A matrix with rows as sites and species as columns. Values are abundances or
#' 		presence/absence
#' @return A vector of diversity values
#' @export
richness <- function(x) {
	if(any(x < 0)) stop("Values in x must be positive")
	x[x > 0] <- 1
	x[x != 1] <- 0
	rowSums(x)
}

#' @rdname alpha_diversity
#' @param proportion Logical. If true, abundances in x are considered proportional abundances.
#' 		If false, x will be transformed to proportional abundance
#' @export
simpson <- function(x, proportion=TRUE) {
	if(any(x < 0) | (proportion & any(rowSums(x) > 1))) stop("Abundances must be >= 0 and must be <= 1 if proportion=TRUE")
	if(! proportion) {
		N <- matrix(rowSums(x), nrow=nrow(x), ncol=ncol(x))
		x <- x/N
	}
	apply(x, 1, function(xx) sum(xx^2))
}

#' @rdname alpha_diversity
#' @export
shannon <- function(x) {
	if(!all(.fp_equal(rowSums(x), 1))) {
		warning(paste("Data for shannon diversity are not proportions;",
		              "data will be rescaled to proportional cover"))
		x <- t(apply(x, 1, function(xx) xx/sum(xx)))
	}
	apply(x, 1, function(xx) {
		xx <- xx[xx!= 0]
		-sum(xx * log(xx))
	})
}

.fp_equal <- function(x,y,tol=1e-9) {
	abs(x - y) <= tol
}


cat("Calculating likelihoods under different motif lengths...\n")
# Calculate likelihoods
rates_full$logLik1 <- dbinom(rates_full$num,
  rates_full$COUNT,
  rates_full$rel_prop1, log=T)

rates_full$logLik3 <- dbinom(rates_full$num,
  rates_full$COUNT,
  rates_full$rel_prop3, log=T)

rates_full$logLik5 <- dbinom(rates_full$num,
  rates_full$COUNT,
  rates_full$rel_prop5, log=T)

rates_full$logLik7 <- dbinom(rates_full$num,
  rates_full$COUNT,
  rates_full$rel_prop, log=T)

ra1<-rates_full %>%
  group_by(Category2) %>%
  summarise(L1=-2*sum(logLik1),
    L3=-2*sum(logLik3),
    L5=-2*sum(logLik5),
		L7=-2*sum(logLik7))

ra1a<-gather(ra1, model, log, L1:L7)

ra1a$k <- c(rep(1,9),
  c(rep(16,3), rep(12,3), rep(4,3)),
  c(rep(256,3), rep(192,3), rep(64,3)),
	c(rep(4096,3), rep(3072,3), rep(1024,3)))

ra1a$AIC <- 2*ra1a$k+ra1a$log

ra1c <- merge(ra1a, rates1, by="Category2")
# ra1c$BIC <- ra1c$k*log(ra1c$num1)+ra1c$log

ra1b <- gather(ra1c, stat, L, c(log, AIC))
levels(ra1b$model) <- c("1", "3", "5", "7")

levels(ra1b$stat) <- c("-2ln(L)", "AIC")
names(ra1b) <- c("Category", "Motif_Length", "k", "COUNT",
  "num1", "rel_prop", "Stat", "L")

# Plot AIC and -2log(L) for each category
cat("Plotting likelihood curves...\n")
ggplot(ra1b, aes(x=Motif_Length, y=L, group=Stat, colour=Stat))+
  scale_colour_brewer(palette="Set1")+
  geom_point()+
  geom_line()+
  facet_wrap(~Category, scales="free")+
  theme_bw()+
  xlab("Motif Length")+
  theme(axis.title.y=element_blank(),
    legend.title=element_blank())

ggsave("/net/bipolar/jedidiah/mutation/images/compare_AIC.png")

rf2<-rates_full %>%
  group_by(Category2, Seq3) %>%
  summarise(s3=-2*sum(logLik3), s5=-2*sum(logLik5)) %>%
  ungroup() %>%
  arrange(Category2, desc(s5)) %>%
  group_by(Category2) %>%
  mutate(D3_5=s5-s3,s3s=sum(s3)) %>%
  arrange(D3_5) %>%
  mutate(D3_5c=cumsum(D3_5),
    L=s3s+D3_5c,
    rk=rank(-L),
    rk2=max(rk)-rk+16*rk,
    rk3=rk2,
    gp="3>5")

rf3 <- rates_full %>%
  group_by(Category2, Seq5) %>%
  summarise(s5=-2*sum(logLik5), s7=-2*sum(logLik7)) %>%
  ungroup() %>%
  arrange(Category2, desc(s7)) %>%
  group_by(Category2) %>%
  mutate(D5_7=s7-s5,s5s=sum(s5)) %>%
  arrange(D5_7) %>%
  mutate(D5_7c=cumsum(D5_7),
    L=s5s+D5_7c,
    rk=rank(-L),
    rk2=max(rk)-rk+16*rk,
    rk3=min(rk2)+min(rk2)*rk2/max(rk2),
    gp="5>7")

names(rf3)[2] <- "Sequence"
names(rf2)[2] <- "Sequence"

rfc <- rbind(dplyr::select(rf2, Category2, Sequence, L, rk, rk2, rk3, gp),
  dplyr::select(rf3, Category2, Sequence, L, rk, rk2, rk3, gp))

write.table(ra1b, "/net/bipolar/jedidiah/mutation/ra1b.txt", col.names=T, row.names=F, quote=F, sep="\t")

l1ll <- ra1b %>%
  filter(Motif_Length %in% c("L1", "L3"), Stat=="log") %>%
  dplyr::mutate(Sequence=substr(Category, 1,1), rk=5, rk2=k,
    rk3=min(rk2)+min(rk2)*rk2/max(rk2), gp=Motif_Length) %>%
  dplyr::select(Category2=Category, Sequence, L, rk, rk2, rk3, gp)

rfc2 <- merge(rbind(l1ll, rfc), rates1, by="Category2")

rfc2$AIC <- 2*rfc2$rk2 + rfc2$L
rfc2$BIC <- rfc2$rk2*log(rfc2$num1) + rfc2$L

rfc3<-gather(rfc2, z=AIC:BIC)

ggplot(rfc3, aes(x=rk3, y=value, group=key, colour=key))+
  scale_x_continuous(expand = c(.15, .15))+
  scale_y_continuous(expand = c(.1, .1))+
  scale_colour_brewer(palette="Dark2")+
  geom_point(size=4, aes(alpha=0.4))+
  facet_wrap(~Category2, scales="free")+
  theme_bw()+
  ylab("-2log(L)")+
  theme(axis.title.x=element_blank(),
    axis.text.x=element_blank(),
    axis.title.y=element_text(size=16),
    axis.text.y=element_text(size=14),
    strip.text.x = element_text(size=16),
    legend.title=element_blank(),
    legend.text=element_text(size=16))

ggsave("/net/bipolar/jedidiah/mutation/images/compare_AIC-BIC_full.png",
  width=12, height=12)

ggplot(rfc2, aes(x=rk3, y=L))+
  scale_x_continuous(expand = c(.15, .15))+
  scale_y_continuous(expand = c(.1, .1))+
  scale_colour_brewer(palette="Set1")+
  geom_point(size=4, aes(colour=gp))+
  geom_line()+
  geom_text(size=6, angle=10,
    aes(label=ifelse(rk<5, as.character(Sequence), ''),
      hjust=rep(c(1,-0.5), length.out=length(Sequence)),
      vjust=0.5))+#rep(c(.5,-.5), length.out=length(Sequence))))+
  facet_wrap(~Category2, scales="free")+
  theme_bw()+
  ylab("-2log(L)")+
  theme(axis.title.x=element_blank(),
    axis.text.x=element_blank(),
    axis.title.y=element_text(size=16),
    axis.text.y=element_text(size=14),
    strip.text.x = element_text(size=16),
    legend.title=element_blank(),
    legend.text=element_text(size=16))

ggsave("/net/bipolar/jedidiah/mutation/images/compare_LL_full.png",
  width=12, height=12)


# load the libraries (install them if needed)
library(data.table)
library(ggplot2)
library(stringr)
library(minpack.lm)

# cleaning up the environment (probably not needed, but better safe than sorry)
rm(list=ls())
gc()

# read in the COVID Australia data, downloaded from https://www.covidaustralia.com/cases
dt <- fread("covid_australia.csv")

# pre-define the string of months to fix the date format in the original data
mmm <- c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")

# mess around with the date column to get it sorted in the right format
dt[,`:=`(mo=str_pad(match(substr(mody,1,3),month.abb),2,pad="0"),dy=str_pad(str_trim(as.character(substr(dt$mody,5,6))),2,pad="0"))]
dt[,`:=`(date=as.Date(paste(yr,mo,dy,sep="-")))]

# store the numbers as numbers
dt[,`:=`(vic=as.numeric(vic),nsw=as.numeric(nsw),qld=as.numeric(qld),wa=as.numeric(wa),sa=as.numeric(sa),tas=as.numeric(tas),act=as.numeric(act),nt=as.numeric(nt),total=as.numeric(total))]

# toss some unused columns -- keep the ones we (may) need
covid_dt <- dt[date>=as.Date("2021-06-06"),.(date,total,nsw,vic,qld,wa,sa,tas,act,nt)]
covid_dt <- covid_dt[order(date)]

# add trend and weekdays
covid_dt[,`:=`(trend=as.numeric(as.factor(date)),wday=weekdays(date,abbreviate=T))]

# order the weekday factors
covid_dt$wday <- factor(covid_dt$wday,levels=c("Mon","Tue","Wed","Thu","Fri","Sat","Sun"))

# main model: logistic smooth transition regression of the form: y_t = a + b G(t;g,c)
# where G(t;g,c)=(1+exp[-g(t-c)/sd(t)])^{-1} is the logistic transition function,
# and where g and c are parameters of this logistic transition function.

# fit the restricted logistic smooth transition model (we restrict a=0)

# obtain approximate starting values (usually quite important)
covid_dt$G <- as.numeric((1+exp(-(2/sd(covid_dt$trend))*(covid_dt$trend-max(covid_dt$trend))))^(-1))

theta <- as.numeric(c(lm(nsw~G-1,data=covid_dt)$coef,2,max(covid_dt$trend)))
theta <- 0.9*theta+rnorm(length(theta),0,0.01)
names(theta) <- c("b","g","c")

# fit the nonlinear least squares
reg_str <- nlsLM(nsw~b*((1+exp(-g/sd(trend)*(trend-c)))^(-1)),data=covid_dt,start=theta,lower=c(-Inf,.1,-Inf),upper=c(Inf,100,Inf),control=nls.control(maxiter=1000,warnOnly=T))

# the estimated logistic function
Ghat <- (1+exp(-coefficients(reg_str)["g"]/(sd(covid_dt$trend))*(covid_dt$trend-coefficients(reg_str)["c"])))^(-1)

# store the fitted values into the dataset
covid_dt$yhat_str <- coefficients(reg_str)["b"]*Ghat

# generate bootstrap parameters
B <- 1000
boot_mat <- matrix(NA,B,length(coefficients(reg_str)))
for(i in 1:B){
  set.seed(i)
  eboot_str <- sample(residuals(reg_str),length(residuals(reg_str)),replace=T)
  covid_dt$yboot_str <- round(covid_dt$yhat_str+residuals(reg_str)*sample(c(-1,1),length(residuals(reg_str)),replace=T))
  boot_str <- nlsLM(yboot_str~b*((1+exp(-g/sd(trend)*(trend-c)))^(-1)),data=covid_dt,start=theta,lower=c(-Inf,.1,-Inf),upper=c(Inf,100,Inf),control=nls.control(maxiter=1000,warnOnly=T))
  boot_mat[i,] <- coefficients(boot_str)
}

colnames(boot_mat) <- names(coefficients(boot_str))

# multi-day forecast horizon
h <- 7

trend_f <- c(as.numeric(max(covid_dt$trend)+1):as.numeric(max(covid_dt$trend)+h))

# point forecast
Ghat_f <- ((1+exp(-coefficients(reg_str)["g"]/(sd(covid_dt$trend))*(trend_f-coefficients(reg_str)["c"])))^(-1))

ystr_f <- coefficients(reg_str)["b"]*Ghat_f

# bootstrap forecasts
ystr_b <- matrix(NA,length(ystr_f),B)
for(i in 1:B){
  Ghat_b <- ((1+exp(-boot_mat[i,"g"]/(sd(covid_dt$trend))*(trend_f-boot_mat[i,"c"])))^(-1))

  ystr_b[,i] <- boot_mat[i,"b"]*Ghat_b
}

ystr_ci <- as.data.table(t(apply(ystr_b,1,quantile,c(.025,.975))))
colnames(ystr_ci) <- c("lower","upper")

# arrange the dataset to bind together the fitted and forecast values along with the observed data
nsw_dt <- covid_dt[,.(date,observed=nsw,forecast=yhat_str)]
nsw_dt[,`:=`(lower=NA,upper=NA)]
nsw_fc <- data.table(date=seq(covid_dt[date==max(date)]$date+1,by="day",length.out=h),observed=NA,forecast=ystr_f,lower=ystr_ci$lower,upper=ystr_ci$upper)

# bind the in-sample and out-of-sample segments
nsw_cb <- rbind(nsw_dt,nsw_fc)

# melt to 'long table' for plotting purposes
nsw_lg <- melt(nsw_cb,id.vars=c("date","lower","upper"))
nsw_lg$variable <- factor(nsw_lg$variable,levels=c("observed","forecast"))

# plot the graph
gg_plot_str <- ggplot(nsw_lg,aes(x=date,y=value))+
  geom_ribbon(aes(ymin=lower,ymax=upper),fill="steelblue",alpha=.25)+
  geom_line(aes(color=variable,linetype=variable),size=.5,na.rm=T)+
  scale_color_manual(values=c("darkgray","steelblue"))+
  scale_linetype_manual(values=c(1,5))+
  labs(title="COVID NSW",subtitle=paste("Forecast made on",format(as.Date(max(covid_dt$date)),"%d %b %Y"),"for the subsequent seven days"),x="Date",y="Daily Cases",caption="Source of the data: https://www.covidaustralia.com/cases")+
  theme_classic()+
  theme(axis.title=element_text(size=12),axis.text=element_text(size=10),legend.title=element_blank(),legend.text=element_text(size=8),legend.position=c(.025,1),legend.justification=c(0,1),plot.caption = element_text(color="darkgray",size=9),plot.subtitle=element_text(size=9),legend.key.size=unit(0.5,"cm"))

# save the figure
ggsave("covid_star.png",gg_plot_str,dpi="retina",width=6.5,height=3.5)

# print the rounded case numbers for the forecast period
forecast_dt <- nsw_fc[,.(date,forecast)]
forecast_dt$weekday <- weekdays(forecast_dt$date,abbreviate=T)

forecast_dt <- forecast_dt[,.(weekday,date=format(date,"%d %b"),forecast=round(forecast))]

# an alternative model: exponential trend: y_t = exp(a+b*t)
reg_exp <- nlsLM(nsw~exp(a+trend*b),data=covid_dt,start=list(a=1,b=.1),control=nls.control(maxiter=1000,warnOnly=T))
covid_dt$yhat_exp <- c(fitted(reg_exp))

# seven-day forecast
trend_f <- c(as.numeric(max(covid_dt$trend)+1):as.numeric(max(covid_dt$trend)+h))
yexp_f <- exp(coef(reg_exp)["a"]+trend_f*coef(reg_exp)["b"])

# arrange the dataset to bind together the fitted and forecast values along with the observed data
nsw_dt <- covid_dt[,.(date,observed=nsw,logistic=yhat_str,exponential=yhat_exp)]
nsw_dt[,`:=`(lower=NA,upper=NA)]
nsw_fc <- data.table(date=seq(covid_dt[date==max(date)]$date+1,by="day",length.out=h),observed=NA,logistic=ystr_f,exponential=yexp_f,lower=ystr_ci$lower,upper=ystr_ci$upper)

nsw_cb <- rbind(nsw_dt,nsw_fc)

# melt to 'long table' for plotting purposes
nsw_lg <- melt(nsw_cb,id.vars=c("date","lower","upper"))
nsw_lg$variable <- factor(nsw_lg$variable,levels=c("observed","logistic","exponential"))

# plot the graph
gg_plot_comb <- ggplot(nsw_lg,aes(x=date,y=value))+
  geom_ribbon(aes(ymin=lower,ymax=upper),fill="steelblue",alpha=.25)+
  geom_line(aes(color=variable,linetype=variable),size=.5,na.rm=T)+
  scale_color_manual(values=c("darkgray","steelblue","indianred"))+
  scale_linetype_manual(values=c(1,5,2))+
  labs(title="COVID NSW",subtitle=paste("Forecast made on",format(as.Date(max(covid_dt$date)),"%d %b %Y"),"for the subsequent seven days"),x="Date",y="Daily Cases",caption="Source of the data: https://www.covidaustralia.com/cases")+
  theme_classic()+
  theme(axis.title=element_text(size=12),axis.text=element_text(size=10),legend.title=element_blank(),legend.text=element_text(size=8),legend.position=c(.025,1),legend.justification=c(0,1),plot.caption = element_text(color="darkgray",size=9),plot.subtitle=element_text(size=9),legend.key.size=unit(0.5,"cm"))

# save the figure
ggsave("covid_models.png",gg_plot_comb,dpi="retina",width=6.5,height=3.5)


model_potentialtranspiration <- function (evapoTranspiration = 830.958,
         tau = 0.9983){
    #'- Name: PotentialTranspiration -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: PotentialTranspiration Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA/LEPSE Montpellier
    #'            * Abstract: SiriusQuality2 uses availability of water from the soil reservoir as a method to restrict
    #'                    transpiration as soil moisture is depleted
    #'- inputs:
    #'            * name: evapoTranspiration
    #'                          ** description : evapoTranspiration
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 830.958
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: tau
    #'                          ** description : plant cover factor
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.9983
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'- outputs:
    #'            * name: potentialTranspiration
    #'                          ** description : potential Transpiration
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    potentialTranspiration <- evapoTranspiration * (1.0 - tau)
    return (list('potentialTranspiration' = potentialTranspiration))
}


 ZGEESX Example Program Results

 Matrix A
                    1                 2                 3                 4
 1  (-3.9700,-5.0400) (-4.1100, 3.7000) (-0.3400, 1.0100) ( 1.2900,-0.8600)
 2  ( 0.3400,-1.5000) ( 1.5200,-0.4300) ( 1.8800,-5.3800) ( 3.3600, 0.6500)
 3  ( 3.3100,-3.8500) ( 2.5000, 3.4500) ( 0.8800,-1.0800) ( 0.6400,-1.4800)
 4  (-1.1000, 0.8200) ( 1.8100,-1.5900) ( 3.2500, 1.3300) ( 1.5700,-3.4400)

 Number of eigenvalues for which SELECT is true =    2
 (dimension of invariant subspace)

 Selected eigenvalues
    1   ( 7.9982,-0.9964)
    2   ( 3.0023,-3.9998)


#' @useDynLib VN
#' @importFrom Rcpp sourceCpp
NULL

#' Matches Graphs given a seeding of vertex correspondences
#'
#' Given two adjacency matrices \code{A} and \code{B} of the same size, match
#' the two graphs with the help of \code{m} seed vertex pairs which correspond
#' to \code{m} rows (and columns) of the adjacency matrices.
#'
#' The approximate graph matching problem is to find a bijection between the
#' vertices of two graphs , such that the number of edge disagreements between
#' the corresponding vertex pairs is minimized. For seeded graph matching, part
#' of the bijection that consist of known correspondences (the seeds) is known
#' and the problem task is to complete the bijection by estimating the
#' permutation matrix that permutes the rows and columns of the adjacency
#' matrix of the second graph.
#'
#' It is assumed that for the two supplied adjacency matrices \code{A} and
#' \code{B}, both of size \eqn{n\times n}{n*n}, the first \eqn{m} rows(and
#' columns) of \code{A} and \code{B} correspond to the same vertices in both
#' graphs. That is, the \eqn{n \times n}{n*n} permutation matrix that defines
#' the bijection is \eqn{I_{m} \bigoplus P} for a \eqn{(n-m)\times
#' (n-m)}{(n-m)*(n-m)} permutation matrix \eqn{P} and \eqn{m} times \eqn{m}
#' identity matrix \eqn{I_{m}}. The function \code{match_vertices} estimates
#' the permutation matrix \eqn{P} via an optimization algorithm based on the
#' Frank-Wolfe algorithm.
#'
#' See references for further details.
#'
# @aliases match_vertices seeded.graph.match
#' @param A a numeric matrix, the adjacency matrix of the first graph
#' @param B a numeric matrix, the adjacency matrix of the second graph
#' @param seeds a numeric matrix, the number of seeds x 2 matching vertex table.
#' If \code{S} is \code{NULL}, then it is using a \eqn{soft} seeding algorithm.
#' @param hard a bloolean, TRUE for hard seeding, FALSE for soft seeding.
#' @param pad a scalar value for padding
#' @param maxiter The number of maxiters for the Frank-Wolfe algorithm
#' @return A numeric matrix which is the permutation matrix that determines the
#' bijection between the graphs of \code{A} and \code{B}
#' @author Vince Lyzinski \url{http://www.ams.jhu.edu/~lyzinski/}
#' @references Vogelstein, J. T., Conroy, J. M., Podrazik, L. J., Kratzer, S.
#' G., Harley, E. T., Fishkind, D. E.,Vogelstein, R. J., Priebe, C. E. (2011).
#' Fast Approximate Quadratic Programming for Large (Brain) Graph Matching.
#' Online: \url{http://arxiv.org/abs/1112.5507}
#'
#' Fishkind, D. E., Adali, S., Priebe, C. E. (2012). Seeded Graph Matching
#' Online: \url{http://arxiv.org/abs/1209.0367}
#'
#' @export

sgm <- function (A,B,seeds,hard=TRUE,pad=0,start="barycenter",maxiter=20){
    gamma <- 0.1
    nv1<-nrow(A)
    nv2<-nrow(B)
    nv<-max(nv1,nv2)

    if(is.null(seeds)) { # no seed!
        m=0
        if (start=="barycenter") {
            S<-matrix(1/nv,nv,nv)
        } else {
            S <- rsp(nv,gamma)
        }
        AA <- A
        BB <- B
    }else {
        A.ind <- c(seeds[,1], setdiff(1:nv1, seeds[,1]))
        B.ind <- c(seeds[,2], setdiff(1:nv2, seeds[,2]))
        AA <- A[A.ind, A.ind]
        BB <- B[B.ind, B.ind]

        m <- nrow(seeds)
        if (hard==TRUE) {
            n <- nv-m
            if (start=="barycenter") {
                S <- matrix(1/n,n,n)
            } else {
                S <- rsp(n,gamma)
            }
        } else {
            s <- m
            m <- 0
            if (start=="barycenter") {
                diag1 <- diag(s)
                diag2 <- matrix(1/(nv-s),nv-s,nv-s)
                offdiag <- matrix(0,s,nv-s)
                S <- rbind(cbind(diag1,offdiag), cbind(t(offdiag),diag2))
            } else {
                M <- rsp(nv-s,gamma)
                S <- diag(nv);
                S[(s+1):nv,(s+1):nv] <- M
            }
        }
    }

    P <- sgm.ordered(AA,BB,m,S,pad,maxiter)
    return(P)
}

sgm2 <- function (A,B,seeds,hard=TRUE,pad=0,start="barycenter",maxiter=20){
    gamma <- 0.1
    if(is.null(seeds)){ # no seed!
        m=0
        nv1<-nrow(A)
        nv2<-nrow(B)
        nv<-max(nv1,nv2)
        if (start=="barycenter") {
            S<-matrix(1/nv,nv,nv)
        } else {
            S <- rsp(nv,gamma)
        }
        AA <- A
        BB <- B
    }else{
        nv1<-nrow(A)
        nv2<-nrow(B)
        nv<-max(nv1,nv2)

        s1<-seeds[,1]
        temp<-s1
        s1<-rep(FALSE,nv1)
        s1[temp]<- TRUE
        ns1 <- !s1

        s2<-seeds[,2]
        temp<-s2
        s2<-rep(FALSE,nv2)
        s2[temp]<- TRUE
        ns2 <- !s2

        A11<-A[s1,s1]
        A12<-A[s1,ns1]
        A22<-A[ns1,ns1]
        A21<-A[ns1,s1]

        AA<-rbind(cbind(A11,A12),cbind(A21,A22))

        B11<-B[s2,s2]
        B12<-B[s2,ns2]
        B22<-B[ns2,ns2]
        B21<-B[ns2,s2]

        BB<-rbind(cbind(B11,B12),cbind(B21,B22))

        if(hard==TRUE){
            m <- length(temp)
            n <- nv-m
            if (start=="barycenter") {
                S <- matrix(1/n,n,n)
            } else {
                S <- rsp(n,gamma)
            }
        }else{
            m <- 0
            s <- length(temp)
            if (start=="barycenter") {
                S <- rbind(cbind(diag(s),matrix(0,s,nv-s)),cbind(matrix(0,nv-s,s),matrix(1/(nv-s),nv-s,nv-s)))
            } else {
                M <- rsp(nv-s,gamma)
                S <- diag(nv);
                S[(s+1):nv,(s+1):nv] <- M
            }
        }
    }

    P <- sgm.ordered(AA,BB,m,S,pad,maxiter)
    return(P)
}

#' Matches Graphs given a seeding of vertex correspondences
#'
#' Given two adjacency matrices \code{A} and \code{B} of the same size, match
#' the two graphs with the help of \code{m} seed vertex pairs which correspond
#' to the first \code{m} rows (and columns) of the adjacency matrices.
#'
#' The approximate graph matching problem is to find a bijection between the
#' vertices of two graphs , such that the number of edge disagreements between
#' the corresponding vertex pairs is minimized. For seeded graph matching, part
#' of the bijection that consist of known correspondences (the seeds) is known
#' and the problem task is to complete the bijection by estimating the
#' permutation matrix that permutes the rows and columns of the adjacency
#' matrix of the second graph.
#'
#' It is assumed that for the two supplied adjacency matrices \code{A} and
#' \code{B}, both of size \eqn{n\times n}{n*n}, the first \eqn{m} rows(and
#' columns) of \code{A} and \code{B} correspond to the same vertices in both
#' graphs. That is, the \eqn{n \times n}{n*n} permutation matrix that defines
#' the bijection is \eqn{I_{m} \bigoplus P} for a \eqn{(n-m)\times
#' (n-m)}{(n-m)*(n-m)} permutation matrix \eqn{P} and \eqn{m} times \eqn{m}
#' identity matrix \eqn{I_{m}}. The function \code{match_vertices} estimates
#' the permutation matrix \eqn{P} via an optimization algorithm based on the
#' Frank-Wolfe algorithm.
#'
#' See references for further details.
#'
# @aliases match_vertices seeded.graph.match
#' @param A a numeric matrix, the adjacency matrix of the first graph
#' @param B a numeric matrix, the adjacency matrix of the second graph
#' @param m The number of seeds. The first \code{m} vertices of both graphs are
#' matched.
#' @param start a numeric matrix, the permutation matrix estimate is
#' initialized with \code{start}
#' @param pad a scalar value for padding
#' @param maxiter The number of maxiters for the Frank-Wolfe algorithm
#' @param LAP a character either "exact" or "approx"
#' @return A numeric matrix which is the permutation matrix that determines the
#' bijection between the graphs of \code{A} and \code{B}
#' @author Vince Lyzinski \url{http://www.ams.jhu.edu/~lyzinski/}
#' @references Vogelstein, J. T., Conroy, J. M., Podrazik, L. J., Kratzer, S.
#' G., Harley, E. T., Fishkind, D. E.,Vogelstein, R. J., Priebe, C. E. (2011).
#' Fast Approximate Quadratic Programming for Large (Brain) Graph Matching.
#' Online: \url{http://arxiv.org/abs/1112.5507}
#'
#' Fishkind, D. E., Adali, S., Priebe, C. E. (2012). Seeded Graph Matching
#' Online: \url{http://arxiv.org/abs/1209.0367}
#'
#' @export
sgm.ordered <- function(A,B,m,start,pad=0,maxiter=20,LAP="exact",verbose=FALSE){
    #seeds are assumed to be vertices 1:m in both graphs
#    suppressMessages(library(clue))
    totv1<-ncol(A)
    totv2<-ncol(B)
    if(totv1>totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv1-totv2
#        for (j in 1:diff){B<-cbind(rbind(B,pad),pad)}
        B <- cbind(B, matrix(pad, nrow(B), diff))
        B <- rbind(B, matrix(pad, diff, ncol(B)))
    }else if(totv1<totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv2-totv1
#        for (j in 1:diff){A<-cbind(rbind(A,pad),pad)}
        A <- cbind(A, matrix(pad, nrow(A), diff))
        A <- rbind(A, matrix(pad, diff, ncol(A)))
    }
    totv<-max(totv1,totv2)
    n<-totv-m
    if (m==0){
        A12 <- A21 <- B12 <- B21 <- matrix(0,n,n)
    } else {
        A12<-rbind(A[1:m,(m+1):(m+n)])
        A21<-cbind(A[(m+1):(m+n),1:m])
        B12<-rbind(B[1:m,(m+1):(m+n)])
        B21<-cbind(B[(m+1):(m+n),1:m])
    }
    if (n==1) {
        A12 <- A21 <- B12 <- B21 <- t(A12)
    }

    A22<-A[(m+1):(m+n),(m+1):(m+n)]
    tA22 <- t(A22)
    B22<-B[(m+1):(m+n),(m+1):(m+n)]
    tB22 <- t(B22)
    tol<-1
    P<-start
    toggle<-1
    iter<-0
    x<- A21 %*% t(B21)
    y<- t(A12) %*% B12
    xy <- x + y
    while (toggle==1 & iter<maxiter)
    {
        iter<-iter+1
        z <- A22 %*% P %*% tB22
        w <- tA22 %*% P %*% B22
        Grad <- xy+z+w;

        if (LAP=="exact") {
            mm <- max(abs(Grad))
            ind<-matrix(clue::solve_LSAP(Grad+matrix(mm,totv-m,totv-m), maximum =TRUE))
        } else { # approx
            temp <- matrix(0, n, n)
            Grad1 <- rbind(cbind(temp, t(Grad)),cbind(Grad, temp))
            ind <- parallelMatch(Grad1)
        }

        Pdir <- diag(n)
        Pdir <- Pdir[ind,]
        tPdir <- t(Pdir)
        tP <- t(P)
        wt <- tA22 %*% Pdir %*% B22
        c <- sum(diag(w %*% tP))
        d <- sum(diag(wt %*% tP)) + sum(diag(w %*% tPdir))
        e <- sum(diag(wt %*% tPdir))
        u <- sum(diag(tP %*% x + tP %*% y))
        v <- sum(diag(tPdir %*% x + tPdir %*% y))
        if( c-d+e==0 && d-2*e+u-v==0){
            alpha <- 0
        }else{
            alpha <- -(d-2*e+u-v)/(2*(c-d+e))}
        f0 <- 0
        f1 <- c-e+u-v
        falpha <- (c-d+e)*alpha^2+(d-2*e+u-v)*alpha
        if(alpha < tol && alpha > 0 && falpha > f0 && falpha > f1){
            P <- alpha*P+(1-alpha)*Pdir
        }else if(f0 > f1){
            P <- Pdir
        }else{
            toggle<-0}
        if (verbose) cat("iter = ", iter, "\n")
    }
    D<-P

    if (LAP=="exact") {
        corr<-matrix(clue::solve_LSAP(P, maximum = TRUE))
    } else {
        PP <- rbind(cbind(temp, t(P)),cbind(P, temp))
        corr<- t(parallelMatch(PP))
    }
    P=diag(n)
    P=rbind(cbind(diag(m),matrix(0,m,n)),cbind(matrix(0,n,m),P[corr,]))
    corr<-cbind(matrix((m+1):totv, n),matrix(m+corr,n))
    return(list(corr=corr[,2], P=P, D=D, iter=iter))
}

#' @export
sgm.ordered.rk1<-function(A,B,m,start,pad=0,maxiter=20,symmetric=TRUE){
    #seeds are assumed to be vertices 1:m in both graphs
#    require('clue')
    totv1<-ncol(A)
    totv2<-ncol(B)
    X<-stfp(A,1)$X
    Y<-stfp(B,1)$X
    if(symmetric==FALSE){
        XX<-stfp(t(A),1)$X
        X<-rbind(X,XX)
        YY<-stfp(t(B),1)$X
        Y<-rbind(Y,YY)
        A=A-t(X)%*%X
        B=B-t(Y)%*%Y
    }else{
        A=A-X%*%t(X)
        B=B-Y%*%t(Y)}
    if(totv1>totv2){
        diff<-totv1-totv2
#        for (j in 1:diff){B<-cbind(rbind(B,0),0)}
        B <- cbind(B, matrix(pad, nrow(B), diff))
        B <- rbind(B, matrix(pad, diff, ncol(B)))
    }else if(totv1<totv2){
        diff<-totv2-totv1
#        for (j in 1:diff){A<-cbind(rbind(A,0),0)}
        A <- cbind(A, matrix(pad, nrow(A), diff))
        A <- rbind(A, matrix(pad, diff, ncol(A)))
    }
    totv<-max(totv1,totv2)
    n<-totv-m
    if (m==0){
        A12<-matrix(0,n,n)
        A21<-matrix(0,n,n)
        B12<-matrix(0,n,n)
        B21<-matrix(0,n,n)
    } else {
        A12<-rbind(A[1:m,(m+1):(m+n)])
        A21<-cbind(A[(m+1):(m+n),1:m])
        B12<-rbind(B[1:m,(m+1):(m+n)])
        B21<-cbind(B[(m+1):(m+n),1:m])
    }
    if (n==1){
        A12=t(A12)
        A21=t(A21)
        B12=t(B12)
        B21=t(B21)
    }
    A22<-A[(m+1):(m+n),(m+1):(m+n)]
    tA22 <- t(A22)
    B22<-B[(m+1):(m+n),(m+1):(m+n)]
    tB22 <- t(B22)
    tol<-1
    P<-start
    toggle<-1
    iter<-0
    x<- A21%*%t(B21)
    y<- t(A12)%*%B12
    while (toggle==1 & iter<maxiter)
    {
        iter<-iter+1
        z<- A22 %*% P %*% tB22
        w<- tA22 %*% P %*% B22
        Grad<-x+y+z+w;
        mm=max(abs(Grad))
        ind<-matrix(clue::solve_LSAP(Grad+matrix(mm,totv-m,totv-m), maximum =TRUE))
        T<-diag(n)
        T<-T[ind,]
        tT <- t(T)
        wt<-tA22 %*% T %*% B22
        tP <- t(P)
        c<-sum(diag(w%*%tP))
        d<-sum(diag(wt%*%tP)) + sum(diag(w%*%tT))
        e<-sum(diag(wt%*%tT))
        u<-sum(diag(tP%*%x + tP%*%y))
        v<-sum(diag(tT%*%x + tT%*%y))
        if( c-d+e==0 && d-2*e+u-v==0){
            alpha<-0
        }else{
            alpha<- -(d-2*e+u-v)/(2*(c-d+e))}
        f0<-0
        f1<- c-e+u-v
        falpha<-(c-d+e)*alpha^2+(d-2*e+u-v)*alpha
        if(alpha < tol && alpha > 0 && falpha > f0 && falpha > f1){
            P<- alpha*P+(1-alpha)*T
        }else if(f0 > f1){
            P<-T
        }else{
            toggle<-0}
    }
    D<-P
    corr<-matrix(clue::solve_LSAP(P, maximum = TRUE))
    P=diag(n)
    P=rbind(cbind(diag(m),matrix(0,m,n)),cbind(matrix(0,n,m),P[corr,]))
    corr<-cbind(matrix((m+1):totv, n),matrix(m+corr,n))
    return(list(corr=corr[,2], P=P, D=D, iter=iter))
}

#' @export
sgm.ordered.cross <- function(A,B,m,start,pad=0,maxiter=20){
    #seeds are assumed to be vertices 1:m in both graphs
    #    suppressMessages(library(clue))
    totv1<-ncol(A)
    totv2<-ncol(B)
    if(totv1>totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv1-totv2
#        for (j in 1:diff){B<-cbind(rbind(B,pad),pad)}
        B <- cbind(B, matrix(pad, nrow(B), diff))
        B <- rbind(B, matrix(pad, diff, ncol(B)))
    }else if(totv1<totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv2-totv1
#        for (j in 1:diff){A<-cbind(rbind(A,pad),pad)}
        A <- cbind(A, matrix(pad, nrow(A), diff))
        A <- rbind(A, matrix(pad, diff, ncol(A)))
    }
    totv<-max(totv1,totv2)
    n<-totv-m
    if (m==0){
        A12<-matrix(0,n,n)
        A21<-matrix(0,n,n)
        B12<-matrix(0,n,n)
        B21<-matrix(0,n,n)
    } else {
        A12<-rbind(A[1:m,(m+1):(m+n)])
        A21<-cbind(A[(m+1):(m+n),1:m])
        B12<-rbind(B[1:m,(m+1):(m+n)])
        B21<-cbind(B[(m+1):(m+n),1:m])
    }
    if (n==1) {
        A12=t(A12)
        A21=t(A21)
        B12=t(B12)
        B21=t(B21)
    }

    A22<-A[(m+1):(m+n),(m+1):(m+n)]
    B22<-B[(m+1):(m+n),(m+1):(m+n)]
    tol<-1
    P<-start
    toggle<-1
    iter<-0
    x<- tcrossprod(A21, B21) # A21 %*% t(B21)
    y<- crossprod(A12, B12) #t(A12) %*% B12
    while (toggle==1 & iter<maxiter)
    {
        iter <- iter+1
        z <- tcrossprod(crossprod(t(A22),P), B22) #     A22 %*% P %*% t(B22)
        w <- crossprod(t(crossprod(A22, P)), B22) #     t(A22) %*% P %*% B22
        Grad<-x+y+z+w;
        mm=max(abs(Grad))
        ind<-matrix(clue::solve_LSAP(Grad+matrix(mm,totv-m,totv-m), maximum =TRUE))
        T<-diag(n)
        T<-T[ind,]
        wt <- crossprod(t(crossprod(A22, T)), B22) #     t(A22) %*% T %*% B22
        c <- sum(diag(tcrossprod(w, P)))  # w %*% t(P)
        d <- sum(diag(tcrossprod(wt, P))) + sum(diag(tcrossprod(w, T))) # wt %*% t(P), w %*% t(T)
        e<-sum(diag(tcrossprod(wt, T))) # wt %*% t(T)
        u<-sum(diag(crossprod(P, x) + crossprod(P, y))) # t(P) %*% x, t(P) %*% y
        v<-sum(diag(crossprod(T, x) + crossprod(T, y))) # t(T) %*% x, t(T) %*% y
        if( c-d+e==0 && d-2*e+u-v==0){
            alpha<-0
        }else{
            alpha<- -(d-2*e+u-v)/(2*(c-d+e))}
        f0<-0
        f1<- c-e+u-v
        falpha<-(c-d+e)*alpha^2+(d-2*e+u-v)*alpha
        if(alpha < tol && alpha > 0 && falpha > f0 && falpha > f1){
            P<- alpha*P+(1-alpha)*T
        }else if(f0 > f1){
            P<-T
        }else{
            toggle<-0}
    }
    D<-P
    corr<-matrix(clue::solve_LSAP(P, maximum = TRUE))
    P=diag(n)
    P=rbind(cbind(diag(m),matrix(0,m,n)),cbind(matrix(0,n,m),P[corr,]))
    corr<-cbind(matrix((m+1):totv, n),matrix(m+corr,n))
    return(list(corr=corr[,2], P=P, D=D, iter=iter))
}

#' @export
sgm.ordered.rcpp <- function(A,B,m,start,pad=0,maxiter=20){
    #seeds are assumed to be vertices 1:m in both graphs
#    suppressMessages(library(clue))
    totv1<-ncol(A)
    totv2<-ncol(B)
    if(totv1>totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv1-totv2
        B <- cbind(B, matrix(pad, nrow(B), diff))
        B <- rbind(B, matrix(pad, diff, ncol(B)))
#        for (j in 1:diff){B<-cbind(rbind(B,pad),pad)}
    }else if(totv1<totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv2-totv1
        A <- cbind(A, matrix(pad, nrow(A), diff))
        A <- rbind(A, matrix(pad, diff, ncol(A)))
#        for (j in 1:diff){A<-cbind(rbind(A,pad),pad)}
    }
    totv<-max(totv1,totv2)
    n<-totv-m
    if (m==0){
        A12<-matrix(0,n,n)
        A21<-matrix(0,n,n)
        B12<-matrix(0,n,n)
        B21<-matrix(0,n,n)
    } else {
        A12<-rbind(A[1:m,(m+1):(m+n)])
        A21<-cbind(A[(m+1):(m+n),1:m])
        B12<-rbind(B[1:m,(m+1):(m+n)])
        B21<-cbind(B[(m+1):(m+n),1:m])
    }
    if (n==1) {
        A12=t(A12)
        A21=t(A21)
        B12=t(B12)
        B21=t(B21)
    }

    A22<-A[(m+1):(m+n),(m+1):(m+n)]
    B22<-B[(m+1):(m+n),(m+1):(m+n)]
    tol<-1
    P<-start
    toggle<-1
    iter<-0
    x<- armaMatMult(A21, t(B21)) #A21 %*% t(B21)
    y<- armaMatMult(t(A12), B12) #t(A12) %*% B12
    while (toggle==1 & iter<maxiter)
    {
        iter<-iter+1
        z<- armaMatMult(armaMatMult(A22, P), t(B22))  #A22 %*% P %*% t(B22)
        w<- armaMatMult(armaMatMult(t(A22), P), B22)  # t(A22) %*% P %*% B22
        Grad<-x+y+z+w;
        mm=max(abs(Grad))
        ind<-matrix(clue::solve_LSAP(Grad+matrix(mm,totv-m,totv-m), maximum =TRUE))
        T<-diag(n)
        T<-T[ind,]
        wt<- armaMatMult(armaMatMult(t(A22), T), B22)    #t(A22) %*% T %*% B22
        c<-sum(diag(armaMatMult(w, t(P))))
        d<-sum(diag(armaMatMult(wt, t(P)))) + sum(diag(armaMatMult(w, t(T))))
        e<-sum(diag(armaMatMult(wt, t(T))))
        u<-sum(diag(armaMatMult(t(P), x) + armaMatMult(t(P),y)))
        v<-sum(diag(armaMatMult(t(T), x) + armaMatMult(t(T),y)))
        if( c-d+e==0 && d-2*e+u-v==0){
            alpha<-0
        }else{
            alpha<- -(d-2*e+u-v)/(2*(c-d+e))}
        f0<-0
        f1<- c-e+u-v
        falpha<-(c-d+e)*alpha^2+(d-2*e+u-v)*alpha
        if(alpha < tol && alpha > 0 && falpha > f0 && falpha > f1){
            P<- alpha*P+(1-alpha)*T
        }else if(f0 > f1){
            P<-T
        }else{
            toggle<-0}
    }
    D<-P
    corr<-matrix(clue::solve_LSAP(P, maximum = TRUE))
    P=diag(n)
    P=rbind(cbind(diag(m),matrix(0,m,n)),cbind(matrix(0,n,m),P[corr,]))
    corr<-cbind(matrix((m+1):totv, n),matrix(m+corr,n))
    return(list(corr=corr[,2], P=P, D=D, iter=iter))
}

#' @export
sgm.ordered.gpu <- function(A,B,m,start,pad=0,maxiter=20){
    #seeds are assumed to be vertices 1:m in both graphs
#    suppressMessages(library(clue))
    suppressMessages(library(gpuR))
    totv1<-ncol(A)
    totv2<-ncol(B)
    if(totv1>totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv1-totv2
        B <- cbind(B, matrix(pad, nrow(B), diff))
        B <- rbind(B, matrix(pad, diff, ncol(B)))
        #        for (j in 1:diff){B<-cbind(rbind(B,pad),pad)}
    }else if(totv1<totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv2-totv1
        A <- cbind(A, matrix(pad, nrow(A), diff))
        A <- rbind(A, matrix(pad, diff, ncol(A)))
        #        for (j in 1:diff){A<-cbind(rbind(A,pad),pad)}
    }
    totv<-max(totv1,totv2)
    n<-totv-m
    if (m==0){
        A12<-matrix(0,n,n)
        A21<-matrix(0,n,n)
        B12<-matrix(0,n,n)
        B21<-matrix(0,n,n)
    } else {
        A12<-rbind(A[1:m,(m+1):(m+n)])
        A21<-cbind(A[(m+1):(m+n),1:m])
        B12<-rbind(B[1:m,(m+1):(m+n)])
        B21<-cbind(B[(m+1):(m+n),1:m])
    }
    if (n==1) {
        A12=t(A12)
        A21=t(A21)
        B12=t(B12)
        B21=t(B21)
    }

    A22<-A[(m+1):(m+n),(m+1):(m+n)]
    B22<-B[(m+1):(m+n),(m+1):(m+n)]
    tol<-1
    P<-start
    toggle<-1
    iter<-0
    A21.g <- gpuMatrix(A21, type="float")
    tB21.g <- gpuMatrix(t(B21), type="float")
    x.g <- A21.g %*% tB21.g; x <- as.matrix(x.g)
    tA12.g <- gpuMatrix(t(A12), type="float")
    B12.g <- gpuMatrix(B12, type="float")
    y.g <- tA12.g %*% B12.g; y <- as.matrix(y.g)

    A22.g <- gpuMatrix(A22, type="float")
    B22.g <- gpuMatrix(B22, type="float")
    tA22.g <- gpuMatrix(t(A22), type="float")
    tB22.g <- gpuMatrix(t(B22), type="float")

    while (toggle==1 & iter<maxiter)
    {
        iter<-iter+1
        P.g <- gpuMatrix(P, type="float")
        tP.g <- gpuMatrix(t(P), type="float")
        z<- A22.g %*% P.g %*% tB22.g; z <- as.matrix(z)
        w.g <- tA22.g %*% P.g %*% B22.g; w <- as.matrix(w.g)
        Grad<-x+y+z+w;
        mm=max(abs(Grad))
        ind<-matrix(clue::solve_LSAP(Grad+matrix(mm,totv-m,totv-m), maximum =TRUE))
        T<-diag(n)
        T<-T[ind,]
        T.g <- gpuMatrix(T, type="float")
        tT.g <- gpuMatrix(t(T), type="float")
        wt.g <- tA22.g %*% T.g %*% B22.g; wt <- as.matrix(wt.g)
        c<-sum(diag(as.matrix(w.g %*% tP.g)))
        d<-sum(diag(as.matrix(wt.g %*% tP.g))) + sum(diag(as.matrix(w.g %*% tT.g)))
        e<-sum(diag(as.matrix(wt.g %*% tT.g)))
        u<-sum(diag(as.matrix(tP.g %*% x.g) + as.matrix(tP.g %*% y.g)))
        v<-sum(diag(as.matrix(tT.g %*% x.g) + as.matrix(tT.g %*% y.g)))
        if( c-d+e==0 && d-2*e+u-v==0){
            alpha<-0
        }else{
            alpha<- -(d-2*e+u-v)/(2*(c-d+e))}
        f0<-0
        f1<- c-e+u-v
        falpha<-(c-d+e)*alpha^2+(d-2*e+u-v)*alpha
        if(alpha < tol && alpha > 0 && falpha > f0 && falpha > f1){
            P<- alpha*P+(1-alpha)*T
        }else if(f0 > f1){
            P<-T
        }else{
            toggle<-0}
    }
    D<-P
    corr<-matrix(clue::solve_LSAP(P, maximum = TRUE))
    P=diag(n)
    P=rbind(cbind(diag(m),matrix(0,m,n)),cbind(matrix(0,n,m),P[corr,]))
    corr<-cbind(matrix((m+1):totv, n),matrix(m+corr,n))
    return(list(corr=corr[,2], P=P, D=D, iter=iter))
}

sgm.ordered.sparse <- function(A,B,m,start,pad=0,maxiter=20){
  #seeds are assumed to be vertices 1:m in both graphs
  totv1<-ncol(A)
  totv2<-ncol(B)
  if(totv1>totv2){
    A[A==0]<- -1
    B[B==0]<- -1
    diff<-totv1-totv2
#    for (j in 1:diff){B<-cbind(rbind(B,pad),pad)}
    B <- cbind(B, matrix(pad, nrow(B), diff))
    B <- rbind(B, matrix(pad, diff, ncol(B)))
  }else if(totv1<totv2){
    A[A==0]<- -1
    B[B==0]<- -1
    diff<-totv2-totv1
#    for (j in 1:diff){A<-cbind(rbind(A,pad),pad)}
    A <- cbind(A, matrix(pad, nrow(A), diff))
    A <- rbind(A, matrix(pad, diff, ncol(A)))
  }
  totv<-max(totv1,totv2)
  n<-totv-m
  if (m==0){
      A12<-matrix(0,n,n)
      A21<-matrix(0,n,n)
      B12<-matrix(0,n,n)
      B21<-matrix(0,n,n)
  } else {
      A12<-rbind(A[1:m,(m+1):(m+n)])
      A21<-cbind(A[(m+1):(m+n),1:m])
      B12<-rbind(B[1:m,(m+1):(m+n)])
      B21<-cbind(B[(m+1):(m+n),1:m])
  }
  if (n==1) {
      A12=Matrix::t(A12)
      A21=Matrix::t(A21)
      B12=Matrix::t(B12)
      B21=Matrix::t(B21)
  }

  A22<-A[(m+1):(m+n),(m+1):(m+n)]
  B22<-B[(m+1):(m+n),(m+1):(m+n)]
  tol<-1
  P <- start
  toggle<-1
  iter<-0
  x<- A21%*%Matrix::t(B21)
  y<- Matrix::t(A12)%*%B12
  while (toggle==1 & iter<maxiter)
  {
    iter<-iter+1
    z<- A22 %*% P %*% Matrix::t(B22)
    w<- Matrix::t(A22) %*% P %*% B22
    Grad<-x+y+z+w;
    mm=max(abs(Grad))
    ind<-matrix(clue::solve_LSAP(as.matrix(Grad)+matrix(mm,totv-m,totv-m), maximum =TRUE))
    T<-diag(n)
    T<-T[ind,]
    wt<-Matrix::t(A22) %*% T %*% B22
    c<-sum(diag(w%*%Matrix::t(P)))
    d<-sum(diag(wt%*%Matrix::t(P)))+sum(diag(w%*%Matrix::t(T)))
    e<-sum(diag(wt%*%Matrix::t(T)))
    u<-sum(diag(Matrix::t(P)%*%x+Matrix::t(P)%*%y))
    v<-sum(diag(Matrix::t(T)%*%x+Matrix::t(T)%*%y))
    if( c-d+e==0 && d-2*e+u-v==0){
      alpha<-0
    }else{
      alpha<- -(d-2*e+u-v)/(2*(c-d+e))}
    f0<-0
    f1<- c-e+u-v
    falpha<-(c-d+e)*alpha^2+(d-2*e+u-v)*alpha
    if(alpha < tol && alpha > 0 && falpha > f0 && falpha > f1){
      P<- alpha*P+(1-alpha)*T
    }else if(f0 > f1){
      P<-T
    }else{
      toggle<-0}
  }
  D<-P
  corr<-matrix(clue::solve_LSAP(P, maximum = TRUE))
  P=diag(n)
  P=rbind(cbind(diag(m),matrix(0,m,n)),cbind(matrix(0,n,m),P[corr,]))
  corr<-cbind(matrix((m+1):totv, n),matrix(m+corr,n))
  return(list(corr=corr[,2], P=P, D=D, iter=iter))
}

#' Matches Graphs given a seeding of vertex correspondences (igraph implmentation)
#'
#' Given two adjacency matrices \code{A} and \code{B} of the same size, match
#' the two graphs with the help of \code{m} seed vertex pairs which correspond
#' to the first \code{m} rows (and columns) of the adjacency matrices.
#'
#' The approximate graph matching problem is to find a bijection between the
#' vertices of two graphs , such that the number of edge disagreements between
#' the corresponding vertex pairs is minimized. For seeded graph matching, part
#' of the bijection that consist of known correspondences (the seeds) is known
#' and the problem task is to complete the bijection by estimating the
#' permutation matrix that permutes the rows and columns of the adjacency
#' matrix of the second graph.
#'
#' It is assumed that for the two supplied adjacency matrices \code{A} and
#' \code{B}, both of size \eqn{n\times n}{n*n}, the first \eqn{m} rows(and
#' columns) of \code{A} and \code{B} correspond to the same vertices in both
#' graphs. That is, the \eqn{n \times n}{n*n} permutation matrix that defines
#' the bijection is \eqn{I_{m} \bigoplus P} for a \eqn{(n-m)\times
#' (n-m)}{(n-m)*(n-m)} permutation matrix \eqn{P} and \eqn{m} times \eqn{m}
#' identity matrix \eqn{I_{m}}. The function \code{match_vertices} estimates
#' the permutation matrix \eqn{P} via an optimization algorithm based on the
#' Frank-Wolfe algorithm.
#'
#' See references for further details.
#'
# @aliases match_vertices seeded.graph.match
#' @param A a numeric matrix, the adjacency matrix of the first graph
#' @param B a numeric matrix, the adjacency matrix of the second graph
#' @param m The number of seeds. The first \code{m} vertices of both graphs are
#' matched.
#' @param start a numeric matrix, the permutation matrix estimate is
#' initialized with \code{start}
#' @param maxiter The number of maxiters for the Frank-Wolfe algorithm
#' @return A numeric matrix which is the permutation matrix that determines the
#' bijection between the graphs of \code{A} and \code{B}
#' @author Vince Lyzinski \url{http://www.ams.jhu.edu/~lyzinski/}
#' @references Vogelstein, J. T., Conroy, J. M., Podrazik, L. J., Kratzer, S.
#' G., Harley, E. T., Fishkind, D. E.,Vogelstein, R. J., Priebe, C. E. (2011).
#' Fast Approximate Quadratic Programming for Large (Brain) Graph Matching.
#' Online: \url{http://arxiv.org/abs/1112.5507}
#'
#' Fishkind, D. E., Adali, S., Priebe, C. E. (2012). Seeded Graph Matching
#' Online: \url{http://arxiv.org/abs/1209.0367}
#'
#' @export

sgm.igraph<-function(A,B,m,start,iteration){
    require(igraph)
    return(match_vertices(A,B,m,start,iteration))
}

#' Matches Graphs given a seeding of vertex correspondences
#'
#' Given two adjacency matrices \code{A} and \code{B} of the same size, match
#' the two graphs with the help of \code{m} seed vertex pairs which correspond
#' to the first \code{m} rows (and columns) of the adjacency matrices.
#'
#' The approximate graph matching problem is to find a bijection between the
#' vertices of two graphs , such that the number of edge disagreements between
#' the corresponding vertex pairs is minimized. For seeded graph matching, part
#' of the bijection that consist of known correspondences (the seeds) is known
#' and the problem task is to complete the bijection by estimating the
#' permutation matrix that permutes the rows and columns of the adjacency
#' matrix of the second graph.
#'
#' It is assumed that for the two supplied adjacency matrices \code{A} and
#' \code{B}, both of size \eqn{n\times n}{n*n}, the first \eqn{m} rows(and
#' columns) of \code{A} and \code{B} correspond to the same vertices in both
#' graphs. That is, the \eqn{n \times n}{n*n} permutation matrix that defines
#' the bijection is \eqn{I_{m} \bigoplus P} for a \eqn{(n-m)\times
#' (n-m)}{(n-m)*(n-m)} permutation matrix \eqn{P} and \eqn{m} times \eqn{m}
#' identity matrix \eqn{I_{m}}. The function \code{match_vertices} estimates
#' the permutation matrix \eqn{P} via an optimization algorithm based on the
#' Frank-Wolfe algorithm.
#'
#' See references for further details.
#'
# @aliases match_vertices seeded.graph.match
#' @param A a numeric matrix, the adjacency matrix of the first graph
#' @param B a numeric matrix, the adjacency matrix of the second graph
#' @param S a numeric matrix, the number of seeds x 2 matching vertex table.
#' If \code{S} is \code{NULL}, then it is using a \eqn{soft} seeding algorithm,
#' otherwise a \eqn{hard} seeding is used.
#' @param start a numeric matrix, the permutation matrix estimate is
#' initialized with \code{start}
#' @param pad a scalar value for padding
#' @param iteration The number of iterations for the Frank-Wolfe algorithm
#' @return A numeric matrix which is the permutation matrix that determines the
#' bijection between the graphs of \code{A} and \code{B}
#' @author Vince Lyzinski \url{http://www.ams.jhu.edu/~lyzinski/}
#' @references Vogelstein, J. T., Conroy, J. M., Podrazik, L. J., Kratzer, S.
#' G., Harley, E. T., Fishkind, D. E.,Vogelstein, R. J., Priebe, C. E. (2011).
#' Fast Approximate Quadratic Programming for Large (Brain) Graph Matching.
#' Online: \url{http://arxiv.org/abs/1112.5507}
#'
#' Fishkind, D. E., Adali, S., Priebe, C. E. (2012). Seeded Graph Matching
#' Online: \url{http://arxiv.org/abs/1209.0367}
#'
#' @export

sgm.ori <- function(A,B,start,S=NULL,pad=0,iteration=20){
    # forcing seeds to be first m vertices in both graphs
    m <- nrow(S)
    if(is.null(m)){
        m <- 0
    }else{
        Aseeds <- S[,1]
        Anotseeds <- setdiff(1:nrow(A),Aseeds)
        Aorder <- c(Aseeds,Anotseeds)
        Anew <- A[Aorder,Aorder]
        A <- Anew

        Bseeds <- S[,2]
        Bnotseeds <- setdiff(1:nrow(B),Bseeds)
        Border <- c(Bseeds,Bnotseeds)
        Bnew <- B[Border,Border]
        B <- Bnew
    }

    #seeds are assumed to be vertices 1:m in both graphs
    require('clue')
    totv1<-ncol(A)
    totv2<-ncol(B)
    if(totv1>totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv1-totv2
        for (j in 1:diff){B<-cbind(rbind(B,pad),pad)}
    }else if(totv1<totv2){
        A[A==0]<- -1
        B[B==0]<- -1
        diff<-totv2-totv1
        for (j in 1:diff){A<-cbind(rbind(A,pad),pad)}
    }
    totv<-max(totv1,totv2)
    n<-totv-m
    if (m != 0){
        A12<-rbind(A[1:m,(m+1):(m+n)])
        A21<-cbind(A[(m+1):(m+n),1:m])
        B12<-rbind(B[1:m,(m+1):(m+n)])
        B21<-cbind(B[(m+1):(m+n),1:m])
    }
    if (m==0){
        A12<-matrix(0,n,n)
        A21<-matrix(0,n,n)
        B12<-matrix(0,n,n)
        B21<-matrix(0,n,n)
    }
    if (n==1){ A12=t(A12)
    A21=t(A21)
    B12=t(B12)
    B21=t(B21)}

    A22<-A[(m+1):(m+n),(m+1):(m+n)]
    B22<-B[(m+1):(m+n),(m+1):(m+n)]
    tol<-1
    P<-start
    toggle<-1
    iter<-0
    x<- A21%*%t(B21)
    y<- t(A12)%*%B12
    while (toggle==1 & iter<maxiter)
    {
        iter<-iter+1
        z<- A22%*%P%*%t(B22)
        w<- t(A22)%*%P%*%B22
        Grad<-x+y+z+w;
        mm=max(abs(Grad))
        ind<-matrix(solve_LSAP(Grad+matrix(mm,totv-m,totv-m), maximum =TRUE))
        T<-diag(n)
        T<-T[ind,]
        wt<-t(A22)%*%T%*%B22
        c<-sum(diag(w%*%t(P)))
        d<-sum(diag(wt%*%t(P)))+sum(diag(w%*%t(T)))
        e<-sum(diag(wt%*%t(T)))
        u<-sum(diag(t(P)%*%x+t(P)%*%y))
        v<-sum(diag(t(T)%*%x+t(T)%*%y))
        if( c-d+e==0 && d-2*e+u-v==0){
            alpha<-0
        }else{
            alpha<- -(d-2*e+u-v)/(2*(c-d+e))}
        f0<-0
        f1<- c-e+u-v
        falpha<-(c-d+e)*alpha^2+(d-2*e+u-v)*alpha
        if(alpha < tol && alpha > 0 && falpha > f0 && falpha > f1){
            P<- alpha*P+(1-alpha)*T
        }else if(f0 > f1){
            P<-T
        }else{
            toggle<-0}
    }
    D<-P
    corr<-matrix(solve_LSAP(P, maximum = TRUE))
    P=diag(n)
    P=rbind(cbind(diag(m),matrix(0,m,n)),cbind(matrix(0,n,m),P[corr,]))
    corr<-cbind(matrix((m+1):totv, n),matrix(m+corr,n))
    return(list(corr=corr[,2], P=P, D=D))
}

stfp <- function(A, dim = NULL, scaling = TRUE)
{
    suppressMessages(require(irlba))

    if (dim(A)[1]==dim(A)[2]) {
        L <- nonpsd.laplacian(A) ## diagonal augmentation
    } else {
        L <- A
    }

    if(is.null(dim)) {
        L.svd <- irlba(L)
        #        L.svd <- svd(L)
        dim <- getElbows(L.svd$d,3,plot=FALSE)[2] # ignore this, use "getElbows" instead
    } else {
        L.svd <- irlba(L,dim,dim)
        #        L.svd <- svd(L)
    }

    L.svd.values <- L.svd$d[1:dim]
    L.svd.vectors <- L.svd$v[,1:dim]

    if(scaling == TRUE) { # projecting to sphere
        if(dim == 1)
            L.coords <- sqrt(L.svd.values) * L.svd.vectors
        else
            L.coords <- L.svd.vectors %*% diag(sqrt(L.svd.values))
    }
    else {
        L.coords <- L.svd.vectors
    }

    return(list(X=L.coords,D=L.svd.values))
}

getElbows <- function(dat, n = 3, threshold = FALSE, plot = F) {
    if (is.matrix(dat))
        d <- sort(apply(dat,2,sd), decreasing=T)
    else
        d <- sort(dat,decreasing=TRUE)

    if (!is.logical(threshold))
        d <- d[d > threshold]

    p <- length(d)
    if (p == 0)
        stop(paste("d must have elements that are larger than the threshold ",
                   threshold), "!", sep="")

    lq <- rep(0.0, p)                     # log likelihood, function of q
    for (q in 1:p) {
        mu1 <- mean(d[1:q])
        mu2 <- mean(d[-(1:q)])              # = NaN when q = p
        sigma2 <- (sum((d[1:q] - mu1)^2) + sum((d[-(1:q)] - mu2)^2)) / (p - 1 - (q < p))
        lq[q] <- sum( dnorm(  d[1:q ], mu1, sqrt(sigma2), log=TRUE) ) +
            sum( dnorm(d[-(1:q)], mu2, sqrt(sigma2), log=TRUE) )
    }

    q <- which.max(lq)
    if (n > 1 && q < p) {
        q <- c(q, q + getElbows(d[(q+1):p], n=n-1, plot=FALSE))
    }

    if (plot==TRUE) {
        if (is.matrix(dat)) {
            sdv <- d # apply(dat,2,sd)
            plot(sdv,type="b",xlab="dim",ylab="stdev")
            points(q,sdv[q],col=2,pch=19)
        } else {
            plot(dat, type="b")
            points(q,dat[q],col=2,pch=19)
        }
    }

    return(q)
}

nonpsd.laplacian <- function(A)
{
    A <- as.matrix(A)
    n <- nrow(A)
    s <- rowSums(A)/(n-1)
    diag(A) <- diag(A)+s
    return(A)
}

## for aLAP
# Help method of parrallelMatch
matchVertex <- function(s, candidate, mate, Q) {
    if (candidate[candidate[s]] == s) {
        mate[s] <- candidate[s];
        mate[candidate[s]] <- s;
        Q <- c(Q, s, candidate[s]);
    }
    return(list(Q, mate));
}

findMate <- function(s, graph, mate) {
    # Initialization
    max_wt <- -Inf;
    max_wt_id <- NaN;

    # Find the locally dominant vertices for one single vertex
    if (s <= dim(graph)[2] / 2) {
        for (i in (dim(graph)[2] / 2 + 1) : dim(graph)[2]) {
            if (is.nan(mate[i]) && max_wt < graph[s, i]) {
                max_wt <- graph[s, i];
                max_wt_id <- i;
            }
        }
    } else {
        for (i in 1 : (dim(graph)[2] / 2)) {
            if (is.nan(mate[i]) && max_wt < graph[s, i]) {
                max_wt <- graph[s, i];
                max_wt_id <- i;
            }
        }
    }
    return(max_wt_id);
}

# Function to solve Linear Assignment Problem
# Using algorithm in A multithreaded algorithm for network alignment
# via approximate matching
# graph has the form: [0 C; C' 0] where C is the cost function
# Output mate is a permutation
# Written by Ao Sun and Lingyao Meng
parallelMatch <- function(graph) {
    ##require('foreach')
    ##source('findMate.R');
    ##source('matchVertex.R');
    ## adjacency matrix corresponding to graph G
    numVertices <- nrow(graph)

    ## Initialize the matching vector with NaN
    mate <- rep(NaN, numVertices)

    ## Initialize the other parameters
    candidate <- rep(0, numVertices);
    qC <- vector(); qN <- vector();

    #--------------------------------- Phase 1 ------------------------------------------
    candidate <- sapply(seq_len(numVertices), function(x) findMate(x,graph,mate))

    for (j in 1 : numVertices) {
        temp <- matchVertex(j, candidate, mate, qC);
        qC <- temp[[1]]; mate <- temp[[2]];
    }
    #--------------------------------- Phase 2 ------------------------------------------
    repeat {
        for (k in 1 : length(qC)) {
            ## Return to the index of adjacent Vertex
            if (qC[k] <= (numVertices / 2)) {

                for (h in (numVertices / 2 + 1) : numVertices) {
                    if ((candidate[h] == qC[k]) && (h != mate[qC[k]])) {
                        candidate[h] <- findMate(h, graph, mate);
                        temp2 <- matchVertex(h, candidate, mate, qN);
                        qN <- unlist(temp2[1]); mate <- unlist(temp2[2]);
                    }
                }
            } else {
                for (h in 1 : (numVertices / 2)) {
                    if ((candidate[h] == qC[k]) && h != mate[qC[k]]) {
                        candidate[h] <- findMate(h, graph, mate);
                        temp3 <- matchVertex(h, candidate, mate, qN);
                        qN <- unlist(temp3[1]); mate <- unlist(temp3[2]);
                    }
                }
            }
        }

        qC <- qN;
        qN <- vector();
        if (length(qC) == 0) {
            break;
        }
    }
    mate <- mate[(numVertices / 2 + 1) : length(mate)];
    return(mate)
}