# 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)


library(quantmod)

rm(list = ls())

stock <- na.omit(get(getSymbols('AAPL')))

pl <- setNames( rep( 0, length(Cl(stock)) ), time(stock) ) # [p]rofit and [l]ose vector
head(pl)

m <- 4
while ( m < nrow(stock) ) {
    if ( Cl(stock)[m] > max( Hi(stock)[ (m-1):(m-3) ] ) ) {
        long <- as.numeric( Op(stock)[m+1] )
        while ( Cl(stock)[m] >= min( Lo(stock)[ (m-1):(m-3) ] )
             && m < nrow(stock) ) {
            m <- m + 1
        }
        pl[m] <- as.numeric( Op(stock)[m+1] ) - long
    }
    m <- m+1
}

plot( cumsum(pl), type='l', col='red', lwd=2 )


## Author: Alan Ruttenberg
## Project: OHD
## Date: May, 2013
##
## Demonstrates simple statistics on our data set with R. Here draw distribution of age at first procedure.
##
## Modifed by Bill Duncan Oct. 10, 2017
## Summary of changes:
## After updating to GraphDB SE 8.3 and R 3.4.2, the endpoint url was changed and the rrdf library no
## no longer worked. To fix, I updated the current_endpoint in environment.r and I am using the SPARQL
## library (i.e., current_sparqlr <<- "SPARQL") for queries.
## Two important side effects:
## 1. In order to get dates to work, I had to cast them as strings; e.g.: bind(str(?birth_date) as ?bdate)
## 2. To count rows in results, use ncol instead of nrows
##
## In the SPARQL query, I also changed the results from returning a sample (i.e., SAMPLE(?birth_date))
## to returning all birth dates. The labels on the plot were updated to reflect this.

years_difference_from_dates <- function(first_date,second_date)
  { start <- as.Date(first_date)
    end <- as.Date(second_date)
    as.numeric((end-start)/365.25)
  }

mean_median_and_sd_from_dates_in_years <- function (first_date,second_date,print=TRUE)
{
  years <- years_difference_from_dates(first_date,second_date);
  if (print)  { cat(paste("mean: ", mean(years),", median: ", median(years),  ", standard deviation: ",sd(years),"\n"))}
  c(as.numeric(mean(years)),as.numeric(median(years)),as.numeric(sd(years)));
}

#  http://stats.stackexchange.com/questions/12232/calculating-the-parameters-of-a-beta-distribution-using-the-mean-and-variance
estimate_beta_distribution_parameters <- function(mean, sd) {
  var <- sd*sd;
  alpha <- ((1 - mean) / var - 1 / mean) * mean ^ 2
  beta <- alpha * (1 / mean - 1)
  return(params = list(shape1 = alpha, shape2 = beta))
}

# show a histogram of date differences with a beta function fit to it
histogram_fit_to_distribution_of_dates_in_years <- function (first_date,second_date,breaks=20,topic="times",subtitle="")
{
  # compute years different
  years <- years_difference_from_dates(first_date,second_date);
  count <- length(years)
  # pick arbitrary bigger than we expect, so we can scale 0-1
  years_max = 110;
  # scale years to fit beta
  years_scaled <- years/years_max;
  # estimate the parameters from the means and sd
  beta_parameter_estimates <- estimate_beta_distribution_parameters(mean(years_scaled),sd(years_scaled));
  # I'm not sure if this is right. How to scale the fit to the counts?
  distscale <- count/breaks;
  # compute the beta distribution
  years_distribution <- fitdistr(years_scaled,"beta",beta_parameter_estimates);
  # histogram it
  hist(as.numeric(years),breaks=breaks,
       main=paste("Distribution of ",topic,", fit to",expression("beta"),"distribution"),
       xlab="Years",
       ylab="Count",
       sub=subtitle
  );
  # draw the function on top of it
  curve(distscale*dbeta(x/years_max,years_distribution$estimate[1],years_distribution$estimate[2]),add=TRUE)
  years_distribution
}

age_to_first_treatment_statistics <- function ()
{
  # retrieve a row for each patient with the birth date first treatment date for each
  queryRes <- queryc("SELECT ?patient (str(sample(?birth_date)) as ?bdate) (str(min(?treatdatei)) as ?treatdate)
                     WHERE
                     {
                      ?patient rdf:type dental_patient: .
                      ?patient participates_in: ?procedure.
                      ?procedure rdf:type dental_procedure: .
                      ?procedure occurrence_date: ?treatdatei .
                      ?patient birth_date: ?birth_date
                     } group by ?patient");

  # currently the date fields are strings
  # converty them to dates
  queryRes[,"bdate"] <- as.Date(queryRes[,"bdate"]);
  queryRes[,"treatdate"] <- as.Date(queryRes[,"treatdate"]);

  # count how many procedures had a patient participate
  query <-  "SELECT distinct ?procedure
             WHERE
             {  ?patient rdf:type dental_patient: .
                ?patient participates_in: ?procedure.
                ?procedure rdf:type dental_procedure: .
                ?procedure occurrence_date: ?treatdatei .
                ?patient birth_date: ?birth_date .
              } "
  if(current_sparqlr == "rrdf")
    { withpatient <- nrow(queryc(query)) }
  else
    { withpatient <- ncol(queryc(query)) }

  ## count the total procedures
  if(current_sparqlr == "rrdf")
    { total <- nrow(queryc("SELECT distinct ?procedure WHERE { ?procedure rdf:type dental_procedure:  . } "));}
  else # use when current_sparqlr == "SPARQL"
    { total <- ncol(queryc("SELECT distinct ?procedure WHERE { ?procedure rdf:type dental_procedure:  . } "));}

  # compute mean, median, sd
  meansd<-mean_median_and_sd_from_dates_in_years(queryRes[,"bdate"],queryRes[,"treatdate"]);

  # visualize
  histogram_fit_to_distribution_of_dates_in_years(
    queryRes[,"bdate"],queryRes[,"treatdate"],
    topic="age at first treatment",
    subtitle=paste("median=",signif(meansd[2],3),"sd=",signif(meansd[3],3),"  ",
                   # summarize how many first treatments, summarized from how many treatments, from how many total treatments
                   dim(queryRes)[1],"first from",withpatient,"procedures of ",total)
  );
}

age_at_first_dental_procedure_statistics <- function ()
{ # retrieve a row for each patient with the birth date first procedure date for each
  queryRes <- queryc("
     SELECT
        ?patient
        (str(?birth_date) as ?bdate)
        (min(?age) as ?first_procedure_age)
        (str(min(?procdatei)) as ?procdate)
	   WHERE {
        ?patient rdf:type dental_patient: .
        ?patient participates_in: ?procedure.
        ?procedure rdf:type dental_procedure: .
        ?procedure occurrence_date: ?procdatei .
        ?patient birth_date: ?birth_date .
        bind(year(?procdatei)-year(?birth_date) as ?age) .
      }
      group by ?patient ?birth_date");

  values <- c(queryRes[,"first_procedure_age"]);
  hist(
    values
    #, breaks = seq(0,100, by = 10)
    #, labels = TRUE
    , main = "Distribution of patient's age during first dental procedure \n (fit to normal distribution)"
    , sub = paste("N:", format(length(values), big.mark = ","),"patients",
                  " mean age:", round(mean(values), digits = 2),
                  " SD age:", round(sd(values), digits = 2))
    , xlab = "Patient age"
    #, ylim = c(0, 200)
    , ylim = c(0, 0.03)
    , xlim = c(0, 100)
    , freq = FALSE
    , col= "lightgreen"
    , font.lab = 2
  )

  # lines(density(values), col="darkblue", lwd = 3)
  curve(dnorm(x, mean=mean(values), sd=sd(values)), add=TRUE, col="darkblue", lwd = 3)
}

age_at_first_dental_encounter_statistics <- function ()
{ # retrieve a row for each patient with the birth date first procedure date for each
  queryRes <- queryc("
                     SELECT DISTINCT
                       ?patient
	                     (min(?age) as ?min_age)
                       (str(min(?encounter_date)) as ?min_encounter_date)
                     WHERE {
                       ?patient rdf:type dental_patient: .
                       ?patient participates_in: ?encounter.
                       ?encounter rdf:type health_care_encounter: .
                       ?encounter occurrence_date: ?encounter_date .
                       ?patient birth_date: ?birth_date .
                       bind(year(?encounter_date)-year(?birth_date) as ?age) .
                     }
                     group by ?patient");

  values <- c(queryRes[,"min_age"]);
  hist(
    values
    #, breaks = seq(0,100, by = 10)
    , breaks = 20
    #, labels = TRUE
    , main = "Distribution of patient's age during first dental encounter \n (fit to normal distribution)"
    , sub = paste("N:", format(length(values), big.mark = ","),"patients",
                  " mean age:", round(mean(values), digits = 2),
                  " SD age:", round(sd(values), digits = 2))
    , xlab = "Patient age"
    #, ylim = c(0, 200)
    , ylim = c(0, 0.02)
    , xlim = c(0, 100)
    , freq = FALSE
    , col= "lightgreen"
    , font.lab = 2
  )

  # lines(density(values), col="darkblue", lwd = 3)
  curve(dnorm(x, mean=mean(values), sd=sd(values)), add=TRUE, col="darkblue", lwd = 3)
}

which_distribution_for_ages <- function ()
{   queryRes <- queryc("
     SELECT ?patient ?bdate (str(min(?procdatei)) as ?procdate)
	   WHERE
	   {
       ?patient rdf:type dental_patient: .
	     ?patient participates_in: ?procedure.
       ?procedure rdf:type dental_procedure: .
	     ?procedure occurrence_date: ?procdatei .
   	   ?patient birth_date: ?birth_date
       bind(str(?birth_date) as ?bdate)
      }
      group by ?patient ?bdate");

    compare_normal_to_beta_distribution(
      years_difference_from_dates(as.Date(queryRes[,"bdate"]),
      as.Date(queryRes[,"procdate"]))/115);
}

# See http://en.wikipedia.org/wiki/Kolmogorov–Smirnov_test - a way of testing goodness of fit of a probability distribution to a sample
compare_normal_to_beta_distribution <- function (data)
{ beta_parameter_estimates <- estimate_beta_distribution_parameters(mean(data),sd(data));
  # compute the beta distribution
  beta_parameters <- fitdistr(data,"beta",beta_parameter_estimates);
  # compute the normal distribution
  normal_parameters <- fitdistr(data,"normal")
  # Now do the KS test for the normal distribution and print
  cat("Normal\n");
  print(ks.test(data,"pnorm",normal_parameters$estimate[1],normal_parameters$estimate[2]))
  # And do the KS test for the beta distribution and print
  cat("Beta\n");
  print(ks.test(data,"pbeta",beta_parameters$estimate[1],beta_parameters$estimate[2]))
}


# R function to generate ROC and precision-recall curves after fitting
# a logit/probit regression model in Stan
# Johannes Karreth

# stan_object: rstan object of class "stanfit", including parameters and
# 	predicted values for each observation, with the prefix "pred"
# model_frame: model frame used to fit the model
# model_name: name of model for plotting

# Output:
# a list with four elements
# area_under_roc: area under ROC curve (scalar)
# area_under_prc: area under precision-recall curve (scalar)
# prc_dat: data to plot precision-recall curve (data frame)
# roc_dat: data to plot ROC curve (data frame)

# Credit: Area under the curve functions written by Andreas Beger
# <https://ssrn.com/abstract=2765419>

MCMC_roc_prc <- function(stan_object,
		 model_frame,
		 model_name = "Model"){

	# Prepare MCMC output
	require("ggmcmc")
	mcmc_ggs <- ggs(stan_object, family = "pred")

	require("dplyr")
	median_pred <- summarize(group_by(mcmc_ggs, Parameter),
							 y_pred = median(value) #,
							 # y_pred_lower = quantile(value, probs = ci[1]),
							 # y_pred_upper = quantile(value, probs = ci[2])
							 )

	# Observed y and x
	median_pred$y_obs <- model_frame[, 1]
	# median_pred$x_obs <- model_frame[, xvar]

	# Area under the curve functions from Andreas Beger
	# <https://ssrn.com/abstract=2765419>

		require("ROCR")
		require("caTools")

		auc_roc <- function(obs, pred) {
  		pred <- prediction(pred, obs)
  		auc  <- performance(pred, "auc")@y.values[[1]]
  		return(auc)
		}

		auc_pr <- function(obs, pred) {
  		xx.df <- prediction(pred, obs)
  		perf  <- performance(xx.df, "prec", "rec")
  		xy    <- data.frame(recall = perf@x.values[[1]],
                      precision = perf@y.values[[1]])

  		# take out division by 0 for lowest threshold
  		xy <- subset(xy, !is.nan(xy$precision))

  		res   <- trapz(xy$recall, xy$precision)
  		res
		}

	area_under_roc <- data.frame(auc = auc_roc(obs = median_pred$y_obs, pred = median_pred$y_pred), Model = model_name)

	area_under_prc <- data.frame(auc = auc_pr(obs = median_pred$y_obs, pred = median_pred$y_pred), Model = model_name)

	prediction_obj <- prediction(predictions = median_pred$y_pred,
								 labels = median_pred$y_obs)

	prc_performance_obj <- performance(prediction.obj = prediction_obj,
								   	   measure = "prec",
								   	 x.measure = "rec")

	prc_dat <- data.frame(x = prc_performance_obj@x.values,
					      y = prc_performance_obj@y.values,
					      Model = model_name)
	names(prc_dat) <- c("x", "y", "Model")

	roc_performance_obj <- performance(prediction.obj = prediction_obj,
								   	   measure = "tpr",
								   	   x.measure = "fpr")

	roc_dat <- data.frame(x = roc_performance_obj@x.values,
					      y = roc_performance_obj@y.values,
					      Model = model_name)
	names(roc_dat) <- c("x", "y", "Model")

	# Results as a list
	results <- list()
	results$area_under_roc <- area_under_roc
	results$area_under_prc <- area_under_prc
	results$prc_dat <- prc_dat
	results$roc_dat <- roc_dat

	return(results)
}


n <- 10
x <- seq(1, n)
x <- 4

log(10^x)
log10(x^10)
log(exp(x))
exp(log(x, base=2))


onecor.wtd <- function(x, y, weight=NULL){
  if(sum((!is.na(x))*(!is.na(y)))>0){
    if(is.null(weight)){
      weight <- rep(1, length(x))
    }
    use <- !is.na(y) & !is.na(x)
    x <- x[use]
    y <- y[use]
    weight <- weight[use]
    #r1 <- lm(stdz(y, weight=weight)~stdz(x, weight=weight), weight=weight)
    #corcoef <- coef(summary(r1))[2,]
    corcoef <- coef(summary(lm(stdz(y, weight=weight)~stdz(x, weight=weight), weights=weight)))[2,]
  }
  else
    corcoef <- rep(NA, 4)
  names(corcoef) <- rep("", 4)
  corcoef
}


#' chol2inv
#'
#' Return the inverse of the original matrix using the Cholesky factorization of
#' a float vector/matrix.
#'
#' @param x
#' A float vector/matrix.
#' @param size
#' The number of columns to use.
#' @param LINPACK
#' Ignored.
#'
#' @return
#' A float vector/matrix.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' cp = crossprod(s)
#' cp %*% chol2inv(chol(cp))
#'
#' @useDynLib float R_chol2inv_spm
#' @name chol2inv
#' @rdname chol2inv
NULL

chol2inv_float32 = function(x, size=NCOL(x), LINPACK=FALSE)
{
  ret = .Call(R_chol2inv_spm, DATA(x), as.integer(size))
  float32(ret)
}

#' @rdname chol2inv
#' @export
setMethod("chol2inv", signature(x="float32"), chol2inv_float32)


##Perform sliding window regional analysis as described in Hannon et al. Genome Biology 2016.

calcCovMatrix<-function(x){
   ### x is a vector of correlations
   y<-vector(length = length(x))
   for(i in 1:length(x)){
      if(x[i] <= 1 & x[i] >= 0){
         y[i]<-x[i]*(3.25 + 0.75*x[i])
    } else {
      if(x[i] <= 0 & x[i] >= -0.5){
         y[i]<-x[i]*(3.27 + 0.71*x[i])
      }
    }

  }
  return(y)
}

brownsP<-function(covar, pval){
	## covar is vector of covariances between all pairs of tests NOTE not correlations
	## pval is vector of p values
	ntests<-length(pval)
	var_xsq<-sum(covar)*2 + 4*ntests 	# equation (3)
	exp_xsq<-2*ntests	#equation (2)

	## estimate parameters for chi square distribution using Brown's notation
	f = (2*(exp_xsq^2))/var_xsq
	c = var_xsq/(2*exp_xsq)

	##### NOTE: doesn't match Brown's answer but matches my answer by hand
	chi_sq<- -2*sum(log(pval))

	### to obtain p value
	test.stat<-chi_sq/c
	browns.pval<-1-pchisq(test.stat, df = f)
	return(c(browns.pval, test.stat, f))
}

## load DNA methylation data to calculate correlations
setwd("")
load("QCed_Data.rda")

crosshyb<-read.csv("450KAnno/CrossHybridisingProbesPriceORWeksberg.csv", row.names = 1)
probes<-read.csv("450KAnno/SNPsinProbesAnno.csv", row.names = 1)

## remove cross hybridising probes
remove<-match(crosshyb[,1], rownames(betas))
remove<-remove[which(is.na(remove) != TRUE)]
betas<-betas[-remove,]
## remove SNP probes as not a twin analysis
probes<-probes[row.names(betas),]
betas<-betas[which(probes$Weksburg_CommonSNP_Af_within10bpSBE == "" | probes$Illumina_CommonSNP_Af_within10bpSBE == ""),]

betas<-betas[-grep("rs", rownames(betas)),]

## load EWAS results
res<-read.csv("", row.names = 1, stringsAsFactors = FALSE)

res<-res[which(res$chr != "chrY"),]

betas<-betas[intersect(rownames(res), rownames(betas)),]
res<-res[rownames(betas),]
res<-res[order(res$pos),]

res$chr<-as.character(res$chr)
res$chr[which(res$chr == "chrX")]<-23
res$chr<-as.numeric(gsub("chr", "", res$chr))
res$UCSC_RefGene_Name<-as.character(res$UCSC_RefGene_Name)
windows<-c(1000,2000,5000)
out<-NULL
for(chr in 1:22){
	print(paste("CHR: ", chr))
	res.tmp<-res[which(res$chr == chr),]

	out.tmp<-matrix(data = NA, nrow = nrow(res.tmp), ncol = 2+length(windows)*7)
	colnames(out.tmp)<-c("Central Probe", "Chr", rep(c("Start Region", "End Region", "nProbes", "Gene Anno", "Min P", "Fishers P", "Browns P"), length(windows)))
	out.tmp[,1]<-rownames(res.tmp)
	out.tmp[,2]<-chr
	for(i in 1:nrow(res.tmp)){

		chr<-res.tmp$chr[i]
		bp<-res.tmp$pos[i]

		for(j in 1:length(windows)){
		sub<-res.tmp[which(res.tmp$chr == chr & res.tmp$pos <= (bp+windows[j]) & res.tmp$pos >= (bp-windows[j])),]
		#sub<-sub[order(sub$pos),]

			out.tmp[i,(j*7)-4]<-min(sub$pos)
			out.tmp[i,(j*7)-3]<-max(sub$pos)
			out.tmp[i,(j*7)-2]<-nrow(sub)

			if(nrow(sub) > 1){
				out.tmp[i,(j*7)-1]<-paste(unique(unlist(strsplit(sub$UCSC_RefGene_Name, ";"))), collapse = ";")
				betas.sub<-betas[rownames(sub),]

				cor.mat<-c(unique(as.vector(cor(t(betas.sub)))))[-1]
				covar<-calcCovMatrix(cor.mat)

				pval<-sub$P.value
				out.tmp[i,(j*7)]<-min(pval)

				### compare to fishers p value
				fisher<-(sum(-log(pval))*2)
				out.tmp[i,(j*7)+1]<-1-pchisq(fisher, 2*length(pval))

				brownsp<-brownsP(covar, pval)
				out.tmp[i,(j*7)+2]<-brownsp[1]
			}

		}
	}
out<-rbind(out,out.tmp)

}

## save results for all tested regions
write.csv(out, "")

## filter results to unique regions tested
tmp2<-out[,c(1,2,10:16)]
tmp3<-out[,c(1,2,17:23)]
colnames(tmp2)<-colnames(out)[c(1:9)]
colnames(tmp3)<-colnames(out)[c(1:9)]
out2<-rbind(out[,c(1:9)], tmp2, tmp3)
out2<-unique(out2[,-1])
## filter regions to those with at least one DNA methylation site
out2<-out2[which(out2[,4] > 1),]
## sort by regional p value
out2<-out2[order(out2[,8]),]


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))
}


library(cellrangerRkit)
context('tsne')

pipestance_path <- system.file("extdata", "test_pipestance", package="cellrangerRkit")

gbm <- load_cellranger_matrix(pipestance_path)
pca <- run_pca(gbm, 2)
tsne_res <- run_tsne(pca, theta=0.75)


##### Chapter 4: Classification using Naive Bayes --------------------

## Example: Filtering spam SMS messages ----
## Step 2: Exploring and preparing the data ----

# read the sms data into the sms data frame
sms_raw <- read.csv("sms_spam.csv", stringsAsFactors = FALSE)

# examine the structure of the sms data
str(sms_raw)

# convert spam/ham to factor.
sms_raw$type <- factor(sms_raw$type)

# examine the type variable more carefully
str(sms_raw$type)
table(sms_raw$type)

# build a corpus using the text mining (tm) package
library(tm)
sms_corpus <- Corpus(VectorSource(sms_raw$text))

# examine the sms corpus
print(sms_corpus)
inspect(sms_corpus[1:3])

# clean up the corpus using tm_map()
corpus_clean <- tm_map(sms_corpus, tolower)
corpus_clean <- tm_map(corpus_clean, removeNumbers)
corpus_clean <- tm_map(corpus_clean, removeWords, stopwords())
corpus_clean <- tm_map(corpus_clean, removePunctuation)
corpus_clean <- tm_map(corpus_clean, stripWhitespace)

# examine the clean corpus
inspect(sms_corpus[1:3])
inspect(corpus_clean[1:3])

# create a document-term sparse matrix
sms_dtm <- DocumentTermMatrix(corpus_clean)
sms_dtm

# creating training and test datasets
sms_raw_train <- sms_raw[1:4169, ]
sms_raw_test  <- sms_raw[4170:5559, ]

sms_dtm_train <- sms_dtm[1:4169, ]
sms_dtm_test  <- sms_dtm[4170:5559, ]

sms_corpus_train <- corpus_clean[1:4169]
sms_corpus_test  <- corpus_clean[4170:5559]

# check that the proportion of spam is similar
prop.table(table(sms_raw_train$type))
prop.table(table(sms_raw_test$type))

# word cloud visualization
library(wordcloud)

wordcloud(sms_corpus_train, min.freq = 30, random.order = FALSE)

# subset the training data into spam and ham groups
spam <- subset(sms_raw_train, type == "spam")
ham  <- subset(sms_raw_train, type == "ham")

wordcloud(spam$text, max.words = 40, scale = c(3, 0.5))
wordcloud(ham$text, max.words = 40, scale = c(3, 0.5))

# indicator features for frequent words
findFreqTerms(sms_dtm_train, 5)
sms_dict <- Dictionary(findFreqTerms(sms_dtm_train, 5))
sms_train <- DocumentTermMatrix(sms_corpus_train, list(dictionary = sms_dict))
sms_test  <- DocumentTermMatrix(sms_corpus_test, list(dictionary = sms_dict))

# convert counts to a factor
convert_counts <- function(x) {
  x <- ifelse(x > 0, 1, 0)
  x <- factor(x, levels = c(0, 1), labels = c("No", "Yes"))
}

# apply() convert_counts() to columns of train/test data
sms_train <- apply(sms_train, MARGIN = 2, convert_counts)
sms_test  <- apply(sms_test, MARGIN = 2, convert_counts)

## Step 3: Training a model on the data ----
library(e1071)
sms_classifier <- naiveBayes(sms_train, sms_raw_train$type)
sms_classifier

## Step 4: Evaluating model performance ----
sms_test_pred <- predict(sms_classifier, sms_test)

library(gmodels)
CrossTable(sms_test_pred, sms_raw_test$type,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

## Step 5: Improving model performance ----
sms_classifier2 <- naiveBayes(sms_train, sms_raw_train$type, laplace = 1)
sms_test_pred2 <- predict(sms_classifier2, sms_test)
CrossTable(sms_test_pred2, sms_raw_test$type,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))


# Script for filtering temporal outliers

#library(probaV)
#library(foreach)
library(sf)
library(pbapply)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/ProbaVDataDirs.r")
source("pixel-based/utils/db-io.r")

OutputDB = "../data/pixel-based/timeseries/timeseries-cloudfree.gpkg"
InputDB = "../data/pixel-based/timeseries/timeseries-masked.gpkg"

#TileList = GetTileList(LoadGlobalRasterPoints())
Dates = LoadRawDataDirs()$date
ColDates = paste0("X", gsub("-", "", Dates))

# Modified probaV::smoothLoess to plot the result
# This function is by Johannes Eberenz under Expat license:
# https://github.com/johanez/probaV/blob/master/LICENSE.md
smoothLoessPlot = function (tsx, QC_good = NULL, dates = NULL, threshold = c(-50,
  Inf), res_type = c("distance", "sd_distance", "all", "filled",
  "omit", "QC"), span=0.3, family="gaussian", threshstat="none", plot=TRUE, ...)
{
    if (is.null(QC_good)) {
        QC_good <- as.numeric(!is.na(tsx))
    }
    else {
        QC_good <- as.numeric(QC_good)
    }
    x <- as.numeric(tsx)
    x[QC_good == 0] <- NA
    if (all(is.na(x)))
    {
        warning("Input is all NA")
        return(x)
    }
    if (plot)
        plot(x, type="o", ...)
    if (is.null(dates)) {
        dates <- index(tsx)
    }
    dates <- as.numeric(dates)
    loe <- try(loess(formula = x ~ dates, na.action = "na.omit", span=span, family=family))
    if (class(loe) == "try-error")
        return(x)
    loe_pred <- predict(loe, dates)
    if (plot)
        lines(loe_pred, col="green")
    distance <- (loe_pred - x)
    predmae = mean(abs(distance), na.rm=TRUE)
    predrmse = sqrt(mean(distance^2, na.rm=TRUE))
    xsd = sd(x, na.rm=TRUE)
    xmad = mad(x, na.rm=TRUE)
    if (plot)
        title(sub=paste("MAE:", round(predmae), "RMSE:", round(predrmse), "sd:", round(xsd), "mad:", round(xmad)))
    threshstat = switch(threshstat, none=1, sd=xsd, mad=xmad, mae=predmae, rmse=predrmse)
    threshold = threshold * threshstat
    if (!is.null(threshold)) {
        QC_good[distance < threshold[1] & !is.na(distance)] <- 2
        QC_good[distance > threshold[2] & !is.na(distance)] <- 2
    }
    if (class(tsx) == "zoo") {
        tsx <- zoo(cbind(x = as.numeric(tsx), QC_good, filled = loe_pred),
                   index(tsx))
        return(tsx)
    }
    else {
        x_omit <- x
        x_omit[QC_good != 1] <- NA
        if (plot)
            points(x_omit, type="o", col="red")
        res <- switch(res_type, all = data.frame(x = as.numeric(tsx),
                                                 QC_good = QC_good, filled = loe_pred, distance = round(distance)),
                      filled = loe_pred, omit = x_omit, QC = QC_good, distance = distance,
                      sd_distance = (distance/sd(x, na.rm = T)))
        return(res)
    }
}

BlueSF = st_read(InputDB, "RADIOMETRY-3") # Red, NIR, Blue, SWIR
BlueXY = data.frame(X=BlueSF$X, Y=BlueSF$Y)
gc(TRUE)
BlueMatrix = as.matrix(as.data.frame(BlueSF)[,ColDates])
rm(BlueSF)
gc(TRUE)

## Test thresholding ##
TestTS = sample(1:nrow(BlueMatrix), 50)
for (i in TestTS)
    smoothLoessPlot(BlueMatrix[i,], dates=Dates, res_type="omit", span=0.2, threshold=c(-100, 90), family="symmetric", main=i)

for (i in TestTS)
    smoothLoessPlot(BlueMatrix[i,], dates=Dates, res_type="omit", span=0.2, threshold=c(-3, 4), family="symmetric", main=i, threshstat = "mae")

for (i in TestTS)
    smoothLoessPlot(BlueMatrix[i,], dates=Dates, res_type="omit", span=0.2, threshold=c(-2, 2), family="symmetric", main=i, threshstat = "rmse")

for (i in TestTS)
    smoothLoessPlot(BlueMatrix[i,], dates=Dates, res_type="omit", span=0.2, threshold=c(-3, 4), family="symmetric", main=i, threshstat = "mad")

for (i in TestTS)
    smoothLoessPlot(BlueMatrix[i,], dates=Dates, res_type="omit", span=0.2, threshold=c(-2, 2), family="symmetric", main=i, threshstat = "sd")

i=297100
i=250595 # test bottom
i=146733
i=210376
i=214477 # Test bottom
i=207984
i=357404 # Snow!
i=29110
i=242024
i=279749
i=283071
i=216074
i=181

# sd with -2, 2 looks best

## End thresholding ##

# Get blue mask
CloudMask = pbapply(BlueMatrix, 1, smoothLoessPlot, dates=Dates, res_type="omit", span=0.2, threshstat = "sd", threshold=c(-2, 2), family="symmetric", plot=FALSE)
CloudMask = t(CloudMask)

# Statistics
mean(is.na(BlueMatrix)) # 60.2% of all data is NA
mean(is.na(CloudMask)) # 61.4% of all data is now NA, so we only removed 1%

rm(BlueMatrix)
gc(TRUE)

pb = txtProgressBar(1, 5, style = 3)
for (VI in c("NDVI", paste0("RADIOMETRY-", 1:4)))
{
    InputSF = st_read(InputDB, VI)
    stopifnot(all(InputSF$X == BlueXY$X))
    InputMatrix = as.matrix(as.data.frame(InputSF)[,ColDates])
    InputMatrix[is.na(CloudMask)] = NA
    InputSF[,ColDates] = InputMatrix
    rm(InputMatrix)
    gc(TRUE)
    st_write(InputSF, OutputDB, VI)
    rm(InputSF)
    gc(TRUE)
    setTxtProgressBar(pb, pb$getVal()+1)
}
close(pb)


 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)


### 과제1 의사결정트리 실습문제

df_skin <- read.csv('./skin.csv', header = T)
str(df_skin)
# 'data.frame':	30 obs. of  7 variables:
# $ 고객번호    : int  1 2 3 4 5 6 7 8 9 10 ...
# $ 성별        : chr  "남" "여" "여" "여" ...
# $ 나이        : chr  "30대" "20대" "20대" "40대" ...
# $ 직장여부    : chr  "NO" "YES" "YES" "NO" ...
# $ 결혼여부    : chr  "YES" "YES" "YES" "NO" ...
# $ 차량보유여부: chr  "NO" "YES" "NO" "NO" ...
# $ 쿠폰반응여부: chr  "NO" "NO" "NO" "NO" ...

df_skin <- df_skin[-1] # 1번째 idx 빼고 저장 (고객번호)
head(df_skin)
# 성별 나이 직장여부 결혼여부 차량보유여부 쿠폰반응여부
# 1   남 30대       NO      YES           NO           NO
# 2   여 20대      YES      YES          YES           NO
# 3   여 20대      YES      YES           NO           NO
# 4   여 40대       NO       NO           NO           NO
# 5   여 30대       NO      YES           NO           NO
# 6   여 30대       NO       NO          YES           NO

library(rpart)
library(rattle)
library(rpart.plot)
library(RColorBrewer)

tree1 <- rpart(쿠폰반응여부 ~ ., data=df_skin, control=rpart.control(minsplit = 2))
plot(tree1, compress = T, uniform = T, margin=0.1)
text(tree1, use.n = T, col = "blue")
tree1

# 오류가 존재하지 않을 때 까지 가지 생성

# n= 30
#
# node), split, n, loss, yval, (yprob)
# * denotes terminal node
#
# 1) root 30 12 NO (0.6000000 0.4000000)
# 2) 결혼여부=NO 10  0 NO (1.0000000 0.0000000) *
#   3) 결혼여부=YES 20  8 YES (0.4000000 0.6000000)
#   6) 나이=20대,30대 16  8 NO (0.5000000 0.5000000)
#   12) 성별=남 5  1 NO (0.8000000 0.2000000)
#   24) 직장여부=NO 3  0 NO (1.0000000 0.0000000) *
#     25) 직장여부=YES 2  1 NO (0.5000000 0.5000000)
#     50) 나이=20대 1  0 NO (1.0000000 0.0000000) *
#       51) 나이=30대 1  0 YES (0.0000000 1.0000000) *
#         13) 성별=여 11  4 YES (0.3636364 0.6363636)
#         26) 나이=20대 5  2 NO (0.6000000 0.4000000)
#         52) 직장여부=YES 2  0 NO (1.0000000 0.0000000) *
#           53) 직장여부=NO 3  1 YES (0.3333333 0.6666667)
#           106) 차량보유여부=NO 1  0 NO (1.0000000 0.0000000) *
#             107) 차량보유여부=YES 2  0 YES (0.0000000 1.0000000) *
#               27) 나이=30대 6  1 YES (0.1666667 0.8333333)
#               54) 직장여부=NO 2  1 NO (0.5000000 0.5000000)
#               108) 차량보유여부=NO 1  0 NO (1.0000000 0.0000000) *
#                 109) 차량보유여부=YES 1  0 YES (0.0000000 1.0000000) *
#                   55) 직장여부=YES 4  0 YES (0.0000000 1.0000000) *
#                     7) 나이=40대 4  0 YES (0.0000000 1.0000000) *
#

xtabs(~결혼여부 + 쿠폰반응여부, data=df_skin)

# 쿠폰반응여부
# 결혼여부 NO YES
# NO  10   0
# YES  8  12

chisq.test(xtabs(~결혼여부+쿠폰반응여부, data=df_skin))
# 카이제곱 검정 결과 p-value > 0.05, 귀무가설 기각
# 즉, 카이제곱을 따르지 않는다.
# 변량 간의 영향이 있다. (독립이 아님)

# Pearson's Chi-squared test with Yates' continuity correction
#
# data:  xtabs(~결혼여부 + 쿠폰반응여부, data = df_skin)
# X-squared = 7.6562, df = 1, p-value = 0.005658
#
fancyRpartPlot(tree1)

### 과제2 Doit R 시각화

data("USArrests")
library(rpart)
#install.packages("mapproj")
#install.packages("ggiraphExtra")
library(ggiraphExtra)

str(USArrests)
head(USArrests)
library(tibble) # 행이름을 변수로 바꿔 새 데이터 프레임 만들기
crime <- rownames_to_column(USArrests, var = "state")
crime$state <- tolower(crime$state)
str(crime)

# 지도 데이터 준비
#install.packages("maps")
library(ggplot2)
states_map <- map_data("state")
str("states_map")

#단계구분도
?ggChoropletth
ggChoropleth(data = crime, aes(fill = Murder, map_id = state), map = states_map)
ggChoropleth(data = crime, aes(fill = Murder, map_id = state), map = states_map, interactive = T)


#' @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)
}


library(CHNOSZ)

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

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

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

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

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

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

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

}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  return(data0_template) # returns a single string

}


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

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

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

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

#
I = diag(N)

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

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

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

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

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

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

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


 ZGESDD Example Program Results

 Singular values of A:
         3.9994        3.0003        1.9944        0.9995

 Minimum norm solution:
    ( -0.4024,  0.3777)
    ( -0.2272,  0.3626)
    (  0.1704, -0.1532)
    (  0.2125,  0.0781)
    (  0.2041,  0.2236)
    (  0.2766, -0.1517)

 Norm of Solution:
         0.8846

 Norm of Residual:
         0.0000


library(tidyverse)

mtcars %>% head

theme_set(theme_light())

my_ggsave <- function(plot, filename, height = 11.4, width = 11.4, units = "cm", ...){
    ggsave(filename = filename,
           plot = plot,
           height = height,
           width = width,
           units = units,
           dpi = 300,
           ...)
}

p1 <- ggplot(mtcars, aes(x = wt, y = mpg, col = as.factor(cyl))) +
  geom_point() +
  geom_smooth(method = lm, se = FALSE)

my_ggsave(p1, "scat.png")

fit <- lm(mpg ~ wt * cyl, data = mtcars)
tb1 <- stargazer(fit)
kable(tb1)

p2 <- ggplot(mtcars, aes(x = gear, y = mpg, fill = as.factor(gear))) +
  geom_boxplot()

my_ggsave(p2, "boxp.png")

mtcars$`car name` <- rownames(mtcars)  # create new column for car names
mtcars$mpg_z <- round((mtcars$mpg - mean(mtcars$mpg))/sd(mtcars$mpg), 2)  # compute normalized mpg
mtcars$mpg_type <- ifelse(mtcars$mpg_z < 0, "below", "above")  # above / below avg flag
mtcars <- mtcars[order(mtcars$mpg_z), ]  # sort
mtcars$`car name` <- factor(mtcars$`car name`, levels = mtcars$`car name`)  # convert to factor to retain sorted order in plot.

# Diverging Barcharts
p3 <- ggplot(mtcars, aes(x=`car name`, y=mpg_z, label=mpg_z)) +
  geom_bar(stat='identity', aes(fill=mpg_type), width=.5)  +
  scale_fill_manual(name="Mileage",
                    labels = c("Above Average", "Below Average"),
                    values = c("above"="#00ba38", "below"="#f8766d")) +
  labs(subtitle="Normalised mileage from 'mtcars'",
       title= "Diverging Bars") +
  coord_flip()

my_ggsave(p3, "div_bar.png")


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(1:30, 10)
  cs = colSums(x)
  cm = colMeans(x)
} else {
  x = NULL
}

dx = expand(x)
cs_test = colSums(dx)
cm_test = colMeans(dx)

comm.print(all.equal(cs, cs_test))
comm.print(all.equal(cm, cm_test))

finalize()


# Define a single iteration of the MH within Gibbs sampler
blocked.mcmc.update <- function(U.data, cur){
        cur <- sample.th(U.data, cur)
        cur <- sample.a(U.data, cur)
        cur <- sample.b(U.data, cur)
        cur <- sample.s2(U.data, cur)
        return(cur)
}


setwd("C:/R")
data=read.csv('RestaurantTips.csv',sep=",",header=TRUE)
View(data)
names(data)

plot(data[,2:5],cex.axis=0.6,cex.lab=0.6,cex.labels=0.6,cex=0.6,pch=16)

cor(data[,2:5])

formula1=CustomerWillTip ~ Service + Food + Ambience
LGModel<-glm(formula1 , data = data, family = binomial(logit))
summary(LGModel)

LGModel1<-glm(CustomerWillTip ~ Service, data = data, family = binomial(logit))
summary(LGModel1)

LGModel1Pred <- round(predict(LGModel1, data, type="response"))

library(caret)
LGModel1CM <- confusionMatrix(LGModel1Pred, data[,"CustomerWillTip"])
LGModel1CM


# Survival time with stratification.  Thanks: Cathy Jenkins
require(rms)
Load(sampledf)
S  <- with(sampledf, Surv(fu, death))
dd <- datadist(sampledf); options(datadist='dd')

f <- cph(S ~ rcs(age, c(1, 2, 4)) + rcs(sqrt(cd4), sqrt(c(210,475,875))) +
           strat(site), data=sampledf, x=TRUE, y=TRUE, iter.max=30, eps=1e-10)
g <- coxph(S ~ rcs(age, c(1, 2, 4)) + rcs(sqrt(cd4), sqrt(c(210,475,875))) +
             strata(site), data=sampledf, x=TRUE, y=TRUE, control=coxph.control(eps=1e-10, iter.max=30))

# -------------------------- #
#   Survival probabilities   #
#         at 1 year          #
#  for fixed ages/CD4 counts #
# -------------------------- #
Pd <- expand.grid(age=c(1,2,6,9,15),
                  cd4=c(100,200,350,500),
                  site=levels(sampledf$site))
pd <- Pd[1, ]

a <- survfit(f, newdata=pd); a$strata
b <- survfit(g, newdata=pd); b$strata

h <- function(a, b, chkeq=FALSE) {
  a <- sapply(a, length)
  b <- sapply(b, length)
  k <- unique(c(names(a), names(b)))
  z <- matrix(NA, nrow=length(k), ncol=2, dimnames=list(k, c('a', 'b')))
  z[names(a), 'a'] <- a
  z[names(b), 'b'] <- b
  print(z)
  if(chkeq) {
    k <- intersect(names(a), names(b))
    for(n in k)
      cat(n, ' equal:', all.equal(a[[n]], b[[n]]), '\n')
    }
}
h(a, b)

a <- survfit(f, newdata=Pd)
b <- survfit(g, newdata=Pd)
h(a, b, chkeq=TRUE)

z <- summary(survfit(g, newdata=Pd[1:1,]), times=5)

z <- survest(f, newdata=Pd[33,], times=5)

comp <- function(a, b, ntimes=1, time=1, ib=TRUE) {
  b$std.err <- b$std.err / b$surv
  for(n in c('time', 'surv', 'std.err', 'lower', 'upper',
             if(length(a$strata)) 'strata')) {
    x <- a[[n]]
    y <- b[[n]][ib]
    if(n %nin% c('time', 'strata') && ntimes > 1) {
      x <- x[, time]
      y <- y[seq(time, length(y), by=ntimes)]
      }
    cat(n, ' equal:',
        if(length(x) == length(y)) all.equal(x, y)
        else
          paste('lengths:', length(x), length(y)),
        '\n')
  }
}

chk <- function(f, g, strat=FALSE) {
  a <- survest(f, newdata=Pd[33,], times=5)
  b <- summary(survfit(g, newdata=Pd[33,]), times=5)
  cat('-------------------------- newdata 1 row, 1 time\n')
  comp(a, b, ib=if(strat) 2 else TRUE)

  a <- survest(f, newdata=Pd, times=5)
  b <- summary(survfit(g, newdata=Pd), times=5)
  cat('-------------------------- newdata all, 1 time\n')
  comp(a, b)

  a <- survest(f, newdata=Pd, times=5:6)
  b <- summary(survfit(g, newdata=Pd), times=5:6)
  cat('-------------------------- newdata all, 2 times\n')
  comp(a, b, ntimes=2, time=1)
}
chk(f, g, strat=TRUE)

## Try with no strata

f <- cph  (S ~ rcs(age, c(1, 2, 4)) + rcs(sqrt(cd4), sqrt(c(210,475,875))) +
           site, data=sampledf, x=TRUE, y=TRUE, iter.max=30, eps=1e-10)
g <- coxph(S ~ rcs(age, c(1, 2, 4)) + rcs(sqrt(cd4), sqrt(c(210,475,875))) +
             site, data=sampledf, x=TRUE, y=TRUE, control=coxph.control(eps=1e-10, iter.max=30))
cbind(coef(f), coef(g))

chk(f, g)


#fitting as much as I can to tedersoo
#clear environment, source functions.
rm(list=ls())
source('NEFI_functions/crib_fun.r')
source('paths.r')

#load data
d <- data.table(readRDS(ted.ITSprior_data))

#transform [0,1] to (0,1) a la Cribari-Neto & Zeileis 2010
start <- grep("Ectomycorrhizal", colnames(d))
  end <- grep('hydrophobic', colnames(d))
d[,start:end] <- lapply(d[,start:end],crib_fun)

#functional group y data.
y_fg <- d[,.(Ectomycorrhizal,Saprotroph,Arbuscular,Pathogen,hydrophillic,hydrophobic)]
y_fg <- as.data.frame(y_fg)
#genus level y data.
start <- grep('Russula',colnames(d))
  end <- grep('Tricholoma',colnames(d))
y_ge <- d[,start:end]
y_ge <- as.data.frame(y_ge)

#Get matrix of predictors.
x <- d[,.(pH,moisture,pC,cn,doy,NPP,mat,map,mat_CV,map_CV,mdr,aridity,latitude,forest,conifer,relEM)]
x <- d[,.(pH,moisture,pC,cn    ,NPP,mat,map,mat_CV,map_CV,mdr,aridity,latitude,forest,conifer,relEM)]
#x$mat_relEM <- x$mat * x$relEM
x <- as.data.frame(x)

fg_models <- list()
for(i in 1:ncol(y_fg)){
  name <- colnames(y_fg)[i]
  data <- cbind(y_fg[,i],x)
  colnames(data)[1] <- 'y'
  data <- data[complete.cases(data),]
  preds <- paste(colnames(x), collapse = ' + ')
  form <- as.formula(paste0('y ~ ',preds))
  mod <- betareg::betareg(form, data = data)
   pred <- fitted(mod)
    obs <- data$y
  resid <- obs - pred
  super.list <- list(mod,pred,obs,resid)
  names(super.list) <- c('model','predicted','observed','residual')
  fg_models[[i]] <- super.list
}
names(fg_models) <- colnames(y_fg)

ge_models <- list()
for(i in 1:ncol(y_ge)){
  name <- colnames(y_ge)[i]
  data <- cbind(y_ge[,i],x)
  colnames(data)[1] <- 'y'
  data <- data[complete.cases(data),]
  preds <- paste(colnames(x), collapse = ' + ')
  form <- as.formula(paste0('y ~ ',preds))
  mod <- betareg::betareg(form, data = data)
  pred <- fitted(mod)
  obs <- data$y
  resid <- obs - pred
  super.list <- list(mod,pred,obs,resid)
  names(super.list) <- c('model','predicted','observed','residual')
  ge_models[[i]] <- super.list
}
names(ge_models) <- colnames(y_ge)

#png(filename='figures/ted_ITSprior_fg_fits.png',width=12,height=10,units='in',res=300)
par(mfrow = c(2,3))
for(i in 1:length(fg_models)){
  name <- names(fg_models)[i]
  rsq <- round(summary(fg_models[[i]]$model)$pseudo.r.squared,3)
  plot(fg_models[[i]]$observed ~ fg_models[[i]]$predicted, cex = 2) #on relative scale
  abline(lm(fg_models[[i]]$observed ~ fg_models[[i]]$predicted), lty = 2, col = 'green')
  #plot(boot::logit(fg_models[[i]]$observed) ~ boot::logit(fg_models[[i]]$predicted), cex = 0.8) #logit transform to linear.
  #abline(lm(boot::logit(fg_models[[i]]$observed) ~ boot::logit(fg_models[[i]]$predicted)), lty = 2, col = 'green')
  abline(0,1,lwd=2)
  mtext(name, line = -2, adj = 0.05, col = 'purple')
  mtext(paste0('R2 = ',rsq), line = -3.2, adj = 0.05, col = 'purple')
}

#dev.off()

#png(filename='figures/ted_ITSprior_20.top.genera_fits.png',width=12,height=10,units='in',res=300)
par(mfrow = c(5,4),
    mai = c(0.3,0.3,0.3,0.3))
for(i in 1:length(ge_models)){
  name <- names(ge_models)[i]
  rsq <- round(summary(ge_models[[i]]$model)$pseudo.r.squared,3)
  plot(ge_models[[i]]$observed ~ ge_models[[i]]$predicted, cex = 0.8)
  abline(lm(ge_models[[i]]$observed ~ ge_models[[i]]$predicted), lty = 2, col = 'green')
  #plot(boot::logit(ge_models[[i]]$observed) ~ boot::logit(ge_models[[i]]$predicted), cex = 0.8) #logit transform to linear.
  #abline(lm(boot::logit(ge_models[[i]]$observed) ~ boot::logit(ge_models[[i]]$predicted)), lty = 2, col = 'green')
  abline(0,1,lwd=2)
  mtext(name, line = -2, adj = 0.05, col = 'purple')
  mtext(paste0('R2 = ',rsq), line = -3.2, adj = 0.05, col = 'purple')
}
#dev.off()