library("e1071")
source('load.r')
source('../utils.r')
load_mnist()
sink(file = 'results.txt')
samples = resampleBase(train$x, train$y, 0.2, c(5, 8))
reduction = reducePCA(samples$X)
samples$X = reduction$x
# linear
logMessage('Linear')
r = run.experiment(samples, c(1), c(0), c(10,100), 1, "linear")
a = gb.analyze(r$n, r$nu, r$radius, r$rho)
print(a$gb)
print(a$n)
# polynomial
logMessage('Polynomial')
r = run.experiment(samples, c(1,2,3), c(0,1), c(10,100), 1, "polynomial")
a = gb.analyze(r$n, r$nu, r$radius, r$rho)
print(a$gb)
print(a$n)
# gaussian
logMessage('Gaussian')
r = run.experiment(samples, c(1), c(0), c(10,100), 1, "radial")
a = gb.analyze(r$n, r$nu, r$radius, r$rho)
print(a$gb)
print(a$n)
sink()
asdasd
tests = resampleBase(test$x, test$y, 1.0, c(5, 8))
logMessage("Prepare test data")
tests$X = scale(tests$X, reduction$pca$center, reduction$pca$scale) %*% reduction$pca$rotation
tests$X = tests$X[,1:reduction$i]
logMessage("Predicting tests")
prediction = predict(svm.model, tests$X)
logMessage("finished!")


isobath_db = function(
  p = NULL,
  spatial_domain="canada.east.superhighres",
  depths=c( 0, 10, 20, 50, 75, 100, 200, 250, 300, 350, 400, 450, 500, 550, 600, 700, 750, 800, 900,
             1000, 1200, 1250, 1400, 1500, 1750, 2000, 2500, 3000, 4000, 5000 ),
  DS="isobath",
  project_to=projection_proj4string("lonlat_wgs84"),
  data_dir=project.datadirectory( "aegis", "bathymetry" ),
  aRange = 3  # # pixels to approx 1 SD ,
   ) {

  #\\ create or return isobaths and coastlines/coast polygons
  #\\ isobaths come from aggregated data (resolution of pres) which is then locally smoothed through a guassian kernal process

  if (DS %in% c( "isobath", "isobath.redo" )) {

    # behviour determmined by p. If passed then a p-specific Zsmooth is created otherwise use the highest resoltuion for the region
    require (fields)

    if ( spatial_domain %in% c( "canada.east.superhighres", "canada.east.highres", "canada.east", "SSE", "SSE.mpa" , "snowcrab" ) ) spatial_domain_input = "canada.east.superhighres"

    isobaths = NULL

    options( max.contour.segments=50000 )

    depths = sort( unique( depths ) )

    if ( is.null(p)) {

      if ( DS == "isobath" ) {

        fn.iso = file.path( data_dir, "isobaths", paste("isobaths", spatial_domain_input, "rdata", sep=".") )  # in case there is an alternate project

        if (file.exists(fn.iso)) {
          load(fn.iso)
          isobaths = as( isobaths, "sf")

          nn = row.names(isobaths)
          if ( st_crs( isobaths ) != st_crs(project_to) ) isobaths = st_transform( isobaths, st_crs( project_to ) )

          notfound = setdiff( as.character(depths), nn )

          if (length( notfound) > 0 ) {
            message( "matching isobaths not found, computing on the fly  .. " )

            Zsmoothed = attributes( isobaths)$Zsmoothed

            x = seq(min(attributes( isobaths)$corners$plon), max(attributes( isobaths)$corners$plon), by=attributes( isobaths)$pres)
            y = seq(min(attributes( isobaths)$corners$plat), max(attributes( isobaths)$corners$plat), by=attributes( isobaths)$pres)

            cl = contourLines( x=x, y=y, Zsmoothed$z, levels=depths )

            iso_crs = attributes( isobaths)$proj4string_planar
            isobaths = maptools::ContourLines2SLDF(cl, proj4string=sp::CRS(iso_crs) )
            isobaths = as( isobaths, "sf")
            st_crs(isobaths) = st_crs( iso_crs )

            isobaths = st_transform( isobaths, st_crs(projection_proj4string("lonlat_wgs84")) )  ## longlat  as storage format
            row.names(isobaths) = as.character(isobaths$level)

          }
          return( isobaths  )
        }
      }

    }

    # here is redoing or p is passed and a lower (alt) resolution, p-specific isobath is desired
    if (is.null(p)) p = aegis.bathymetry::bathymetry_parameters( spatial_domain=spatial_domain_input )

    fn.iso = file.path( data_dir, "isobaths", paste("isobaths", spatial_domain, "rdata", sep=".") )  # in case there is an alternate project

    Z = bathymetry_db( p=p, DS="aggregated_data" )
    Zi = array_map( "xy->2", Z[, c("plon", "plat")], gridparams=p$gridparams )

    # remove raw data outside of the bounding box
    good = which( Zi[,1] >= 1 & Zi[,1] <= p$nplons & Zi[,2] >= 1 & Zi[,2] <= p$nplats )
    Zi = Zi[good,]
    Z = Z[good,]

    Zmatrix = matrix(NA, nrow=p$nplons, ncol=p$nplats )
    Zmatrix[Zi] = Z$z.mean
    Zsmoothed = image.smooth( Zmatrix, aRange=aRange )

    x = seq(min(p$corners$plon), max(p$corners$plon), by=p$pres)
    y = seq(min(p$corners$plat), max(p$corners$plat), by=p$pres)

    cl = contourLines( x=x, y=y, Zsmoothed$z, levels=depths )

    isobaths = maptools::ContourLines2SLDF(cl, proj4string=sp::CRS( p$aegis_proj4string_planar_km ) )
    isobaths = as( isobaths, "sf")
    st_crs(isobaths) = st_crs( p$aegis_proj4string_planar_km  )

    isobaths = st_transform( isobaths, st_crs(projection_proj4string("lonlat_wgs84")) )  ## longlat  as storage format
    row.names(isobaths) = as.character(isobaths$level)

    attr( isobaths, "Zsmoothed" ) = Zsmoothed
    attr( isobaths, "aRange" ) =  aRange
    attr( isobaths, "corners" ) =  p$corners
    attr( isobaths, "pres" ) =  p$pres
    attr( isobaths, "proj4string_planar" ) =  p$aegis_proj4string_planar_km
    attr( isobaths, "proj4string_lonlat" ) =  projection_proj4string("lonlat_wgs84")

    save( isobaths, file=fn.iso, compress=TRUE)

    if ( ! st_crs( isobaths ) == st_crs( project_to) ) isobaths = st_transform( isobaths, st_crs( project_to ) )

    return( isobaths )
  }

  # ------------------------

  if (DS %in% c( "coastLine", "coastLine.redo")) {
    #\\ synomym for coastline_db ... left for historical compatibility .. deprecated
    if (DS=="coastline") return( coastline_db( project_to = project_to   ) )

  }

  # ------------------------

  if (DS %in% c("coastPolygon", "coastPolygon.redo") ) {
    #\\ synomym for coastline_db ... left for historical compatibility .. deprecated
    if (DS=="coastPolygon") return( coastline_db( project_to = project_to   ) )
  }

}


anglesFromLineSizes <- function(a, b, c)
  acos((a**2 - c**2 - b**2)/(-2*b*c)) * 57.295779513

c(anglesFromLineSizes(1.25, 13.30, 13.10),
anglesFromLineSizes(1.55, 13.10, 13.00),
anglesFromLineSizes(1.55, 13.00, 13.10),
anglesFromLineSizes(1.55, 13.10, 13.30))

c(anglesFromLineSizes(1.25, 4.75, 4.35),
  anglesFromLineSizes(1.55, 4.35, 4.00),
  anglesFromLineSizes(1.55, 4.00, 4.35),
  anglesFromLineSizes(1.55, 4.35, 4.75))


#' Unit Testing script for NMF package: NMF distances.
#'
#' @author Renaud Gaujoux
#' @creation 08 April 2010

.TestSeed <- 123456

# make the internal function visible
if( isNamespaceLoaded('NMF') ){
	.rss <- NMF:::.rss
	.KL <- NMF:::.KL
}

check.storage.mode <- function(R.fun, C.fun, name, ...){

	n <- 5000; p <- 50;

	# create random matrices in storage mode double
	x <- rmatrix(n, p, min=1, max=100)
	y <- rmatrix(n, p, min=1, max=100)

	# create random matrices in storage mode integer
	xi <- x; storage.mode(xi) <- 'integer'
	yi <- y; storage.mode(yi) <- 'integer'

	# check result for all combinations
	checkEquals( R.fun(x, y, ...), C.fun(x, y), paste(name, "- Version double-double: OK" ))
	checkEquals( R.fun(x, yi), C.fun(x, yi), paste(name, "- Version double-integer: OK" ))
	checkEquals( R.fun(xi, y), C.fun(xi, y), paste(name, "- Version integer-double: OK" ))
	checkEquals( R.fun(xi, yi), C.fun(xi, yi), paste(name, "- Version integer-integer: OK" ))

}

test.rss <- function(){

	set.seed(.TestSeed)

	# create R version for RSS
	R_rss <- function(x, y) sum((x-y)^2)

	# check the storage mode
	check.storage.mode(R_rss, .rss, 'RSS')
}

test.KL <- function(){

	set.seed(.TestSeed)

	# create R version for RSS
	R_kl <- function(x, y) sum( ifelse(x==0, y, x * log(x/y) - x + y) );

	# check the storage mode
	check.storage.mode(R_kl, .KL, 'KL divergence')

	# create random matrices
	n <- 5000; p <- 50;
	x <- rmatrix(n, p, min=1, max=100)
	y <- rmatrix(n, p, min=1, max=100)

	# check result with NA values
	z <- x; z[1,1] <- NA
	checkTrue( is.na(.KL(z, y)), "Return NA if there is a NA in x")
	checkTrue( is.na(.KL(x, z)), "Return NA if there is a NA in y")

	# check result with NaN values
	z <- x; z[1,1] <- NaN
	checkTrue( is.na(.KL(z, y)), "Return NA if there is a NaN in x")
	checkTrue( is.na(.KL(x, z)), "Return NA if there is a NaN in y")

	# check result with 0 values in y
	z <- y; z[1,1] <- 0
	checkEquals( .KL(x, z), Inf, "Return Inf if there is a 0 in y")

}


#devtools::test("asremlPlus")
context("model_selection")

cat("#### Test for boot using wheat example with asreml4\n")
test_that("Wheatboot_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  ## use asremlPlus to analyse the wheat (barley) example from section 8.6 of the asreml manual (Butler et al. 2010)
  data(Wheat.dat)
  #'## Add cubic trend to Row so that spline is not bound
  Wheat.dat <- within(Wheat.dat,
                      {
                        vRow <- as.numeric(Row)
                        vRow <- vRow - mean(unique(vRow))
                        yield <- yield + 10*vRow + 10 * (vRow^2) + 5 * (vRow^3)
                      })

  # Fit initial model
  asreml.options(design = TRUE)
  current.asr <- do.call("asreml",
                         list(yield ~ Rep + WithinColPairs + Variety,
                              random = ~ spl(vRow) + Row + Column + units,
                              residual = ~ ar1(Row):ar1(Column),
                              maxit=100, data=Wheat.dat))
  summary(current.asr)$varcomp
  info <- infoCriteria(current.asr)
  testthat::expect_equal(info$varDF, 5)
  testthat::expect_lt(abs(info$AIC - 1357.118), 1e-03)

  # Load current fit into an asrtests object
  current.asrt <- as.asrtests(current.asr, NULL, NULL)

  # Check for and remove any boundary terms
  current.asrt <- rmboundary(current.asrt)

  #Check term for within Column pairs
  current.asrt <- testranfix(current.asrt, "WithinColPairs", drop.fix.ns=TRUE)

  # Test nugget term
  current.asrt <- testranfix(current.asrt, "units", positive=TRUE)
  current.asrt$test.summary

  # Use bootstrap to test units
  full.asreml.obj <- current.asrt$asreml.obj
  reduced.asreml.obj <- update(full.asreml.obj, random = ~ . - units)
  units.lrt <- REMLRT(h0.asreml.obj = reduced.asreml.obj,
                      h1.asreml.obj = full.asreml.obj)
  boot.units <- bootREMLRT(h0.asreml.obj = reduced.asreml.obj,
                           h1.asreml.obj = full.asreml.obj,
                           nboot = 100, seed = 6250,
                           fixed.spline.terms = "spl(vRow)")
  testthat::expect_equal(length(boot.units), 6)
  testthat::expect_equal(boot.units$DF, 1)
  testthat::expect_equal(length(boot.units$REMLRT.sim) +
                           length(attr(boot.units$REMLRT.sim, which = "na.action")), 100)
  testthat::expect_equal(length(boot.units$nunconverged), 100)
  testthat::expect_lt(abs(boot.units$REMLRT - 10.9), 1e-01)
  testthat::expect_lt(abs(boot.units$REMLRT - units.lrt$REMLRT), 1e-01)

  # Use bootstrap to test Row autocorrelation
  full.asreml.obj <- current.asrt$asreml.obj
  reduced.asreml.obj <- update(full.asreml.obj, residual. = ~ Row:ar1(Column))
  arR.lrt <- REMLRT(h0.asreml.obj = reduced.asreml.obj,
                    h1.asreml.obj = full.asreml.obj)
  REMLRT(h0.asreml.obj = reduced.asreml.obj,
         h1.asreml.obj = full.asreml.obj, bound.exclusions = "B")
  boot.units <- bootREMLRT(h0.asreml.obj = reduced.asreml.obj,
                           h1.asreml.obj = full.asreml.obj,
                           nboot = 100, seed = 6250,
                           fixed.spline.terms = "spl(vRow)")
  testthat::expect_equal(length(boot.units), 6)
  testthat::expect_equal(boot.units$DF, 2)
  testthat::expect_equal(length(boot.units$REMLRT.sim) +
                           length(attr(boot.units$REMLRT.sim, which = "na.action")), 100)
  testthat::expect_equal(length(boot.units$nunconverged), 100)
  testthat::expect_lt(abs(boot.units$REMLRT - 29.8), 1e-01)
  testthat::expect_lt(abs(boot.units$REMLRT - arR.lrt$REMLRT), 1e-01)

  # Use bootstrap to test Col autocorrelation
  reduced.asreml.obj <- update(full.asreml.obj, residual. = ~ ar1(Row):Column)
  arC.lrt <- REMLRT(h0.asreml.obj = reduced.asreml.obj,
                    h1.asreml.obj = full.asreml.obj)
  boot.units <- bootREMLRT(h0.asreml.obj = reduced.asreml.obj,
                           h1.asreml.obj = full.asreml.obj,
                           nboot = 100, seed = 6250,
                           fixed.spline.terms = "spl(vRow)")
  testthat::expect_equal(length(boot.units), 6)
  testthat::expect_equal(boot.units$DF, 1)
  testthat::expect_equal(length(boot.units$REMLRT.sim) +
                           length(attr(boot.units$REMLRT.sim, which = "na.action")), 100)
  testthat::expect_equal(length(boot.units$nunconverged), 100)
  testthat::expect_lt(abs(boot.units$REMLRT - 56.1), 1e-01)
  testthat::expect_lt(abs(boot.units$REMLRT - arC.lrt$REMLRT), 1e-01)

  asreml.options(design = FALSE)
})


library(MASS)
library(flexmix)
n.iters <- 1000

policy.RPM.Logit.LC2 <- function(m,y,...){

  d$impressions <- m
  d$conversions <- y

  d$arm <- d$sizeandconcept
  arm.names <- levels(d$arm)

  y.perarm <- tapply(d$conversions, list(d$arm), sum)
  m.perarm <- tapply(d$impressions, list(d$arm), sum)
  mu.obs <- y.perarm/m.perarm

  concept <- d$concept
  size <- d$size
  concept_each <- factor(rep(levels(concept),3))
  size_each <- factor(rep(levels(size),each=4))
  creative.names <- paste(size_each, concept_each, sep="_")
  designmatrix.interactions <- model.matrix( ~ size_each*concept_each)[,-1]
  rownames(designmatrix.interactions) <- creative.names

model2seg.interactions <- stepFlexmix(cbind(conversions,impressions-conversions) ~ 1+ size*concept | unitid,
            model = FLXMRglmfix(family = "binomial",fixed = ~1 ),
            data = d, k = 2, nrep = 5,
            control = list(iter=20, verbose=0, classify="weighted")
            )
model2seg.interactions.refit <- refit(model2seg.interactions)

mi <- model2seg.interactions
miref <- model2seg.interactions.refit
ncoef <- length(miref@coef)-1

#miref@coef
#miref@vcov
#miref@coef[(ncoef+1)]
#miref@coef[-(ncoef+1)]
#miref@vcov[-(ncoef+1),-(ncoef+1)]
#posterior(mi)[,2]
#summary(miref)
#miref@coef[(ncoef+1)]
#sqrt( miref@vcov[(ncoef+1),(ncoef+1)] )
#miref@vcov[(ncoef+1),(ncoef+1)]

mu.wgtavg <- apply( fitted(mi)*posterior(mi) , 1, sum)
mu.obs <- d$conversions/d$impressions

latent.class.assignment <- clusters(mi)
latent.class.postprob <- posterior(mi)

# for each segment
idx.1 <- 1:(ncoef/2)
idx.2 <- (ncoef/2+1):ncoef

beta.glm.mean.1 <- miref@coef[idx.1]
beta.glm.se.1 <- sqrt(diag(miref@vcov[idx.1,idx.1]))
beta.glm.varcov.1 <- miref@vcov[idx.1,idx.1]

beta.glm.mean.2 <- miref@coef[idx.2]
beta.glm.se.2 <- sqrt(diag(miref@vcov[idx.2,idx.2]))
beta.glm.varcov.2 <- miref@vcov[idx.2,idx.2]

### ------  estimates2allocprobs( ) ----- ###
### ---- FUNCTION STAR ----- ###
estimates2allocprobs <- function(beta.glm.mean, beta.glm.varcov, desmat=designmatrix.interactions, ...){ # begin
  beta.glm.samp <- mvrnorm(n.iters, beta.glm.mean, beta.glm.varcov)
  zstar.samp <- beta.glm.samp %*% t(cbind(rep(1,nrow(desmat)),desmat))
  zstar.which.max <- factor( apply(zstar.samp, 1, which.max), levels=1:ncol(zstar.samp) )
  alloc.probs <- as.numeric( table( zstar.which.max )/dim(zstar.samp)[1] )

  zstar.which.max.size1 <- factor( apply(zstar.samp[,1:4],1,which.max), levels=1:4 )
  zstar.which.max.size2 <- factor( apply(zstar.samp[,5:8],1,which.max), levels=1:4 )
  zstar.which.max.size3 <- factor( apply(zstar.samp[,9:12],1,which.max), levels=1:4 )
  alloc.probs.size1 <- as.numeric( table( zstar.which.max.size1 )/dim(zstar.samp)[1] )
  alloc.probs.size2 <- as.numeric( table( zstar.which.max.size2 )/dim(zstar.samp)[1] )
  alloc.probs.size3 <- as.numeric( table( zstar.which.max.size3 )/dim(zstar.samp)[1] )

  zstar.byarm.post.mean <- apply( zstar.samp, 2, mean )
  p.samp <- 1/( 1 + exp(-zstar.samp) )
  z.samp <- zstar.samp
  prob.byarm.post.mean <- 1/( 1 + exp(-zstar.byarm.post.mean) )
  alloc.probs.byconcept <- c(sum( alloc.probs[ c(1,5,9) ] ),
                            sum( alloc.probs[ c(2,6,10) ] ),
                            sum( alloc.probs[ c(3,7,11) ] ),
                            sum( alloc.probs[ c(4,8,12) ] ) )
  alloc.probs.withinsize <- c(alloc.probs.size1, alloc.probs.size2, alloc.probs.size3 )
  return(list(p.samp=p.samp,
              z.samp=z.samp,
              alloc.probs=alloc.probs,
              alloc.probs.byconcept=alloc.probs.byconcept,
              alloc.probs.withinsize=alloc.probs.withinsize)
         )
} #
### ---- FUNCTION END ----- ###

psamplist.seg1 <- estimates2allocprobs(beta.glm.mean.1, beta.glm.varcov.1, desmat=designmatrix.interactions)
psamplist.seg2 <- estimates2allocprobs(beta.glm.mean.2, beta.glm.varcov.2, desmat=designmatrix.interactions)

p.samp.seg1 <- psamplist.seg1$p.samp
z.samp.seg1 <- psamplist.seg1$z.samp
alloc.probs.seg1 <- psamplist.seg1$alloc.probs
alloc.probs.byconcept.seg1 <- psamplist.seg1$alloc.probs.byconcept
alloc.probs.withinsize.seg1 <- psamplist.seg1$alloc.probs.withinsize

p.samp.seg2 <- psamplist.seg2$p.samp
z.samp.seg2 <- psamplist.seg2$z.samp
alloc.probs.seg2 <- psamplist.seg2$alloc.probs
alloc.probs.byconcept.seg2 <- psamplist.seg2$alloc.probs.byconcept
alloc.probs.withinsize.seg2 <- psamplist.seg2$alloc.probs.withinsize

# create space for resampling within each j
d.long <- d[ rep(1:nrow(d), each=n.iters), ]
d.long$iter <- rep(1:n.iters, nrow(d))
d.long$p.samp <- rep(0, nrow(d)*n.iters)
d.long$z.samp <- rep(0, nrow(d)*n.iters)

# draw latent class assignments using seg2 probabilities
d.long$latent.class.postprob.seg2 <- latent.class.postprob[ rep(1:nrow(d), each=n.iters), 2]
d.long$segnum <- rbinom(nrow(d.long), d.long$latent.class.postprob.seg2, size=1) + 1
d.long$segment <- paste("segment",d.long$segnum,sep="")

# combine p sampled from each segment in proportion to membership prob to each segment
d.long$adsize <- d.long$size
K <- length(arm.names)
for (k in 1:K){
    curobs.long.1 <- d.long$arm==arm.names[k] & d.long$segment=="segment1"
    curobs.long.2 <- d.long$arm==arm.names[k] & d.long$segment=="segment2"
    d.long$z.samp[curobs.long.1] <- sample(z.samp.seg1[,k],size=sum(curobs.long.1),replace=T)
    d.long$z.samp[curobs.long.2] <- sample(z.samp.seg2[,k],size=sum(curobs.long.2),replace=T)
}

# obtain combined w, looping over j
w <- rep(0,nrow(d))
place <- d$placeid
for ( curplace in levels(place) ){
  curobs.long <- which(d.long$placeid == curplace)
  zsampperj <- matrix( d.long$z.samp[curobs.long], nrow=n.iters, ncol=4, byrow=F )
  zsampperj.whichmax <- factor( apply(zsampperj,1,which.max) , levels=1:4 )
  wcur <- as.numeric( table( zsampperj.whichmax ) )/n.iters
  curobs <- which(d$placeid == curplace)
  w[ curobs ] <- wcur
}

return(list(w=w))

} ### END FUNCTION  policy.RPM.Logit.LC2


library(MASS)
pdf("empericalDist.bin100.pdf")

s<-read.table("empericalDist.bin100")
allFrag<-s[1:10000,2]
x<-read.table("bin100.withNonloop")
#a<-log(x[1:1000,2])

b<-log(x[1:1000,1]*100+50)
print(sum(as.numeric(x[,2])))
c<-x[1:1000,2]
excludeFRpair<-x[1:10000,2]
FRpair<-(allFrag-excludeFRpair)/allFrag
plot(FRpair)
print(mean(FRpair[15:10000]))
c<-c/3*4
#c<-s[1:1000,2]
#d<-log(x[1:1000,1]*100+50)

y<-read.table("csDistanceDistr")
meanNum<-mean(y[,2])
c=c/y[,2]

glmfit<-glm(c~b, family="poisson")
print (glmfit)
print(coef(glmfit)[1])
print(coef(glmfit)[2])

mu<- (coef(glmfit)[1])
beta<- (coef(glmfit)[2])

#lmfit<-lm(a~b)
#print (lmfit)
#mu<- (coef(lmfit)[1])
#beta<- (coef(lmfit)[2])
head(c)

plot(b,log(c))
lines(c(0,-mu/beta),c(mu,0))
plot(b,c,ylim=c(0,10))
plot(b,log(c),xlim=c(4,12))
#lines(smooth.spline(b[11:1000],log(c[11:1000])))
#smspl<-(smooth.spline(b[11:1000],log(c[11:1000])))
#print(smspl$fit)
#summary(smspl)
lmobj<-lm(log(c) ~ poly(b, 7, raw=TRUE))
#lines(seq(4,12,0.01),predict.lm(lmobj,seq(4,12,0.01)))
lines(b, fitted(lmobj), col='red', type='b')
coefNames<-matrix(0.0, length(coef(lmobj)),1)
print(coefNames)
coefNames[1,1]<-0
for(i in 2:length(coef(lmobj)))
{
    coefNames[i,1]<-substr(names(coef(lmobj))[i],nchar(names(coef(lmobj))[i]),nchar(names(coef(lmobj))[i]))
}
print(coefNames)
coefMatrix<-cbind(coefNames,coef(lmobj))
print(coefMatrix)
write.matrix(coefMatrix, file="PolyCoef", sep=" ")
print(summary(lmobj))
print(lmobj)
#co<-coef(lmobj)
#co[1]+co[2]*7+co[3]*7^2+co[4]*7^3+co[5]*7^4+co[6]*7^5+co[7]*7^6+co[8]*7^7
dev.off()


# Define the function for Bayesian Parallel Analysis --------------------

bayes.pa <- function(data, n.thin = 1, N.draw = 100, n.burnin = 1000, N.CD = 100, quantile = .95, report = "probability"){

  # data refers to the raw data of scores
  # n.thin refers to the thinning parameter for MCMC
  # N.draw refers to the number of draws from the posterior to be used in B-PA
  # n.burnin refers to the number of iterations to burn in MCMC sampler
  # N.CD refers to the number of comparison datasets (per each draw from the posterior)
  # quantile refers to the cutoff of the distribution used to evaluate whether the observed eigenvalue is sufficiently large
  # report refers to whether to report results as a probability or percentage

  # load the required packages
  library(psych)
  library(MCMCpack)

  #function for generating the model syntax to run lavaan
  triag_model <- function(P, num.factor){

    random.rows <- sample(1:P, num.factor, replace=F) #generate random numbers to decide which rows to use

    output_fixed <- matrix(rep(NA,(num.factor)*(num.factor-1)),
                           nrow = (num.factor)*(num.factor-1)/2, ncol = 2)

    output_constraint <- matrix(rep(NA,num.factor*2), ncol = 2)

    count2 <- 1
    for (i1 in 1:(num.factor-1)){
      for (i2 in (i1+1):num.factor){
        output_fixed[count2,1] <- i2
        output_fixed[count2,2] <- random.rows[i1]
        count2 <- count2 + 1
      }
    }

    for (i1 in 1: num.factor){
      output_constraint[i1,1] <- i1
      output_constraint[i1,2] <- random.rows[i1]
    }

    colnames(output_fixed)      <- c("factor","item")
    colnames(output_constraint) <- c("factor","item")

    #specifying the loading matrix
    row_which.factor <- c(rep(NA,num.factor))
    tmp1 <- matrix(c(rep(NA,P)),nrow=num.factor,ncol=P)
    for (which.factor in 1:num.factor){
      for (which.item in 1:P){
        tmp1[which.factor, which.item] <- paste("r",which.factor,which.item, "*V", which.item, sep="")
      }

      row_which.factor[which.factor] <- paste("f", which.factor,"=~", tmp1[which.factor, 1]  ,sep="")
      for (which.item in 2:P){
        row_which.factor[which.factor] <- paste(row_which.factor[which.factor], tmp1[which.factor, which.item], sep="+")
      }
    }

    #facor correlations need to be fixed at 0;
    #given num.factor, I need num.factor-1 rows to make it an identity matrix
    row_factor_cor <- c(rep(NA, (num.factor*(num.factor-1)/2)))
    for (i in 2:num.factor){
      for (j in 1: (i-1))
        row_factor_cor[ (i-1)*(i-2)/2+j ] <- paste("f", i, "~~0*f", j, sep="")
    }

    #next, put the loadings to zero indicated by the randomly selected rows;
    rows_constraint <- rep(NA, (num.factor)*(num.factor-1)/2)

    count<-1

    for (i in 1: (length(random.rows)-1)){
      for (j in (i+1):(num.factor)){
        rows_constraint[count] <- paste("r", j ,random.rows[i],"==0",sep="")
        count<-count+1
      }
    }

    #Last, combine the syntax to form the model specification
    model <- row_which.factor[1]
    for (i in 2:(num.factor)){
      model <- paste(model, row_which.factor[i],sep='\n')
    }

    for (i in 1:length(row_factor_cor)){
      model <- paste(model, row_factor_cor[i],sep='\n')
    }

    for (i in 1:length(rows_constraint)){
      model <- paste(model, rows_constraint[i], sep='\n')
    }
    # print the syntax I wrote using : cat(model)
    #random.rows

    fixed_param <- rep(NA, num.factor)

    for (i in 1:num.factor){

      fixed_param[i] <- paste("r", i, random.rows[i], sep="")

    }

    return(list(model=model,
                fixed_param=fixed_param,
                output_fixed = output_fixed,
                output_constraint = output_constraint))
  }
  #function for generating parallel data set
  gen.pa.data <- function(n_sample, ni, est_lambda_CD, est_unique_CD){

    implied_matrix <- est_lambda_CD %*% t(est_lambda_CD) + diag(est_unique_CD)
    generated.data <- mvrnorm(n = n_sample, mu = rep(0, ni), Sigma = implied_matrix)

  }

  N <- dim(data)[1] #sample size
  P <- dim(data)[2] #n of item

  data <- as.matrix(data)

  c_names <- rep(NA, P)
  for (i in 1:P){c_names[i]<-paste("V",i,sep="")}
  colnames(data) <- c_names

  eigs.data <- fa(data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values # Compute the eigenvalues for observed data
  F.Max <- sum(eigs.data>0) #define the max number of possible factors

  eigs.comp.array <- array(NA, c(P, N.CD, N.draw, F.Max)) # set up array for saving eigenvalues from comparsion datasets

  #create a vector to save the results
  sav_result <- matrix(rep(NA, N.draw * P), nrow = N.draw, P)

  # Generate N.CD comparision datasets based on the kth factor and compare eigen values, test the number of factors
  T.NFactor=1 # Start with testing one factor

  while(T.NFactor <= F.Max){ # Loop from one factor to the max number of factors
    # Testing the first factor
    if(T.NFactor==1){

      print(paste0("Evaluating factor ", T.NFactor, " of ", F.Max))

      for(which.cd in 1:N.CD){ # Loop over N.CD comparsion datasets

        # generate one comparsion dataset using computed loadings
        comp.data <- matrix(rnorm(N*P), nrow=N, ncol=P)
        cor.comp.data <- cor(comp.data) # compute the correlation matrix

        # save the eigenvalues from running PAF on the comparison dataset
        eigs.comp.array[ , which.cd, 1, T.NFactor] <- fa(cor.comp.data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values
      }

      if(eigs.data[T.NFactor]>as.numeric(quantile(eigs.comp.array[T.NFactor, , 1,  T.NFactor], quantile))) T.NFactor <- T.NFactor+1 else break
    }

    # Testing the second factor
    if(T.NFactor==2){

      print(paste0("Evaluating factor ", T.NFactor, " of ", F.Max))

      #step 1, fit the 1 factor CFA model to bayes
      list.of.lambda.constraints <- list(
        V1=list(1,"+") #constrain the first loading to be positive
      )

      posterior.draws <- MCMCfactanal(
        x = data,
        factors = T.NFactor-1,
        lambda.constraints = list.of.lambda.constraints,
        burnin = n.burnin,
        mcmc = N.draw*n.thin,
        thin = n.thin,
        store.scores = FALSE,
        std.var = TRUE
      )

      #step 2, generate CD based on posterior.draws
      #save the estimated loading parameters
      est_lambda <- array(1, c(P, T.NFactor-1, N.draw)) #I don't need N.CD here, because I'm drawing parameters

      for (which.draw in 1: N.draw){
        count <- 1 #a count number to asist entering the parameters

        for (i1 in 1:P){
          for (j1 in 1:(T.NFactor-1)){

            if (est_lambda[i1, j1, which.draw] == 1 ){
              est_lambda[i1, j1, which.draw] <- posterior.draws[which.draw,][count]
              count <- count+1
            }

            if (i1 == P & j1 == (T.NFactor-1) ){ count <- 0 } #reset the count to 0 for the next draw

          }
        }
      }

      #save the estimated unique variances
      est_unique <- matrix(NA, nrow=N.draw, ncol=P)

      for (which.draw in 1: N.draw){
        for (i1 in P:1){
          est_unique[which.draw, i1] <- posterior.draws[which.draw, ncol(posterior.draws)- (P-i1)]
        }
      }

      #get the eigen values for each CD.
      for (which.draw in 1: N.draw){
        for (which.cd2 in 1:N.CD){
          comp.data <- gen.pa.data(N, P, est_lambda[,,which.draw], est_unique[which.draw,])
          cor.comp.data <- cor(comp.data) # compute the correlation matrix
          eigs.comp.array[ , which.cd2, which.draw, T.NFactor] <- fa(cor.comp.data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values
        }

        #decide if we want to move to the next number of factor given this parameter draw
        if(eigs.data[T.NFactor]> as.numeric(quantile(eigs.comp.array[T.NFactor, , which.draw, T.NFactor], quantile))) {
          sav_result[which.draw, T.NFactor] <- 1
        } else {
          sav_result[which.draw, T.NFactor] <- 0
        }
      }

      #decide if we want to move to the next number of factor
      if( sum(sav_result[, T.NFactor], na.rm = TRUE)>0 ) {
        T.NFactor <- T.NFactor+1
      } else break
    }

    # Testing the 3rd, 4th... factor
    if(T.NFactor>2 & T.NFactor<=F.Max){

      print(paste0("Evaluating factor ", T.NFactor, " of ", F.Max))

      Msyntax1 <- triag_model(P,  T.NFactor-1) #get the model syntax to run the CFA in lavaan

      # Create the list of constraints for MCMCpack
      # Initiate file and start sending text
      sink("temp1.R")
      cat("list.of.lambda.constraints <- list(")
      cat("\n") # go to next line

      # loop over constraints that fix loadings to 0
      which.constraint=1
      for(which.constraint in 1:nrow(Msyntax1$output_fixed)){
        cat(
          "V", Msyntax1$output_fixed[which.constraint, 2], "=list(", Msyntax1$output_fixed[which.constraint, 1], ",0),", sep=""
        )
        cat("\n") # go to next line
      }

      cat("\n") # go to next line

      # loop over constraints that fix loadings to be > 0
      which.constraint=1
      for(which.constraint in 1:nrow(Msyntax1$output_constraint)){

        # if it's not the last constraint, include a comma at the end
        if(which.constraint < nrow(Msyntax1$output_constraint)){
          cat(
            "V", Msyntax1$output_constraint[which.constraint, 2], "=list(", Msyntax1$output_constraint[which.constraint, 1], ',"+"),', sep=""
          )
          cat("\n") # go to next line
        }

        # if it's the last constraint, don't include a comma at the end, but do close the whole list
        if(which.constraint == nrow(Msyntax1$output_constraint)){
          cat(
            "V", Msyntax1$output_constraint[which.constraint, 2], "=list(", Msyntax1$output_constraint[which.constraint, 1], ',"+")', sep=""
          )
          cat("\n") # go to next line
          cat(")")
        }

      }

      sink()

      # Run and then remove the file with source code to define the constraints for MCMCpack
      source("temp1.R")
      file.remove("temp1.R")

      #list.of.lambda.constraints

      posterior.draws <- MCMCfactanal(
        x = data,
        factors = T.NFactor-1,
        lambda.constraints = list.of.lambda.constraints,
        burnin = n.burnin,
        mcmc = N.draw*n.thin,
        thin = n.thin,
        store.scores = FALSE,
        std.var = TRUE
      )

      # generate CD based on posterior.draws
      #Msyntax1$output_fixed #indicate which parameters should be fixed = 0

      #save the estimated loading parameters
      est_lambda <- array(1, c(P, T.NFactor-1, N.draw))

      #for fixed parameters, put a value of 0; for freely estimated parameters, keep it 1.
      for (which.draw in 1: N.draw){
        for (i1 in 1: nrow(Msyntax1$output_fixed)){
          est_lambda[Msyntax1$output_fixed[i1,2], Msyntax1$output_fixed[i1,1], which.draw] <- 0
        }
      }

      for (which.draw in 1: N.draw){
        count <- 1 #a count number to asist entering the parameters

        for (i1 in 1:P){
          for (j1 in 1:(T.NFactor-1)){

            if (est_lambda[i1, j1, which.draw] == 1 ){
              est_lambda[i1, j1, which.draw] <- posterior.draws[which.draw,][count]
              count <- count+1
            }

            if (i1 == P & j1 == (T.NFactor-1) ){ count <- 0 } #reset the count to 0 for the next draw

          }
        }
      }

      #save the estimated unique variances
      est_unique <- matrix(NA, nrow=N.draw, ncol=P)

      for (which.draw in 1: N.draw){
        for (i1 in P:1){
          est_unique[which.draw, i1] <- posterior.draws[which.draw, ncol(posterior.draws)- (P-i1)]
        }
      }

      #
      #get the eigen values for each draw.
      for (which.draw in 1: N.draw){
        for (which.cd2 in 1:N.CD){
          comp.data <- gen.pa.data(N, P, est_lambda[,,which.draw], est_unique[which.draw,])
          cor.comp.data <- cor(comp.data) # compute the correlation matrix
          eigs.comp.array[ , which.cd2, which.draw, T.NFactor] <- fa(cor.comp.data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values
        }

        #decide if we want to move to the next number of factor given this parameter draw
        if(eigs.data[T.NFactor]> as.numeric(quantile(eigs.comp.array[T.NFactor, , which.draw, T.NFactor], quantile))) {
          sav_result[which.draw, T.NFactor] <- 1
        } else {
          sav_result[which.draw, T.NFactor] <- 0
        }
      }

      #decide if we want to move to the next number of factor
      if( sum(sav_result[, T.NFactor], na.rm = TRUE)>0 ) {
        T.NFactor <- T.NFactor+1
      } else break
    }
  }

  n.factors = T.NFactor-1 #the max num to be retained

  sav_result <- apply(sav_result, 2, sum)

  if (n.factors == 0){
    sav_result[1] <- 0
  }else{sav_result[1] <- N.draw}

  sav_result[is.na(sav_result)] <- 0

  #vector saving the draws suggesting not moving to the next factor
  sav_result_not <- N.draw - sav_result

  #vector saving the probabilities for each number of factors
  prob_baes <- matrix(rep(1, 1*(1+F.Max)), nrow=1)

  for (i in 0: F.Max){
    if (i == 0){
      prob_baes[(i+1)] <- ifelse(sav_result_not[(i+1)]==0, 0, 100) #prob of keeping 0 factor; either 0 or 100%.
    }

    if (i > 0){
      for (j in 1:i){
        prob_baes[(i+1)] <- prob_baes[(i+1)] * (sav_result[(j)]/N.draw)
      }
      prob_baes[(i+1)] <- prob_baes[(i+1)] *  sav_result_not[(i+1)]/N.draw
    }
  }

  # Specify the column names
  c.names <- rep(NA, ncol(prob_baes))
  for (i in 1: ncol(prob_baes)){
    c.names[i] <- paste("prob_", i-1, "_factors", sep = "")
  }

  # Convert to percentages for reporting, if requested
  if(report=="percentage"){
    prob_baes <- prob_baes*100
    c.names <- rep(NA, ncol(prob_baes))
    for (i in 1: ncol(prob_baes)){
      c.names[i] <- paste("%_", i-1, "_factors", sep = "")
    }
  }

  colnames(prob_baes) <- c.names

  return(prob_baes)
}

# Run the Example --------------------

#read in the example data for illustration
#data <- read.csv("HolzingerSwinefore_Grant-White_19tests.csv")

#run BPA using the bayes.pa function
#bayes.pa(data)


library(rgl)
t<-seq(0,3.14*10,0.1)
plot3d(t,sin(t),cos(t),col="red", size=5)


 ZHEGVD Example Program Results

 Eigenvalues
      -61.7321    -6.6195     0.0725    43.1883
 Eigenvectors
             1          2          3          4
 1      0.3903    -0.1560     2.2909    -0.1943
        0.0000    -0.0404     0.0000    -0.0690

 2     -0.1814    -0.1552    -0.5042     0.3884
        0.0114    -0.3651    -0.7120     0.0000

 3      0.0438     0.5364    -1.2701     0.0657
        0.0338     0.0000    -0.4547    -0.2095

 4     -0.2221    -0.1298     0.5706     0.2924
       -0.2272    -0.1880     1.3132    -0.0675

 Estimate of reciprocal condition number for B
        2.5E-03

 Error estimates (relative to machine precision)
 for the eigenvalues:
        2.4E+04    2.8E+03    2.3E+02    1.7E+04

 for the eigenvectors:
        4.7E+02    1.0E+03    1.0E+03    4.9E+02


 ZPTCON Example Program Results

 Estimate of condition number =   9.21E+03


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Global Average Temperature (Land + Ocean) Anomalies
# HadCRUT4 time series: ensemble medians and uncertainties:
# https://www.metoffice.gov.uk/hadobs/hadcrut4/data/current/download.html
# Absolute temp by latitude:
# https://crudata.uea.ac.uk/cru/data/temperature/
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(list = ls()) # clears workspace
library(ncdf4)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dat <-
  read.table('Data/GlobalTemp/HadCRUT4_Annual_medians.txt', skip = 20)
datD <-
  read.table('Data/GlobalTemp/HadCRUT4_Decadal_Smooth.txt', skip = 0)

colnames(datD)[c(1, 2, 11, 12)] <-
  colnames(dat)[c(1, 2, 11, 12)] <- c('Year', 'Anom', 'l95', 'u95')

pdf(
  'Figures/Supp/FracFeed-FigS-TempAnomDynamics.pdf',
  height = 3,
  width = 4
) # repeated in main text figure
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 0.8,
  cex.axis = 0.8
)
plot(
  Anom ~ Year,
  data = dat,
  las = 1,
  xlim = c(1920, 2016),
  type = 'n',
  ylab = expression("Global temperature anomaly " (degree * C))
)
# polygon(c(dat$Year,rev(dat$Year)),c(dat$l95,rev(dat$u95)),border=NA,col='grey80')
abline(h = 0, lty = 2)
lines(datD$Year, datD$Anom, col = 'red')
points(dat$Year,
       dat$Anom,
       pch = 21,
       bg = 'grey',
       type = 'o')
box(lwd = 1)
dev.off()

pdf('Output/Plots/TempAnomDynamics.pdf',
    height = 3,
    width = 4)
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 0.8,
  cex.axis = 0.8
)
plot(
  Anom ~ Year,
  data = dat,
  las = 1,
  xlim = c(1850, 2016),
  type = 'n',
  ylab = expression("Global temperature anomaly " (degree * C))
)
polygon(c(dat$Year, rev(dat$Year)),
        c(dat$l95, rev(dat$u95)),
        border = NA,
        col = 'grey80')
abline(h = 0, lty = 2)
lines(datD$Year, datD$Anom, col = 'red')
points(dat$Year,
       dat$Anom,
       pch = 21,
       bg = 'grey',
       type = 'o')
box(lwd = 1)
dev.off()

pdf(
  'Output/Plots/TempAnomDynamics_post1930.pdf',
  height = 3,
  width = 4
)
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 0.8,
  cex.axis = 0.8
)
plot(
  Anom ~ Year,
  data = dat,
  las = 1,
  xlim = c(1930, 2016),
  type = 'n',
  ylab = expression("Global temperature anomaly " (degree * C))
)
polygon(c(dat$Year, rev(dat$Year)),
        c(dat$l95, rev(dat$u95)),
        border = NA,
        col = 'grey80')
abline(h = 0, lty = 2)
lines(datD$Year, datD$Anom, col = 'red')
points(dat$Year,
       dat$Anom,
       pch = 21,
       bg = 'grey',
       type = 'o')
box(lwd = 1)
dev.off()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

nc <- nc_open('Data/GlobalTemp/HadCRUT_Absolute.nc', write = F)

lat <- ncvar_get(nc, varid = "lat")
dim(lat)
tem <- ncvar_get(nc, varid = "tem")
dim(tem)

temp.mean <- apply(tem, 2, mean, na.rm = T)
temp.sd <- apply(tem, 2, sd, na.rm = T)

pdf(
  'Figures/Supp/FracFeed-FigS-TempLatitude.pdf',
  height = 2.75,
  width = 4
)
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 1,
  cex.axis = 0.8,
  las = 1
)
plot(
  lat,
  temp.mean,
  type = 'n',
  las = 1,
  xaxs = 'i',
  ylab = expression(paste("Mean temperature, ", degree, "C")),
  xlab = 'Latitude',
  xlim = c(-90, 90),
  axes = F
)
axis(2)
xat = seq(-90, 90, 30)
axis(1, at = xat)
polygon(c(lat, rev(lat)),
        c(temp.mean + temp.sd, rev(temp.mean - temp.sd)),
        col = 'grey',
        border = NA)
lines(lat, temp.mean, lwd = 2)
box(lwd = 1)
dev.off()

plot(
  lat,
  temp.mean,
  type = 'l',
  las = 1,
  xaxs = 'i',
  xlim = c(-80, 80)
)
axis(1, at = seq(-90, 90, 10))
abline(h = 0, lty = 2)
spl <- splinefun(lat, temp.mean)
curve(spl, -80, 80, add = T, col = 'red')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Kelv <- function(x) {
  273.15 + x
}

Arrhen <- function(x, A, E) {
  k = 8.6173303 * 10 ^ -5
  A * exp(-E / (k * x))
}
ArrhenX <- function(x) {
  Arrhen(x, A, E)
}
InvArrhenX <- function(x) {
  1 / Arrhen(x, A, E)
}

ProdArrhen <- function(x, A1, A2, E1, E2) {
  Arrhen(x, A1, E1) * Arrhen(x, A2, E2)
}
ProdArrhenX <- function(x) {
  ProdArrhen(x, A1, A2, E1, E2)
}

A = 1
E = 0.6
curve(ArrhenX, Kelv(-30), Kelv(40))
plot(ArrhenX, Kelv(-30), Kelv(40), log = 'xy')

Tmin <- min(temp.mean)
Tmax <- max(temp.mean)

A1 = exp(20)
E1 = 0.65 # from Brown et al. 2004 (approx.)
A2 = 0.8
E2 = 0.1

par(mfrow = c(3, 2))
A = A1
E = E1
plot(ArrhenX,
     Kelv(Tmin),
     Kelv(Tmax),
     xlab = 'Temp (K)',
     ylab = 'Mortality rate')
plot(lat, Arrhen(Kelv(temp.mean), A, E), xlab = 'Latitude', ylab = 'Mortality rate')

A = A2
E = E2
plot(ArrhenX,
     Kelv(Tmin),
     Kelv(Tmax),
     xlab = 'Temp (K)',
     ylab = 'Detection time')
plot(lat, Arrhen(Kelv(temp.mean), A, E), xlab = 'Latitude', ylab = 'Detection time')

plot(ProdArrhenX,
     Kelv(Tmin),
     Kelv(Tmax),
     xlab = 'Temp (K)',
     ylab = 'Product')
plot(lat,
     ProdArrhen(Kelv(temp.mean), A1, E1, A2, E2),
     xlab = 'Latitude',
     ylab = 'Product')

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


# ------------------------------------------------------------------------------
# basics
# ------------------------------------------------------------------------------

cmp(x$dim(), c(m, n))

# ------------------------------------------------------------------------------
# fill
# ------------------------------------------------------------------------------

x$fill_val(1)
test = x$to_robj()
truth = matrix(1, m, n)
cmp(test, truth)

x$fill_eye()
test = x$to_robj()
truth = diag(1, m, n)
cmp(test, truth)

x$fill_zero()
test = x$to_robj()
truth = matrix(0, m, n)
cmp(test, truth)

x$fill_val(3)
test = x$to_robj()
truth = matrix(3, m, n)
cmp(test, truth)

x$fill_linspace(1, m*n)
test = x$to_robj()
truth = matrix(1:(m*n), m, n)
cmp(test, truth)

# ------------------------------------------------------------------------------
# misc
# ------------------------------------------------------------------------------

x$fill_linspace(1, m*n)
x$rev_rows()
test = x$to_robj()
truth = matrix(1:(m*n), m, n)[m:1, ]
cmp(test, truth)

x$rev_cols()
test = x$to_robj()
truth = matrix(1:(m*n), m, n)[m:1, n:1]
cmp(test, truth)

x$fill_linspace(1, 6)
x$scale(1000)
test = x$to_robj()
truth = matrix(1:(m*n) * 1000, m, n)
cmp(test, truth)


# Generate and plot Brownian tree. Version #1.
# 7/27/16 aev
# gpBrownianTree1(m, n, clr, fn, ttl, dflg, psz)
# Where: m - defines matrix m x m; n - limit of the number of moves;
#   fn - file name (.ext will be added); ttl - plot title; dflg - 0-no dump,
#   1-dump: psz - picture size.
gpBrownianTree1 <- function(m, n, clr, fn, ttl, dflg=0, psz=600)
{
  cat(" *** START:", date(), "m=",m, "n=",n, "clr=",clr, "psz=", psz, "\n");
  M <- matrix(c(0), ncol=m, nrow=m, byrow=TRUE);
  # Seed in center
  x <- m%/%2; y <- m%/%2;
  M[x,y]=1;
  pf=paste0(fn, ".png");
  cat(" *** Plot file -", pf, "\n");
  # Main loops
  for (i in 1:n) {
    if(i>1) {
      x <- sample(1:m, 1, replace=FALSE)
      y <- sample(1:m, 1, replace=FALSE)}
    while(1) {
      ox = x; oy = y;
      x <- x + sample(-1:1, 1, replace=FALSE);
      y <- y + sample(-1:1, 1, replace=FALSE);
      if(x<=m && y<=m && x>0 && y>0 && M[x,y])
        {if(ox<=m && oy<=m && ox>0 && oy>0) {M[ox,oy]=1; break}}
      if(!(x<=m && y<=m && x>0 && y>0)) {break}
    }
  }
  plotmat(M, fn, clr, ttl, dflg, psz);
  cat(" *** END:",date(),"\n");
}
gpBrownianTree1(400,15000,"red", "BT1R", "Brownian Tree v.1", 1);


b <- 1:5
m <- matrix(c(b, b^2, b^3, b^4), 5, 4)
print(m)
tm <- t(m)
print(tm)


require(rms)

x <- runif(20)
x2 <- runif(20)
X <- cbind(x, x2)
y <- sample(0:1, 20, TRUE)

m <- model.frame(y ~ X)
names(m)
mft <- attr(m, 'terms')
mft
attr(mft, 'term.labels')
p  <- terms(y ~ X)
attr(p, 'term.labels')
all.vars(y ~ X)
d <- data.frame(y, I(X))
names(d)
Xr <- X; class(Xr) <- c('rms', class(Xr))
ms <- modelData(formula=y ~ X)
names(ms)
# f <- lrm(y ~ X, x=TRUE, y=TRUE)

X <- pol(x, 2)
ms <- modelData(formula=y ~ X)
names(ms)

k <- 4
x <- 1:20
d <- data.frame(x)
modelData(d, formula= ~ rcs(x,k))
d <- list(x=x, k=6)
modelData(d, ~ rcs(x, k))

b <- 1:8
a <- c(1, 1, 2, 2, 3, 4, 7, 7)
rmsb::Ocens(a, b)
d <- data.frame(a, b)
x <- runif(8)
m <- modelData(d, rmsb::Ocens(a, b) ~ x, subset=1:4)
attributes(m[[1]])

x <- c(rep('a', 10), rep('b', 11), rep('c', 12))
x <- factor(x, c('a', 'b', 'c', 'd'))
table(x)
y <- runif(length(x))
d <- data.frame(x, y)
m <- modelData(d, y ~ x)
attributes(m$x)

## LCAextend package example like this failed
g <- function() {
  d <- data.frame(x=runif(20), y=sample(0:1, 20,TRUE))
  w <- (1:20)/20
  # d$w <- (1:20)/100 will take precedence
  # return(model.frame(y ~ x, weights=as.vector(w), data=d)) # works
  lrm(y ~ x, weights=as.vector(w), data=d)
}
g()


# A mussel pattern formation model that follows the Cahn-Hilliard model
# for phase separation. See Liu et al, PNAS 2013, 110 :11905-11910

# First setup of the model
#remove(list=ls()) # Remove all variables from memory

require("fields") # An R package to load

D    = 1;         # 1    - The diffusivity parameter
Beta = 1.89;      # 1.89 - The non-parameterical density-dependence parameter
k1   = 0.1;       # 0.1  - The non-local diffusion term

# Simulation parameters
Length=32             #  128 - The length of the simulated landscape, in meters
m=64                  #  128 - # gridcellen
dT=0.01               # 0.25 - timestep
EndTime=1000          #      - Time at which the simulation ends
Numframes=300         #      - Number of frames displayed during the entire simulation

WinWidth=7             #      - Width of the simulation window
WinHeight=5            #      - Height of the simulation window

NX=NY=m                # Setting the grid dimensions
dx=Length/NX           # The size of a grid cell in the x dimension
dy=Length/NY           # The size of a grid cell in the y dimension

# ------ Function definitions
Laplacian <- function (C, dx, dy) {

  NX=dim(C)[2]
  NY=dim(C)[1]

  dC=matrix(nrow=NY, ncol=NX, data=0)

  dC[2:(NY-1),2:(NX-1)] =
    (C[2:(NY-1),1:(NX-2)] + C[2:(NY-1),3:NX] - 2*C[2:(NY-1),2:(NX-1)])/dx/dx +
    (C[1:(NY-2),2:(NX-1)] + C[3:NY,2:(NX-1)] - 2*C[2:(NY-1),2:(NX-1)])/dy/dy

  return(dC)

}

GradientX <- function (C, dx, dy) {

  NX=dim(C)[2]
  NY=dim(C)[1]

  dC=matrix(nrow=NY, ncol=NX, data=0)

  dC[2:(NY-1),2:(NX-1)] =
    - (C[2:(NY-1),1:(NX-2)] - C[2:(NY-1),3:NX] )/dx/2

  return(dC)

}

GradientY <- function (C, dx, dy) {

  NX=dim(C)[2]
  NY=dim(C)[1]

  dC=matrix(nrow=NY, ncol=NX, data=0)

  dC[2:(NY-1),2:(NX-1)] =
    - (C[1:(NY-2),2:(NX-1)] - C[3:NY,2:(NX-1)] )/dy/2

  return(dC)

}

# Initialisation: declaring variable and setting up initial values
# All arrays of dimension m x m

C = matrix(nrow=NY,ncol=NX, data=runif(NY*NX)*1.3)
C = matrix(nrow=NY,ncol=NX, data=0)
X = matrix(nrow=15,ncol=15, data=(1:15)*4)
Y = matrix(nrow=15,ncol=15, data=(1:15)*4, byrow=TRUE)
C[X,Y]=1.3;
dC = matrix(nrow=NY,ncol=NX, data=0)
J2 = J3 = J4 = matrix(nrow=NY-2,ncol=NX-2, data=0)

RecordTimes=(0:Numframes)*EndTime/Numframes
Step=EndTime^(1/(Numframes-1))
RecordTimes=Step^(0:(Numframes-1))

AllData=array(data=0,dim=c(m,m,length(RecordTimes)))

Time  =  1        ; # Begin time
jj    =  1        ; # The counter needed for recording data during the run

# ------- Setting up the figure ------------------------------------------

## Open a graphics window (Darwin stands for a Mac computer)
if (Sys.info()["sysname"]=="Darwin"){
    quartz(width=WinWidth, height=WinHeight, title="Mussel pattern formation")
  } else
    win.graph(width = WinWidth, height = WinHeight)

par(mar=c(3, 4, 2, 6) + 0.1)

# ------------ The simulation loop ---------------------------------------

print(system.time(
while (Time<=EndTime){  # Here the time loop starts

  J0 = (C^2 - Beta*C + 1)*(3*C^2 - 2*Beta*C + 1 )

  J1X = J0 * GradientX(C,dx,dy)
  J2X = D*GradientX(J1X,dx,dy)

  J1Y = J0 * GradientY(C,dx,dy)
  J2Y = D*GradientY(J1Y,dx,dy)

  J3 = Laplacian(C,dx,dy)
  J4 = D * k1 * Laplacian(J3,dx,dy)

  dC = J2X + J2Y - J4

    # Graphic representation of the model every now and then
    if ((Time+dT/100)>=RecordTimes[jj]){   # The dT/100 is to avoid inaccuracy problems

      image.plot(C, zlim=c(0,1.4), xaxt="n", yaxt="n", useRaster=TRUE,
                 col = topo.colors(255),asp=1, bty="n",
                 legend.shrink = 0.99, legend.width = 2)
      title("Mussel density")

      mtext(text=paste("Time : ",sprintf("%1.0f",Time),
                       "of" ,sprintf("%1.0f",EndTime), "Minutes"),
                       side=1, adj=0.5, line=1.5, cex=1)

      dev.flush()
      dev.hold()

      AllData[,,jj]=C

      jj=jj+1 # Increasing the Recorder counter

    }

    C = C + dC*dT;

    # Circular boundary conditions

    C[,1:2]=C[,(NX-3):(NX-2)]
    C[1:2,]=C[(NY-3):(NY-2),]
    C[,(NX-1):NX]=C[,3:4]
    C[(NY-1):NY,]=C[3:4,]

    Time=Time+dT;  # Incrementing time by dT

    #pause

  }

))

save(file='Mussel_PDE.rda',AllData,RecordTimes)

system('say Finished')


library(rstan)
library(tidyverse)
library(lubridate)

load('cleanedData.RData')

dat <- dat%>%filter(!is.na(anxlevel),!is.na(Date))%>%
  group_by(StudyId)%>%mutate(ntimes=n())%>%filter(ntimes>1)%>%
  arrange(Date)%>%mutate(time=as.numeric(Date-min(Date))/100)%>%
  ungroup()%>%
  mutate(id=as.numeric(as.factor(StudyId)))

stanDat <- list(
  Ndat=nrow(dat),
  Nsubj=max(dat$id),
  subj=dat$id,
  time=dat$time,
  anx=dat$anxlevel
  )

dat <- dat

dat$gender <- with(dat,ifelse(is.na(PresentSex_R),birthSex_R,PresentSex_R))
dat$race <- as.factor(dat$Race_R)

covDat <- dat%>%
  dplyr::select(id,age,gender,race,Hispanic_R,Site,ntimes)%>%
  group_by(id)%>%
  summarize_all(function(x) if(any(!is.na(x))) x[!is.na(x)][1] else NA)

## fill in missing values by assumption
covDat$race[is.na(covDat$race)] <- 1

covDat$Hispanic_R[is.na(covDat$Hispanic_R)] <- 2
covDat$hisp <- ifelse(covDat$Hispanic_R==1,1,0)

covDat$gender[is.na(covDat$gender)] <- 1

X <- model.matrix(~age+gender+race+hisp+Site,covDat)

stanDat$X <- scale(X[,-1])

stanDat$p <- ncol(X)-1

mod <- stan('anx2.stan',data=stanDat,chains=4,iter=1000,cores=10)


#All ACT-R functions are defined here:

# act-r noise
noise <- function(number)
{
    random <- runif(1, min = 0.0001, max = 0.9999)
    number * log( (1 - random ) / random)
}

# function which converts time in ms to an internal representation in pulses
msecs_to_pulses <- function(msecs)
{
    pulse_counter = 0 # number of accumulated pulses
    time_counter <- 0 # passed time
    pulse <- exp_dict$tick_base # length of the initial pulse

    while (time_counter < msecs)
    {
        pulse <- exp_dict$tick_increment * pulse + noise(exp_dict$b * exp_dict$tick_increment * pulse) # generate next pulse
        pulse_counter <- pulse_counter + 1
        time_counter <- time_counter + pulse
    }

    pulse_counter
}

# function which produces time in ms based on an internal representation in pulses
pulse_to_msces <- function(pulses_input)
{

    time_counter <- 0 # passed time
    pulse_counter <- 0 # number of pulses
    pulse <- exp_dict$tick_base # length of the initial pulse

    while (pulse_counter < pulses_input)
    {
        pulse <- exp_dict$tick_increment * pulse + noise(exp_dict$b * exp_dict$tick_increment * pulse) # generate next pulse
        pulse_counter <- pulse_counter + 1
        time_counter <- time_counter + pulse
    }

    time_counter
}

encounter_add <- function(subject_setup, sample_int_pulse)
{
    tmp <- sum(!is.na(subject_setup$DecMem[sample_int_pulse, ])) + 1
    subject_setup$DecMem[sample_int_pulse, tmp] <- subject_setup$real_time
    subject_setup$real_time <- subject_setup$real_time + 100
    subject_setup
}

encounters_get <- function(subject_setup, current_row)
{
    tmp <- subject_setup$DecMem[current_row,]

    if (length(tmp[!is.na(tmp)]) == 0){
        return(NA)
    }else{
        return(tmp[!is.na(tmp)])
    }

}

chunk_activation <- function(encounters, curtime)
{
    if (curtime < min(encounters)) {
        return(NA)
    } else {
        sum((curtime - encounters[encounters<curtime])^exp_dict$decay)
    }
}

prob_calc <- function(current_activation, total_activation)
{
    dividend = sum(current_activation) / exp_dict$parm_t
    divisor = total_activation / exp_dict$parm_t

    retrieval_prob = dividend / divisor
}

blending <- function(subject_setup)
{
    total_activation <- 0
    blended_response <- 0

    for (current_row in seq(1, nrow(subject_setup$DecMem)))
    {
        amount_presentations <- sum(!is.na(subject_setup$DecMem[current_row, ]))

        if (amount_presentations > 0)
        {
            encounters <- encounters_get(subject_setup, current_row)

            current_activation <- chunk_activation(encounters, subject_setup$real_time)

            total_activation <- total_activation + current_activation # ACTIVATION OF THE DECLARATIVE MEMORY
        }
    }

    for (current_row in seq(1, nrow(subject_setup$DecMem)))
    {
        amount_presentations <- sum(!is.na(subject_setup$DecMem[current_row, ]))

        if (amount_presentations > 0)
        {

            encounters <- encounters_get(subject_setup, current_row)

            current_activation <- chunk_activation(encounters, subject_setup$real_time)

            retrieval_prob <- prob_calc(current_activation, total_activation)
            blended_response <- blended_response + (retrieval_prob * current_row)

        }
    }

    blended_response
}


# *************************************************************************
# CMI2NI: Conditional mutual inclusive information(CMI2)-based Network
# Inference method from gene expression data
# *************************************************************************
# This is matlab code for netwrk inference method CMI2NI.
# Input:
# 'data' is expression of variable,in which row is varible and column is the sample;
# 'lamda' is the parameter decide the dependence;
# 'order0' is the parameter to end the program when order=order0;
# If nargin==2,the algorithm will be terminated untill there is no change
# in network toplogy.
# Output:
# 'G' is the 0-1 network or graph after pc algorithm;
# 'Gval' is the network with strenthness of dependence;
# 'order' is the order of the pc algorithm, here is equal to order0;
# Example:
#
# Author: Xiujun Zhang.
# Version: Sept.2014.
#
# Downloaded from: http://www.comp-sysbio.org/cmi2ni/

CMI2NI <- function(data,lamda,order0=NULL){
  data = t(data) # In original implementation, data is given as pxn
  n_gene <- dim(data)[1]
  G <- matrix(1,n_gene,n_gene)
  G[lower.tri(G, diag=T)] <- 0
  G <- G+t(G)
  Gval <- G
  order <- -1
  t <- 0
  while (t == 0){
     order <- order+1
     if (!is.null(order0)){
       if (order>order0){
           order <- order-1
           return(list(G=G,Gval=Gval,order=order))
       }
     }
     res.temp <- edgereduce(G,Gval,order,data,t,lamda)
     G = res.temp$G
     Gval = res.temp$Gval
     t = res.temp$t

     if (t==0){
          print('No edge is reduced! Algorithm  finished!')
          return(list(G=G,Gval=Gval,order=order))
     } else {
          t <- 0
     }
  }
  order <- order-1 # The value of order is the last order of the algorithm
  return(list(G=G,Gval=Gval,order=order))
}

## edgereduce
edgereduce <- function(G,Gval,order,data,t,lamda){
  G0 <- G
  if (order==0){
    for (i in 1:dim(G)[1]){
        for (j in 1:dim(G)[1]){
            if (G[i,j]!=0){
                cmiv <- cmi(data[i,],data[j,])
                Gval[i,j] <- cmiv
                Gval[j,i] <- cmiv
                if (cmiv<lamda){
                    G[i,j] <- 0
                    G[j,i] <- 0
                }
            }
        }
    }
    t <- t+1
    return(list(G=G,Gval=Gval,t=t))
  }
  else {
    for (i in 1:dim(G)[1]){
      for (j in 1:dim(G)[1]){
          if (G[i,j]!=0){
              adj <- c()
              for (k in 1:dim(G)[1]){
                  if (G[i,k]!=0 & G[j,k]!=0){
                      adj <- c(adj,k)
                  }
              }
              if (length(adj)>=order){
                   if(length(adj)==1){ # Need a special case as combn does not work allow single element arguments
                     combntnslist <- as.matrix(adj)
                   }
                   else{
                     combntnslist <- t(combn(adj,order))
                   }
                   combntnsrow <- dim(combntnslist)[1]

                   cmiv <- 0
                   v1 <- data[i,]
                   v2 <- data[j,]
                   for (k in 1:combntnsrow){
                     vcs <- data[combntnslist[k,],]
                     a <- MI2(v1,v2,vcs)
                     cmiv <- max(cmiv,a)
                   }
                   Gval[i,j] <- cmiv
                   Gval[j,i] <- cmiv
                   if (cmiv<lamda){
                      G[i,j] <- 0
                      G[j,i] <- 0
                   }
                   t <- t+1
              }
          }
      }
    }
    return(list(G=G,Gval=Gval,t=t))
  }
}

## compute conditional mutual information of x and y
cmi <- function(v1,v2,vcs=NULL){
 if (is.null(vcs)){
      c1 <- (var(v1)) # removed det as this is just a scalar
      c2 <- (var(v2))
      c3 <- det(cov(t(rbind(v1,v2)))) # cov in r only gives a matrix if we give one, so must use rbind
      cmiv <- 0.5*log(c1*c2/c3)
  }
  else if (!is.null(vcs)){
      c1 <- det(cov(t(rbind(v1,vcs))))
      c2 <- det(cov(t(rbind(v2,vcs))))
      c3 <- (var(t(vcs)))
      c4 <- det(cov(t(rbind(v1,v2,vcs))))
      cmiv <- 0.5*log((c1*c2)/(c3*c4))
  }
  if (cmiv == Inf){
      cmiv <- 1.0e+010
  }
  return(cmiv)
}

# Conditional mutual inclusive information (CMI2)
MI2 <- function(x,y,z){
  r_dmi <- (cas(x,y,z) + cas(y,x,z))/2
  return(r_dmi)
}

# x and y are 1*m dimensional vector; z is n1*m dimensional.
cas <- function(x,y,z){
  # x,y,z are row vectors;
  if(is.null(dim(z))){
    n1 = 1
  }
  else{
    n1 <- dim(z)[1] # This is equal to the order
  }
  n <- n1 +2

  Cov <- var(x)
  Covm <- cov(t(rbind(x,y,z)))
  Covm1 <- cov(t(rbind(x,z)))

  InvCov <- solve(Cov)
  InvCovm <- solve(Covm)
  InvCovm1 <- solve(Covm1)

  C11 <- InvCovm1[1,1] # 1x1
  C12 <- 0 # 1x1
  C13 <- InvCovm1[1,2:(1+n1)] # 1x n1
  C23 <- InvCovm[2,3:(2+n1)]-(InvCovm[1,2] * as.numeric(1/(InvCovm[1,1]-InvCovm1[1,1]+InvCov[1,1]))) %*% (InvCovm[1,3:(2+n1)] - InvCovm1[1,2:(1+n1)]) # 1x n1
  C22 <- InvCovm[2,2]- InvCovm[1,2]^2 * (1/(InvCovm[1,1]-InvCovm1[1,1]+InvCov[1,1])) # 1x1

  C33 <- InvCovm[3:(2+n1),3:(2+n1)]- (as.numeric((1/(InvCovm[1,1]-InvCovm1[1,1]+InvCov[1,1]))) * (t(t(InvCovm[1,3:(2+n1)]-
                                          InvCovm1[1,2:(1+n1)]))%*%(InvCovm[1,3:(2+n1)]-InvCovm1[1,2:(1+n1)]))) # n1 x n1

  InvC <- rbind(c(C11,C12,C13),c(C12,C22,C23),cbind(C13,t(C23),C33))

  C0 <- Cov * (InvCovm[1,1] - InvCovm1[1,1] + InvCov[1,1])
  CS <- 0.5 * (sum(diag(InvC%*%Covm))+log(C0)-n)
  return(CS)
}


#' @name BMGL
#' @rdname  BMGL
#' @title Bivarite MGL and survival MGL copula
#' @description Density, distribution function, and random generation for the bivariate MGL/survival MGL copula with copula parameter \eqn{\delta}.
#' @param u1,u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param pars copula parameter, denoted by \eqn{\delta >0}.
#' @param n number of observations. If length(n) > 1, the length is taken to be the number required.
#' @md
#' @return
#' * \code{dcMGL.bivar}, \code{pcMGL.bivar} and \code{rcMGL.bivar} gives values of density, distribution function, and random generation for the two dimensional MGL copula with copula parameter \eqn{\delta>0}.
#' * \code{dcMGL180.bivar}, \code{pcMGL180.bivar} and \code{rcMGL180.bivar} gives values of density, distribution function, and random generation for the two dimensional survival MGL copula with copula parameter \eqn{\delta>0}.
NULL

#' @rdname  BMGL
#' @export
#' @examples
#' # density function
#' dcMGL.bivar(u1 = 0.001, u2 = 0.999, pars = 1)
dcMGL.bivar <- function(u1, u2, pars) {
  dim <- 2
  a <- 1 / pars
  q1 <- qbeta(1 - u1, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u1, shape1 = 0.5, shape2 = a))
  q2 <- qbeta(1 - u2, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u2, shape1 = 0.5, shape2 = a))
  # if(u1 == 0|u2 == 0|q1 == Inf|q2 == Inf) dc <- 0
  if (q1 == Inf | q2 == Inf) {
    dc <- 0
  } else {
    # q <- cbind(q1, q2)
    # dc <- gamma(a)^(dim - 1)*gamma(a + dim/2)/(gamma(a + 0.5)^dim)*(q1 + 1)^(a + 0.5)*(q2 + 1)^(a + 0.5)/((q1 + q2) + 1)^(a + dim/2)
    dc <- gamma(a)^(dim - 1) / (gamma(a + 0.5)^(dim - 1)) / (gamma(a + 0.5)) * gamma(a + dim / 2) * (q1 + 1)^(a + 0.5) * (q2 + 1)^(a + 0.5) / ((q1 + q2) + 1)^(a + dim / 2)
  }
  return(dc)
}
dcMGL.bivar <- Vectorize(dcMGL.bivar)

#' @rdname BMGL
#' @export
#' @examples
#' # distribution function
#' pcMGL.bivar(u1 = c(0.6, 0.1, 0.7), u2 = c(0.3, 0.6, 0.9), pars = 5)
pcMGL.bivar <- function(u1, u2, pars) {
  a <- 1 / pars
  q1 <- qbeta(1 - u1, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u1, shape1 = 0.5, shape2 = a))
  q2 <- qbeta(1 - u2, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u2, shape1 = 0.5, shape2 = a))
  fin <- function(theta) { # rely on a
    m1 <- pracma::erfc((q1 * theta)^0.5)
    m2 <- pracma::erfc((q2 * theta)^0.5)
    out <- m1 * m2 * theta^(a - 1) * exp(-theta) / gamma(a)
    out
  }
  if (u1 == 0 | u2 == 0) {
    z <- 0
  } else if (u1 == 1 & u2 != 0) {
    z <- u2
  } else if (u1 != 0 & u2 == 1) {
    z <- u1
  } else {
    z <- as.numeric(pracma::integral(fun = fin, xmin = 0, xmax = Inf, method = "Clenshaw"))
  }
  return(z) # rely on k
}
pcMGL.bivar <- Vectorize(pcMGL.bivar)

#' @rdname BMGL
#' @export
#' @examples
#' # random generation
#' rcMGL.bivar(n = 200, pars = 0.8)
rcMGL.bivar <- function(n, pars) {
  Usim <- rcMGL.multi(n = n, pars = pars, d = 2)
  Usim
}

#' @rdname  BMGL
#' @export
#' @examples
#' dcMGL180.bivar(u1 = 0.001, u2 = 0.999, pars = 1)
dcMGL180.bivar <- function(u1, u2, pars) {
  dcMGL.bivar(1 - u1, 1 - u2, pars)
}

#' @rdname BMGL
#' @export
#' @examples
#' pcMGL180.bivar(u1 = c(0.6, 0.1, 0.7), u2 = c(0.3, 0.6, 0.9), pars = 5)
pcMGL180.bivar <- function(u1, u2, pars) {
  u1 + u2 - 1 + pcMGL.bivar(1 - u1, 1 - u2, pars)
}

#' @rdname BMGL
#' @export
#' @examples
#' rcMGL180.bivar(n = 200, pars = 0.8)
rcMGL180.bivar <- function(n, pars) {
  Usim <- rcMGL.multi(n = n, pars = pars, d = 2)
  1 - Usim
}

#' @name hBMGL
#' @rdname  hBMGL
#' @title Conditional Distribution Function of a Bivariate MGL and survival Copula
#'
#' @param u1 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param pars numeric; single number or vector of size length(u1); copula parameter > 0.
#'
#' @details
#' The h-function is defined as the conditional distribution function of a bivariate copula, i.e.,
#' \deqn{h_1(u_2|u_1,\delta) := P(U_2 \leq u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,}
#'
#' \deqn{h_2(u_1|u_2,\delta) := P(U_1 \leq u_1 | U_2 = u_2) := \partial C(u_1,u_2) / \partial u_2,}
#'
#' where \eqn{(U_1, U_2) \sim C}, and \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{\delta}. For more details see Aas et al. (2009).
#' @md
#' @return hcMGL.bivar/hcMGL180.bivar returns a list with
#' * hfunc1: \eqn{\partial C(u_1,u_2) / \partial u_1,}
#' * hfunc2: \eqn{\partial C(u_1,u_2) / \partial u_2,}
#' @references
#' Zhengxiao Li, Jan Beirlant, Liang Yang. A new class of copula regression models for modelling multivariate heavy-tailed data. 2021, arXiv:2108.05511.
NULL

#' @rdname hBMGL
#' @export
#' @examples
#' hcMGL.bivar(u1 = c(0.1, 0.001, 0.3), u2 = c(0, 0.9999, 0.88), pars = 2)
hcMGL.bivar <- function(u1, u2, pars) {
  a <- 1 / pars
  # another method
  index1 <- u1 == 0 & u2 != 0
  index2 <- u1 != 0 & u2 == 0
  index3 <- u1 == 0 & u2 == 0
  q1 <- qbeta(1 - u1, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u1, shape1 = 0.5, shape2 = a))
  q2 <- qbeta(1 - u2, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u2, shape1 = 0.5, shape2 = a))
  z1 <- q2 / (q1 + q2 + 1)
  z2 <- q1 / (q1 + q2 + 1)
  z1[index1] <- 0.0000000001
  z2[index1] <- 1
  z1[index2] <- 1
  z2[index2] <- 0.0000000001
  z1[index3] <- 0.5
  z2[index3] <- 0.5

  hfunc1 <- 1 - pbeta(z1, shape1 = 0.5, shape2 = a + 0.5) # Pr(U_2 <= u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,
  hfunc2 <- 1 - pbeta(z2, shape1 = 0.5, shape2 = a + 0.5) # C(u1|u2)
  list(hfunc1 = hfunc1, hfunc2 = hfunc2)
}

#' @rdname hBMGL
#' @export
#' @examples
#' hcMGL180.bivar(u1 = c(0.1, 0.001, 0.3), u2 = c(0, 0.9999, 0.88), pars = 2)
hcMGL180.bivar <- function(u1, u2, pars) {
  hfunc1 <- 1 - hcMGL.bivar(u1 = 1 - u1, u2 = 1 - u2, pars = pars[1])$hfunc1
  hfunc2 <- 1 - hcMGL.bivar(u1 = 1 - u1, u2 = 1 - u2, pars = pars[1])$hfunc2
  out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
  out
}