######################################################
### Code to generate Figure 3 and related analysis
### #################################################

# N.b. the raster files were further edited in ArcGIS
# for improved aesthetic appearance

############
##libraries
###########
require(raster)
require(rgdal)
library(INLA)
library(RColorBrewer)
library(cvTools)
library(zoo)
library(boot)
library(pROC)
library(ROCR)

###########
#data load
##########
#define/load dataset containing location and time info

dd <- "INSERT PATH/OBJECT CONTAINING LOCATION AND TIME INFORMATION "

#define/load Rt (response)
Rt <- "INSERT PATH/OBJECT CONTAINING RESPONSE (REPRODUCTION NUMBERS)"
dd$Rt <- Rt

#Rt<-load("C:/Users/ir515/Dropbox/El_Sal_transmission_chain_reconstruction/spatial_netrate_V4_2908/out/sd_mid_vivax_yunnan.RData")
dd$x <- "COLUMN/VECTOR OF LONGITUDES"
dd$y <- "COLUMN/VECTOR OF LATITUDES"

#load covariate rasters
lsf <- c(acc, elev, lst_day, lst_night, lst_diff, precip, urban)

###################
#functions required
###################
#auc

fun.auc <-
  function(pred, obs) {
    # Run the ROCR functions for AUC calculation
    ROC_perf <- performance(prediction(pred, obs), "tpr", "fpr")
    ROC_sens <- performance(prediction(pred, obs), "sens", "spec")
    ROC_err <- performance(prediction(pred, labels = obs), "err")
    ROC_auc <- performance(prediction(pred, obs), "auc")
    # AUC value
    AUC <- ROC_auc@y.values[[1]] # AUC
    # Mean sensitivity across all cutoffs
    x.Sens <- mean(as.data.frame(ROC_sens@y.values)[, 1])
    # Mean specificity across all cutoffs
    x.Spec <- mean(as.data.frame(ROC_sens@x.values)[, 1])
    # Sens-Spec table to estimate threshold cutoffs
    SS <-
      data.frame(SENS = as.data.frame(ROC_sens@y.values)[, 1],
                 SPEC = as.data.frame(ROC_sens@x.values)[, 1])
    # Threshold cutoff with min difference between Sens and Spec
    SS_min_dif <-
      ROC_perf@alpha.values[[1]][which.min(abs(SS$SENS - SS$SPEC))]
    # Threshold cutoff with max sum of Sens and Spec
    SS_max_sum <-
      ROC_perf@alpha.values[[1]][which.max(rowSums(SS[c("SENS", "SPEC")]))]
    # Min error rate
    Min_Err <- min(ROC_err@y.values[[1]])
    # Threshold cutoff resulting in min error rate
    Min_Err_Cut <-
      ROC_err@x.values[[1]][which(ROC_err@y.values[[1]] == Min_Err)][1]
    # Kick out the values
    round(cbind(
      AUC,
      x.Sens,
      x.Spec,
      SS_min_dif,
      SS_max_sum,
      Min_Err,
      Min_Err_Cut
    ),
    3)
  }

# AUC plot function
fun.aucplot <- function(pred, obs, title) {
  # Run the AUC calculations
  ROC_perf <- performance(prediction(pred, obs), "tpr", "fpr")
  ROC_sens <- performance(prediction(pred, obs), "sens", "spec")
  ROC_err <- performance(prediction(pred, labels = obs), "err")
  ROC_auc <-
    performance(prediction(pred, obs), "auc")  # Spawn a new plot window (Windows OS)
  # Plot the curve
  plot(
    ROC_perf,
    colorize = T,
    print.cutoffs.at = seq(0, 1, by = 0.1),
    lwd = 3,
    las = 1,
    main = title
  )
  # Add some statistics to the plot
  text(1,
       0.25,
       labels = paste("Npres = ", sum(obs == 1), sep = ""),
       adj = 1)
  text(1,
       0.20,
       labels = paste("Nabs = ", sum(obs == 0), sep = ""),
       adj = 1)
  text(1,
       0.15,
       labels = paste("AUC = ", round(ROC_auc@y.values[[1]], digits = 2), sep =
                        ""),
       adj = 1)
  text(1,
       0.10,
       labels = paste("Sens = ", round(mean(
         as.data.frame(ROC_sens@y.values)[, 1]
       ), digits = 2), sep = ""),
       adj = 1)
  text(1,
       0.05,
       labels = paste("Spec = ", round(mean(
         as.data.frame(ROC_sens@x.values)[, 1]
       ), digits = 2), sep = ""),
       adj = 1)
}

#data shaping functions

#latlong to xyz
ll.to.xyz <- function(ll) {
  if (is.null(colnames(ll))) {
    colnames(ll) <- c('longitude', 'latitude')
  }
  if (colnames(ll)[1] == 'x' & colnames(ll)[2] == 'y') {
    colnames(ll) <- c('longitude', 'latitude')
  }
  if (colnames(ll)[1] == 'lon' & colnames(ll)[2] == 'lat') {
    colnames(ll) <- c('longitude', 'latitude')
  }
  ll[, 'longitude'] <- ll[, 'longitude'] * (pi / 180)
  ll[, 'latitude'] <- ll[, 'latitude'] * (pi / 180)
  x = cos(ll[, 'latitude']) * cos(ll[, 'longitude'])
  y = cos(ll[, 'latitude']) * sin(ll[, 'longitude'])
  z = sin(ll[, 'latitude'])
  return(cbind(x, y, z))
}

#temporal data clean
temporalInfo <- function(f) {
  library(zoo)
  start_dates <-
    as.yearmon(paste(f[, "year_start"], "-", f[, "month_start"], sep = ""))
  end_dates <-
    as.yearmon(paste(f[, "year_end"], "-", f[, "month_end"], sep = ""))
  mid_dates <- (start_dates + end_dates) / 2
  return(as.numeric(mid_dates))
}

#colour matching
match.cols <- function(val, n) {
  colfunc <-
    colorRampPalette(
      c(
        "snow1",
        "snow2",
        "snow3",
        "seagreen",
        "orange",
        "firebrick",
        "darkred"
      ),
      space = "rgb",
      bias = 5
    )#colors
  #	colfunc <- colorRampPalette(c("blue","cyan","yellow","orange","red"), space = "rgb",bias=1)

  col <-
    data.frame(val = seq(min(val), max(val), length.out = n), col = colfunc(n))
  out <- rep(NA, length(col))
  for (i in 1:length(val)) {
    out[i] <- as.character(col[which.min(abs(col$val - val[i])), 'col'])
  }
  return(out)
}

#alternative latlong to xyz
ll2xyz <- function (longlat, radius = 6371) {
  # check inputs
  stopifnot(is.finite(radius) & radius > 0)
  stopifnot(inherits(longlat, 'matrix') |
              inherits(longlat, 'data.frame'))
  stopifnot(ncol(longlat) == 2)

  # extract required columns
  longitude <- longlat[, 1]
  latitude <- longlat[, 2]

  # convert
  ans <- data.frame(
    x = radius * cos(latitude) * cos(longitude),
    y = radius * cos(latitude) * sin(longitude),
    z = radius * sin(latitude)
  )

  return (ans)

}

Mode <- function(x) {
  ux <- unique(x)
  ux[which.max(tabulate(match(x, ux)))]
}

#xyz to latlong
xyz2ll <- function (xyz, radius = 6371) {
  # check inputs
  stopifnot(is.finite(radius) & radius > 0)
  stopifnot(inherits(longlat, 'matrix') |
              inherits(longlat, 'data.frame'))
  stopifnot(ncol(xyz) == 3)

  # extract columns
  x <- xyz[, 1]
  y <- xyz[, 2]
  z <- xyz[, 3]

  # convert
  ans <- data.frame(longitude = atan2(y, x),
                    latitude = asin(z / radius))

  return (ans)

}
#trimming
trim2 <- function(x, out = "raster") {
  if (!any(out == c("matrix", "raster")))
    stop("output must be a matrix or raster")
  if (class(x) == "matrix" &
      out == "raster")
    stop("if you supply a matrix, you must use out='matrix'")
  if (class(x) == "RasterLayer") {
    if (out == "raster") {
      cres <- 0.5 * res(x)
      crs <- projection(x)
      y <- x
    }
    x <- matrix(as.array(x), nrow = nrow(x), ncol = ncol(x))
  }
  if (class(x) != "matrix") {
    stop("x must be a matrix or raster")
  } else {
    r.na <- c.na <- c()
    for (i in 1:nrow(x))
      r.na <- c(r.na, all(is.na(x[i,])))
    for (i in 1:ncol(x))
      c.na <- c(c.na, all(is.na(x[, i])))
    r1 <-
      1 + which(diff(which(r.na)) > 1)[1]
    r2 <- nrow(x) -  which(diff(which(rev(r.na))) > 1)[1]
    c1 <-
      1 + which(diff(which(c.na)) > 1)[1]
    c2 <- ncol(x) - which(diff(which(rev(c.na))) > 1)[1]
    x <- x[r1:r2, c1:c2]
    if (out == "raster") {
      xs <- xFromCol(y, col = c(c1, c2)) + c(-1, 1) * cres[1]
      ys <- yFromRow(y, row = c(r2, r1)) + c(-1, 1) * cres[2]
      x <- raster(
        x,
        xmn = xs[1],
        xmx = xs[2],
        ymn = ys[1],
        ymx = ys[2],
        crs = crs
      )
    }
  }
  return(x)
}

#colour scale function
colfunc <-
  colorRampPalette(
    c(
      "snow1",
      "snow2",
      "snow3",
      "seagreen",
      "orange",
      "firebrick",
      "darkred"
    ),
    space = "rgb",
    bias = 1
  )

###########
#data shape
###########

#Stack and extract raster
st <- stack(lsf)
cn <- calc(st, sum)
cn[!is.na(cn)] = 1
#trim2(x=cn)
NAvalue(cn) = -9999
wh <- extract(cn, cbind(dd$x, dd$y))

#cropping and formatting stack
NAvalue(st) = -9999
st <- crop(st, cn)
#st[[1]]=asinh(st[[1]])

#cells from xy coords - match to covariate rasters
dd$cell <- cellFromXY(cn, cbind(dd$x, dd$y))
covs <- st[dd$cell]
covs <- as.data.frame(covs)

#make matrix of response and covs
mat <- cbind(dd$Rt, covs)

#exclude missingness
Rt <- Rt[complete.cases(mat)]
covs <- covs[complete.cases(mat),]

#df <- data.frame(matrix(unlist(dd), nrow=nrow(dd), byrow=T),stringsAsFactors=FALSE)
dd <- dd[complete.cases(mat),]

###########################
##exploratory vizualisation
###########################

par(mfrow = c(1, 2))
cols <- match.cols(Rt, 1000)
image(cn, col = 'grey')
points(dd$x, dd$y, pch = 16, col = cols)

image(cn, col = 'grey')
points(dd$x[dd$I == 1], dd$y[dd$I == 1], pch = 16, col = 'red')
points(dd$x[dd$I == 0], dd$y[dd$I == 0], pch = 16, col = 'blue')

##############
#INLA model
##############

# make mesh

mesh1d = inla.mesh.1d(
  seq(2010, 2017, by = 1),
  interval = c(2010, 2017),
  degree = 2,
  boundary = c('free')
)

xyz <- as.data.frame(ll.to.xyz(cbind(dd$x, dd$y)))
mesh = inla.mesh.2d(
  loc = cbind(xyz['x'], xyz['y'], xyz['z']),
  cutoff = 0.005,
  #should be 0.003
  min.angle = c(25, 25),
  max.edge = c(0.005, 1)
)

# spde function
spde = inla.spde2.matern(mesh, alpha = 2)

A.est =
  inla.spde.make.A(
    mesh,
    loc = cbind(xyz[, 'x'], xyz[, 'y'], xyz[, 'z']),
    group = dd$Date.symptoms.year,
    group.mesh = mesh1d
  )

#-- Create index matrix --#
field.indices =
  inla.spde.make.index("field", n.spde = mesh$n, n.group = mesh1d$m)

est.cov <- as.list(as.data.frame(covs))
est.cov$Intercept = 1
covariate.names <- names(est.cov)
Rtb = Rt
Rtb[Rt > 0] = 1

#Rtb = log(Rt+1)

stack.est =
  inla.stack(
    data = list(response = Rtb),
    A = list(A.est, 1),
    effects =
      list(c(field.indices),
           c(est.cov)),
    tag = "est",
    remove.unused = FALSE,
    compress = FALSE
  )

# Define formula

formula <- as.formula(paste(
  paste("response ~ -1 + "),
  # paste("f(field, model=spde) + ",sep=""),
  paste(
    "f(field, model=spde,group=field.group, control.group=list(model='ar1')) + ",
    sep = ""
  ),
  paste(covariate.names, collapse = '+'),
  sep = ""
))
stack.est <- stack.est

# Call INLA and get results #
mod.pred =   inla(
  formula,
  data = inla.stack.data(stack.est),
  family = "binomial",
  control.predictor = list(
    A = inla.stack.A(stack.est),
    compute = TRUE,
    quantiles = NULL
  ),
  control.compute = list(cpo = TRUE, dic = TRUE, config =
                           TRUE),
  keep = FALSE,
  verbose = TRUE,
  #num.threads=5,
  control.inla = list(
    strategy = 'gaussian',
    int.strategy = 'eb',
    verbose = TRUE,
    fast = TRUE,
    dz = 1,
    step.factor = 1,
    stupid.search = FALSE
  )
)

index_lp = inla.stack.index(stack.est, "est")$data
lp = mod.pred$summary.linear.predictor$mean[index_lp]

##############
## Diagnostics
##############
#AUC
fun.auc(plogis(lp), Rtb)
fun.aucplot(plogis(lp), Rtb, "AUC")

#######################
##visualisation of maps
#######################

samp = inla.posterior.sample(100, mod.pred)

#by year
st_pred <- stack()
st_sd <- stack()
for (year in 2011:2016) {
  ind <- cn
  pred_val <- getValues(ind)#get values again
  w <- is.na(pred_val) #find NAs again
  index <- 1:length(w)
  index <- index[!w]
  pred_locs <-
    xyFromCell(ind, 1:ncell(ind))  #get prediction locations
  pred_locs <- pred_locs[!w,] #remove NA cells

  colnames(pred_locs) <- c('longitude', 'latitude')
  pred_locs <- ll.to.xyz(pred_locs) #get locations
  pred_mat <- matrix(nrow = nrow(pred_locs), ncol = length(names))
  Xp <- st[index]
  Xp = as.data.frame(Xp)
  Xp$intercept = 1
  A = inla.spde.make.A(
    mesh,
    loc = cbind(pred_locs[, 'x'], pred_locs[, 'y'], pred_locs[, 'z']),
    group = rep(year, nrow(pred_locs)),
    group.mesh = mesh1d
  )
  #A= inla.spde.make.A(mesh, loc=cbind(pred_locs[,'x'],pred_locs[,'y'],pred_locs[,'z']))

  lp <-
    as.matrix(Xp) %*% (mod.pred$summary.fixed$mean) + drop(A %*% mod.pred$summary.random$field$mean)

  P <- cn
  P[!w] = plogis(lp)
  print(year)
  st_pred <- addLayer(st_pred, P)

  #standard dev
  S <- stack()
  for (xx in 1:100) {
    coeff <- c()
    for (xxx in 1:length(covariate.names)) {
      coeff[xxx] <-
        samp[[xx]]$latent[grep(covariate.names[xxx], rownames(samp[[xx]]$latent)),]
    }
    field <-
      samp[[xx]]$latent[grep('field', rownames(samp[[xx]]$latent)),]

    Z <- cn
    Z[!w] = (drop(coeff %*% t(Xp)) + drop(A %*% field))
    S <- addLayer(S, Z)
  }
  lt <- function(x)
    exp(x) / (1 + exp(x))
  Qi <-
    calc(
      S,
      fun = function(x) {
        quantile(x, probs = c(.025, .975), na.rm = TRUE)
      }
    )

  M <- calc(S, mean)
  Sd <- calc(lt(S), sd)
  st_sd <- addLayer(st_sd, Sd)

}

# keeps scales standard
for (i in 1:nlayers(st_pred)) {
  st_pred[[i]][1:5] = 1
  st_pred[[i]][6:10] = 0

}

for (i in 1:nlayers(st_sd)) {
  st_sd[[i]][1:5] = 0.35
  st_sd[[i]][6:10] = 0

}
dev.off()
year <- c(2011:2016)
par(mfrow = c(2, 3))
for (i in 1:nlayers(st_pred)) {
  plot(st_pred[[i]], col = colfunc(1000),  axes = FALSE)
  writeRaster(st_pred[[i]], paste0(year[i], '.tif'))
}

par(mfrow = c(2, 3))
for (i in 1:nlayers(st_sd)) {
  plot(st_sd[[i]],  col = colfunc(1000), axes = FALSE)
  writeRaster(st_sd[[i]], paste0('sd', year[i], '.tif'))
}

par(mfrow = c(1, 2))

P[2] = 0
P[1] = 1
#colors

plot(P, col = colfunc(1000))


s=c(8.69, 6.89, 80.22)
s_min=min(s)
s_max=max(s)
#test statistic
F=s_max/s_min
print(F)

# critical value
alpha=0.05
df=8
F.alpha=qnorm(alpha/2,8)
print(F.alpha)

# Reject H0 if F >=F.alpha
# conclusion : Thus, we reject H0 and conclude that the variances are not all equa


library(jsonlite)
library(NISTunits)

system.time(x <- fromJSON("hist.json"))

#Promien ziemi
R = 6378137

loc = x$locations

loc$activity = NULL
loc$altitude = NULL
loc$verticalAccuracy = NULL
loc$velocity = NULL
loc$heading = NULL

loc$time = as.POSIXct(as.numeric(x$locations$timestampMs)/1000, origin = "1970-01-01")
loc$lat = loc$latitudeE7 / 1e7
loc$lon = loc$longitudeE7 / 1e7

day = loc[(loc$time > '2018-05-12 9:35:00' & loc$time <= '2018-05-12 9:50:00'),]

#day$lat = day$lat - lat_ref
#day$lon = day$lon - lon_ref

day$lat = NISTdegTOradian(day$lat)
day$lon = NISTdegTOradian(day$lon)

day$y = R * cos(day$lat) * cos(day$lon)
day$x = R * cos(day$lat) * sin(day$lon)

day$y = day$y - min(day$y)
day$y = max(day$y) - day$y
day$x = day$x - min(day$x)
day$time_sek = 0
day$time_sek[2:length(day$time)] = as.numeric(day$time[1:length(day$time)-1]) - as.numeric(day$time[2:length(day$time)])

summary(day)

plot(day$x/1000, day$y/1000, xlim = c(0, 100), ylim = c(0, 100))
plot(day$time, day$time_sek/60)
plot(day$time, day$x/1000)
plot(day$time, day$y/1000)
plot(day$time, (day$y^2 + day$x^2)^(1/2))

day<- day[seq(dim(day)[1],1),]

write.csv(cbind(day$x, day$y, day$time_sek, as.numeric(day$timestampMs)), file = "data.csv")


set.seed(13435)
x <- data.frame("var1"=sample(1:5), "var2"=sample(6:10), "var3"=sample(11:15))
x <- x[sample(1:5),];
x$var2[c(1,3)] = NA
#subset
print(x[, 1]); # first column
print(x[, "var1"]) # first column
print(x[1:2, "var2"]) # first two row and second column

##Subset using logicals ands and ors
x[(x$var1 <= 3 & x$var3 > 11), ]

x[(x$var1 <= 3 | x$var3 > 11), ]


library(plyr)

bnames <- read.csv("../data/bnames.csv", stringsAsFactors = FALSE)
head(bnames)

# Whole dataset transformations ---------------------------------------------
letter <- function(x, n = 1) {
  if (n < 0) {
    nc <- nchar(x)
    n <- nc + n + 1
  }
  tolower(substr(x, n, n))
}
vowels <- function(x) {
  nchar(gsub("[^aeiou]", "", x))
}

bnames <- transform(bnames,
  first = letter(name, 1),
  last = letter(name, -1),
  length = nchar(name),
  vowels = vowels(name)
)

# Whole dataset summaries ----------------------------------------------------

summarise(bnames,
  max_perc = max(percent),
  min_perc = min(percent))

# Group-wise transformations  ------------------------------------------------

# Want to calculate rank of each name in each year (per sex).  This is easy if
# we have a single sex for a single year:
one <- subset(bnames, sex == "boy" & year == 2008)
one$rank <- rank(-one$percent, ties.method = "first")
# or
one <- transform(one, rank = rank(-percent, ties.method = "first"))
head(one)

# Conceptually if we want to perform this same task for every sex in every
# year, we need to split up the data, apply the transformation to every piece
# and then join the pieces back together

# This is what ddply does
bnames <- ddply(bnames, c("sex", "year"), transform,
  rank = rank(-percent, ties.method = "first"))

# Group-wise summaries -------------------------------------------------------

# Group-wise summaries are much more interesting!

head(ddply(bnames, c("name"), summarise, tot = sum(percent)), n = 10)
head(ddply(bnames, c("length"), summarise, tot = sum(percent)), n = 10)
head(ddply(bnames, c("year", "sex"), summarise, tot = sum(percent)), n = 10)

fl <- ddply(bnames, c("year", "sex", "first"), summarise, tot = sum(percent))
library(ggplot2)
qplot(year, tot, data = fl, geom = "line", colour = sex, facets = ~ first)


library(ngram)

x = "a b a c a b b"

test = get.phrasetable(ngram(x, 2))
truth <- data.frame(
  ngrams = c("a b ", "b a ", "c a ", "a c ", "b b "),
  freq = c(2, 1, 1, 1, 1),
  prop = c(1/3, 1/6, 1/6, 1/6, 1/6),
  stringsAsFactors=FALSE
)

stopifnot(all.equal(test, truth))

test = get.phrasetable(ngram(x, 3))
truth <- data.frame(
  ngrams = c("a b a ", "a c a ", "b a c ", "a b b ", "c a b "),
  freq = c(1, 1, 1, 1, 1),
  prop = c(1/5, 1/5, 1/5, 1/5, 1/5),
  stringsAsFactors=FALSE
)

stopifnot(all.equal(test, truth))


library(Seurat)

seurat_recipet = function(expr){
expr_obj = CreateSeuratObject(expr)
expr_obj = NormalizeData(expr_obj, normalization.method = "LogNormalize", scale.factor = 10000)
expr_obj = ScaleData(expr_obj)
expr_obj = FindVariableFeatures(expr_obj, selection.method = "vst", nfeatures = 2000)
expr_obj = RunPCA(expr_obj, features = VariableFeatures(object = expr_obj), npcs = 100)
expr_obj
}

write_csv = function(vec, fn){write.table(vec, file = fn, append = FALSE, quote = FALSE, sep = ",",
                eol = "\n", na = "NA", dec = ".", row.names = TRUE,
                col.names = TRUE, qmethod = c("escape", "double"),
                fileEncoding = "")}

tissues = c('clean_data')

for (tissue in tissues)
{
    folder_to_read = paste0('../processed_data/', tissue, '/')
    exprs=read.csv(paste0(folder_to_read, 'gene_expression.csv'), row.names=1, header=T , check.names = F)
    exprs=t(exprs)

    meta=read.csv(paste0(folder_to_read, 'metadata.csv'), row.names=1, header=T, check.names = F)
    abrain = seurat_recipet(exprs)
    write_csv(Embeddings(object = abrain, reduction = "pca"), paste0(folder_to_read, 'seurat_pca.csv'))

    for (npc in c(20, 50, 100))
    {

    abrain1=FindNeighbors(object = abrain, dims = 1:npc, k.param = 100)
    abrain1=FindClusters(object = abrain1, resolution = 1., graph.name = 'RNA_snn')
    abrain1=RunUMAP(object = abrain1, min.dist = 1.5, graph = 'RNA_snn')

    write_csv(abrain1@meta.data$seurat_clusters, paste0(folder_to_read, "seurat_clusters_pc", npc, '.csv') )
    write_csv(Embeddings(object = abrain1, reduction = "umap"), paste0(folder_to_read, 'seurat_umap_pc', npc, '.csv') )

    }
}


## example conditional logistic regression using Stan
## David C Muller

library(survival)
library(rstan)

set.seed(77834)

## use the infertility data from the survival package
datlist <- list(N=nrow(infert),
                n_grp=max(infert[, "stratum"]),
                n_coef=2,
                x=infert[,c("spontaneous", "induced")],
                y=infert[, "case"],
                grp=infert[, "stratum"])

## fit using default parameters
clogit_stan <- stan("clogit.stan", data=datlist)
clogit_stan

## fit using survival::clogit for comparison
clogit_survival <- clogit(case ~ spontaneous + induced + strata(stratum),
                          data=infert)
summary(clogit_survival)


library("ggplot2")

data <- read.table("miniDistance")

changetoK <- function ( position ){
  position=(10^position)/1000;
  paste(position, "K", sep="")
}

changetoK2 <- function ( position ){
  position=position/1000;
  paste(position, "K", sep="")
}

pdf(file="conserved_hist.pdf")
ggplot(data=data, aes(x=log10(data$V2))) +
  geom_histogram(color="black", fill="white", binwidth = 0.25)+
  scale_x_continuous(labels=changetoK)+
  labs(y="Frequency", x="minimum extent of flanking",  title="")+
  theme_bw() +theme_grey(base_size = 31)+
  theme(axis.line = element_blank(),
  panel.background = element_blank(),
  panel.grid.major = element_blank(),
  panel.grid.minor = element_blank(),
  panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"))
dev.off()

pdf(file="conserved_accumulation.pdf")
ggplot(data=data, aes(x=log10(data$V2))) +
  geom_step(aes(y=..y..),stat="ecdf")+
  scale_x_continuous(labels=changetoK)+
  labs(y="Accumulation proportion\nof mapped genes", x="minimum extent of flanking",  title="")+
  theme_bw() +theme_grey(base_size = 31)+
  theme(axis.line = element_blank(),
  panel.background = element_blank(),
  panel.grid.major = element_blank(),
  panel.grid.minor = element_blank(),
  panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"))
dev.off()

pdf(file="conserved_small_accumulation.pdf")

ggplot(data=data, aes(x=(data$V2))) +
  geom_step(aes(y=..y..),stat="ecdf")+
  scale_x_continuous(labels=changetoK2)+
  coord_cartesian(xlim=c(5000, 50000))+
  geom_hline(yintercept = 0.5) +
  labs(y="Accumulation proportion\nof mapped genes", x="minimum extent of flanking",  title="")+
  theme_bw() +theme_grey(base_size = 31)+
  theme(axis.line = element_blank(),
        panel.background = element_blank(),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"))
dev.off()


# -*- encoding=utf-8 -*-

# 本脚本用来实现案例分析

library(readxl)

plot_clustering <- function(X, res, main){
    pch_set=c(1,2,3,5,7,8,9)
    plot(X[,1], X[,2],xlab = 'the cumulative confirmed number',ylab='the cumulative death toll',main=main, col='white')
    for(i in 1:length(res_grid_svm_knn)){
        if(res[i] == 0){
            points(x = X[i,1], y = X[i,2], col=res[i]+1, pch=15)
        }else{
            points(x = X[i,1], y = X[i,2], col=res[i]+1, pch=pch_set[res[i]])
        }
    }
}

# 设置工作路径
setwd('E:/projects/grid_svm_knn/data/')
setwd('D:/个人/坚果云同步/我的坚果云/论文/grid_svm_knn/data')
setwd('E:/坚果云同步/我的坚果云/论文/grid_svm_knn/data/')
# 读取数据
mydata <- readxl::read_excel('china_provincedata.xlsx')
mydata <- as.data.frame(mydata)
# 截取需要的数据
usedvar <- c('confirmedCount', 'confirmedIncr', 'dateId', 'provinceShortName')
mydata <- mydata[,usedvar]
mydata <- mydata[mydata$dateId == 20200208, ]
# 绘制图像
plot(mydata[-18,]$confirmedCount, mydata[-18,]$confirmedIncr)
X <- as.matrix(mydata[,c('confirmedCount', 'confirmedIncr')], rownames.force = FALSE)

res_grid_svm_knn <- grid_svm_knn(X, gamma=1,cost=1, k=3, Index1=1)
print(res_grid_svm_knn)
plot_clustering(X, res_grid_svm_knn, 'Result')

# 由于相差太大，需要剔除噪声点再次聚类
X_new <- X[-which(res_grid_svm_knn == 2),]
res_grid_svm_knn <- grid_svm_knn(X_new, gamma=50,cost=1, k=3, Index1=6)
print(res_grid_svm_knn)
plot_clustering(X_new, res_grid_svm_knn, 'Result')

mydata_new <- mydata[-which(res_grid_svm_knn == 2),]
mydata_new$provinceShortName[which(res_grid_svm_knn == 5)]

# 新案例

set.seed(123)
n1 <- 1000  # 上圆弧的样本点数量
n2 <- 200  # 下圆弧的样本点数量
n3 <- 300
X1 <- matrix(nrow = n1,ncol = 2)
mu <- c(0,0)
sigma <- matrix(c(1,0,0,1),nrow = 2,ncol = 2)
for(i in 1:n1){
    x <- mvrnorm(1,mu,sigma)
    while(TRUE){
        if(((x[1])^2 + x[2]^2) >= 1 & ((x[1])^2 + x[2]^2) <= 2 & x[2] < 0){
            X1[i,] <- x
            break()
        }else{
            x <- mvrnorm(1,mu,sigma)
        }
    }
}

mu <- c(2,2)
sigma <- matrix(c(0.2,0,0,0.2),nrow = 2,ncol = 2)
X2 <- mvrnorm(n2,mu,sigma)

mu <- c(-2,2)
sigma <- matrix(c(0.2,0,0,0.2),nrow = 2,ncol = 2)
X3 <- mvrnorm(n3,mu,sigma)

# 合并数据
X <- rbind(X1,X2,X3)
g <- c(rep(1,n1),rep(2,n2),rep(3,n3))

# 噪声数据
n_noise <- 50
X_noise <- matrix(ncol=2,nrow = n_noise)
for(i in 1:n_noise){
    min_dist <- 0
    while(min_dist < 0.1){
        noise_x<- runif(1,-2,2)
        noise_y <- runif(1,-2,2)
        noise_one <- matrix(rep(c(noise_x, noise_y), times=dim(X)[1]), ncol = 2,byrow = TRUE)
        min_dist <- min(dist(noise_one, X))
    }
    X_noise[i,] <- noise_one[1,]
}

X <- rbind(X,X_noise)
g <- c(g,rep(4,n_noise))

# 无标签绘图
plot(X,pch=20,col='blue',main='DataSet2',xlab = expression(X[1]),ylab=expression(X[2]))
# 有标签绘图
plot(X,col=g,pch=20,main='组合形状数据',xlab = expression(X[1]),ylab=expression(X[2]))
# 保存数据
dataset4 <- cbind(X,g)
colnames(dataset4) <- c('X1','X2','g')
write.csv(dataset4, 'dataset4.csv', fileEncoding = 'utf-8', row.names = FALSE)

res_db <- dbscan(X,eps=0.2,minPts=8)
res_grid_svm_knn <- grid_svm_knn(X, gamma=10, cost=0.023, k=18, Index1=1213)

setwd('E:/坚果云同步/我的坚果云/论文/grid_svm_knn/data/')
# 读取数据
mydata <- read.csv('12-10-2020.csv')
# 截取需要的数据
usedvar <- c("Country_Region", "Confirmed", "Deaths")
mydata <- mydata[,usedvar]
# 对数据按照国家进行聚合处理
mydata_new <- rowsum(mydata[,c(2,3)], group=mydata$Country_Region)
data_name <- row.names(mydata_new)
# 绘制图像
plot(mydata_new)
# 整理一下数据
X <- as.matrix(mydata_new, rownames.force = FALSE)
# 对数据进行标准化处理
X_scale <- scale(X)

# 绘制图像
plot(mydata[-18,]$confirmedCount, mydata[-18,]$confirmedIncr)
X <- as.matrix(mydata[,c('confirmedCount', 'confirmedIncr')], rownames.force = FALSE)

res_grid_svm_knn <- grid_svm_knn(X_scale, gamma=1,cost=10, k=10, Index1=1)
print(res_grid_svm_knn)
plot_clustering(X_scale, res_grid_svm_knn, '聚类结果')

# 由于相差太大，需要剔除噪声点再次聚类
X_new <- X[-which(res_grid_svm_knn == 2),]
res_grid_svm_knn <- grid_svm_knn(X_new, gamma=50,cost=1, k=3, Index1=6)
print(res_grid_svm_knn)
plot_clustering(X_new, res_grid_svm_knn, '聚类结果')
legend('bottomright', c('other', 'Mexico', 'Brazil', 'India', 'US'), pch =c(1,2,3,5,7), col=c(2,3,4,5,6))

mydata_new <- mydata[-which(res_grid_svm_knn == 2),]
mydata_new$provinceShortName[which(res_grid_svm_knn == 2)]


dat1 = read.table("D:/_tmp/20150330/sim1/simfreqs.txt");
E = dat1$V1

#plot(Th, type = 'b', col = "red")
#abline(v = seq(10, 500, 10), col = "blue")
#plot(Th, type = 'l', col = "red")
dat2 = read.table("D:/_tmp/20150330/sim1/theory.txt"); Th = dat2$V1

plot(Th, type='l', col="red", xlim = c(0, 100))
abline(v = seq(10, 500, 10), col = "blue")

# Theory
plot(Th, type='l', col="red", xlim = c(0, 100))
#abline(v = seq(10, 500, 10), col = "blue")
abline(h = 0.1)

sinc <- function (x,period,b,l) {
  if (x==0){
    1/b
  }
  else{
    sin((2*pi/period)*x - b) / (x-b) + l
  }
}
sinc(0)

x = seq(0, 100)
y = sinc(x, 10, 13, 0.1)
#y = sin((2*pi/10)*x - d)/(x-d) + 0.1
plot(y, type = 'b')
abline(v = seq(10, 200, 10), col = "blue")
abline(v =0)
#lines(c(rep(0, 0), E*30), type='b', cex = 0.7)

plot(Th, type='b')
abline(h = c(0, 0.1)); abline(v = seq(10, 500, 10), col = "blue")

plot(Th, type='l', xlim = c(1,120))

#h = hist(E, 500, freq = TRUE, xlim = c(0, 70))
lines(Th * 1000000, type = 'l', col = "red", lw = 2)


context("Test Ship Power Calculation for Admiralty law")

test_that("calcAdmPwr works for shipSpeed == serviceSpeed",{
  expect_equal( calcAdmPwr (shipSpeed = 10, actualDraft = 10,
                                refSpeed  = 10, maxDraft    = 10,
                                totalInstalledPwr = 100,
                                n=3, serviceMargin = 0
                                ),
                100*0.94^3
              )

})

test_that("calcAdmPwr works for shipSpeed == maxSpeed",{
  expect_equal( calcAdmPwr (shipSpeed = 10, actualDraft = 10,
                                refSpeed  = 10, maxDraft    = 10,
                                totalInstalledPwr = 100,
                                n=3, serviceMargin = 0,
                                refSpeedType = "maxSpeed"
                                ),
                100
  )

})

test_that("serviceMargin has the intended effect",{
  expect_equal( calcAdmPwr (shipSpeed = 9, actualDraft = 10,
                                refSpeed  = 10, maxDraft    = 10,
                                totalInstalledPwr = 100,
                                n=3, serviceMargin = 15,
                                refSpeedType = "maxSpeed"
  ),
  100*(0.9^3)*1.15
  )

})

test_that("maximum power output is 100% load",{
  expect_equal( calcAdmPwr (shipSpeed = 20, actualDraft = 15,
                                refSpeed  = 10, maxDraft    = 10,
                                totalInstalledPwr = 100,
                                n=3, serviceMargin = 15),
                100
  )

})

test_that("minimum non-zero power is 2% load",{
  expect_equal( calcAdmPwr (shipSpeed = 0.2, actualDraft = 10,
                                refSpeed  = 10,  maxDraft    = 10,
                                totalInstalledPwr = 100,
                                n=3, serviceMargin = 0),
                2
              )

})

test_that("changing speed generates the correct power",{
  shipSpeed   <- 5
  actualDraft <- 10
  refSpeed    <- 10
  maxDraft    <- 10
  totalInstalledPwr <- 100
  n <- 3
  serviceMargin <- 0

  expect_equal( calcAdmPwr (totalInstalledPwr,
                                shipSpeed, refSpeed,
                                actualDraft, maxDraft,
                                serviceMargin,
                                n,
                                refSpeedType = "maxSpeed"
                                ),
                totalInstalledPwr*((shipSpeed/refSpeed)^n)*((actualDraft/maxDraft)^(2/3))
  )

})

test_that("changing draft generates the correct power",{
  shipSpeed   <- 10
  actualDraft <- 5
  refSpeed    <- 10
  maxDraft    <- 10
  totalInstalledPwr <- 100
  n <- 3
  serviceMargin <- 0

  expect_equal( calcAdmPwr (totalInstalledPwr,
                                shipSpeed, refSpeed,
                                actualDraft, maxDraft,
                                serviceMargin,
                                n,
                                refSpeedType = "maxSpeed"
                                ),
                totalInstalledPwr*((shipSpeed/refSpeed)^n)*((actualDraft/maxDraft)^(2/3))
  )

})


require(rpart)
require(rpart.plot)
require(car)
require(caret)

# establece el directorio de trabajo
setwd("/home/jorge/Documents/TesisNoFallout")
# lee los datos del archivo csv y los guarda en wdbc, indica que se
# separa por ',' y que no tiene header (pone como header V1, V2, V3, ..., V#)
wdbc=read.table("datos_caidas.csv", sep=",", header=TRUE)

# dimensión del vector
dim(wdbc)

# reemplaza los '?' por 'NA' como numérico
#wdbc$V7=as.numeric(recode(wdbc$V7, "'?'=NA"))

# solo para pruebas, deja solo dos valores para clasificar
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "1=1"))
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "2=1"))
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "3=1"))
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "5=1"))
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "6=1"))
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "7=1"))
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "8=1"))
wdbc$TIPO=as.numeric(recode(wdbc$TIPO, "9=1"))

# guarda en 'x' los datos que NO tienen datos incompletos. Columnas con NA
#x=wdbc[complete.cases(wdbc),]
x=wdbc # solo si todos están completos

# dimensión del vector
dim(x)

# entrenamiento (2/3), pruebas (1/3)
N=dim(x)[1]
# hace un vector con la longitud de 'x'
all=seq(1,N)
# selecciona 2/3 de las muestras randomly aleatoriamente
train=sort(sample(N,N*2/3.0))
# lo que esta en el conjunto 'a' que no esta en el 'b'
# o sea, selecciona los índices que no están en 'train'
# que son los indices de entrenamiento
test=setdiff(all,train) # indices para vector de prueba

xtrain=x[train,]
xtest=x[test,]

# crear primero el arbol usando parametros predeterminados
t0=rpart(as.factor(TIPO) ~ VARIANZA_X+VARIANZA_Y+VARIANZA_Z,
         data = xtrain, method = "class",
         control = rpart.control(minsplit = 0, cp = 0.0))
prp(t0, extra = 1)
y1train=predict(t0, xtrain, type = "class")
y1test=predict(t0, xtest, type = "class")
# analizar que tan bien es t0 como un clasificador
confusionMatrix(table(xtrain$TIPO,y1train))
confusionMatrix(table(xtest$TIPO,y1test))

t1=rpart(as.factor(TIPO) ~ MAXIMO_X+MAXIMO_Y+MAXIMO_Z+MINIMO_X+MINIMO_Y+MINIMO_Z+MEDIA_X+MEDIA_Y+MEDIA_Z+MODA_X+MODA_Y+MODA_Z+MEDIANA_X+MEDIANA_Y+MEDIANA_Z+VARIANZA_X+VARIANZA_Y+VARIANZA_Z,
         data = xtrain, method = "class")
# la gráfica se lee como
#(SI es menor)  [ V3 < 3.5 ] (NO es menor) # indica qué rama es SI y cuál NO en todas las comparaciones
#    [    2   ]        [    4   ]  # los que están clasificados como 2 o 4 según el criterio anterior
#    [ 285 8  ]        [ 7 138  ]  # 285 están bien clasificados como "2" y 8 son mal clasificados
prp(t1, extra = 1)
y1train=predict(t1, xtrain, type = "class")
y1test=predict(t1, xtest, type = "class")

# analizar que tan bien es t1 como un clasificador
confusionMatrix(table(xtrain$V11,y1train))
confusionMatrix(table(xtest$V11,y1test))

# calcular PCA para las muestras de entrenamiento
pca=princomp(xtrain[,2:10])
summary(pca)
pca$loadings[,1]

# a~nadir una nueva variable con el resultado del pca
xtrain$C1=pca$scores[,1]
xtest$C1=predict(pca,xtest)[,1]

# crear el arbol t2 usando esta variable
t2=rpart(as.factor(V11) ~ V2+V3+V4+V5+V6+V7+V8+V9+V10+C1,
         data = xtrain, method = "class")

prp(t2, extra = 1)
y2train=predict(t2, xtrain, type = "class")
y2test=predict(t2, xtest, type = "class")

confusionMatrix(table(xtrain$V11,y2train))
confusionMatrix(table(xtest$V11,y2test))

# NO se presenta overfitin

# forzar a completar un arbol puro t3 (sin ningun error)
t3=rpart(as.factor(V11) ~ V2+V3+V4+V5+V6+V7+V8+V9+V10+C1,
         data = xtrain, method = "class",
         control = rpart.control(minsplit = 0, cp = 0.0))
#control point CP es cero

prp(t3, extra = 1)
y3train=predict(t3, xtrain, type = "class")
y3test=predict(t3, xtest, type = "class")

confusionMatrix(table(xtrain$V11,y3train))
confusionMatrix(table(xtest$V11,y3test))
# min 18:47

Transformada Wavelet Haar Y Arbol de Decisiones/arbol_decisiones.r


library("zoo")
library("xts")
library("ggplot2")

bandwidth <- read.csv("output/bandwidth/part-r-00000", header=F)

z_bandwidth <- zoo(bandwidth$V2/(1024*1024), as.POSIXlt(bandwidth$V1,origin="1970-01-01", tz="GMT"))

pdf(file="output/bandwidth/plot.pdf")

plot(z_bandwidth) #,title="Bandwidth in MB/s",ylab="MB's")
hist(z_bandwidth/(1024*1024), breaks=100, xlab="MB/s")
qplot(z_bandwidth) # $V2/(1024*1024), stat='density', geom='line', ylab="Density")


# Load h2o library
suppressPackageStartupMessages(library(h2o))

# Start and connect to a local H2O cluster
h2o.init(nthreads = -1)

# Importing data from local CSV
h_secom <- h2o.importFile(path = "secom.csv", destination_frame = "h_secom")

# Print out column names
colnames(h_secom)

# Look at "Classification"
summary(h_secom$Classification, exact_quantiles=TRUE)

# "Classification" is a column of numerical values
# Convert "Classification" in secom dataset from numerical to categorical value
h_secom$Classification <- as.factor(h_secom$Classification)

# Look at "Classification" again
summary(h_secom$Classification, exact_quantiles=TRUE)

# Define target (y) and features (x)
target <- "Classification"
features <- setdiff(colnames(h_secom), target)
print(features)

# Splitting dataset into training and test
h_split <- h2o.splitFrame(h_secom, ratios = 0.7, seed = 1234)
h_train <- h_split[[1]] # 70%
h_test  <- h_split[[2]] # 30%

# Look at the size
dim(h_train)
dim(h_test)

# Check Classification in each dataset
summary(h_train$Classification, exact_quantiles = TRUE)
summary(h_test$Classification, exact_quantiles = TRUE)

# H2O Gradient Boosting Machine with default settings
model <- h2o.gbm(x = features,
                 y = target,
                 training_frame = h_train,
                 seed = 1234)

# Print out model summary
summary(model)

# Check performance on test set
h2o.performance(model, h_test)

# Use the model for predictions
yhat_test <- h2o.predict(model, h_test)

# Show first 10 rows
head(yhat_test, 10)


library(ALDEx2)
load('~/Documents/0_git/effect/data/tiyani_pup_vs_ys.Rdata')

# THIS RAN SUCCESSFULLY ON SERVER
 conds.ty <- c(rep("Pup", 161), rep("YS", 212))

t <- aldex.clr(d, conds=conds.ty)
t.e <- aldex.effect(t)

ty.ol <- rownames(t.e)[which(t.e$overlap < 0.05)]
ty.diff <- rownames(t.e)[which(abs(t.e$diff.btw) > 1)]
ty.eff <- rownames(t.e)[which(abs(t.e$effect) > 1)]

ty.diff.ol <- intersect(ty.ol, ty.diff)
ty.diff.eff <- intersect(ty.eff, ty.diff)
ty.ol.eff <- intersect(ty.eff, ty.ol)

#######

output.summary.ty <- list()
output.summary2 <- list()

# original tests done at 100 replicates
test.size <- 100
max.samples <- 20
registerDoMC(6) # this is the MC backend.
# 4 cores seems to be the performance limit
# beyond that there is throttling of each thread

output.summary.ty <- foreach(j = 2:max.samples)%dopar%{
    print(j)
	n.samples = j

	summary.stats <- matrix(data=NA, ncol=12, nrow=test.size)

	colnames(summary.stats) <- c('eff.TP', 'eff.FP', 'diff.TP', 'diff.FP', 'eff.diff.TP', 'eff.diff.FP', 'ol.TP', 'ol.FP', 'ol.diff.TP','ol.diff.FP', 'ol.eff.diff.TP', 'ol.eff.diff.FP')

	for(i in 1:test.size){
		test.col <- c(sample(1:161, n.samples), sample(162:373, n.samples))
		test.conds <- c(rep("P", n.samples), rep("Y", n.samples))
		test.data <- d[,test.col]

		x.test <- aldex.clr(test.data, test.conds, verbose=F)
		x.e.test <- aldex.effect(x.test, CI=T, verbose=F)

		test.diff <- rownames(x.e.test)[which(abs(x.e.test$diff.btw) > 1)]

		test.ol <- rownames(x.e.test)[which(x.e.test$overlap < 0.1)]

		test.eff <- rownames(x.e.test)[which(abs(x.e.test$effect) > 1)]

		test.diff.eff <- intersect(test.diff, test.eff)
		test.diff.ol <- intersect(test.diff, test.ol)
		test.ol.eff.diff <- intersect(test.eff, intersect(test.ol, test.diff))

		summary.stats[i,1] <- length(intersect(ty.eff, test.eff))
		summary.stats[i,2] <- length(setdiff(test.eff, ty.eff))

		summary.stats[i,3] <- length(intersect(ty.diff, test.diff))
		summary.stats[i,4] <- length(setdiff(test.diff, ty.diff))

		summary.stats[i,5] <- length(intersect(ty.diff.eff, test.diff.eff))
		summary.stats[i,6] <- length(setdiff(test.diff.eff, ty.diff.eff))

		summary.stats[i,7] <- length(intersect(ty.ol, test.ol))
		summary.stats[i,8] <- length(setdiff(test.ol, ty.ol))

		summary.stats[i,9] <- length(intersect(ty.diff.ol, test.diff.ol))
		summary.stats[i,10] <- length(setdiff(test.diff.ol, ty.diff.ol))

		summary.stats[i,11] <- length(intersect(ty.diff.eff, test.ol.eff.diff))
		summary.stats[i,12] <- length(setdiff(test.ol.eff.diff, ty.diff.eff))
	}

    output.summary2[[j]] <- summary.stats

}

med.data.ty <- matrix(data=NA, nrow=(max.samples - 1), ncol=13)
colnames(med.data.ty) <- c('N samples', colnames(output.summary.ty[[1]]) )
for( i in 1:(max.samples - 1) ){
  med.data.ty[i,1] <- i+1
  med.data.ty[i,2:13] <- apply(output.summary.ty[[i]], 2, median)
}

# TP open, FP closed
# proportion of TP found
plot(med.data.ty[,1], med.data.ty[,2]/length(ty.eff), ylim=c(0,1), main='Proportion',
  xlab='N samples per group', ylab='TP and FP rate')
points(med.data.ty[,1], med.data.ty[,4]/length(ty.diff), col="cornflowerblue")
#points(med.data.ty[,1], med.data.ty[,8]/length(ty.ol), col="brown")
points(med.data.ty[,1], med.data.ty[,12]/length(ty.diff.eff), col="orange")

# FP - proportion of all that are FP
points(med.data.ty[,1], med.data.ty[,3]/(med.data.ty[,2] + med.data.ty[,3]), pch=19)
points(med.data.ty[,1], med.data.ty[,5]/(med.data.ty[,4] + med.data.ty[,5]), pch=19, col="cornflowerblue")
#points(med.data.ty[,1], med.data.ty[,9]/(med.data.ty[,8] + med.data.ty[,9]), pch=19, col="brown")
points(med.data.ty[,1], med.data.ty[,13]/(med.data.ty[,12] + med.data.ty[,11]), pch=19, col="orange")

legend(15.5,0.5, legend=c('effect','difference','overlap','triple'),pch=19, col=c("black", "cornflowerblue",'brown','orange','grey70','grey40'))

legend(12.8,0.5, legend=c('TP','FP'),pch=c(1,19))
abline(h=0.8, lty=2, lwd=3, col='darkgrey')
abline(h=0.1, lty=2, lwd=3, col='darkgrey')

#######

n.samples = 10
test.col <- c(sample(1:161, n.samples), sample(162:373, n.samples))
test.conds <- c(rep("Pup", n.samples), rep("YS", n.samples))
test.data <- d[,test.col]

t.s <- aldex.clr(test.data, test.conds)
t.s.e <- aldex.effect(t.s)

test.ty.ol <- rownames(t.s.e)[which(t.s.e$overlap < 0.05)]
test.ty.diff <- rownames(t.s.e)[which(abs(t.s.e$diff.btw) > 1)]
test.ty.eff <- rownames(t.s.e)[which(abs(t.s.e$effect) > 1)]
test.ty.diff.ol <- intersect(test.ty.ol, test.ty.diff)
test.ty.ol.ef <- intersect(test.ty.ol, test.ty.eff)
test.ty.diff.eff <- intersect(test.ty.eff, test.ty.diff)

TP.ty.ol <- intersect(ty.ol, test.ty.ol)
TP.ty.eff <- intersect(ty.eff, test.ty.eff)
TP.ty.diff <- intersect(ty.diff, test.ty.diff)
TP.ty.diff.ol <- intersect(ty.diff.ol, test.ty.diff.ol)
TP.ty.diff.eff <- intersect(ty.diff.eff, test.ty.diff.eff)
TP.ty.ol.eff <- intersect(ty.ol.eff, test.ty.ol.eff)

FP.ty.ol <- setdiff(test.ty.ol, ty.ol)
FP.ty.eff <- setdiff(test.ty.eff, ty.eff)
FP.ty.diff <- setdiff(test.ty.diff, ty.diff)
FP.ty.diff.ol <- setdiff(test.ty.diff.ol, ty.diff.ol)
FP.ty.diff.eff <- setdiff(test.ty.diff.eff, ty.diff.eff)

plot(t.e$diff.win, t.e$diff.btw, col='grey')
points(t.e[FP.ty.eff,'diff.win'], t.e[FP.ty.eff,'diff.btw'], col='blue')
points(t.e[FP.ty.ol,'diff.win'], t.e[FP.ty.ol,'diff.btw'], col='orange', pch=19, cex=0.5)
points(t.e[FP.ty.diff,'diff.win'], t.e[FP.ty.diff,'diff.btw'], col='red')
points(t.e[TP.ty.ol,'diff.win'], t.e[TP.ty.ol,'diff.btw'], col='cyan')
points(t.e[TP.ty.eff,'diff.win'], t.e[TP.ty.eff,'diff.btw'], col='cyan', pch=19, cex=0.5)


#!/usr/bin/env Rscript

# SalaPreMBA SalaPostMBA Tuition GMAT
data = read.table(file = "res/bschool.txt", header = T)
par(mfrow=c(1,1))
# SalaPostMBA 和 SalaPreMBA 散点图
plot(SalaPostMBA~SalaPreMBA, data, pch=16)


#' Computing gene-gene correlation normaized over a similarity graph
#'
#' This is generating a randomized umi matrix by substituting each umi call (per cell and gene) with a umi call from the same gene on a cell that is connected to the original cell in a given similarity graph. If the similarity graph is based on some specific features that express a specific process (e.g. cell cycle), this can help in normalizing this effect and retaining correlation that are independent of it.
#'
#' @param cgraph_id id of the cell graph to be used for normalization
#' @param mat_id the matrix with umis to be analyzed
#' @param K the maxium number of edges to consider per cell in normalization. This can be smaller than the K used in cgraph_id, to provide tighter control
#' @param min_gtot minimal number of umis to consider when computing gene-gene correlaitons
#' @return a list with two entries. gcor - is the gene correlation matrix of the downsampled matrix. r_gcor - is the correlation of the randomized umi matrix
#'
#' @export

mcell_cgraph_norm_gcor = function(cgraph_id, mat_id, K=-1, min_gtot=1000)
{
	old_seed = .set_seed(get_param("mc_rseed"))

	cgraph = scdb_cgraph(cgraph_id)
	if(is.null(cgraph)) {
		stop("missing cgraph for gene cor normalization, id = ", cgraph_id)
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("missing mat for gene cor normalization, id = ", mat_id)
	}

	dsamp_n = scm_which_downsamp_n(mat)

	mat_ds = scm_downsamp(mat@mat, dsamp_n)
	c_nms = colnames(mat_ds)

	adjs = split(cgraph@edges$mc2, cgraph@edges$mc1)
	adjs = adjs[c_nms]
	if(K==-1) {
	  K = max(unlist(lapply(adjs, length)))
	}
	m_adjs = t(sapply(adjs, function(x) {
						x1 = intersect(x, c_nms);
						x[1+(0:(K-1))%%length(x)]
						}))
	C = nrow(m_adjs)
	f_gene = rowSums(mat_ds)>min_gtot
	r_mat = t(apply(mat_ds[f_gene,], 1, function(x) {
				shuf = m_adjs[(1:C)+C*(sample(1:K,s=C, r=T)-1)]
				x[shuf]
				}))

	gcor = tgs_cor(as.matrix(t(mat_ds[f_gene,])), spearman = T)
	r_mat[is.na(r_mat)] = 0
	r_gcor = tgs_cor(t(r_mat), spearman = T)

	.restore_seed(old_seed)
	return(list(gcor=gcor, r_gcor=r_gcor))
}


# Library
library(ggplot2)
library(hrbrthemes)
library(EnvStats)

load("./v6/SI.data.rda")

Metro.ATL <- c("FULTON", "DEKALB", "GWINNETT", "COBB", "CLAYTON")

gamma.dat <- data.frame(rbind(
  c("total",length(SI.data$t_interval),mean(SI.data$t_interval),var(SI.data$t_interval)),
  c("hosp+",length(SI.data$t_interval[SI.data$hospitalized_1=="Yes"]),mean(SI.data$t_interval[SI.data$hospitalized_1=="Yes"]),var(SI.data$t_interval[SI.data$hospitalized_1=="Yes"])),
  c("hosp-",length(SI.data$t_interval[SI.data$hospitalized_1=="No"]),mean(SI.data$t_interval[SI.data$hospitalized_1=="No"]),var(SI.data$t_interval[SI.data$hospitalized_1=="No"])),
  c("vent+",length(SI.data$t_interval[SI.data$ventilator_1=="Yes"]),mean(SI.data$t_interval[SI.data$ventilator_1=="Yes"]),var(SI.data$t_interval[SI.data$ventilator_1=="Yes"])),
  c("vent-",length(SI.data$t_interval[SI.data$ventilator_1=="No"]),mean(SI.data$t_interval[SI.data$ventilator_1=="No"]),var(SI.data$t_interval[SI.data$ventilator_1=="No"])),
  c("death+",length(SI.data$t_interval[SI.data$death_1=="Yes"]),mean(SI.data$t_interval[SI.data$death_1=="Yes"]),var(SI.data$t_interval[SI.data$death_1=="Yes"])),
  c("death-",length(SI.data$t_interval[SI.data$death_1=="No"]),mean(SI.data$t_interval[SI.data$death_1=="No"]),var(SI.data$t_interval[SI.data$death_1=="No"])),
  c("fever+",length(SI.data$t_interval[SI.data$fever_1=="Yes"]),mean(SI.data$t_interval[SI.data$fever_1=="Yes"]),var(SI.data$t_interval[SI.data$fever_1=="Yes"])),
  c("fever-",length(SI.data$t_interval[SI.data$fever_1=="No"]),mean(SI.data$t_interval[SI.data$fever_1=="No"]),var(SI.data$t_interval[SI.data$fever_1=="No"])),
  c("cough+",length(SI.data$t_interval[SI.data$cough_1=="Yes"]),mean(SI.data$t_interval[SI.data$cough_1=="Yes"]),var(SI.data$t_interval[SI.data$cough_1=="Yes"])),
  c("cough-",length(SI.data$t_interval[SI.data$cough_1=="No"]),mean(SI.data$t_interval[SI.data$cough_1=="No"]),var(SI.data$t_interval[SI.data$cough_1=="No"])),
  c("short_breath+",length(SI.data$t_interval[SI.data$short.breath_1=="Yes"]),mean(SI.data$t_interval[SI.data$short.breath_1=="Yes"]),var(SI.data$t_interval[SI.data$short.breath_1=="Yes"])),
  c("short_breath-",length(SI.data$t_interval[SI.data$short.breath_1=="No"]),mean(SI.data$t_interval[SI.data$short.breath_1=="No"]),var(SI.data$t_interval[SI.data$short.breath_1=="No"])),
  c("diarrhea+",length(SI.data$t_interval[SI.data$diarrhea_1=="Yes"]),mean(SI.data$t_interval[SI.data$diarrhea_1=="Yes"]),var(SI.data$t_interval[SI.data$diarrhea_1=="Yes"])),
  c("diarrhea-",length(SI.data$t_interval[SI.data$diarrhea_1=="No"]),mean(SI.data$t_interval[SI.data$diarrhea_1=="No"]),var(SI.data$t_interval[SI.data$diarrhea_1=="No"])),
  c("xray+",length(SI.data$t_interval[SI.data$abnormal.chest.xray_1=="Yes"]),mean(SI.data$t_interval[SI.data$abnormal.chest.xray_1=="Yes"]),var(SI.data$t_interval[SI.data$abnormal.chest.xray_1=="Yes"])),
  c("xray-",length(SI.data$t_interval[SI.data$abnormal.chest.xray_1=="No"]),mean(SI.data$t_interval[SI.data$abnormal.chest.xray_1=="No"]),var(SI.data$t_interval[SI.data$abnormal.chest.xray_1=="No"])),
  c("55+",length(SI.data$t_interval[!is.na(SI.data$age_1) & SI.data$age_1>55]),mean(SI.data$t_interval[!is.na(SI.data$age_1) & SI.data$age_1>55],na.rm=T),var(SI.data$t_interval[!is.na(SI.data$age_1) & SI.data$age_1>55])),
  c("55-",length(SI.data$t_interval[!is.na(SI.data$age_1) & SI.data$age_1<=55]),mean(SI.data$t_interval[!is.na(SI.data$age_1) & SI.data$age_1<=55],na.rm=T),var(SI.data$t_interval[!is.na(SI.data$age_1) & SI.data$age_1<=55])),
  c("male",length(SI.data$t_interval[SI.data$gender_1=="Male"]),mean(SI.data$t_interval[SI.data$gender_1=="Male"]),var(SI.data$t_interval[SI.data$gender_1=="Male"])),
  c("female",length(SI.data$t_interval[SI.data$gender_1=="Female"]),mean(SI.data$t_interval[SI.data$gender_1=="Female"]),var(SI.data$t_interval[SI.data$gender_1=="Female"])),
  c("black",length(SI.data$t_interval[!is.na(SI.data$race_1) & SI.data$race_1=="BLACK"]),mean(SI.data$t_interval[!is.na(SI.data$race_1) & SI.data$race_1=="BLACK"],na.rm=T),var(SI.data$t_interval[!is.na(SI.data$race_1) & SI.data$race_1=="BLACK"])),
  c("white",length(SI.data$t_interval[!is.na(SI.data$race_1) & SI.data$race_1=="WHITE"]),mean(SI.data$t_interval[!is.na(SI.data$race_1) & SI.data$race_1=="WHITE"],na.rm=T),var(SI.data$t_interval[!is.na(SI.data$race_1) & SI.data$race_1=="WHITE"])),
  c("metroATL",length(SI.data$t_interval[SI.data$county_1 %in% Metro.ATL]),mean(SI.data$t_interval[SI.data$county_1 %in% Metro.ATL]),var(SI.data$t_interval[SI.data$county_1 %in% Metro.ATL])),
  c("rural",length(SI.data$t_interval[!SI.data$county_1 %in% Metro.ATL]),mean(SI.data$t_interval[!SI.data$county_1 %in% Metro.ATL]),var(SI.data$t_interval[!SI.data$county_1 %in% Metro.ATL]))
))

names(gamma.dat) <-c("parent.group","n","mean","var")
gamma.dat$n <- as.numeric(as.character(gamma.dat$n))
gamma.dat$mean <- as.numeric(as.character(gamma.dat$mean))
gamma.dat$var <- as.numeric(as.character(gamma.dat$var))
gamma.dat$shape <- (gamma.dat$mean^2)/gamma.dat$var
gamma.dat$scale <- gamma.dat$var/gamma.dat$mean

write.csv(gamma.dat,file=paste0("./v4/output/param_table_gamma_",Sys.Date(),".csv"))

chisq.test(table(SI.data$hospitalized_1[which(SI.data$hospitalized_1 %in% c("Yes","No") & SI.data$hospitalized_2 %in% c("Yes","No"))],
                 SI.data$hospitalized_2[which(SI.data$hospitalized_1 %in% c("Yes","No") & SI.data$hospitalized_2 %in% c("Yes","No"))]))
#secondary case tend to have higher prob to be hospitalized given primary cases were hospitalized (<0.001);

fisher.test(table(SI.data$ventilator_1[which(SI.data$ventilator_1 %in% c("Yes","No") & SI.data$ventilator_2 %in% c("Yes","No"))],
                  SI.data$ventilator_2[which(SI.data$ventilator_1 %in% c("Yes","No") & SI.data$ventilator_2 %in% c("Yes","No"))]))

fisher.test(table(SI.data$death_1[which(SI.data$death_1 %in% c("Yes","No") & SI.data$death_2 %in% c("Yes","No"))],
                  SI.data$death_2[which(SI.data$death_1 %in% c("Yes","No") & SI.data$death_2 %in% c("Yes","No"))]))

chisq.test(table(SI.data$fever_1[which(SI.data$fever_1 %in% c("Yes","No") & SI.data$fever_2 %in% c("Yes","No"))],
                 SI.data$fever_2[which(SI.data$fever_1 %in% c("Yes","No") & SI.data$fever_2 %in% c("Yes","No"))]))
#secondary case tend to have higher prob to have fever given primary cases developed fever (p=0.004);

chisq.test(table(SI.data$cough_1[which(SI.data$cough_1 %in% c("Yes","No") & SI.data$cough_2 %in% c("Yes","No"))],
                 SI.data$cough_2[which(SI.data$cough_1 %in% c("Yes","No") & SI.data$cough_2 %in% c("Yes","No"))]))
#secondary case tend to have higher prob to have cough as symptom given primary cases developed cough as symptom (p=0.01);

chisq.test(table(SI.data$short.breath_1[which(SI.data$short.breath_1 %in% c("Yes","No") & SI.data$short.breath_2 %in% c("Yes","No"))],
                 SI.data$short.breath_2[which(SI.data$short.breath_1 %in% c("Yes","No") & SI.data$short.breath_2 %in% c("Yes","No"))]))
#secondary case tend to have higher prob to have short of breath as symptom given primary cases developed short of breath as symptom (p=0.01);

chisq.test(table(SI.data$diarrhea_1[which(SI.data$diarrhea_1 %in% c("Yes","No") & SI.data$diarrhea_2 %in% c("Yes","No"))],
                 SI.data$diarrhea_2[which(SI.data$diarrhea_1 %in% c("Yes","No") & SI.data$diarrhea_2 %in% c("Yes","No"))]))
#secondary case tend to have higher prob to have diarrhea as symptom given primary cases developed diarrhea as symptom (p=0.009);

chisq.test(table(SI.data$abnormal.chest.xray_1[which(SI.data$abnormal.chest.xray_1 %in% c("Yes","No") & SI.data$abnormal.chest.xray_2 %in% c("Yes","No"))],
                 SI.data$abnormal.chest.xray_2[which(SI.data$abnormal.chest.xray_1 %in% c("Yes","No") & SI.data$abnormal.chest.xray_2 %in% c("Yes","No"))]))
#secondary case tend to have higher prob to have abnormal xray given primary cases had abnormal xray (p<0.001);
par(mfrow=c(1,1),mar=c(4,4,2,1))
plot(SI.data$age_1,SI.data$age_2,xlab="primary case age",ylab="secondary case age")

# Dummy data
x <- 1:10*10-5
y <- 1:10*10-5
data <- expand.grid(X=x, Y=y)
data$Z <- NA
for (i in x){
  for (j in y){
    data$Z[which(data$X==i & data$Y==j)] <- length(which(SI.data$age_1 <= i+5 & SI.data$age_1 > i-5 & SI.data$age_2 <= j+5 & SI.data$age_2 > j-5))
  }
}
data$Z <- data$Z/sum(data$Z)*100

# Give extreme colors:
ggplot(data, aes(X, Y, fill= Z)) +
  geom_tile() +
  geom_text(aes(label = round(Z, 1)),size=8) +
  scale_fill_gradient(low="white", high="red") +
  labs(x="primary case age",y="secondary case age",fill = "Percent of\ntransmissions\n(N=2990)") +
  theme(
    legend.title = element_text(size=16),
    legend.text = element_text(size=14),
    axis.title.x = element_text(size = 16),
    axis.text.x = element_text(size = 14),
    axis.title.y = element_text(size = 16),
    axis.text.y = element_text(size = 14))

#age shows transmission happen between people with similar age;

chisq.test(table(SI.data$gender_1[which(SI.data$gender_1 %in% c("Male","Female") & SI.data$gender_2 %in% c("Male","Female"))],
                 SI.data$gender_2[which(SI.data$gender_1 %in% c("Male","Female") & SI.data$gender_2 %in% c("Male","Female"))]))
#Male primary case tend to pass to Female? (p<0.001);

chisq.test(table(SI.data$race_1[which(SI.data$race_1 %in% c("BLACK","WHITE") & SI.data$race_2 %in% c("BLACK","WHITE"))],
                 SI.data$race_2[which(SI.data$race_1 %in% c("BLACK","WHITE") & SI.data$race_2 %in% c("BLACK","WHITE"))]))
#Pass to same race (p<0.001)

table(SI.data$county_1==SI.data$county_2)


#' Reduce methylation profiles to most cell-type specific sites
#'
#' @param beta Numeric matrix (values = 0..1; rows = CpG sites; columns = samples).
#' @param cell.types Name of cell type for each column of beta.
#' @param number.sites For each cell type, the number of sites less methylated and the number
#' more methylated than other cell types to include in the reduced methylation profiles.
#' @return Numeric matrix (values = 0..1; rows = CpG sites; columns = cell types)
#' with \code{number.sites} CpG sites per cell type more methylated than other cell types
#' and the same number less methylated.  Values are the mean CpG site methylation levels
#' of all original samples of the same cell type.#
#'
#' @export
meffil.cell.type.specific.methylation <- function(beta, cell.types, number.sites=50, verbose=F) {
    msg("cell types", paste(unique(cell.types), collapse=", "), verbose=verbose)

    stopifnot(is.matrix(beta))
    stopifnot(ncol(beta) == length(cell.types))
    stopifnot(number.sites > 0 && number.sites <= nrow(beta))

    number.cell.types <- length(unique(cell.types))
    cell.types <- as.character(cell.types)
    design <- model.matrix(~ 0 + cell.types)

    msg("fitting linear model with limma::lmFit", verbose=verbose)
    fit <- limma::lmFit(beta, design=design)
    contrasts <- diag(x=2, nrow=number.cell.types) - 1
    contrasts[which(contrasts == 1)] <- nrow(contrasts)-1

    msg("computing t-statistics with limma::eBayes", verbose=verbose)
    fit.eb <- limma::eBayes(contrasts.fit(fit, contrasts))

    sites.idx <- apply(fit.eb$t, 2, function(t.statistics) {
        c(order(t.statistics, decreasing=F)[1:number.sites],
          order(t.statistics, decreasing=T)[1:number.sites])
    })
    sites.idx <- unique(as.vector(sites.idx))

    ## checked that this wwas working as expected:
    ## 1. should be equal
    ## 6*fit$coefficients[1000,1] - sum(fit$coefficients[1000,-1])
    ## fit.eb$coefficients[1000,1]

    ## 2. should be large (methylation differences between cell type and the rest)
    ## quantile(apply(abs(fit.eb$coefficients[sites.idx,])/6, 1, max, na.rm=T))

    ## 3. p-values should all be really small
    ## quantile(apply(fit.eb$p.value[sites.idx,], 1, min, na.rm=T))

    ## 4. t-statistics should be positive or negative and all far from 0.
    ## quantile(apply(fit.eb$t[sites.idx,], 1, min, na.rm=T))
    ## quantile(apply(fit.eb$t[sites.idx,], 1, max, na.rm=T))
    ## quantile(apply(abs(fit.eb$t[sites.idx,]), 1, max, na.rm=T))

    ret <- fit$coefficients[sites.idx,]
    colnames(ret) <- gsub("cell.types", "", colnames(ret))
    ret
}


# AUTHOR : IENG KIT NICHOLAS, HO
# DATE : MARCH 2017
#########################################################################################

# INITIALIZATION

# Please install the appropriate packages before running this program

library(foreach)
library(doParallel)
cl <- makeCluster(detectCores() - 1)
registerDoParallel(cl)
setwd("")
rw <- read.csv(file="",header=FALSE,sep=",");
p <- sweep(rw,1,rowSums(rw),'/')
p <- matrix(unlist(p), ncol = length(p), nrow = length(p), byrow = FALSE)
ver <- c(names(rw))
ver <- matrix(unlist(ver), ncol = length(names(rw)), nrow = 1, byrow = FALSE)
allVer <- ver[1,]
inc <- function(x){eval.parent(substitute(x <- x + 1))}
index <- 0; dist <- c()

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

# IMPLEMENTATION

# The graph walk algorithm :

graphwalk <- function(from, to, number_of_random_walks, threshold) {
	verFrom <- ver[1,from];verTo <- ver[1,to];pFrom <- p[from,]
	for (j in 1:number_of_random_walks) {
		counter <- matrix(c(rep(0,length(ver))), ncol = length(ver), nrow = 1, byrow = FALSE)
		v <- sample(allVer, 1, FALSE, pFrom)
		index <- match(v, allVer)
        inc(counter[1,index])
		if (v == verTo) {
			ifelse((v == verFrom), dist <- c(dist,0), dist <- c(dist,1))
			next}
		else if ((p[from,index] == 1)&(!(v == verTo))) {
			dist <- c(dist, NA)
			break}
		for (i in 1:threshold) {
				if (v == ver[1,index]) {
					inc(counter[1,index])
					v <- sample(allVer, 1, FALSE, p[index,])
					index <- match(v, allVer)
					inc(counter[1,index])
					if (v == verTo) {
						dist <- c(dist,sum(counter))
						break}}
					else if ((i == threshold) & (!(v == verTo))) {
						dist <- c(dist,NA)}}}
	dist<-na.omit(dist)
	if (length(dist) > 0) {
		dist <- matrix(unlist(dist), ncol = length(dist), nrow = 1, byrow = FALSE)
		sol <- sum(dist)/length(dist) }
	else sol <- NA
	return(sol)}

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

# COMPUTATION

# Nested for loop version

nr = length(rw)

# The maximum traversal distance allowed for v_i to find v_j
# This value should be set high enough to gurantee convergence (but will increase computation time)
# For large_g.csv set this value to be at least 3000 to ensure coverage
# For small_g.csv set this value to be at least 700 to ensure coverage
th = 1000

result.mat <- matrix(c(rep(0, nr^2)), nrow=nr, ncol=nr, byrow=TRUE)

# Number of random walks for each pair of vertices must be at least 1000 times by default
nw = 1000

system.time({
for (i in 1:nr){
	for (k in 1:nr){
		result.mat[i,k] <- graphwalk(i,k,nw,th)}}})

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

# Parallel Version - This is a faster version

system.time({
foreach(i=1:nr) %:%
	foreach (k=1:nr)  %do% {
    	result.mat[i,k] <- graphwalk(i,k,nw,th)} })

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

# DATA EXPORTATION

# Write data to csv

write.csv(result_mat, file = "")


# Read in data from text connection
datalines <- readLines(tc <- textConnection("710889
B0YBKJ
406566
B0YBLH
228276
B0YBKL
557910
B0YBKR
585284
B0YBKT")); close(tc)

# Check data valid
checkSedol <- function(datalines)
{
   ok <- grep("^[[:digit:][:upper:]]{6}$", datalines)
   if(length(ok) < length(datalines))
   {
      stop("there are invalid lines")
   }
}
checkSedol(datalines)

# Append check digit
appendCheckDigit <- function(x)
{
   if(length(x) > 1) return(sapply(x, appendCheckDigit))
   ascii <- as.integer(charToRaw(x))
   scores <- ifelse(ascii < 65, ascii - 48, ascii - 55)
   weights <- c(1, 3, 1, 7, 3, 9)
   chkdig <- (10 - sum(scores * weights) %% 10) %% 10
   paste(x, as.character(chkdig), sep="")
}
withchkdig <- appendCheckDigit(datalines)

#Print in format requested
writeLines(withchkdig)


#########################################################################################################
# Empirical Size simulation Codes of New Combined Threshold Unit Root Test introduced in
#
# "Threshold Unit Root Tests with Smooth Transitions: A Monte Carlo Study"
#
# written by
#
# Dr. Mehmet ÖZCAN
# mehmetozcan@kmu.edu.tr
#
# *NOTES*
# 1)  Caner & Hansen (2001) Threshold Unit Root test and Threshold Effect test
#     programs are taken from Hansen's web page http://www.ssc.wisc.edu/~bhansen/ .
#     However, unit root test program are adjusted to test unit root null hypothesis
#     without any deterministic component.
#
# 2)  There are two indicator which come from Caner & Hansen (2001)'s codes. Caner &
#     Hansen investigate different type of threshol variable type and different trimming
#     intervals. In this study, lagged difference threshold variable and [0.15, 0.85]
#     trimming interval are used for all simulation experiments and empirical application.
#
#     thresh    Type of threshold variable
#  		  1 for long difference,   z(t-1)=y(t-1)-y(t-(m-1))
#  		  2 for lagged difference, z(t-1)=y(t-m)-y(t-m-1)
#  		  3 for lagged level,      z(t-1)=y(t-m)
#     trim      Trimming Range (normalized threshold, lambda)
#  		  1 for [.15,.85]
#  	 	  2 for [.10,.90]
#  		  3 for [.05,.95]
#
#    Other important imputs:
#     rep       Monte-Carlo replication
#     p         Autoregressive Lag Order
#     mmin      Minimal Delay Order for testing
#     mmax      Maximal Delay Order for testing
#     m		    Delay Order (fixed) for estimation. Set to 0 for m to be estimated by maximizing Wald RT statistics.
#
# 3) Results are printed to the screen.
#
# 4) All steps of simulation process are explained below. Please check them before run the codes.
#
# *Instructions*
#
# 1) First, please install required R packcages stated below.
# 2) You could simulate different parameter settings. Please check "simulation settings" part blow.
# 3) This codes includes critical values for T=100 and T=200.
# 4) Run all codes
#
#
#########################################################################################################
# Required Packcages
library(nloptr)
#########################################################################################################
# Required Functions
#########################################################################################################

# Size DGP
CHSizeDGP <- function(n,a){
    n <- n+1
    et<- as.matrix(rnorm(n))
    et<- et-mean(et)

    dyt <- matrix(0,n,1)
    for(i in 2:n) dyt[i] <- (a*dyt[i-1])+et[i]

    yo <- matrix(0,n,1)
    for(i in 2:n) yo[i]<-yo[i-1]+dyt[i]
    yo<-as.matrix(yo[2:n])
}

# Starting value estimation for LNV(1998) Models (A, B & C) #
startLNV<-function(dta){
tt<-length(dta)
tr<-as.matrix(c(1:tt))
cc<-as.matrix(rep(1,tt))

tauGs<-c()
for(kk in 1:tt){ tauGs[kk]<-(kk/tt) }
gamaGs<-seq(1,10,1)

SSRA<-matrix(0,length(tauGs),length(gamaGs))
SSRB<-matrix(0,length(tauGs),length(gamaGs))
SSRC<-matrix(0,length(tauGs),length(gamaGs))

for(vk in 1:3){
for(vi in 1:(length(gamaGs))){
for(vj in 1:(length(tauGs))){
st<-as.matrix((1/(1+exp(-(gamaGs[vi])*((tr)-(tauGs[vj]*tt))))))
if(vk==1){X<-as.matrix(cbind(cc,st))}
if(vk==2){X<-as.matrix(cbind(cc,tr,st))}
if(vk==3){X<-as.matrix(cbind(cc,tr,st,(tr*st)))}
XX<-(MASS:::ginv(t(X)%*%X, tol=1e-25))
betas<-XX%*%(t(X)%*%dta)
Yhat<-t((t(betas)%*%t(X)))
ehat<-(dta-Yhat)
if(vk==1){SSRA[vj,vi]<-sum((ehat)^2)}
if(vk==2){SSRB[vj,vi]<-sum((ehat)^2)}
if(vk==3){SSRC[vj,vi]<-sum((ehat)^2)}
}
}
}

for(vs in 1:3){
if(vs==1){posA<-which(SSRA == min(SSRA), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posA[2]])*((tr)-(tauGs[posA[1]]*tt))))));
X<-as.matrix(cbind(cc,st))}
if(vs==2){posB<-which(SSRB == min(SSRB), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posB[2]])*((tr)-(tauGs[posB[1]]*tt))))));
X<-as.matrix(cbind(cc,tr,st))}
if(vs==3){posC<-which(SSRC == min(SSRC), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posC[2]])*((tr)-(tauGs[posC[1]]*tt))))));
X<-as.matrix(cbind(cc,tr,st,(tr*st)))}

XX<-(MASS:::ginv(t(X)%*%X, tol=1e-25))

if(vs==1){betasA<-XX%*%(t(X)%*%dta);
betasA<-rbind(betasA,gamaGs[posA[2]],tauGs[posA[1]])}
if(vs==2){betasB<-XX%*%(t(X)%*%dta);
betasB<-rbind(betasB,gamaGs[posB[2]],tauGs[posB[1]])}
if(vs==3){betasC<-XX%*%(t(X)%*%dta);
betasC<-rbind(betasC,gamaGs[posC[2]],tauGs[posC[1]])}
}
list(betasA=betasA, betasB=betasB, betasC=betasC)
}

# LNV(1998) Models (A, B & C) Estimation with Sequential Quadratic Programing
estLNV<-function(yt, X, b0a, b0b, b0c){
tt<-length(yt)
stabA<-function(b){sum((yt-(b[1]*X[,1]+b[2]*(1/(1+exp(-(b[3])*((X[,2])-b[4]*tt))))))^2)}
stabB<-function(b){sum((yt-(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[4])*((X[,2])-b[5]*tt))))))^2)}
stabC<-function(b){sum((yt-(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))+
b[4]*(X[,2])*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))))^2)}

lba<-c(-Inf,-Inf,0,0)
uba<-c(Inf,Inf,Inf,1)

lbb<-c(-Inf,-Inf,-Inf,0,0)
ubb<-c(Inf,Inf,Inf,Inf,1)

lbc<-c(-Inf,-Inf,-Inf,-Inf,0,0)
ubc<-c(Inf,Inf,Inf,Inf,Inf,1)

SA<-nloptr:::slsqp(b0a,fn=stabA,lower=lba,upper=uba, control=list(xtol_rel=1e-25))
SB<-nloptr:::slsqp(b0b,fn=stabB,lower=lbb,upper=ubb, control=list(xtol_rel=1e-25))
SC<-nloptr:::slsqp(b0c,fn=stabC,lower=lbc,upper=ubc, control=list(xtol_rel=1e-25))

staba<-function(b){(b[1]*X[,1]+b[2]*(1/(1+exp(-(b[3])*((X[,2])-b[4]*tt)))))}
yhatA<-staba(SA$par)

stabb<-function(b){b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[4])*((X[,2])-b[5]*tt))))}
yhatB<-stabb(SB$par)

stabc<-function(b){(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))+
b[4]*(X[,2])*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt)))))}
yhatC<-stabc(SC$par)

list(ehat=as.matrix(cbind((yt-yhatA),(yt-yhatB),(yt-yhatC))), yhat=as.matrix(cbind(yhatA,yhatB,yhatC)),BetaA=as.matrix(SA$par),BetaB=as.matrix(SB$par),BetaC=as.matrix(SC$par))
}

# Caner & Hansen (2001) Estimator
tur_est2 <- function(dat,p,mmin,mmax,m,constant,trend){
  t <- nrow(dat)
  n <- t - 1 - p
  mn <- mmax-mmin+1
  ms <- as.matrix(seq(mmin,mn,1))
  dy <- as.matrix(dat[2:t]-dat[1:(t-1)])
  y <- as.matrix(dy[(1+p):(t-1)])
  if(constant==1) x <- matrix(1,n,1)
  if (trend==1) x <- cbind(x,as.matrix(seq(1,n,1)))
  if(constant==1){x <- cbind(x,dat[(1+p):(t-1)],dy[p:(t-2)])}else{
  x <- cbind(dat[(1+p):(t-1)],dy[p:(t-2)])}
  if(p>1) for (ki in 2:p) x <- cbind(x,dy[(p+1-ki):(t-1-ki)])

  if (sum(coef)==0){
      xi_ns <- as.matrix(seq(1,p,1)+1+constant+trend)
        }else{
      idex <- colSums(as.matrix(coef%*%matrix(1,1,p))==(matrix(1,nrow(coef),1)%*%seq(1,p,1)))
      xi_ns <- seq(1,p,1)
      xi_ns <- as.matrix(xi_ns[idex==0]+1+constant+trend)
    }

  if (trend==0){
        if(constant==0){
	        if (sum(coef)==0){
            xi_s <- rbind(1)
                }else{xi_s <- rbind(1,(coef+1))
            }
        }
    }
  if (trend==0){
    if(constant==1){
	if (sum(coef)==0){
      xi_s <- rbind(1,2)
    }else{
      xi_s <- rbind(1,2,(coef+2))
    }
  }
  }
  if (trend==1){
    if(constant==1){
	if (sum(coef)==0){
      xi_s <- rbind(1,2,3)
    }else{
      xi_s <- rbind(1,2,3,(coef+3))
    }
  }
  }

  xs <- as.matrix(x[,xi_s])
  xns <- as.matrix(x[,xi_ns])

  if (thresh==1){
      qs <- dat[(1+p):(t-1)]-dat[(1+p-mmin):(t-1-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p):(t-1)]-dat[(1+p-mi):(t-1-mi)]))
      }
	  }
  }
  if (thresh==2){
      qs <- dat[(1+p-mmin+1):(t-1-mmin+1)]-dat[(1+p-mmin):(t-1-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p-mi+1):(t-1-mi+1)]-dat[(1+p-mi):(t-1-mi)]))
      }
	  }
  }
  if (thresh==3){
      qs <- dat[(1+p-mmin+1):(t-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p-mi+1):(t-mi)]))
      }
	  }
  }
  kx    <- ncol(x)
  ks    <- nrow(coef)+1+constant+trend
  xx    <- solve(t(x)%*%x, tol=1e-25)
  bols  <- xx%*%(t(x)%*%y)
  eols  <- y - x%*%bols
  sols  <- t(eols)%*%eols
  wwss  <- matrix(0,mn,1)
  smins <- matrix(0,mn,1)
  lams  <- matrix(0,mn,1)
  ws    <- matrix(0,mn,1)
  r1    <- matrix(0,mn,1)
  r2    <- matrix(0,mn,1)
  t1    <- matrix(0,mn,1)
  t2    <- matrix(0,mn,1)
  rur <- rbind(1,(ks+1))+trend+constant
  indx <- 1:(n)
  pi1 <-.2-.05*trim
  pi2 <-.8+.05*trim
  for (mi in 1:mn){
    q <- qs[,mi]
    qq <- unique(q)
    qq <- as.matrix(sort(qq))
    qq <- as.matrix(qq[(floor(n*pi1)+1):(ceiling(n*pi2)-1)])
    qn <- nrow(qq)
    s  <- matrix(0,qn,1)
    wws<- matrix(0,qn,1)
    for (qi in 1:qn){
      d1      <- as.matrix((q<qq[qi]))
      d2      <- 1-d1
      xz      <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
      xxi     <- solve(t(xz)%*%xz, tol=1e-25)
      bthresh <- xxi%*%(t(xz)%*%y)
      e       <- y-xz%*%bthresh
      s[qi]   <- t(e)%*%e
      v       <- xxi*as.vector((t(e)%*%e)/(n-kx-ks))
      vd      <- diag(v)
      ts      <- as.matrix(bthresh[rur]/sqrt(vd[rur]))
      wws[qi] <- t(ts)%*%ts
    }
    qi         <- which.max(wws)
    lam        <- qq[qi]
    smin       <- s[qi]
    wwsmax     <- wws[qi]
    ws[mi]     <- (n-kx-ks)*(sols-smin)/smin
    smins[mi]  <- smin
    lams[mi]   <- lam
    wwss[mi]   <- wwsmax
    d1         <- as.matrix((q<lam))
    d2         <- 1-d1
    xz         <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
    mmi        <- solve(t(xz)%*%xz, tol=1e-25)
    bthresh    <- mmi%*%(t(xz)%*%y)
    e          <- y - xz%*%bthresh
    v          <- mmi*as.vector((t(e)%*%e)/(n-kx-ks))
    vd         <- diag(v)
    ts         <- as.matrix(bthresh[rur]/sqrt(vd[rur]))
    r1[mi]     <- t(ts^2)%*%(ts<0)
    r2[mi]     <- t(ts)%*%ts
    t1[mi]     <- -ts[1]
    t2[mi]     <- -ts[2]
  }
  if (m != 0) {mi <- m-mmin+1}else{mi<- which.max(wwss)}
  mhat     <- ms[mi]
  w        <- ws[mi]
  lam      <- lams[mi]
  q        <- qs[,mi]
  d1       <- as.matrix((q<lam))
  d2       <- 1-d1
  xz       <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
  mmi      <- solve(t(xz)%*%xz, tol=1e-25)
  bthresh  <- mmi%*%(t(xz)%*%y)
  e        <- y - xz%*%bthresh
  ee       <- t(e)%*%e
  v        <- mmi*as.vector((ee)/(n-kx-ks))
  vd       <- diag(v)
  v1       <- vd[1:ks]
  v2       <- vd[(ks+1):(2*ks)]
  b1       <- bthresh[1:ks]
  b2       <- bthresh[(ks+1):(2*ks)]
  ts       <- as.matrix(((b1-b2)^2)/(v1+v2))
  bs_s     <- cbind(b1,sqrt(v1),matrix(0,ks,1),b2,sqrt(v2))
  bs_ns    <- cbind(bthresh[(1+2*ks):(kx+ks)],sqrt(vd[(1+2*ks):(kx+ks)]))
  ar01     <-bthresh[(2+constant+trend):(ks)]
  ar02     <-bthresh[(2+constant+trend+ks):(ks*2)]
  leng     <-sum(x[,ncol(x)]>lam)
list(mhat=mhat,lam=lam,e=e,bs_s=bs_s,ar01=ar01,ar02=ar02,b1=b1,b2=b2,r1=r1,r2=r2,t1=t1,t2=t2,ts=ts,ws=ws,w=w,
wws=wws, wwss=wwss,leng=leng,vd=vd)
}

###########################################################
# Caner & Hansen (2001) TAR Model Estimation Settings #####
thresh   <- 2
trim     <- 1
p        <- 1
m        <- 0
mmin     <- 1
mmax     <- p
coef     <- matrix(c(1:p),p,1)
###########################################################
# Simulation Settings #####################################
rep      <- 10000
n        <- 100
alpha    <- 0.8
tr       <-as.matrix(c(1:n))
cc       <-as.matrix(rep(1,n))
###########################################################
# 5% Criticals T=100 ######################################
 R1A <- 21.15948
 R2A <- 21.27445
 R1B <- 27.69705
 R2B <- 27.77254
 R1C <- 30.93129
 R2C <- 30.95712
# 5% Criticals T=200 ######################################
# R1A <- 20.82907
# R2A <- 21.07073
# R1B <- 26.67934
# R2B <- 26.80033
# R1C <- 29.65022
# R2C <- 29.69269
###########################################################
# Simulation Process
ptm <- proc.time()
set.seed(012345)
RTDist <- matrix(0,rep,6)

for(i in 1:rep){
yt   <- as.matrix(CHSizeDGP(n,alpha))
LNV  <- startLNV(yt)
b0a  <- LNV$betasA
b0b  <- LNV$betasB
b0c  <- LNV$betasC
X    <- as.matrix(cbind(cc,tr))
ELNV <- estLNV(yt, X, b0a, b0b,b0c)
D    <- as.matrix(ELNV$ehat)

tarA <- tur_est2(as.matrix(D[,1]),p,mmin,mmax,m,0,0);
tarB <- tur_est2(as.matrix(D[,2]),p,mmin,mmax,m,0,0);
tarC <- tur_est2(as.matrix(D[,3]),p,mmin,mmax,m,0,0);

RTDist[i,1] <- sum(tarA$r1[tarA$mhat]>R1A)
RTDist[i,2] <- sum(tarB$r1[tarB$mhat]>R1B)
RTDist[i,3] <- sum(tarC$r1[tarC$mhat]>R1C)
RTDist[i,4] <- sum(tarA$r2[tarA$mhat]>R2A)
RTDist[i,5] <- sum(tarB$r2[tarB$mhat]>R2B)
RTDist[i,6] <- sum(tarC$r2[tarC$mhat]>R2C)
}
rA <- rbind((sum(RTDist[,1])*100)/rep,(sum(RTDist[,4])*100)/rep)
rB <- rbind((sum(RTDist[,2])*100)/rep,(sum(RTDist[,5])*100)/rep)
rC <- rbind((sum(RTDist[,3])*100)/rep,(sum(RTDist[,6])*100)/rep)
CC  <- cbind(rA,rB,rC)
proc.time() - ptm
print(CC)

printres <- function(CC){
cat ("\n")
cat ("Empirical Size Values for Selected Sample Size & Alpha"                             , "\n")
cat ("\n")
cat ("Number of Observations (T):", n                                                     , "\n")
cat ("                     Alpha:", alpha                                                 , "\n")
cat ("               Replication:", rep                                                   , "\n")
cat ("              Nominal Size:", "%5"                                                  , "\n")
cat ("\n")
cat ("Model A"                                                                            , "\n")
cat ("   ","R1t", "   R2t"                                                                , "\n")
cat ("   ", CC[1,1]," ",CC[2,1]                                                           , "\n")
cat ("\n")
cat ("Model B"                                                                            , "\n")
cat ("   ","R1t", "   R2t"                                                                , "\n")
cat ("   ", CC[1,2]," ",CC[2,2]                                                           , "\n")
cat ("\n")
cat ("Model C"                                                                            , "\n")
cat ("   ","R1t", "   R2t"                                                                , "\n")
cat ("   ", CC[1,3]," ",CC[2,3]                                                           , "\n")
cat ("\n")
}

printres(CC)
# END #


#================================================================
library(truncnorm)
#===============================================================
#Auxiliary functions used during the simulations
#===============================================================
#Function that calculates euclidean distances. It receives two
#matrices of x and y coordinates as parameters.
euclid = function(m1, m2=m1)
{
  sqrt(outer(m1[,1], m2[,1],"-")^2 + outer(m1[,2], m2[,2],"-")^2)
}
#===============================================================
#Function that takes samples from a vector of probabilities
#Given a vector prob of length y, it samples values from 1 to y, the
#probability of value i (i <=y ) being sampled is prob[i].
sampleProb = function(prob, n=1, replace=FALSE)
{
  prob[is.na(prob)] = 0
  positiveProbs = sum(prob!=0)
  if (positiveProbs == 1)
    return(which(prob!=0))
  else if(positiveProbs > 1)
    return(sample(1:length(prob), size = n, replace=replace, prob=prob))
  else return(NA)
}
#===============================================================
#Function that runs a simulation of a mating system with information
#filtering during mate choice.
#It simulates one mating season of a population with 1:1 sex ratio
#The function returns a list containing three data.frames, if a
#filename is given, all data is also registered in three csv files.
simScramble = function(N=100, w = 1, zmean=4, zsd=1, radius=0.10,
                       B=2, filename=NA, append=TRUE, seed=NA,
                       choice=1, zmin=1, zmax=Inf, autocorr = FALSE)
{

  #if a random seed is given, it is used
  if(!is.na(seed))
    set.seed(seed)

  #a trick to facilitate indexing
  xy = c("x","y")

  #creating the data.frames for males and females
  females = data.frame(wid=seed, id=1:N, x=runif(N, min=0, max=w),
                       y=runif(N, min=0, max=w))
  males = data.frame(wid=seed, id=1:N, x=runif(N, min=0, max=w), y=runif(N, min=0, max=w), ms=0)

  zmatrix = NA
  difs = NA

  #creating data.frame for males
  zmean = as.numeric(zmean);zsd = as.numeric(zsd);
  zmin = as.numeric(zmin);zmax = as.numeric(zmax);

  #if there is spatial autocorrelation of traits
  if (autocorr)
  {
    MdistOrigin = euclid(cbind(males$x,males$y), matrix(c(0,0), nrow = 1, ncol=2))
    MmeanZ = (MdistOrigin/(sqrt(2)*w)*zmean)+1
    males$trait = rtruncnorm(N, a=MmeanZ/4, b=zmax, mean = MmeanZ, sd=zsd)
  }
  else
  {
    males$trait=rtruncnorm(n = N, a = zmin, b = zmax, mean=zmean, sd=zsd)
  }

  if(choice==1)#directional choice
  {
    #male trait matrix
    zbase = matrix(males$trait, nrow=N, ncol=N, byrow=TRUE)
    zmatrix = zbase^B

  }
  else #assortative choice
  {
    #then females also have a trait value(from the same distribution)

    if(autocorr)
    {
      FdistOrigin = euclid(cbind(females$x,females$y), matrix(c(0,0), nrow = 1, ncol=2))
      FmeanZ = (FdistOrigin/(sqrt(2)*w)*zmean)+1
      females$trait=rtruncnorm(n = N, a = FmeanZ/4, b = zmax, mean=FmeanZ, sd=zsd)
    }
    else
    {
      females$trait=rtruncnorm(n = N, a = zmin, b = zmax, mean=zmean, sd=zsd)
    }

    #calculates all pairwise differences
    difs = outer(females$trait, males$trait, "-")

    #divides by female trait
    fzmatrix = matrix(females$trait, nrow=N, ncol=N, byrow=TRUE)
    difs = difs/fzmatrix
    difs = abs(difs)

    zbase = difs
    zmatrix = exp(-B*(difs))
  }

  #In all the matrices, females are lines, males are columns
  #distance matrix
  smatrix = euclid(females[,xy], males[,xy])

  #adjacency matrix of neighborhood (males available)
  #females are connected to males within r distance
  nmatrix = ifelse(smatrix<=radius, 1, 0)

  #also, by default females are connected to the closest male
  nmatrix[cbind(1:N, apply(smatrix, 1, which.min))] = 1

  #choice matrix
  cmatrix = nmatrix * zmatrix

  #choosing the males
  chosenMales = apply(cmatrix, 1, sampleProb, replace=FALSE)

  #data.frame that registers the copulations
  groups = data.frame(wid=seed, female = females$id, male = chosenMales)

  #adding mating success to the males
  males$ms=0
  tms = tabulate(chosenMales, nbins = N)#table of mating success
  males$ms = tms

  #If there is a filename, files must be written
  #Columns are separated by ";" and "," is used as decimal separator
  if(!(is.na(filename)))
  {
    write.table(x = females, file = paste(filename, "Females.csv", sep=""),
                append = append, sep = ";", dec=",", row.names = FALSE, col.names = !append)
    write.table(x = males, file = paste(filename, "Males.csv", sep=""),
                append = append, sep = ";", dec=",", row.names = FALSE, col.names = !append)
    write.table(x = groups, file = paste(filename, "Groups.csv", sep=""),
                append = append, sep = ";", dec=",", row.names = FALSE, col.names = !append)
  }

  invisible(list(females=females, males=males,groups=groups))

}
#====================================================================


# Parameters
THETA <- c(10L, 90L) # Fundamental Biodiversity Number. May et al. 2015 PRSB fit thetas of 25 to 90 to BCI data, depending on which pattern was fit. Tittensor & Worm 2016 GEB use 10, citing Hubbell. These values span a range.
M <- c(0.01, 0.1, 0.9) # migration rate (probability of new individual coming from regional pool)
N <- c(20L, 200L) # number of individuals in local community
NSAMPS <- 600L # Number of sampled timesteps
STEPL <- 0.5 # Sampling frequency multiplier (multiplies by N). Scaled so that, on average, half the individuals die between every sample
SEED <- 42L # Seed
NBURN = 100L # Burnin length multiplier (multiplies by N)

parameter_table <- expand.grid(THETA = THETA, M = M, N = N, NSAMPS = NSAMPS, STEPL=STEPL, SEED=SEED, NBURN=NBURN)
parameter_table$parameter_id <- seq_len(nrow(parameter_table))


REBOL [
    Title:  "Whatever"
    Date:   2-Feb-2000
    File:   %whatever.reb
    Author: "Whatever"
    Version: 1.2.3
]
maxLimit: 28

fib: func [x][
	either x < 1 [1][(fib x - 1) + (fib x - 2)]
]

for i 0 maxLimit - 1 1 [
	print fib i
]


#' Get the dimensions of a MODFLOW Model without reading the entire .dis file
#'
#' This function is used for extracting the number of rows, columns, layers, stress periods of a model
#' without reading the entire discritization file
#' It can be used as a utility function for the other MFtools functions
#'
#' @param rootname This is the root name of the dis file
#' @export
#' @examples
#' get_dims(rootname)
#' # A tibble: 1 x 4
#'    NLAY  NROW  NCOL  NPER
#'   <int> <int> <int> <int>
#' 1    34   328   291     1
#'
#' D <- get_dims(rootname)
#' D$NLAY
#' [1] 34
#' D$NCOL
#' [1] 291
#' D$NLAY * D$NCOL
#' [1] 9894

get_dims <- function(rootname){
    infl <- paste0(rootname, ".dis")
    linin <- readr::read_lines(infl, n_max = 10) %>% .[-grep("#", .)]              # READ IN DIS FILE BUT REMOVE COMMENTED LINES
                                                                # THIS IS IN PREPARATION FOR MODFLOW 6
    indx <- 1
    NLAY <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(1) %>% as.integer()
    NROW <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(2) %>% as.integer()
    NCOL <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(3) %>% as.integer()
    NPER <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(4) %>% as.integer()
    DIMS <- tibble::data_frame(NLAY = NLAY,
                               NROW = NROW,
                               NCOL = NCOL,
                               NPER = NPER)
    return(DIMS)
    }


# Conditional Latent Growth Structural Equation Model Power Analysis

# Raymond Viviano
# rayviviano@gmail.com
# February 12th, 2020

# TODO: Vary models by small, medium, and large residual variance

suppressPackageStartupMessages(library(lavaan))
suppressPackageStartupMessages(library(mnormt))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(RColorBrewer))

options(warn=-1)

################### CHANGE MODEL AND SCRIPT PARAMETERS HERE ####################

intercept_mean_control <- 0 # Doesn't currently do anything.
intercept_mean_mci     <- 0

slope_mean_control <- 0
max_slope_mean_mci <- 1

intercept_variance <- 1
max_slope_variance <- 1

intercept_slope_covariance <- .2

residual_variances <- .5

intercept_age_coef_unstd    <-  .2
intercept_edu_coef_unstd    <- -.2
intercept_sex_coef_unstd    <-  .1
intercept_accult_coef_unstd <-  .1

slope_age_coef_unstd    <-  .2
slope_edu_coef_unstd    <- -.2
slope_sex_coef_unstd    <-  .1
slope_accult_coef_unstd <-  .1

nsimulations = 5000

##################### END USE DEFINED PARAMETERS SECTION  ######################

# Set Base Model, i.e., componenets that do not vary between models
growth_model_base <- "i =~ 1*y1 + 1*y2 + 1*y3\ns =~ 0*y1 + 1*y2 + 2*y3\n"
growth_model_base <- paste0(growth_model_base, "i ~~ ", intercept_variance, "*i\n")

# Age, edu, sex, and acculturation path coefficients
age_edu_terms <- paste0("i ~ ", intercept_age_coef_unstd, "*age\n")
age_edu_terms <- paste0(age_edu_terms, "s ~ ", slope_age_coef_unstd, "*age\n")
age_edu_terms <- paste0(age_edu_terms, "i ~ ", intercept_edu_coef_unstd, "*edu\n")
age_edu_terms <- paste0(age_edu_terms, "s ~ ", slope_edu_coef_unstd, "*edu\n")
age_edu_terms <- paste0(age_edu_terms, "i ~ ", intercept_sex_coef_unstd, "*sex\n")
age_edu_terms <- paste0(age_edu_terms, "s ~ ", slope_sex_coef_unstd, "*sex\n")
age_edu_terms <- paste0(age_edu_terms, "i ~ ", intercept_accult_coef_unstd, "*acculturation\n")
age_edu_terms <- paste0(age_edu_terms, "s ~ ", slope_accult_coef_unstd, "*acculturation\n")

# Set slope variance/covariance and residual variance for Ys
for(i in c(max_slope_variance/2, max_slope_variance)){
    # Vary slope variance between .1 and .5
    eval(parse(text=paste0('lgm_svar', i, ' <-paste0(growth_model_base, ',
                           '"s ~~ ', i, '*s +', intercept_slope_covariance,
                           '*i\n")')))

    # Set residual variances to .5
    eval(parse(text=paste0('lgm_svar', i, ' <-paste0(lgm_svar', i,
                           ', "\ny1 ~~ ', residual_variances,'*y1\ny2 ~~ ',
                           residual_variances,'*y2\n",', '"y3 ~~ ',
                           residual_variances,'*y3\n")')))

    # Add age and edu covariates
    eval(parse(text=paste0('lgm_svar', i, ' <- paste0(lgm_svar', i,
                           ', "\n", age_edu_terms)')))
}

# Set mean slope for MCI group
for(i in c(max_slope_variance/2, max_slope_variance)){
    for(j in seq(0, max_slope_mean_mci, by=max_slope_mean_mci/10)){
        # Add path coefficients between mci and slope (vary slope means
        # for the mci group across simulations)
        eval(parse(text=paste0('lgm_svar', i, '_mci_slp_mean', j,
                               ' <- paste0(lgm_svar', i,
                               ', "\ni~0*1\ns~', j, '*1\n")')))
    }
}

# Test Model - Correctly Specified
m1 <- "
i =~ 1*y1 + 1*y2 + 1*y3
s =~ 0*y1 + 1*y2 + 2*y3
i ~~ i + s
s ~~ s
i ~ mci + age + edu + sex + acculturation
s ~ mci + age + edu + sex + acculturation
"

# Test Model - Misspecification 1 - Only MCI
m2 <- "
i =~ 1*y1 + 1*y2 + 1*y3
s =~ 0*y1 + 1*y2 + 2*y3
i ~~ i + s
s ~~ s
i ~ mci
s ~ mci
"

# Test Model - Misspecification 2 - Add test site and language
m3 <- "
i =~ 1*y1 + 1*y2 + 1*y3
s =~ 0*y1 + 1*y2 + 2*y3
i ~~ i + s
s ~~ s
i ~ mci + age + edu + sex + site + acculturation + language
s ~ mci + age + edu + sex + site + acculturation + language
"

# Create dataframes to store simulation results
sim_df_m1 <- data.frame(matrix(ncol = 5, nrow = 0))
sim_df_m2 <- data.frame(matrix(ncol = 5, nrow = 0))
sim_df_m3 <- data.frame(matrix(ncol = 5, nrow = 0))
colnames(sim_df_m1) <- c('mciSlopeMean', 's_mci', 'svar', 'r05', 'r05p05')
colnames(sim_df_m2) <- c('mciSlopeMean', 's_mci', 'svar', 'r05', 'r05p05')
colnames(sim_df_m3) <- c('mciSlopeMean', 's_mci', 'svar', 'r05', 'r05p05')

# Run the simulations
for(i in c(max_slope_variance/2, max_slope_variance)){
    for(j in seq(0, max_slope_mean_mci, by=max_slope_mean_mci/10)){
        cat(i,j,'\n')
        eval(parse(text=paste0('lgm_con <- lgm_svar', i, '_mci_slp_mean', j*0.0)))
        eval(parse(text=paste0('lgm_mci <- lgm_svar', i, '_mci_slp_mean', j)))

        rmsea05_count  <- 0
        r05_path05 <- 0
        mci_slope_path <- 0

        for(k in 1:nsimulations){
            # Simulate 100 MCI and 100 Control Observations
            df_con <- lavaan::simulateData(model=lgm_con, model.type="growth",
                                           sample.nobs=100)

            df_mci <- lavaan::simulateData(model=lgm_mci, model.type="growth",
                                           sample.nobs=100)

            # Add MCI columns to both data frames
            df_con[,"mci"] <- 0
            df_mci[,"mci"] <- 1

            # Combine Control and MCI datasets
            df <- rbind(df_con, df_mci)

            # Test the correctly specified and misspecified models
            m1_fit <- growth(m1, data=df, missing='fiml')
            # m2_fit <- growth(m2, data=df, missing='fiml')
            # m3_fit <- growth(m3, data=df, missing='fiml')

            # Get RMSEA, s~mci estimate, and s~mci pvalue - Model 1
            smci_est <- as.double(parameterEstimates(m1_fit, standardized = FALSE)[15,'est'])
            pval <- as.double(parameterEstimates(m1_fit, standardized = FALSE)[15,'pvalue'])
            rmsea <- as.double(fitMeasures(m1_fit, c('rmsea'))[1])

            mci_slope_path <- mci_slope_path + smci_est

            if(rmsea <= .05){
                rmsea05_count <- rmsea05_count + 1
                if(pval <= .05){
                    r05_path05 <- r05_path05 + 1
                }
            }
        }

        rmsea05_prop <- rmsea05_count/nsimulations
        r05_path05_prop <- r05_path05/nsimulations
        mci_slope_path_avg <- mci_slope_path/nsimulations

        temp_df <- data.frame(j, mci_slope_path_avg, i, rmsea05_prop, r05_path05_prop)
        colnames(temp_df) <- c('mciSlopeMean', 's_mci', 'svar', 'r05', 'r05p05')

        sim_df_m1 <- rbind(sim_df_m1, temp_df)

    }
}

# Sort data
sim_df_m1 <- sim_df_m1[order(sim_df_m1$mciSlopeMean, sim_df_m1$s_mci),]

print(sim_df_m1)

save(sim_df_m1, file="./sim_df_m1.Rda")


rm(list=ls())

library(dplyr)
library(tidyr)
library(ggplot2)
library(ggpubr)

# set dataset

#dataset <- "Streicher"
#dataset <- "Singhal"
#dataset <- "Reeder"
dataset <- "Burbrink"
#dataset <- "Singhal"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data

## Read in data tables, drop any rows that have all NAs
mLBF <- read.table(paste("/Users/ChatNoir/Projects/Squam/scripts_ch1/Graphing/DataFiles/",dataset,"MargLikeSummaryNA64mil.txt",sep=""),
                   header=TRUE) %>% drop_na()
mLGL <- read.table(paste("/Users/ChatNoir/Projects/Squam/scripts_ch1/Graphing/DataFiles/",dataset,"MaxLikeSummaryNA.txt",sep=""),
                     header=TRUE) %>% drop_na()

# Check number of NA
sum(is.na(mLGL$Sclero))

## Number of overlapping
length(intersect(mLBF$Locus,mLGL$Locus))

# Remove any other from the larger dataset - look in environ in R window to see who is bigger
mLBF <- mLBF[mLBF$Locus %in% intersect(mLBF$Locus,mLGL$Locus),]
mLGL <- mLGL[mLGL$Locus %in% intersect(mLBF$Locus,mLGL$Locus),]

# Bayes factors

# K = lnBF(m1,m2) = ln(m1) - ln(m2)
# 2ln(BF) = 2ln(e^K) = 2*K = 2(ln(m1) - ln(m2))

mL <- mLBF

## Calculate BF and put in new columns
mL$TvS <- 2*(mL$ToxPoly-mL$Sclero)
mL$AIvSA <- 2*(mL$ToxAngIg-mL$ToxSnAng)
mL$AIvSI <- 2*(mL$ToxAngIg-mL$ToxSnIg)
mL$SAvSI <- 2*(mL$ToxSnAng-mL$ToxSnIg)

# check NA
sum(is.na(mL))

# Replace NA with zeros

mL[is.na(mL)] <- 0
sum(is.na(mL))

## Switch back into mLBF and clear mL variable to use with dGLS

mLBF <- mL

rm(mL,all,n1,d1,x1,n2,d2,x2,n3,d3,x3)

# Different in gene log likelihood

# dGLS = LH1 - LH2

mL <- mLGL

## Calculate dGLS and put in new columns
mL$TvS <- (mL$ToxPoly-mL$Sclero)
mL$AIvSA <- (mL$ToxAngIg-mL$ToxSnAng)
mL$AIvSI <- (mL$ToxAngIg-mL$ToxSnIg)
mL$SAvSI <- (mL$ToxSnAng-mL$ToxSnIg)
## Averages
mL$AIvAvg <- (mL$ToxAngIg-((mL$ToxSnIg+mL$ToxSnAng)/2))
mL$SAvAvg <- (mL$ToxSnAng-((mL$ToxAngIg+mL$ToxSnIg)/2))
mL$SIvAvg <- (mL$ToxSnIg-((mL$ToxAngIg+mL$ToxSnAng)/2))

# check NA
sum(is.na(mL))

# Replace NA with zeros

mL[is.na(mL)] <- 0
sum(is.na(mL))

## Switch back into mLBF and clear mL variable to use with dGLS

mLGL <- mL

rm(mL)

# If you want to save..

save(mLGL, mLBF, file=paste("Calcs_",dataset,".RData",sep=""))
#save(mLBF, file=paste("Calcs_",dataset,"_BFonly.RData",sep=""))


#' Method of RCTtoolbox: \code{ttest()}
#'
#' When you create R6 object "RCTtoolbox"
#' via \code{\link{create_RCTtoolbox}}
#' and run its method \code{ttest()},
#' the method internally implements a function
#' that performs two-sided t-test or permutation test.
#' The method \code{ttest()} provides some arguments.
#' See the section "Arguments."
#'
#' @param ctrl character. New control arm.
#' If NULL (default),
#' the first element of \code{treat_levels} is control arm.
#' @param subset subset condition.
#' If NULL (default),
#' full observations of \code{data} is used to implement t-test.
#' @param weights weight variable.
#' If NULL (default),
#' unbiased unweighted average and std.err. is calculated.
#' @param bootse integer.
#' Number of bootstrap samples to calculate std.err. of mean.
#' If 0 (default),
#' theoretical std.err. of mean is calculated.
#' @param bootp integer.
#' If 0 (default), welch two-sided t-test is implemented.
#' If 1 or more, the permutation test is implemented
#' (the number of permutations that randomly reallocate assignment
#' to keep the sample size collected from each group).
#' @param seed integer.
#' Seed value passed to the argument of \code{\link{set.seed}}.
#'
#' @return R6 object with "RCTtoolbox.ttest" class.
#' The returned object has following field and methods:
#' \describe{
#'   \item{\code{result}}{Field.
#'     Data frame including estimated result.
#'     See the section "Result Field."}
#'   \item{\code{print()}}{Method.
#'     Print information about the returned object.
#'     Run \code{$print()}.}
#'   \item{\code{plot()}}{Method.
#'     Visualization of result.
#'     Run \code{$plot()}.}
#'   \item{\code{summary()}}{Method.
#'     Print result in console.
#'     Run \code{$summary()}.}
#' }
#'
#' @section Result Field:
#'
#' The R6 object with "RCTtoolbox.ttest" class has \code{result} field.
#' This field has a data frame with 13 variables:
#' \describe{
#'   \item{mean1}{Outcome average of each experimental arm}
#'   \item{se1}{Std.err. of outcome average of each experimental arm}
#'   \item{n1}{Number of observations of each experimental arm}
#'   \item{mean0}{Outcome average of control arm}
#'   \item{se0}{Std.err. of outcome average of control arm}
#'   \item{n0}{Number of observations of control arm}
#'   \item{diff}{Difference between "mean1" - "mean0"}
#'   \item{t}{t-statistics when \code{bootp = 0L} (Two-sided t-test)}
#'   \item{df}{degree of freedom of t-distribution
#'     when \code{bootp = 0L} (Two-sided t-test)}
#'   \item{pval}{p-value of difference mean test.
#'     Pr(>|t|) when \code{bootp = 0L} (Two-sided t-test).
#'     Pr(>|diff|) when \code{bootp > 0L} (Permutation test).}
#'   \item{method}{Character. Method of difference mean test.}
#'   \item{arms}{Factor. Experimental arms.
#'     The first level is control arm.}
#'   \item{outcome}{Character. Outcome variable.}
#' }
#'
#' @section Developer Note:
#' A method \code{ttest()} provided by R6 object RCTtoolbox
#' implements \code{RCTtoolbox.ttest$new()}
#' which generates R6 object with "RCTtoolbox.ttest" class.
#' Initialization of R6 object "RCTtoolbox.ttest" run
#' \code{ttest_multi_mod_arm(private$formula.yd, self$data, private$dvec.levels,
#' private$dvec.labels, ...)}
#' where \code{...} accepts arguments explained in the section "Arguments."
#' The first four arguments passed to \code{ttest_multi_mod_arm()} are
#' \describe{
#'   \item{\code{baseline}}{list of two-sided formula \code{outcome ~ treat}.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{formula.yd} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{data}}{data.frame/tibble object that you want to use.
#'     The method \code{ttest()} automatically
#'     passes a public field \code{data} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{treat_levels}}{character vector. Level of experimental arms.
#'     The first element is control arm.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{dvec.levels} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{treat_labels}}{character vector. Label of experimental arms
#'     corresponding to \code{treat_levels}.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{dvec.labels} of R6 object "RCTtoolbox"
#'     to this argument.}
#' }
#'
#' @examples
#' \dontrun{
#'   data(RubellaNudge)
#'   rct <- create_RCTtoolbox(
#'     atest + avacc ~ treat,
#'     data = RubellaNudge,
#'     treat_levels = LETTERS[1:7]
#'   )
#'
#'   # two-sided t-test
#'   rct$ttest()
#'   # permutation test with control arm "C"
#'   rct$ttest(bootp = 50, ctrl = "C")
#' }
#'
#' @name ttest
#'
NULL


#load data, fit a bunch of hierarchical models
rm(list=ls())
library(nlme)
library(MuMIn)
library(data.table)
library(boot)

#load data
d <- data.table(readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/tal_all_prior_data.rds'))

start.position <- 20 #column number where relative abundances start

#function to transform [0,1] to (0,1) a la Cribari-Neto & Zeileis 2010
crib.fun <- function(x){(x * (length(x) - 1) + 0.5) / length(x)}
d[,start.position:ncol(d)] <- lapply(d[,start.position:ncol(d)],crib.fun)
#then logit transform.
d[,start.position:ncol(d)] <- lapply(d[,start.position:ncol(d)],logit)

#fit models of relative abundance
model.out.list <- list()
#specify columns to model- all relative abundances
to_model <- (d[,start.position:ncol(d)])
#specify fixed and random effects data.
fixed.effects <- d[,.(doy,MAT,MAP,MAT_CV,MAP_CV,pH,cn,Horizon,latitude)]
random.effects <- d[,.(Site,Plot)]

#Run a model loop.
for(i in 1:ncol(to_model)){
  y <- to_model[,to_model[,..i]] #grab dependent variable
  data <- cbind(y,fixed.effects,random.effects) #build dataframe for analysis
  #specify model formula
  formula <- as.formula(paste(paste(colnames(y)),'~', paste(colnames(fixed.effects), collapse="+")))
  #run model
  mod <- lme(formula, random = ~1|Site/Plot, data = data, na.action = na.omit)
  sum <- data.frame(summary(mod)$tTable)
  sum <- sum[-1,]
  #remove non-significant predictors.
  new.fixed <- rownames(sum[sum$p.value < 0.05,])
  #fix categorical variable names
  new.fixed[new.fixed == 'HorizonOH'] <- 'Horizon'
  #specify a new formula of fixed effects, if any predictors are significant
  if(length(new.fixed) > 0){
    formula <- as.formula(paste(paste(colnames(y)),'~', paste(new.fixed, collapse="+")))
    mod <- lme(formula, random = ~1|Site/Plot, data = data, na.action = na.omit)
  }
  #get model summary, R2 values, and a complete dataset with fitted values.
  out.data <- data[,c(y,data[,..new.fixed],random.effects)]
  out.data <- out.data[complete.cases(out.data),]
  out.data$fitted <- fitted(mod)
  r.sq <- r.squaredGLMM(mod)
  report.list <- list(mod,r.sq,out.data)
  names(report.list) <- c('model','r.sq','data')
  model.out.list[[i]] <- report.list
  names(model.out.list)[[i]] <- colnames(y)
}

#sort by r2 values because you are awful.
z <- data.frame(names(model.out.list))
out.r2m <- list()
out.r2c <- list()
out.preds <- list()
for(k in 1:length(model.out.list)){
  r2m <- model.out.list[[k]]$r.sq[1]
  r2c <- model.out.list[[k]]$r.sq[2]
  preds <- rownames(summary(model.out.list[[k]]$model)$tTable)
  out.r2c[[k]] <- r2c
  out.r2m[[k]] <- r2m
  out.preds[[k]] <- preds
}
z$r2m <- do.call('rbind',out.r2m)
z$r2c <- do.call('rbind',out.r2c)
z[order(-z$r2m),]

d <- model.out.list$hydrophobic$data
plot(hydrophobic ~ fitted, data = d, cex = 0.5, pch = 16)

testing_development/fishing hierarchical models of talbot fungi.r