row <- round(SamRate*MPeriod)
col <- round(length(mainFile)/row)
redidu <- row-SamRate*MPeriod
redidu.accum <-0
blank.id <- round(phase.shift*SamRate+1)
cont.num <-0
mat <- matrix(1,row,col)

try(for (u in round(phase.shift*SamRate+1):(length(mainFile)+round(phase.shift*SamRate)) ){
        if (u%%row==0){
                redidu.accum <-redidu.accum + redidu
        }
        if ( redidu.accum > 1  ){
                blank.id <- blank.id +1
                mat[row*ceiling(blank.id/row)-(blank.id-1),ceiling( (u-round(phase.shift*SamRate))/row )] <- mainFile[round(u-phase.shift*SamRate)]
                blank.id <- blank.id +1
                mat[row*ceiling(blank.id/row)-(blank.id-1),ceiling( (u-round(phase.shift*SamRate))/row )] <- mainFile[round(u-phase.shift*SamRate)]
                redidu.accum <- redidu.accum -1
        } else {
                blank.id <- blank.id +1
                mat[row*ceiling(blank.id/row)-(blank.id-1),ceiling( (u-round(phase.shift*SamRate))/row )] <- mainFile[round(u-phase.shift*SamRate)]
        }
})

###Depiction of 2D chromatogram
red_blue <- colorRampPalette(rev(c("#7F0000", "red", "#FF7F00", "yellow", "#7FFF7F", "cyan", "#007FFF", "blue", "#00007F"))) #https://oku.edu.mie-u.ac.jp/~okumura/stat/colors.html
red_blue.alpha <- colorRampPalette(rev(c("#7F000025", "#FF000025", "#FF7F0025", "#FFFF0025", "#7FFF7F25", "#00FFFF25", "#007FFF25", "#0000FF25", "#00007F25")),alpha =T )
zz1 <- t(apply(as.matrix(mat[1:nrow(mat),1:ncol(mat)]),2,rev))
xx1 <- (1:nrow(zz1))/col*RTruntime+RTini
yy1 <-(((1:ncol(zz1))/row*MPeriod))
max.zz<-max(zz1)

cat("xx1,yy1,zz1 are calculated.")
writeLines(sep="\n","")


#gauging predictor importance for spatial forecast of 16S cosmopolitcan genera.
#clear environment, source paths, packages and functions.
rm(list=ls())
source('paths.r')
source('NEFI_functions/tic_toc.r')
#set output path.----
output.path <- NEON_var_importance_data_ddirch_16S.path

#load forecast.----
fcast <- readRDS(paste0(scc_gen_16S_dir,"/NEON_forecasts/delgado-to-NEON_cps_forecast_ddirch.rds"))
mod <- readRDS(paste0(scc_gen_16S_dir,"/JAGS_output/prior_delgado/dir_delgado_8-30-19.rds"))
# mcmc <- mod$all.preds$jags_model$mcmc
# mcmc <- do.call(rbind,mcmc)
# preds <- d$site.preds

#get predictor mean and sd.----
#get predictor mean and sd.----
#get standard deviation of predictors based on the scale at which they are actually observed.
core.preds <- c('pC','cn','pH')
plot.preds <- c('relEM')
site.preds <- c('map','mat','NPP','ndep.glob') #forest and conifer not included, they are 0-1.
#Forest conifer sensitivity will be based on 0-mean, and changing the binary level.
bin.preds <- c('forest')
pred <- list()
for(k in 1:length(fcast)){
  d <- fcast[[k]]

core_mu <- list()
core_sd <- list()
plot_mu <- list()
plot_sd <- list()
site_mu <- list()
site_sd <- list()
for(i in 1:length(core.preds)){
  core_mu[[i]] <- mean(d$core.preds[,core.preds[i]])
  core_sd[[i]] <-   sd(d$core.preds[,core.preds[i]])
}
for(i in 1:length(plot.preds)){
  plot_mu[[i]] <- mean(d$plot.preds[,plot.preds[i]])
  plot_sd[[i]] <-   sd(d$plot.preds[,plot.preds[i]])
}
for(i in 1:length(site.preds)){
  site_mu[[i]] <- mean(d$site.preds[,site.preds[i]])
  site_sd[[i]] <-   sd(d$site.preds[,site.preds[i]])
}
grand_mu <- c(unlist(core_mu),unlist(plot_mu),unlist(site_mu),rep(0,length(bin.preds)))
grand_sd <- c(unlist(core_sd),unlist(plot_sd),unlist(site_sd),rep(1,length(bin.preds)))
to_name <- c(core.preds,plot.preds,site.preds,bin.preds)
to_sim <- data.frame(to_name,grand_mu,grand_sd)
to_sim$delta <- to_sim$grand_mu + to_sim$grand_sd
#put in correct order.
to_sim <- to_sim[order(match(to_sim$to_name, mod$Phylum$species_parameter_output$other$predictor)),]

#deal with fact that we need to log transform MAP.
#logit transform EM and multiply by 100.
#to_sim[to_sim$to_name ==   'map',2:ncol(to_sim)] <- log(to_sim[to_sim$to_name == 'map',2:ncol(to_sim)])
# to_sim[to_sim$to_name == 'relEM',2:ncol(to_sim)] <- boot::inv.logit(as.matrix(to_sim[to_sim$to_name == 'relEM',2:ncol(to_sim)]))*100
to_sim[to_sim$to_name == 'relEM',2:ncol(to_sim)] <- boot::inv.logit(as.matrix(to_sim[to_sim$to_name == 'relEM',2:ncol(to_sim)]))

#return output to list.
pred[[k]] <- to_sim
}
names(pred) <- names(fcast)

#Go ahead and get 1k draws of covariate sensitivity.----
super.out <- list()
n.sim <- 1000
for(j in 1:length(mod)){
  tic()
  #group.mod <- mod[[j]]$all.preds
  n.spp <- length(mod[[j]]$species_parameter_output)
  mcmc <- mod[[j]]$jags_model$mcmc
  mcmc <- do.call(rbind,mcmc)
  preds <- fcast[[j]]$site.preds
  #to_sim <- pred[[j]]

sim.out <- list()
for(i in 1:n.sim){
  #sample parameters, organize into matrix.
  pars <- mcmc[sample(nrow(mcmc),1),]
  pars <- pars[grep("^x\\.m\\[",names(pars))]
  pars <- matrix(pars, ncol = n.spp)

  #get reference group abundances with all preds at means.
  ref <- c(1,to_sim$grand_mu) %*% pars
  ref <- exp(ref)      #exponent- log-link in original model.
  ref <- ref/sum(ref)

  #recalculate abundances perturbing co-variates one at a time.
  out.k <- list()
  for(k in 1:nrow(to_sim)){
    #grab predictors
    pred.k <- to_sim$grand_mu
    #increase the k-th predictor by 1-SD
    pred.k[k] <- to_sim[k,]$delta
    #combine preds and parameters.
    out <- c(1,pred.k) %*% pars
    out <- exp(out)             #exponent: log-link in original model.
    out <- out/rowSums(out)
    #Get change in groups relative to reference.
    out.k[[k]] <- abs(out - ref) / ref
  }
  sim.out[[i]] <- do.call(rbind,out.k)
}

#Get mean change in dependent variable and 95% interval.----
out_mean <- apply(simplify2array(sim.out), 1:2, mean)
ci_0.25 <- apply(simplify2array(sim.out), 1:2, quantile, probs = c(0.25))
ci_0.75 <- apply(simplify2array(sim.out), 1:2, quantile, probs = c(0.75))
out_sd   <- apply(simplify2array(sim.out), 1:2, sd)

#List output and save.----
output.list <- list(out_mean,ci_0.25,ci_0.75,out_sd)
names(output.list) <- c('mean','ci_0.025','ci_0.975','sd')
for(i in 1:length(output.list)){
  rownames(output.list[[i]]) <- to_sim$to_name
  colnames(output.list[[i]]) <- names(mod[[j]]$species_parameter_output)
}

super.out[[j]] <- output.list
toc()
}
names(super.out) <- names(mod)

#Actual save line.
saveRDS(super.out, output.path)
cat('cool.')


context("geojson2wkt")

test_that("convert point works", {
  point <- list('type' = 'Point', 'coordinates' = c(116.4, 45.2))
  a <- geojson2wkt(point)
  expect_is(a, "character")
  expect_match(a, "POINT")
  expect_equal(a, "POINT (116.4000000000000057  45.2000000000000028)")
})

test_that("convert multipoint works", {
  mp <- list(type = 'MultiPoint', coordinates=matrix(c(100, 101, 3.14, 3.101, 2.1, 2.18), ncol = 2))
  b <- geojson2wkt(mp)
  expect_is(b, "character")
  expect_match(b, "POINT")
  expect_match(b, "MULTIPOINT")
  expect_equal(b, "MULTIPOINT ((100.0000000000000000 3.1010000000000000), (101.0000000000000000 2.1000000000000001), (3.1400000000000001 2.1800000000000002))")
})

test_that("convert linestring works", {
  st <- list(type = 'LineString',
              coordinates = matrix(c(0.0, 2.0, 4.0, 5.0,
                                     0.0, 1.0, 2.0, 4.0), ncol = 2))
  cc <- geojson2wkt(st)
  expect_is(cc, "character")
  expect_match(cc, "LINESTRING")
  expect_equal(geojson2wkt(st, 0), "LINESTRING (0 0, 2 1, 4 2, 5 4)")
  expect_equal(length(strsplit(geojson2wkt(st, 1), "\\.")[[1]]), 9)
})

test_that("convert multilinestring works", {
  multist <- list(type = 'MultiLineString',
        coordinates = list(
              matrix(c(0, -2, -4, -1, -3, -5), ncol = 2),
              matrix(c(1.66, 10.9999, 10.9, 0, -31.5, 3.0, 1.1, 0), ncol = 2)
          ))
  d <- geojson2wkt(multist)
  expect_is(d, "character")
  expect_match(d, "LINESTRING")
  expect_match(d, "MULTILINESTRING")
  expect_equal(geojson2wkt(multist, 0), "MULTILINESTRING ((0 -1, -2 -3, -4 -5), (1.6600 -31.5000, 10.9999 3.0000, 10.9000 1.1000, 0.0000 0.0000))")
})

test_that("convert polygon works", {
  poly <- list(type = 'Polygon',
        coordinates = list(
               matrix(c(100.001, 101.1, 101.001, 100.001, 0.001, 0.001, 1.001, 0.001),
                 ncol = 2),
             matrix(c(100.201, 100.801, 100.801, 100.201, 0.201, 0.201, 0.801, 0.201),
               ncol = 2)
          )
  )
  e <- geojson2wkt(poly)
  expect_is(e, "character")
  expect_match(e, "POLYGON")
  expect_equal(geojson2wkt(poly, 0), "POLYGON ((100.001 0.001, 101.100 0.001, 101.001 1.001, 100.001 0.001), (100.201 0.201, 100.801 0.201, 100.801 0.801, 100.201 0.201))")
})

test_that("convert multipolygon works", {
  mpoly <- list(MultiPolygon = list(
    list(
      matrix(c(40, 130, 155, 40, 20, 34, 34, 20), ncol = 2),
      matrix(c(30, 40, 54, 30, 0.1, 42, 62, 0.1), ncol = 2)
    ),
    list(
      matrix(c(9, 49, 79, 9, 11, 35, 15, 11), ncol = 2),
      matrix(c(1, 33, 59, 1, 5, 16, 36, 5), ncol = 2)
    )
  ))
  f <- geojson2wkt(mpoly, fmt=0)
  expect_is(f, "character")
  expect_match(f, "POLYGON")
  expect_match(f, "MULTIPOLYGON")
  expect_equal(f, "MULTIPOLYGON (((40 20, 130 34, 155 34, 40 20), (30.0 0.1, 40.0 42.0, 54.0 62.0, 30.0 0.1)), ((9 11, 49 35, 79 15, 9 11), (1 5, 33 16, 59 36, 1 5)))")
})

test_that("convert geometrycollection works", {
  gmcoll <- list(
    type = 'GeometryCollection',
    geometries = list(
      list(type = 'Point', coordinates = c(0.0, 1.0)),
      list(type = 'LineString', coordinates = matrix(c(0.0, 2.0, 4.0, 5.0,
                              0.0, 1.0, 2.0, 4.0),
                              ncol = 2)),
      list(type = 'Polygon', coordinates = list(
        matrix(c(100.001, 101.1, 101.001, 100.001, 0.001, 0.001, 1.001, 0.001),
          ncol = 2),
        matrix(c(100.201, 100.801, 100.801, 100.201, 0.201, 0.201, 0.801, 0.201),
          ncol = 2)
      ))
    )
  )
  g <- geojson2wkt(gmcoll, fmt = 0)
  expect_is(g, "character")
  expect_match(g, "GEOMETRYCOLLECTION")
  expect_equal(g, "GEOMETRYCOLLECTION (POINT (0 1), LINESTRING (0 0, 2 1, 4 2, 5 4), POLYGON ((100.001 0.001, 101.100 0.001, 101.001 1.001, 100.001 0.001), (100.201 0.201, 100.801 0.201, 100.801 0.801, 100.201 0.201)))")
})

## fails well
test_that("point - fails well", {
  mp <- list(type = 'Point', coordinates = list(100.0, 3.101))
  expect_error(
    geojson2wkt(mp),
    "expecting a vector in 'coordinates', got a list")

  mp <- list(Point = list(100.0, 3.101))
  expect_error(
    geojson2wkt(mp),
    "expecting a vector in 'coordinates', got a list")
})

# tests for old format to make sure we're failing well on those
test_that("multipoint - fails well with bad input", {
  mp <- list(type = 'MultiPoint', coordinates=list(c(100.0, 3.101), c(101.0, 2.1), c(3.14, 2.18)))
  expect_error(geojson2wkt(mp), "expecting a matrix in 'coordinates', got a list")
})

test_that("linestring - fails well with bad input", {
  st <- list(type = 'LineString',
              coordinates = list(c(0.0, 0.0, 10.0), c(2.0, 1.0, 20.0),
                                c(4.0, 2.0, 30.0), c(5.0, 4.0, 40.0)))
  expect_error(geojson2wkt(st),
               "expecting a matrix")
})

test_that("multilinestring - fails well with bad input", {
  multist <- list(type = 'MultiLineString',
        coordinates = list(
          list(c(0.0, -1.0), c(-2.0, -3.0), c(-4.0, -5.0)),
          list(c(1.66, -31023.5), c(10000.9999, 3.0), c(100.9, 1.1), c(0.0, 0.0))
        ))
  expect_error(geojson2wkt(multist), "expecting matrices for all 'coordinates' elements")
})

test_that("polygon - fails well with bad input", {
  poly <- list(type = 'Polygon',
        coordinates=list(
          list(c(100.001, 0.001), c(101.12345, 0.001), c(101.001, 1.001), c(100.001, 0.001)),
          list(c(100.201, 0.201), c(100.801, 0.201), c(100.801, 0.801), c(100.201, 0.201))
  ))
  expect_error(geojson2wkt(poly), "expecting matrices for all 'coordinates' elements")
})

test_that("multipolygon - fails well with bad input", {
  mpoly2 <- list(type = "MultiPolygon",
               coordinates = list(list(list(c(30, 20), c(45, 40), c(10, 40), c(30, 20))),
                              list(list(c(15, 5), c(40, 10), c(10, 20), c(5 ,10), c(15, 5))))
  )
  expect_error(geojson2wkt(mpoly2), "")
})

test_that("geometrycollection - fails well with bad input", {
  gmcoll <- list(type = 'GeometryCollection',
                 geometries = list(
                   list(type = "Point", coordinates = list(0.0, 1.0)),
                   list(type = 'LineString', coordinates = list(c(-100.0, 0.0), c(-101.0, -1.0))),
                   list(type = 'MultiPoint',
                        'coordinates' = list(c(100.0, 3.101), c(101.0, 2.1), c(3.14, 2.18))
                   )
                 )
  )
  expect_error(geojson2wkt(gmcoll), "")
})


#---SEGMENT-SCAN---

#local h2 estimation
#full cis region v.s. segment

library('RiskPortfolios')
library('MASS')
library('Matrix')
library('pdist')
library('corpcor')
library('optparse')

option_list = list(
  make_option("--eqtl_path", action="store", default=NA, type='character',
              help="Path to dataframe of summary statistics [required]"),
  make_option("--genotype_path", action="store", default=NA, type='character',
              help="Path to genotype file (dosage format) [required]"),
  make_option("--res_path", action="store", default=NA, type='character',
              help="Path for the result [required]"),

  make_option("--start_pos", action="store", default=NA, type='integer',
              help="segment position"),
  make_option("--stop_pos", action="store", default=NA, type='integer',
              help="segment position"),

  make_option("--n_cases", action="store", default=NA, type='integer',
              help="n cases (gwas)"),
  make_option("--n_controls", action="store", default=NA, type='integer',
              help="n controls (gwas)")

)

opt = parse_args(OptionParser(option_list=option_list))
eqtl_path = opt$eqtl_path
genotype_path = opt$genotype_path
res_path = opt$res_path
start_pos = opt$start_pos
stop_pos = opt$stop_pos
n_cases = opt$n_cases
n_controls = opt$n_controls

#load eqtl and alpha
eqtl = read.table(eqtl_path, header = T,stringsAsFactors = F)

#load genotype in dosage
dosage = read.table(genotype_path, header = T,stringsAsFactors = F)

#in segment or not
eqtl$in_segment<-ifelse((eqtl$pos>start_pos & eqtl$pos<stop_pos),1,0)

#effective sample size
ascertained_prevalence=n_cases/(n_cases+n_controls)
N_effective = 4*ascertained_prevalence*(1-ascertained_prevalence)*(n_cases+n_controls)

#output df
res = data.frame()

#---estimate h2 for the full cis region of the gene---

full<-eqtl

#estimate snp-snp var-cov matrix (projected)
full_c <- covEstimation(as.matrix(dosage), control = list(type = 'cor'))

#Moore-Penrose pseudoinverse
inverse_full_c<-ginv(full_c)

#q=rank(C)  the maximum number of linearly independent vectors in rows or columns
q=rankMatrix(inverse_full_c)
q=as.numeric(q)

#pseudo gwas beta
alpha = full[1,'alpha']
alpha_se = full[1,'alpha_se']
full$beta_gwas = alpha * full$beta_eqtl

#pseudo gwas se
full$se_gwas = ((alpha_se)^2 * (full$se_eqtl)^2 +
                  (alpha_se)^2 * (full$beta_eqtl)^2 +
                  (alpha)^2 * (full$se_eqtl)^2)^0.5

#n
res[1,'full_n_effective'] = n = N_effective
#p
res[1,'full_n_variants'] = p = nrow(full)
#h2
res[1,'full_h2_local'] = (t(full$beta_gwas) %*% inverse_full_c %*% full$beta_gwas - q/n) / (n-q) *n

#---estimate h2 for the segment (mediated by expression of the gene)---

segment<-full[full$in_segment==1,]

#estimate snp-snp var-cov matrix (projected)
segment_c<-full_c[which(full$in_segment==1),which(full$in_segment==1)]

#Moore-Penrose pseudoinverse
inverse_segment_c<-ginv(segment_c)

#q=rank(C)  the maximum number of linearly independent vectors in rows or columns
q=rankMatrix(inverse_segment_c)
q=as.numeric(q)

#pseudo gwas beta
segment$beta_gwas = alpha * segment$beta_eqtl

#pseudo gwas se
segment$se_gwas = ((alpha_se)^2 * (segment$se_eqtl)^2 +
                     (alpha_se)^2 * (segment$beta_eqtl)^2 +
                     (alpha)^2 * (segment$se_eqtl)^2)^0.5

#n
res[1,'segment_n_effective']=n=N_effective
#p
res[1,'segment_n_variants']=p=nrow(segment)
#h2
res[1,'segment_h2_local']=(t(segment$beta_gwas) %*% inverse_segment_c %*% segment$beta_gwas - q/n) / (n-q) *n

res$pi_c=res$segment_h2_local/res$full_h2_local

res$concentration_ratio=res$segment_h2_local*res$full_n_variants/res$segment_n_variants/res$full_h2_local

write.table(res,res_path,quote = F,sep='\t',row.names = F)


#!/usr/bin/env Rscript

options(stringsAsFactors=FALSE)

library(optparse)
library(maveLLR)

# Get external arguments passed by the command line.
# ==============================================================================

option_list <- list(
    # Full filepath to the benchmark CSV file.
    make_option(c("-b","--benchmark"),type="character",default=NULL,
                help="benchmark dataset filepath",metavar="character"),
    # Full filepath to the score CSV file.
    make_option(c("-s","--score"),type="character",default=NULL,
                help="score dataset filepath",metavar="character"),
    # Full filepath to the download (maveLLR-processed) CSV file.
    make_option(c("-d","--download"),type="character",default=NULL,
                help="download maveLLR dataset filepath",metavar="character")
);

opt_parser <- OptionParser(option_list=option_list)
opt <- parse_args(opt_parser)

benchmark_csv_filepath <- opt$benchmark
score_csv_filepath <- opt$score
download_csv_filepath <- opt$download

# ==============================================================================

# Begin MAVE data processing.
# ==============================================================================

# Load benchmark from file.
benchmark <- read.csv(benchmark_csv_filepath)
# Load MAVE dataset from file...
mave <- read.csv(score_csv_filepath,comment.char="#")
# ...and index by variant descriptor (HGVS).
rownames(mave) <- mave$hgvs_pro

# Extract MAVE scores for positive benchmark variants from benchmark...
posScores <- na.omit(mave[with(benchmark,hgvsp[referenceSet=="Positive"]),"score"])
# ...and the same for negative benchmark variants.
negScores <- na.omit(mave[with(benchmark,hgvsp[referenceSet=="Negative"]),"score"])

# Call the buildLLR.kernel function from maveLLR using the two benchmark score vectors.
llrObj <- buildLLR.kernel(posScores,negScores,bw=0.1,kernel="gaussian")

# Calculate the actual LLR values for the full MAVE dataset using the LLR function.
mave$llr <- llrObj$llr(mave$score)

# Calculate a 95% confidence interval for the LLR values.
mave$llrCIlower <- llrObj$llr(qnorm(0.025,mave$score,mave$se))
mave$llrCIupper <- llrObj$llr(qnorm(0.975,mave$score,mave$se))

# ==============================================================================

# Export results to file and return control to caller.
# ==============================================================================

write.csv(mave,download_csv_filepath,row.names=FALSE)
# Return success exit code to caller.
quit(status=0)

# ==============================================================================


#!/usr/bin/Rscript

library(rphast)

tree <- read.tree('mcc.nh')
load('regDNA.RData')

locMsa <- msa(regDNA, names(regDNA), alphabet='ACTGN')
treeChar <- write.tree(tree)

mod <- phyloFit(locMsa, tree=treeChar, subst.mod='UNREST', no.opt='branches', ninf.sites=1)
mod$tree <- treeChar

mod2 <- phyloFit(locMsa, init.mod=mod, subst.mod='UNREST', no.opt='branches', ninf.sites=1)

pdf('unrest-rate-estimates.pdf')
plot(mod2)
dev.off()


#' Weighted Co-Operation
#'
#' An optimized, efficient implemntation for computing weighted covariance,
#' correlation, and cosine similarity.  Similar to R's \code{cov.wt()}.
#'
#' @details
#' See \code{?coop-package} for implementation details.
#'
#' @param x
#' A matrix or data.frame.
#' @param wt
#' A vector of weights or scalar weight.
#' @param method
#' Either "unbiased" or "ml". Unlike R, case is ignored.
#'
#' @examples
#' x <- matrix(rnorm(10*3), 10, 3)
#' cov.wt(x)
#'
#' @author Drew Schmidt
#' @seealso \code{\link{cosine}}, \code{\link{pcor}}, and \code{\link{covar}}
#' @name weighted
#' @rdname weighted
NULL

## TODO export these
cosine_wt <- function(x, wt=NULL, method="unbiased") UseMethod("cosine_wt")

pcor_wt <- function(x, wt=NULL, method="unbiased") UseMethod("pcor_wt")

covar_wt <- function(x, wt=NULL, method="unbiased") UseMethod("covar_wt")

co_wt.data.frame <- function(x, wt=NULL, method="unbiased")
{
  covar_wt.matrix(as.matrix(x), wt=wt, method=method)
}

cosine_wt.data.frame <- co_wt.data.frame
pcor_wt.data.frame <- co_wt.data.frame
covar_wt.data.frame <- co_wt.data.frame

cosine_wt.matrix <- function(x, wt=NULL, method="unbiased")
{
  co_wt(x=x, wt=wt, method=method, type=CO_SIM)
}

pcor_wt.matrix <- function(x, wt=NULL, method="unbiased")
{
  co_wt(x=x, wt=wt, method=method, type=CO_ORR)
}

covar_wt.matrix <- function(x, wt=NULL, method="unbiased")
{
  co_wt(x=x, wt=wt, method=method, type=CO_VAR)
}

co_wt <- function(x, wt=NULL, method="unbiased", type)
{
  method <- match.arg(tolower(method), c("unbiased", "ml"))

  if (!is.double(x))
    storage.mode(x) <- "double"

  check_badvals(x)

  # FIXME
  # .Call(R_cov_wt, x, wt, type=type)
}


#' Political Independence Index
#'
#' Returns a numeric vector of PII scores for each vertex in network.
#'
#' @useDynLib pii
#' @importFrom Rcpp sourceCpp
#' @param g An igraph graph
#' @param pii.beta Should the vertex and edge names be added to the rows and columns of the matrix.
#' @param e.dist (optional) an edge.distance matrix, if calculated ahead of time.
#' @param t.table (optional) the triad table, if calculated ahead of time
#' @export
#' @examples
#' pii(g)

pii <- function(g, pii.beta = -0.8, e.dist = NULL, triadic = F, pii.delta = 0.1, max.degree = NULL, t.table = NULL) {
  if(!("igraph" %in% class(g))) {
    stop("The graph object must be an igraph object.")
  }
  if(!("valence" %in% names(edge.attributes(g)))) {
    warning("Valence attribute not found. Assuming all ties are positive.")
    E(g)$valence <- 1
  }
  if(!(is.numeric(E(g)$valence))) {
    stop("Valence attribute is not a numeric vector.")
  }
  if(length(E(g)) < 2) {
    warning("At least one component has fewer than two edges in the network.")
    x <- rep(NA, vcount(g))
    names(x) <- V(g)$name
    return(x)
  }
  if(pii.delta == 0){
    warning("Delta set at zero. Running non-triadic PII")
    triadic = F
  }

  # Also, if they don't want to calculate for the "whole-network" then we still want PII values for
  # each node, but just run pii for each component. If you are doing the whole network though, calculate
  # 'x' first and use the same 'x' value for each run.
  if((cl <- igraph::clusters(g))$no > 1) {

    maxdeg <- max(degree(g, mode='total'))
    graph.list <- list()
    for(i in 1:cl$no){
      graph.list[[i]] <- induced.subgraph(g, which(cl$membership == i))
    }
    x <- do.call('c',lapply(graph.list, function(g) {
      pii(g, pii.beta=pii.beta, triadic = triadic, pii.delta = pii.delta, max.degree = maxdeg)
      }))
    x <- x[V(g)$name]
    return(x)
  }
  if(is.null(e.dist)) {
    e.dist <- edge.distance(g)
  }

  e.dist <- matrix(as.integer(e.dist), nrow=nrow(e.dist)) # convert to an integer matrix
  max.distance <- max(e.dist)
  if(is.null(max.degree)){
    max.degree <- max(degree(g, mode='total'))
  }
  edgevalence <- E(g)$valence
  pii.x <- (log(2) - log(abs(pii.beta))) / log(max.degree)
  if(triadic) {
    triads <- cliques(g, min = 3, max= 3)
    triads <- do.call('rbind', lapply(triads, function(x) { as.integer(x) }))
    if(is.null(triads)){
      warning("There are no triads in the component. Returning non-triadic PII.")
      x <- piiCalc(e.dist, edgevalence, pii.beta, pii.x, max.distance)
      names(x) <- V(g)$name
      return(x)
    }
    if(is.null(t.table)){
      triad_table <- triad.table(g, triads)
      triad_table <- triad_table[order(triad_table$focalNode), ]
    }
    else{triad_table <- t.table}
    x <- piiTriadicCalc(e.dist, edgevalence, pii.beta, pii.x, max.distance, triad_table, pii.delta)
  } else {
    x <- piiCalc(e.dist, edgevalence, pii.beta, pii.x, max.distance)
  }
  names(x) <- V(g)$name
  x
}

#' The Sampson Monastery network.
#'
#' This network contains nodes representing monks in a monastery.
#'
#' @format An igraph object with 18 nodes and 90 edges:
#' \describe{
#'   \item{name}{name of the monk}
#'   \item{valence}{valence of the edge}
#' }
#' @source \url{https://sites.google.com/site/ucinetsoftware/datasets/sampsonmonastery}
"g.samp"


NMF_method1_test_version2<-function(tg_list, data_ng, data_normalized, max_ES_cut=0.3,tProp,NMF_RR=10)
{
        tg_selected_R4_RR<-tg_list
        data.matrix0_s<-data_ng
        data_23_s<-data_normalized
        Rbase_selected_R4_RR<-Compute_Rbase_SVD(data.matrix0_s,tg_selected_R4_RR)
        stat_selected_R4_RR<-compute_IM_stat(tg_list_c=tg_selected_R4_RR)
        stat_selected_R4_RR_max<-apply(stat_selected_R4_RR,1,max)
        tg_I_id<-which(stat_selected_R4_RR_max==max(stat_selected_R4_RR_max))[1]
        tg_selected_id<-tg_I_id
        X_I<-data.matrix0_s[tg_selected_R4_RR[[tg_I_id]],]
        N<-0
        NMF_list_c<-list()
        N<-N+1
        NMF_list_c[[N]]<-tg_selected_R4_RR[[tg_I_id]]
        names(NMF_list_c)<- names(tg_I_id)
        NMF_self_c1<-Building_NMF_input_no_cancer(tg_data=X_I,tg_list=NMF_list_c,tg_list_add=list())
        V_I<-t(as.matrix(Rbase_selected_R4_RR[tg_I_id,]))
        V_I_n<-normalize_data2(V_I)
        V_c<-V_I_n
        ccc<-compute_CompRowspace_NN(data_23_s,module_RB=V_c,ROUNDS=min(nrow(V_I),3))
        ES_I<-RMSE_row(ccc)/RMSE_row(data_23_s)
        ES_base_c<-Compute_base_ES_score(ES_I,tg_selected_R4_RR)
        ES_max<-max(ES_base_c)
        tg_id_del<-c()
        track_N_cor<-list()
        track_N_cor[[1]]<-apply(cor(t(tProp),t(V_c)),1,max)
        tg_id<-setdiff(1:length(tg_selected_R4_RR),tg_I_id)
        while((ES_max>max_ES_cut)&(length(tg_id)>0))
        {
                N<-N+1
                tg_id<-which(abs(ES_base_c-max(ES_base_c))<0.01)
                tg_id<-setdiff(tg_id,tg_selected_id)
                if(length(tg_id)==0)
                {
                        break
                }
                tg_id_add<-tg_id[which(stat_selected_R4_RR_max[tg_id]==max(stat_selected_R4_RR_max[tg_id]))[1]]
                tg_selected_id<-c(tg_selected_id,tg_id_add)
                NMF_list_c<-select_R_base(tg_selected_R4_RR,tg_selected_id)
                names(NMF_list_c)<-names(tg_selected_R4_RR)[tg_selected_id]     #?????
                NMF_self_c1<-Building_NMF_input_no_cancer(tg_data=data.matrix0_s,tg_list=NMF_list_c,tg_list_add=list())
                qnmf_result_c_temp <- run_NMF(NMF_self_c1,RR0=NMF_RR,maxIter=20000, tProp)
                U_temp = qnmf_result_c_temp[["U"]]
                V_temp = qnmf_result_c_temp[["V"]]
                ########check correlation between: V and true Proportion
                V_c<-normalize_data2(t(V_temp))
                ccc<-compute_CompRowspace_NN(data_23_s,module_RB=V_c,ROUNDS=min(nrow(V_I),3))
                ES_I<-RMSE_row(ccc)/RMSE_row(data_23_s)
                ES_base_c_temp<-Compute_base_ES_score(ES_I,tg_selected_R4_RR)
                if(ES_base_c_temp[tg_id_add]>max_ES_cut)
                {
                        tg_selected_id<-setdiff(tg_selected_id,tg_id_add)
                        tg_id_del<-c(tg_id_del,tg_id_add)
                        if(length(tg_id_del)>0)
                        {
                                ES_base_c[tg_id_del]<-0
                        }
                        N<-N-1
                }
                else
                {
                        qnmf_result_c<-qnmf_result_c_temp
                        track_N_cor[[N]]<-qnmf_result_c[[4]]
                        V<- qnmf_result_c[["V"]]
                        ES_base_c<-ES_base_c_temp
                        if(length(tg_id_del)>0)
                        {
                                ES_base_c[tg_id_del]<-0
                        }
                        ES_max<-max(ES_base_c)
                        ictd.ccc= t(cor(t(tProp),V) )
                        o6_predict_ture = apply(ictd.ccc, 1, max)
                        o6_predict_ture2 = apply(ictd.ccc, 2, max)
                        print(N)
                        print(o6_predict_ture2)
                        print(apply(cor(t(tProp),t(Rbase_selected_R4_RR[tg_selected_id,])),1,max))
                }
        }
        return(list(qnmf_result_c,track_N_cor,NMF_self_c1))
}


#-------------------------------------------------------------------
# srcfn -- Wrapper function to call lfm and/or generate random noise
#          to create a single epoch of pitch data for analysis or
#          synthesis.
#
# Args:
#  pars -- A vector of parameters that will be referenced by name
#          to select specific source-related parameters. Typically
#          this is the same vector that is also passed to vtfn to
#          generate the spectral response of the vocal tract. The
#          parameters used by srcfn are:
#          oq - open quotient - LTM Te = oq * T0
#          tprat - The ratio of tp/te clamped to the range:
#                  .5 <= tprat <= .95
#          ta - the duration of interval Ta in the LF model
#          av - Amplitude of voicing
#          ah - Amplitude of hiss applied only during the open phase
#               of voiced epochs.
#          af - Amplitude of frication applied only for voiceless
#               epochs.
#  vcd  -- Voicing status 1=voiced; 0=voiceless
#  t0   -- epoch duration in seconds.
#  fs   -- Sampling frequency
#
# 1/10/20 -- htb
#-------------------------------------------------------------------
srcfn <- function(pars, vcd=1, t0=0.01, fs=16000) {
  if (vcd) {
#    if (pars['tprat'] < 0.5)
#      pars['tprat'] = 0.5
#    else if (pars['tprat'] > 0.95)
#      pars['tprat'] = 0.95
#    if (pars['ta'] <.0001)
#      pars['ta'] <- .0001
#    if (pars['oq'] < .1)
#      pars['oq'] <- 0.1

    ug <- lfm(T0=t0,
              TE=pars['oq']*t0,
              TP=pars['oq']*t0*pars['tprat'],
              TA=pars['ta'],
              AV=pars['av'],
              Fs=fs)

    if (pars['ah'] > 0) {
#      n <- pars['oq'] * t0 * fs
      af <- 10^(pars['ah']/20)
#      ug[1:n] <- ug[1:n] + af * rnorm(n, 0, 1) * hanwin(n)
      TE = t0 * pars['oq']
      TP = TE * pars['tprat']
      na <- round(fs * (t0 - TE), 0)
      nb <- round(fs * TP, 0)
      nt0 <- round(fs *t0)
      nte <- round(fs * TE)
      n <- na + nb
      print(sprintf("TE=%f; TP=%f; na=%d; nb=%d; nt0=%d; nte=%d", TE, TP, na, nb, nt0, nte))
      tug <- af * rnorm(n, 0, 1) * hanwin(n)
      ug[1:nb] = ug[1:nb] + tug[(na+1):n]
      ug[(nte+1):nt0] = ug[(nte+1):nt0] + tug[1:na]
    }
  } else {
    n <- t0 * fs
    af <- 10^(pars['af']/20)
    ug <- af * rnorm(n, 0, 1)
  }

  ug
}


fun1=function(n1,n2)
{
  add=(n2+5)
  print(add)
}
fun1(6,)

fun2=function(n3,n4)
{
  add=(n3+5)
  print(add)
  print(6,)
}

fun2(6)

vec=c(1:3)
sq=function(no)
{
  sqr=no*no
  return(sqr)
}

sq(vec)

mat=matrix(1:9,3,3,byrow=TRUE)
sq(mat)

fun3=function(no1)
{
  5*no1-1
}
fun3(5)


#!/usr/bin/rebol -q
{
9x9 multiplication table in REBOL
CC0, Wei-Lun Chao <bluebat@member.fsf.org>, 2018.
}
; ./mt9x9.r || rebol -q mt9x9.r

rebol []
foreach i [1 4 7] [
    repeat j 9 [
        for k i (i + 2) 1 [
            prin rejoin [k "x" j "=" either k * j < 10 [" "] [""] k * j tab]
        ]
        prin crlf
    ]
    print ""
]


#!/usr/local/bin/Rscript --vanilla

###############################################################################
# METAREP : High-Performance Comparative Metagenomics Framework (http://www.jcvi.org/metarep)
# Copyright(c)  J. Craig Venter Institute (http://www.jcvi.org)
#
# Licensed under The MIT License
# Redistributions of files must retain the above copyright notice.
#
# link http://www.jcvi.org/metarep METAREP Project
# package metarep
# version METAREP v 1.3.2
# author Johannes Goll
# lastmodified 2010-07-09
# license http://www.opensource.org/licenses/mit-license.php The MIT License
###############################################################################

args 		= commandArgs(TRUE)
infile 		= args[1];
outfile 	= args[2];
test 		= args[3];
propround 	= as.numeric(args[4]);
pvalround 	= as.numeric(args[5]);

data = read.table(file=infile,sep="\t",header=F,colClasses=c("character","numeric","numeric","numeric","numeric"));
n = nrow(data);

## specify result columns
colums  = c("id","count1","count2","prop1","prop2","odds_ratio","relative_risk","p_value","b_value","q_value");

## init result data frame
result = data.frame(data[,1],matrix(cbind(data[,2],data[,4],matrix(rep(NA,n*(length(colums)-3)),ncol=length(colums)-3)),ncol=length(colums)-1,nrow=n),stringsAsFactors=FALSE);

## set column names for data frame
colnames(result) = colums;

## iterate through features
for(i in 1:n) {

	## generate 2-2 matrix
	m = matrix(as.numeric(data[i,2:5]),ncol=2,nrow=2);

	## proportion one
	result[i,4] = round((m[1,1]/sum(m[,1])),propround);

	## proportion two
	result[i,5] = round((m[1,2]/sum(m[,2])),propround);

	## log odds_ratio
	result[i,6] = round(log((m[1,1]*m[2,2])/(m[2,1]*m[1,2])),3);

	## relative_risk
	result[i,7] = round((m[1,1]/sum(m[,1]))/((m[1,2]/sum(m[,2]))),4);

	## execute test
	result[i,8] = do.call(test,list(m))$p.value;
}

## correct for multiple testing and round adjusted p/q-values
result[,9]  = round(p.adjust(result$p_value, method = "bonferroni"),pvalround);
result[,10] = round(p.adjust(result$p_value, method = "fdr"),pvalround);

## round non adjusted p-value after using the non-rounded values for multi-testing correction
result[,8] = round(result$p_value,pvalround);
write.table(result, file=outfile, row.names=F,sep="\t", eol = "\n",append=F,quote=F)
q(status=0)


#install.packages("FLCore", repo = "http://flr-project.org/R")
#library(devtools)
#install_github("ices-tools-prod/msy")

library(msy)

nsamp <- 1000  # number of stochatic runs for each option

Mstk<-SMS2FLStocks(sumfile=file.path(data.path,'summary.out'),
                         bio.interact=F, read.input=TRUE, read.output=TRUE,control=read.FLSMS.control())

SSB.R.year.first<-SMS.control@SSB.R.year.first
SSB.R.year.last <-SMS.control@SSB.R.year.last
SSB.R.year.first[SSB.R.year.first==-1]<-SMS.control@first.year.model
SSB.R.year.last[SSB.R.year.last==-1]<-SMS.control@last.year.model

# read recruiment years used
recruit.years<-matrix(head(scan(file='recruitment_years.in',comment.char='#'),-1),ncol=SMS.control@last.year.model-SMS.control@first.year.model+1 ,byrow=T)
colnames(recruit.years)<-c(as.character(seq(SMS.control@first.year,SMS.control@last.year)))

dev<-'png'
nox<-1; noy<-1;
noxy<-nox*noy
i<-noxy

  stk<-Mstk
  class(stk)<-'FLStock'

  # move recruitment to first Quarter
  stk@stock.n[1,,,1,,]<-as.vector(stock.n(stk)[1,,,3,,])

  stk<-trim(stk,season=1,year=SSB.R.year.first[1]:(SSB.R.year.last[1]-1))  # Delete the most recent year (as driven by used S/R relation). SSB and recruit are there, but the rest of data is crap (first half-year only)

  harvest.spwn(stk)<-0
  m.spwn(stk)<-0
  #stk@stock.n<-stk@stock.n/1000
  cat('\n',sp.names[1+first.VPA-1],'\n SSB:\n');print(ssb(stk))

  save(stk,file=file.path(data.path,'NOP_FLR.Rdata'))

  models<- c("Ricker", "Segreg", "Bevholt")

  if (0==length(excl.years<-as.numeric(dimnames(recruit.years)[[2]][0==recruit.years[1,]]))) excl.years<-NULL
  FIT<-eqsr_fit(stk, nsamp = nsamp, models = models,
                    method = "Buckland",
                    id.sr = paste(sp.names[1+first.VPA-1],', ',SSB.R.year.first[1],'-',SSB.R.year.last[1],sep=''),
                    remove.years = excl.years)

  if (i>=noxy) {
    if (dev=='png') cleanup()
    newplot(dev,filename=paste('equisim',1,sep='_'),nox,noy,Portrait=T);
    i<-0
  }
  eqsr_plot(FIT,Scale=0.001,n=nsamp)
dev.off()

if (dev=='png') cleanup()

 print(FIT$sr.det)


#This code analyses the EV II data set
#The code is going to read the excel spreadsheets directly using the RODBC library
#this library is required, along with MASS
library(RODBC)
library(stats)
library(ellipse)
library (MASS)
library(scatterplot3d)

#PART 1: READING THE DATA
#Set the working directory so that it reads to the correct path
setwd("H:/Projects/DEH Empirical Validation II/Reports")

#Make a connection to the excel workbook - note that the spreadsheet names must not include any spaces #otherwise the connection cannot read them
evIIData <-odbcConnectExcel("H:/Projects/DEH Empirical Validation II/Survey/Survey results - Oct 05.xls")

#Check what tables are held in the connected file
sqlTables(evIIData)

#Make four dataFrames using the sqlFetch function
samples <- sqlFetch(evIIData, "Samples")
activity <- sqlFetch(evIIData, "Activity")
vessel <- sqlFetch(evIIData, "Vessel")
plankton <- sqlFetch(evIIData, "Plankton")

#Beware that R may read empty rows so constrain the dataset!
samples <- samples[!is.na(samples$boatID), ]
activity <- activity[!is.na(activity$vesID), ]
vessel <- vessel[!is.na(vessel$boatID), ]
plankton <- plankton[!is.na(plankton$boatID), ]

#****************************************************************************************************************
#PART 2A: INITIAL DATA EXPLORATION - vessel
#Histogram and summary statistics of the vessel length and hull surface area
attach(vessel)
names(vessel)

bitmap("Vessel_length_hist.tif", type="tiffpack", width = 8, height = 8, res =600)
#windows()
par(mfrow=c(2,2))
par(xpd = NA)
hist(vessel$Length, prob = F, xlab = "Vessel length (m)", ylab = "Frequency", main = "")
text(5, 27, "a")
plot(density(vessel$Length), xlab = "Vessel length (m)", ylab = "Density", main = "" )
text(2, 0.13, "b")
hist(vessel$ApproxHullSA, prob = F, xlab = "Approx. hull surface area (m2)", ylab = "Frequency", main = "")
text(0, 43, "c")
plot(density(vessel$ApproxHullSA), xlab = "Approx. hull surface area (m2)", ylab = "Density", main = "" )
text(0, 0.022, "d")
dev.off()

#Aggregate the data by boat type (similar to tapply function) to see length and hull surface area statistics,
#use tapply for variance calculation, create different datagroups to investigate these statistics for similar
#vessels - note the exclusion of vessel #22 which was an outlier
#aggregate(vessel, list(VesselType = vessel$boatType), mean)
#tapply(vessel$ApproxHullSA, list(vessel$boatType), var)
g1 <- vessel[boatType %in% c("Motor cruiser", "Yacht"), ]
g2 <- vessel[boatType %in% c("Fishing vessel (Abalone mothership)", "Fishing vessel(Lobster/scallop)", "Fishing vessel (Long line)"), ]

attach(g2)
g2mod <- g2[boatID !=22, ]
g3 <- merge(g1, g2mod, all.x = T, all.y = T)
mean(g3$ApproxHullSA)
var(g3$ApproxHullSA)

#PART 2B: INITIAL DATA EXPLORATION - vessel activity patterns
#Read in the sample date (sDate), the last trip date (ltDate), the last slip date (lsDate) and the last anti-foul
#date (afDate).  Note use of the coercive "as" function because R read the excel dates as a factor
attach(activity)
names(activity)
sDate <- strptime(as(activity$sampleDate, "character"), "%Y-%m-%d")
ltDate <- strptime(as(activity$lastTripDate, "character"), "%Y-%m-%d")
lsDate <- strptime(as(activity$lastSlipDate, "character"), "%Y-%m-%d")
afDate <- strptime(as(activity$lastAFDate, "character"), "%Y-%m-%d")
iwDate <- strptime(as(activity$lastINWDate, "character"), "%Y-%m-%d")

#Remove the NA's from the last slip, in water clean and anti-foul date replace with an earlier date so long as
#there is no overlap
lsDate[is.na(lsDate)] <- strptime("1980-01-01", "%Y-%m-%d")
afDate[is.na(afDate)] <- strptime("1980-01-01", "%Y-%m-%d")
iwDate[is.na(iwDate)] <- strptime("1980-01-01", "%Y-%m-%d")

#Set up the covariate data frame which will also serve for the statistical modelling, enter the time between
#the sample date and the last trip date (days1) in days, the time between the sample date and the date the #vessel was last cleaned, slipped or antifouled (days2) in days, and the median number of trips per annum, #together with boat type and code
covars <- data.frame(array(NA, dim = c(nrow(activity), 8)))
names(covars) <- c("boatID", "days1", "days2", "midTrips", "boatType", "boatCode", "paintType", "paintRating")
covars$boatID <- activity$vesID
covars$boatType <- activity$boatType
covars$boatCode <- activity$boatCode
covars$paintType <- activity$Type
covars$paintRating <- activity$PerfRating
covars$days1 <- as.numeric(round((sDate - ltDate)/(60*60*24), 0))

#Assign days2 the same elements and class as afDate - note the same class is important for subsequent manipulations
covars$days2 <- afDate

#Set up a loops that find the latest date since the vessel was last cleaned, slipped or antifouled and thereby #calculate days2
 for (i in 1: nrow(covars)){
	if(lsDate[i] > afDate[i]) covars$days2[i] <- lsDate[i]
	if(iwDate[i] > covars$days2[i]) covars$days2[i] <- iwDate[i]
}
covars$days2 <- as.numeric(round((sDate - covars$days2), 0))

#Calculate median trip activity per annum
covars$midTrips <- activity$minTrips + (activity$maxTrips - activity$minTrips)/2
#table(covars$midTrips)

#Calculate the number of last trips less than or equal to 14 and 50 days and the number of vessels last
#cleaned within 1/2 and 1 years
attach(covars)
countDay14 <- covars[!is.na(days1) & days1 <= 14, 2]
countDay50 <- covars[!is.na(days1) & days1 <= 50, 2]
length(countDay14)
length(countDay50)
countYr1 <- covars[days2 <= 178, 3]
countYr2 <- covars[days2 <= 356, 3]
length(countYr1)
length(countYr2)

#Plot a histogram of the number of days between the sample date and the last trip date and last slip clean,
#in water clean or antifoul date, and the median trip activity
bitmap("Activity_hist.tif", type="tiffpack", width = 8, height = 8, res =600)
#windows()
par(mfrow=c(2,2))
par(xpd = NA)
hist(covars$days1, prob = F, xlab = "Days since last trip", ylab = "Frequency", main = "")
text(0, 40, "a")
hist(covars$days2, prob = F, xlab = "Days since last cleaned or antifouled", ylab = "Frequency", main = "")
text(0, 25, "b")
hist(covars$midTrips, prob = F, xlab = "Median number of trips per annum", ylab = "Frequency", main = "")
text(0, 40, "c")
dev.off()

#PART 2C: INITIAL DATA EXPLORATION - sample wet weight
#Name and select the data for graphical purposes - note the joining of the
#deck samples and fishing gear samples and the ordering of the samples
attach(samples)
names(samples)
wetHull <- samples[Location %in% c("Wet Hull"),  ]
wetHull <- wetHull[order(wetHull$wetWeight,decreasing = T), ]
intSam <- samples[Location %in% c("Internal spaces"), ]
intSam <- intSam[order(intSam$wetWeight, decreasing = T), ]
propSam <-samples[Location %in% c("Propeller"), ]
propSam <- propSam[order(propSam$wetWeight, decreasing = T), ]
rudSam <-samples[Location %in% c("Rudder"), ]
rudSam <- rudSam[order(rudSam$wetWeight, decreasing = T), ]
deckSam <- samples[Location %in% c("Fishing gear", "Deck", "Anchor"), ]
deckSam <- deckSam[order(deckSam$wetWeight, decreasing = T), ]

#Size frequency plot of the original data and then the ln transformed data
bitmap("Wet_weight_hist.tif", type="tiffpack", width = 8, height = 8, res =600)
#windows()
par(mfrow=c(2,2))
hist(wetHull$wetWeight, prob=F, xlab = "Wet weight (g)", ylab = "Count", main = " Wet Hull")
hist(intSam$wetWeight, prob = F, xlab = "Wet weight (g)", ylab = "Count", main = "Internal spaces")
hist(propSam$wetWeight, prob = F, xlab = "Wet weight (g)", ylab = "Count", main = "Propeller")
hist(rudSam$wetWeight, prob = F, xlab = "Wet weight (g)", ylab = "Count", main = "Rudder")
dev.off()

bitmap("Log_wet_weight_hist.tif", type = "tiffpack", width = 8, height = 8, res=600)
#windows()
par(mfrow=c(2,2))
hist(log(wetHull$wetWeight + 1), prob=F, xlab = "Ln(Wet weight + 1) (g)", ylab = "Count", main = " Wet Hull")
hist(log(intSam$wetWeight + 1), prob = F, xlab = "Ln(Wet weight + 1) (g)", ylab = "Count", main = "Internal spaces")
hist(log(propSam$wetWeight + 1), prob = F,xlab = "Ln(Wet weight + 1) (g)", ylab = "Count", main = "Propeller")
hist(log(rudSam$wetWeight + 1), prob = F, xlab = "Ln(Wet weight + 1) (g)", ylab = "Count", main = "Rudder")
dev.off()

#Create three data frames for the zero, non-zero data and all the data, note the use of aggregate functions
#rather than tapply since the former creates a data frame.  Note also the use of the factor command to
#exclude factors that only had zeroes, (it is otherwise redundant because R already interprets LocID as a factor),
#the use of the unique command to identify the individual factors that the Shapiro test is eventually
#applied to using the == function, and the storage of the results in a data frame (rather than a matrix)
#because this allows different classes of information to be stored (i.e. factor LocID and numeric Shapiro test statistics)
data <- data.frame(LocID = samples$LocID, wetWeight = samples$wetWeight)
data1 <- data[data$wetWeight > 0.5, ]
data0 <- data[data$wetWeight <= 0.5, ]
#data$LocID <- factor(data$LocID, exclude=NULL)
data1$LocID <- factor(data1$LocID, exclude=NULL)
data0$LocID <- factor(data0$LocID, exclude=NULL)
length.data <- aggregate(data$wetWeight, by = list(LocID = data$LocID), length)
length.data1 <- aggregate(data1$wetWeight, by = list(LocID = data1$LocID), length)
length.data0 <- aggregate(data0$wetWeight, by = list(LocID = data0$LocID), length)
unique.loc1 <- unique(data1$LocID)
unique.loc0 <- unique(data0$LocID)
#unique.loc <- unique(data$LocID)
names(length.data0)[[2]] <- "n0"
names(length.data1)[[2]] <- "n1"
names(length.data)[[2]] <- "n"

#Size frequency plot by location the data, note the use of the browser command to step through the loop
#and the need to specify LocID as a factor and the use of the unique command for the data0 and data1 datesets
#(because R holds over the LocID factors that were taken out to create these datasets)
bitmap("Figure2D4.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 1:12) {
	if(length.data$n[i] > 1) {
#browser()
hist(log(data$wetWeight[data$LocID==length.data$LocID[i]]+1), main = as.character(length.data$LocID[i]) , xlab = "Ln (Wet weight + 1) (g)")
	}
}
dev.off()

bitmap("Figure2D5.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 13:24) {
	if(length.data$n[i] > 1) {
hist(log(data$wetWeight[data$LocID==length.data$LocID[i]]+1), main = as.character(length.data$LocID[i]), xlab = "Ln (Wet weight + 1) (g)")
	}
}
dev.off()

bitmap("Figure2D6.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 25:36) {
	if(length.data$n[i] > 1) {
hist(log(data$wetWeight[data$LocID==length.data$LocID[i]]+1), main = as.character(length.data$LocID[i]), xlab = "Ln (Wet weight + 1) (g)")
	}
}
dev.off()

bitmap("Figure2D7.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 37:48) {
	if(length.data$n[i] > 1) {
hist(log(data$wetWeight[data$LocID==length.data$LocID[i]]+1), main = as.character(length.data$LocID[i]), xlab = "Ln (Wet weight + 1) (g)")
	}
}
dev.off()

bitmap("Figure2D8.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 49:50) {
	if(length.data$n[i] > 1) {
hist(log(data$wetWeight[data$LocID==length.data$LocID[i]]+1), main = as.character(length.data$LocID[i]), xlab = "Ln (Wet weight + 1) (g)")
	}
}
dev.off()

bitmap("Figure2D9.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 51:nrow(length.data)) {
	if(length.data$n[i] > 1) {
hist(log(data$wetWeight[data$LocID==length.data$LocID[i]]+1), main = as.character(length.data$LocID[i]), xlab = "Ln (Wet weight + 1) (g)")
	}
}
dev.off()

#Size frequency plot by location the non-zero data, note the use of the browser command to step through the loop
bitmap("Figure2D10.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 1:12) {
	if(length.data1$n1[i] > 1) {
#browser()
hist(log(data1$wetWeight[data1$LocID==length.data1$LocID[i]]), main = as.character(length.data1$LocID[i]), xlab = "Ln (Wet weight) (g)")
	}
}
dev.off()

bitmap("Figure2D11.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 13:24) {
	if(length.data1$n1[i] > 1) {
hist(log(data1$wetWeight[data1$LocID==length.data1$LocID[i]]), main = as.character(length.data1$LocID[i]), xlab = "Ln (Wet weight) (g)")
	}
}
dev.off()

bitmap("Figure2D12.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 25:nrow(length.data1)) {
	if(length.data1$n1[i] > 1) {
hist(log(data1$wetWeight[data1$LocID==length.data1$LocID[i]]), main = as.character(length.data1$LocID[i]), xlab = "Ln (Wet weight) (g)")
	}
}
dev.off()

#Box plot the non-zero data, rotating and setting the axis font to 80% of the default (see #?par)
bitmap("Figure2D13.tif", type = "tiffpack", width = 8, height = 8, res=600)
par(mfrow=c(2,2))
wetHull <- wetHull[wetHull$wetWeight > 0.5, ]
attach(wetHull)
plot(LocID, log(wetWeight), las = 2, xlab = "Location ID", ylab = "Ln (Wet weight) (g)", main = "Wet Hull")
intSam <- intSam[intSam$wetWeight > 0.5, ]
attach(intSam)
plot(LocID, log(wetWeight), las = 2, xlab = "Location ID", ylab = "Ln (Wet weight) (g)", main = "Internal spaces")
propSam <- propSam[propSam$wetWeight > 0.5, ]
attach(propSam)
plot(LocID, log(wetWeight), las = 2, xlab = "Location ID", ylab = "Ln (Wet weight) (g)", main = "Propeller")
rudSam <- rudSam[rudSam$wetWeight > 0.5, ]
attach(rudSam)
plot(LocID, log(wetWeight), las = 2, xlab = "Location ID", ylab = "Ln (Wet weight) (g)", main = "Rudder")
dev.off()

#Q-Q plot the non-zero data by Location ID
bitmap("Figure2D14.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 1:12) {
	if(length.data1$n[i] > 3) {
		qqnorm(log(data1$wetWeight[data1$LocID==unique.loc1[i]]), main = as.character(unique.loc1[i]))
		qqline(log(data1$wetWeight[data1$LocID==unique.loc1[i]]))
	}
}
dev.off()

bitmap("Figure2D15.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 13:24) {
	if(length.data1$n[i] > 3) {
		qqnorm(log(data1$wetWeight[data1$LocID==unique.loc1[i]]), main = as.character(unique.loc1[i]))
		qqline(log(data1$wetWeight[data1$LocID==unique.loc1[i]]))
	}
}
dev.off()

bitmap("Figure2D16.tif", type = "tiffpack", width = 8, height = 10, res=600)
par(mfrow=c(4,3))
for (i in 25:nrow(length.data1)) {
	if(length.data1$n[i] > 3) {
		qqnorm(log(data1$wetWeight[data1$LocID==unique.loc1[i]]), main = as.character(unique.loc1[i]))
		qqline(log(data1$wetWeight[data1$LocID==unique.loc1[i]]))
	}
}
dev.off()

#Perform a Shapiro-Wilks test on the non-zero data (the aggregate function rather than tapply above allows the use of merge functions by column name to construct the output table) and construct an output  table
#showing the sample size (n) number of zero's (n0), the number of non-zeros (n1), and the Shapiro test result
shapTest <- data.frame(array(NA, dim = c(nrow(length.data1),3)))
names(shapTest) <- c("LocID","w","p")
for (i in 1:nrow(length.data1)) {
	shapTest[i,1] <- as.character(unique.loc1[i])
	if(length.data1$n1[i] > 3) {
		shapTest[i,2] <- shapiro.test(log(data1$wetWeight[data1$LocID==length.data1$LocID[i]]))[[1]]
		shapTest[i,3] <- shapiro.test(log(data1$wetWeight[data1$LocID==length.data1$LocID[i]]))[[2]]
	}
}
test <- merge(length.data, length.data1, by.x = "LocID", by.y = "LocID", all.x = T, all.y = T)
test <- merge(test, length.data0, by.x = "LocID", by.y = "LocID", all.x = T, all.y = T)
test <- merge(test, shapTest, by.x = "LocID", by.y = "LocID", all.x = T, all.y = T)
write.table(test, file = "TableYY.csv", sep = ",")

#Construct a table showing the mean and variance of the non-zero data and merge it with the test table, note the use of tapply here because we are reading the results directly into a data frame - beware when reading
#this information out of the data frame because the factor information is still retained with it!
deltaData <- data.frame(array(NA, dim = c(nrow(length.data1), 5)))
names(deltaData) <- c("LocID", "muHat", "varHat", "deltaMu", "deltaVar")
deltaData$LocID <- unique.loc1
deltaData$muHat <- tapply(log(data1$wetWeight), data1$LocID, mean)
deltaData$varHat <- tapply(log(data1$wetWeight), data1$LocID, var)
delta <- merge(test, deltaData, by.x = "LocID", by.y = "LocID", all.x = T, all.y = T)

#Calculate the mean and variance of the delta distribution
for (i in 1:nrow(delta)) {
	if(!is.na(delta$w[i])) {
		dHat <- delta$n0[i]/delta$n[i]
		#bFunc <- besselJ(0.5*delta$varHat[[i]], delta$n1[i])
		#delta$deltaMu[i] <- (1-dHat)*exp(delta$muHat[[i]])*bFunc
		delta$deltaMu[i] <- (1-dHat)*exp(delta$muHat[[i]] + delta$varHat[[i]])
		delta$deltaVar[i] <- (1/delta$n[i])*exp(2*delta$muHat[[i]] + delta$varHat[[i]])*(dHat*(1-dHat) + 0.5*(1-dHat)*(2* delta$varHat[[i]] + (delta$varHat[[i]]^2)))
	}
}
write.table(delta, file = "TableD.csv", sep = ",")

#*****************************************************************************************************************
#PART 3A: STATISTICAL MODELLING ZERO DATA
#Examine the relationships between proportion of clean samples and time since the vessel was last used (days1), time since the vessel was last cleaned (days2), number of trips per annum (midTrips) and paint #type
attach(samples)
samSize1 <- aggregate(samples$wetWeight, by = list(boatID = samples$boatID, LocID = samples$LocID), length)
small.numbers<-function(x){
	return(length(x[x<=0.5]))
}
samSize2 <- aggregate(samples$wetWeight, by = list(boatID = samples$boatID, LocID = samples$LocID), small.numbers)
samSize1 <- cbind(samSize1, samSize2[ , 3])
dimnames(samSize1)[[2]][3] <- "n"
dimnames(samSize1)[[2]][4] <- "n0"

attach(samSize1)
testLoc <- c("IB", "HA", "PJ", "PB", "HD", "HAH", "HP", "HH", "HK")

bitmap("Figure3A1.tif", type = "tiffpack", width = 8, height = 10, res=600)
#windows( )
par(mfrow=c(4,3))
for (i in 1:length(testLoc)){
	dum <- merge(covars, samSize1[samSize1$LocID==testLoc[i], ], by.x = "boatID", by.y = "boatID")
	par(xpd = NA)
	plot(dum$days1, dum$n0/dum$n, main = testLoc[i], xlab = "Days since vessel last used", ylab = "Proportion of clean samples", cex = 1, col = "red", pch = 20)
	text(dum$days1, dum$n0/dum$n, labels = dum$boatID, pos = 3, cex = 0.6)
}
dev.off()

bitmap("Figure3A2.tif", type = "tiffpack", width = 8, height = 10, res=600)
#windows( )
par(mfrow=c(4,3))
for (i in 1:length(testLoc)){
	dum <- merge(covars, samSize1[samSize1$LocID==testLoc[i], ], by.x = "boatID", by.y = "boatID")
	par(xpd = NA)
	plot(dum$days2, dum$n0/dum$n, main = testLoc[i], xlab = "Days since vessel last cleaned", ylab = "Proportion of clean samples", cex = 1, col = "red", pch = 20)
	text(dum$days2, dum$n0/dum$n, labels = dum$boatID, pos = 3, cex = 0.6)
}
dev.off()

bitmap("Figure3A3.tif", type = "tiffpack", width = 8, height = 10, res=600)
#windows( )
par(mfrow=c(4,3))
for (i in 1:length(testLoc)){
	dum <- merge(covars, samSize1[samSize1$LocID==testLoc[i], ], by.x = "boatID", by.y = "boatID")
	par(xpd = NA)
	plot(dum$midTrips, dum$n0/dum$n, main = testLoc[i], xlab = "Median trips per annum", ylab = "Proportion of clean samples", cex = 1, col = "red", pch = 20)
	text(dum$midTrips, dum$n0/dum$n, labels = dum$boatID, pos = 3, cex = 0.6)
}
dev.off()

#Quasi-bionomial GLM model for the proportion of zero samples, in IB compare the two models - one weighted by the number of samples one without
dumIB <- merge(covars, samSize1[samSize1$LocID==testLoc[1], ], by.x = "boatID", by.y = "boatID")
modIB1 <- glm(n0/n ~ days2, data = dumIB, family = quasibinomial, method = "glm.fit", trace = F)
summary(modIB1)
bitmap("Figure3A4.tif", type = "tiffpack", width = 8, height = 8, res=600)
#windows()
par(mfrow=c(2,2))
plot(modIB1, main = testLoc[1])
dev.off()

modIB2 <- glm(n0/n ~ days2, data = dumIB, weight = n, family = quasibinomial, method = "glm.fit", trace = F)
summary(modIB2)
windows()
par(mfrow=c(2,2))
plot(modIB2, main = testLoc[1])

#GLM model for the proportion of zero samples, in the paddle wheel and booth (HK) compare the two models -
#one weighted by the number of samples one without
dumHK <- merge(covars, samSize1[samSize1$LocID==testLoc[9], ], by.x = "boatID", by.y = "boatID")
modHK1 <- glm(n0/n ~ days2, data = dumHK, family = quasibinomial, method = "glm.fit", trace = F)
summary(modHK1)
bitmap("Figure3A5.tif", type = "tiffpack", width = 8, height = 8, res=600)
#windows()
par(mfrow=c(2,2))
plot(modHK1, main = testLoc[9])
dev.off()

modHK2 <- glm(n0/n ~ days2, data = dumHK, weight = n, family = quasibinomial, method = "glm.fit", trace = F)
summary(modHK2)
windows()
par(mfrow=c(2,2))
plot(modHK2, main = testLoc[9])

#GLM model for the proportion of zero samples, in the cover plates (HD) compare the two models - one weighted by the number of samples one without
dumHD <- merge(covars, samSize1[samSize1$LocID==testLoc[5], ], by.x = "boatID", by.y = "boatID")
modHD1 <- glm(n0/n ~ days2, data = dumHD, family = quasibinomial, method = "glm.fit", trace = F)
summary(modHD1)
bitmap("Figure3A6.tif", type = "tiffpack", width = 8, height = 8, res=600)
#windows()
par(mfrow=c(2,2))
plot(modHD1, main = testLoc[5])
dev.off()

modHD2 <- glm(n0/n ~ days2, data = dumHD, weight = n, family = quasibinomial, method = "glm.fit", trace = F)
summary(modHD2)
windows()
par(mfrow=c(2,2))
plot(modHD2, main = testLoc[5])

#GLM model for the proportion of zero samples, in the depth sounder booth(HH) compare the two models - one weighted by the number of samples one without
dumHH <- merge(covars, samSize1[samSize1$LocID==testLoc[8], ], by.x = "boatID", by.y = "boatID")
modHH1 <- glm(n0/n ~ days2, data = dumHH, family = quasibinomial, method = "glm.fit", trace = F)
summary(modHH1)
bitmap("Figure3A7.tif", type = "tiffpack", width = 8, height = 8, res=600)
#windows()
par(mfrow=c(2,2))
plot(modHH1, main = testLoc[5])
dev.off()

modHH2 <- glm(n0/n ~ days2, data = dumHH, weight = n, family = quasibinomial, method = "glm.fit", trace = F)
summary(modHH2)
windows()
par(mfrow=c(2,2))
plot(modHH2, main = testLoc[5])

#Plot up the predicted values from these GLM models
#windows()
bitmap("Zero_samples_GLM.tif", type="tiffpack", width = 8, height = 8, res = 600)
par(mfrow = c(2,2))
newx <- seq(0, 1000, len = 500)
newy <- predict(modIB1, newdata = data.frame(days2 = newx), type = "link", se.fit = T, conf.level = 0.95)
plot(dumIB$days2, dumIB$n0/dumIB$n, xlab="Days since vessel last cleaned", ylab = "Proportion of clean samples", main = testLoc[1])
lines(newx, quasibinomial()$linkinv(newy[[1]]))
lines(newx, quasibinomial()$linkinv(newy[[1]] + 2*newy$se.fit), lty = 2)
lines(newx, quasibinomial()$linkinv(newy[[1]] - 2*newy$se.fit), lty = 2)

newy <- predict(modHK1, newdata = data.frame(days2 = newx), type = "link", se.fit = T, conf.level = 0.95)
plot(dumHK$days2, dumHK$n0/dumHK$n, xlab="Days since vessel last cleaned", ylab = "Proportion of clean samples", main = testLoc[9])
lines(newx, quasibinomial()$linkinv(newy[[1]]))
lines(newx, quasibinomial()$linkinv(newy[[1]] + 2*newy$se.fit), lty = 2)
lines(newx, quasibinomial()$linkinv(newy[[1]] - 2*newy$se.fit), lty = 2)

newy <- predict(modHD1, newdata = data.frame(days2 = newx), type = "link", se.fit = T, conf.level = 0.95)
plot(dumHD$days2, dumHD$n0/dumHD$n, xlab="Days since vessel last cleaned", ylab = "Proportion of clean samples", main = testLoc[5])
lines(newx, quasibinomial()$linkinv(newy[[1]]))
lines(newx, quasibinomial()$linkinv(newy[[1]] + 2*newy$se.fit), lty = 2)
lines(newx, quasibinomial()$linkinv(newy[[1]] - 2*newy$se.fit), lty = 2)

newy <- predict(modHH1, newdata = data.frame(days2 = newx), type = "link", se.fit = T, conf.level = 0.95)
plot(dumHH$days2, dumHH$n0/dumHH$n, xlab="Days since vessel last cleaned", ylab = "Proportion of clean samples", main = testLoc[8])
lines(newx, quasibinomial()$linkinv(newy[[1]]))
lines(newx, quasibinomial()$linkinv(newy[[1]] + 2*newy$se.fit), lty = 2)
lines(newx, quasibinomial()$linkinv(newy[[1]] - 2*newy$se.fit), lty = 2)
dev.off()

#************************************************************************************************************************
#PART 3B: ANALYSIS OF COVARIANCE for the hull quadrats using days2 and paintType
testLoc <- c("IB", "HA", "PJ", "PB", "HD", "HAH", "HP", "HH", "HK")
tempData <- samples[samples$wetWeight > 0.5, ]
tempData <- tempData[ , c("boatID", "LocID", "wetWeight")]
muData <- aggregate(log(tempData$wetWeight), by = list(boatID = tempData$boatID, LocID = tempData$LocID), mean)
modData<- merge(covars, muData[muData$LocID==testLoc[2], ], by.x = "boatID", by.y = "boatID")
modData$paintRating <- relevel(modData$paintRating, ref = "Very Poor")

#Output the raw data table for the report
write.table(modData, file= "Covariance_Data.csv", append = F, sep = ",")

#Plot the raw data
#windows()
bitmap("Covariance_data_plot1.tif", type="tiffpack", width = 8, height = 8, res = 600)
par(mfrow = c(2,1))
plot(modData$midTrips, modData$x, type = "n", xlab = "Median trips per annum", ylab = "Log10(mean hull quadrat wet weight)", cex = 0.6)
text(modData$midTrips, modData$x, substring(as.character(modData$boatID),1,2), cex = 0.6)
plot(modData$days2, modData$x, type = "n", xlab = "Days since last cleaned or antifouled", ylab = "Log10(mean hull quadrat wet weight)", cex = 0.6)
text(modData$days2, modData$x, substring(as.character(modData$boatID),1,2), cex = 0.6)
dev.off()

#windows()
bitmap("Covariance_data_plot2.tif", type="tiffpack", width = 8, height = 8, res = 600)
par(mfrow = c(2,1))
plot(modData$midTrips, modData$x, type = "n", xlab = "Median trips per annum", ylab = "Log10(mean hull quadrat wet weight)", cex = 0.6)
text(modData$midTrips, modData$x, substring(as.character(modData$paintType),1,1), cex = 0.6)
plot(modData$days2, modData$x, type = "n", xlab = "Days since last cleaned or antifouled", ylab = "Log10(mean hull quadrat wet weight)", cex = 0.6)
text(modData$days2, modData$x, substring(as.character(modData$paintType),1,1), cex = 0.6)
dev.off()

#Final model which is used with days2 and midTrips*paintType interaction
coMod6 <- lm(x ~ days2 + midTrips*paintType, modData)
summary(coMod6)
anova(coMod6)

#Basic model diagnostics
bitmap("Covariance_diagnostics.tif", type ="tiffpack", width = 8, height = 8, res =600)
#windows()
par(mfrow=c(2,2))
plot(coMod6)
dev.off()

#Create a table with the model diagnostics
temp <- modData[!is.na(modData$days2),]
temp <- temp[!is.na(temp$midTrips),]
temp <- temp[!is.na(temp$paintType),]
diag_tab <- temp$boatID
diag_tab <- cbind(diag_tab, round(coMod6$res, 2))
diag_tab <- cbind(diag_tab, round(rstandard(coMod6),2))
diag_tab <- cbind(diag_tab, round(rstudent(coMod6),2))
diag_tab <- cbind(diag_tab, round(hatvalues(coMod6),3))
diag_tab <- cbind(diag_tab, round(cooks.distance(coMod6),5))
write.table(diag_tab, file = "Covariance_diagnostics.csv", append = F, sep = ",")

#Model without apparent outliers
outliers <- c(21, 46)
temp <- subset(modData,boatID!= 24 & boatID!=51)
coMod6b <- lm(x ~ days2 + midTrips*paintType, data = temp)
summary(coMod6b)
anova(coMod6b)

#****************************************************************************************************
#Part 4A: IMEA analysis
#Read in the IMEA results and make a dataFrame using the sqlFetch function
imea <-odbcConnectExcel("H:/Projects/DEH Empirical Validation II/Reports/IMEA1.xls")
sqlTables(imea)
imea.data<-sqlFetch(imea, "Data")
imea.data <- imea.data[!is.na(imea.data$LocID), ]

#Create a data frame by location id with the mean of the data for comparison with the IMEA analysis
muData1 <- aggregate(log(samples$wetWeight +1), by = list(LocID = samples$LocID), mean)
varData1 <- aggregate(log(samples$wetWeight +1), by = list(LocID = samples$LocID), var)
countData <- aggregate(samples$wetWeight, by = list(LocID = samples$LocID), length)
tempData <- merge(muData1, varData1, by.x = "LocID", by.y="LocID")
tempData <- merge(tempData, countData, by.y = "LocID")
names(tempData)[[2]] <- "mu"
names(tempData)[[3]] <- "var"
names(tempData)[[4]] <- "n"
tempData <- merge(tempData, imea.data, by.x = "LocID", by.y = "LocID", all.x = T, all.y = T)
tempData$mu <- round(tempData$mu, 2)
tempData$var <- round(tempData$var, 2)
tempData$AvSevRat <- round(tempData$AvSevRat, 2)
tempData$AvOccRat <- round(tempData$AvOccRat, 2)
tempData$SOR <- round(tempData$SOR, 2)
tempData <- tempData[!is.na(tempData$mu), ]
tempData <- tempData[!is.na(tempData$SOR), ]
write.table(tempData, file= "H:/Projects/DEH Empirical Validation II/Reports/TableZZ.csv", append = F, sep = ",")

#Plot the IMEA score by mean wet weight for the different locations
attach(tempData)
bitmap("IMEA_scatterplot.tif", type = "tiffpack", width = 8, height = 8, res=600)
#windows()
plot(tempData$SOR, tempData$mu, ylab = "Ln (Mean wet weight) (g)", xlab = "IMEA score", pch = 19, cex = 0.5)
text(tempData$SOR, tempData$mu, labels = tempData$LocID, pos = 4, cex = 0.7)
dev.off()

#Perform a linear model on the IMEA score
mod8 <- lm(mu ~ SOR, data = tempData)
summary(mod8)
bitmap("IMEA_reg_diag.tif", type = "tiffpack", width = 8, height = 8, res=600)
par(mfrow=c(2,2))
plot(mod8)
dev.off()

#****************************************************************************************
#PART 5: Undaria fouling analysis
#Construct two new data frames showing the proportion of infected samples by location #category
und1.sum <- aggregate(samples$Und, by = list(boatID = samples$boatID, LocCode = samples$LocCode), sum, na.rm = T)
und1.length <- aggregate(samples$Und, by = list(boatID = samples$boatID, LocCode = samples$LocCode), length)
und1.prop <- und1.sum$x/und1.length$x
und1.sum <- data.frame(und1.sum, und1.prop)
und1.sum$LocCode <- as.numeric(und1.sum$LocCode)

und2.sum <- aggregate(plankton$Und, by = list(boatID = plankton$boatID), sum, na.rm = T)
und2.length <- aggregate(plankton$Und, by = list(boatID = plankton$boatID), length)
und2.prop <- und2.sum$x/und2.length$x

attach(vessel)
sam.loc <- vessel[c("samCode", "boatID")]
und1.sum <- merge(sam.loc, und1.sum, by.x = "boatID")

attach(und1.sum)
u1 <- und1.sum[LocCode ==1, ]
#a1$samCode <- as.numeric(a1$samCode)
u2 <- und1.sum[LocCode ==2, ]
#a2$samCode <- as.numeric(a2$samCode)
u3 <- und1.sum[LocCode ==3, ]
#a3$samCode <- as.numeric(a3$samCode)

bitmap("Undaria_positive_samples.tif", type = "tiffpack", width = 10, height = 10, res=600)
#windows()
par(mfrow=c(2,2))
plot(u1$boatID, u1$und1.prop, pch = u1$samCode, main = "Hull", xlim = c(30, 54), ylim = c(0,1), xlab = "", ylab = "")
plot(u2$boatID, u2$und1.prop, pch = u2$samCode, main = "Propeller rudder & anchor", xlim = c(30, 54), ylim = c(0,1), xlab = "", ylab = "")
plot(u3$boatID, u3$und1.prop, pch = u3$samCode, main = "Internal spaces", xlim = c(30, 54), ylim = c(0,1), xlab = "Boat reference", ylab = "Proportion of Undaria positive samples")
plot(u1$boatID, und2.prop, pch = u2$samCode, main = "Plankton samples", xlim = c(30, 54), ylim = c(0,1), xlab = "", ylab = "")
par(xpd = NA)
legend(18,1.5,  c("Sandringham yacht club", "Royal Yacht Club of Victoria", "Hobsons Bay Yacht Club"), pch=c(3,4,5), cex=0.8)
dev.off()

#Make a new data frame showing the proportion of positive samples by location and print this out as a table
Und3.sum <- aggregate(samples$Und, by = list(boatID = samples$boatID, LocID = samples$LocID), sum, na.rm = T)
Und3.length <- aggregate(samples$Und, by = list(boatID = samples$boatID, LocID = samples$LocID), length)

Und3.prop <- Und3.sum$x/Und3.length$x
Und3.sum <- data.frame(Und3.sum, Und3.length, Und3.prop)
Und3.sum <- Und3.sum[Und3.prop !=0, ]
write.table(Und3.sum, file= "Undaria_table.csv", append = F, sep = ",")

#Save the R workspace
save.image("H:/Projects/DEH Empirical Validation II/Reports/Data analysis - Nov 06.RData")

#************************************************************
#Models which were tried but not used in the analysis
#coMod1 <- lm(x ~ days2*paintType, modData)
#summary(coMod1)
#anova(coMod1)

#coMod2 <- lm(x ~ days2*paintRating, modData)
#summary(coMod2)
#anova(coMod2)

#coMod3 <- lm(x ~ days2 + paintRating, modData)
#summary(coMod3)

#coMod4 <- lm(x ~ midTrips + paintType, modData)
#summary(coMod4)

#coMod5 <- lm(x ~ midTrips*paintType, modData)
#summary(coMod5)

#coMod7 <- lm(x ~ days2*midTrips*paintType, modData)
#summary(coMod7)
#anova(coMod7)

scripts/R EVII analysis - fourth draft.r


library(fgsea)

CD38.genes = fread(file.path(PROJECT_DIR, "generated_data/CHI/robust_corr_all.genes.txt"))
gene.ISV = fread(file.path(PROJECT_DIR, "generated_data/CHI/CHI_genes_stability.txt"))
brown.L.E = fread(file.path(PROJECT_DIR, "generated_data/fgsea_with_wgcna_modules/brown-leading-edge-isv050-87genes.txt"))
##
## More information on results columns from DESEQ2
## http://bioconductor.org/packages/devel/bioc/vignettes/DESeq2/inst/doc/DESeq2.html
##
## [1] "mean of normalized counts for all samples"
## [2] "log2 fold change (MLE): condition treated vs untreated"
## [3] "standard error: condition treated vs untreated"
## [4] "Wald statistic: condition treated vs untreated"
## [5] "Wald test p-value: condition treated vs untreated"
## [6] "BH adjusted p-values"

dn.out = file.path(PROJECT_DIR, "generated_data/RNAseq")
if(!file.exists(dn.out)) stop("Please run the script R/RNAseq/Bcell_comparision_DEseq.r")
dn.fig = file.path(PROJECT_DIR, "figure_generation/RNAseq")
dir.create(dn.fig, showWarnings = F, recursive = T)

process <- function(fn, lists, tab1, main.text, y.shows.count, ylab) {
  # lists = brown.L.E
  tab1 = na.omit(tab1)
  setkey(tab1, stat)

  set.seed(2017110101)

  ### ranked by wald stat pvalue
  setkey(tab1, pvalue)
  ranks = tab1$pvalue
  names(ranks) = tab1$V1
  res.fgsea = fgsea(lists, ranks, nperm=100)
  fn.csv = paste0(file.path(dn.out, fn), ".csv")
  fwrite(file = fn.csv, res.fgsea, quote=T)

  fn.pdf = paste0(file.path(dn.fig, fn), ".pdf")
  pdf(fn.pdf, width=3, height=3.5)
         par(lwd=2)
         main = sprintf("%s (p=%0.2f)", main.text, res.fgsea$pval[1])
         xlab = "Gene rank based on\ndifferential expression"
         o = order(ranks)[which(names(ranks) %in% lists[[1]])]
         e = ecdf(o)
         if(y.shows.count) {
           y = e(o) * length(o)
         } else {
           y = e(o)
         }
         plot(o, y, type='l', xlim=c(1,length(ranks)),
              xlab=xlab, ylab=ylab, main=main, cex.main=0.7, cex.lab=0.7, las=1)
         if(y.shows.count) {
           lines(c(1,length(ranks)), c(1, length(o)), col="gray")
         } else {
           lines(c(0,length(ranks)), c(0, 1), col="gray")
         }
  dev.off()
}

tab1 = fread(file.path(dn.out, "resCD19pCD20pvsCD19pCD20pCD38p.csv"))

fn = "Brown-leading-edge-enrichment-in-CD19pCD20pvsCD19pCD20pCD38p-DE-genes"
process(fn, brown.L.E, tab1, main="Enrichment of\nSLE-Sig genes",
        y.shows.count=T, ylab = "Number of genes from SLE-Sig")

#########

process2 <- function(fn, lists, cols, labs, tab1, main.text, ylab) {
  ##lists = brown.L.E
  tab1 = na.omit(tab1)
  setkey(tab1, stat)

  set.seed(2017110101)

  ### ranked by wald stat pvalue
  setkey(tab1, pvalue)
  ranks = tab1$pvalue
  names(ranks) = tab1$V1
  res.fgsea = fgsea(lists, ranks, nperm=100)
  fn.csv = paste0(file.path(dn.out, fn), ".csv")
  fwrite(file = fn.csv, res.fgsea, quote=T)

  fn.pdf = paste0(file.path(dn.fig, fn), ".pdf")
  pdf(fn.pdf, width=5, height=4)
         par(lwd=2, xpd=T, mar=par()$mar+c(0,0,0,7))
         main = main.text
         xlab = "Gene rank based on\ndifferential expression"
         for(k1 in 1:length(lists)) {
           o = order(ranks)[which(names(ranks) %in% lists[[k1]])]
           e = ecdf(o)
           y = e(o)
           if(k1 == 1) {
           plot(o, y, type='l', xlim=c(1,length(ranks)), col=cols[k1],
                xlab=xlab, ylab=ylab, main=main, cex.main=0.7, cex.lab=0.7, las=1, ylim=c(0,1))
           } else {
             lines(o, y, col=cols[k1])
           }
         }
         lines(c(0,length(ranks)), c(0, 1), col="gray")
         labs.text = sprintf("%s (p=%0.2f)", labs, res.fgsea$pval)
         cat(labs.text)
         legend(max(o)*1.1,1, labs.text, col=cols, lty=rep("solid", length(cols)), cex=0.8)
  dev.off()
}

if(1) {
  process3 = function(ISV.cutoff) {
    x = CD38.genes[which(gene %in% gene.ISV[which(ISV >= ISV.cutoff)]$gene)]
    setkey(x, cor.mean.sd.ratio)
    x1 = c(list(tail(x,10)$gene),
           list(tail(x,30)$gene),
           list(tail(x,50)$gene))
    cols = c("red", "gold", "blue")
    labs = c("top 10", "top 30", "top 50")

    tab1 = fread(file.path(dn.out, "resCD19pCD20pvsCD19pCD20pCD38p.csv"))
    fn = sprintf("ISV%d-CD38-top-enrichment-in-CD19pCD20pvsCD19pCD20pCD38p-DE-genes", ISV.cutoff*100)
    tab1 = tab1[which(V1 %in% x$gene)]
    process2(fn, x1, cols, labs, tab1, main=sprintf("Starting with genes\nwith TSM ≥ %.2f", ISV.cutoff),
            ylab = "Fraction of genes")
  }
  process3(ISV.cutoff=0.5)
  process3(ISV.cutoff=0.75)
}


############################################################
# R script 4 of: Birds exposed to physiological stress     #
# post-breeding engage in stress-reducing social           #
# interactions in winter flocks                            #

# Running the repeatability analysis                       #

# author: Lionel Hertzog                                   #
############################################################

# set wd to local position of github folder
setwd("~/Documents/PostDoc_Ghent/Feeder_stuff/network_stress/")

# load libraries
library(plyr)
library(tidyverse)
library(igraph)
library(rptR)

# load the daily networks
lif <- list.files(path = "data/daily_networks/", pattern = "out")
li_net <- list()
for(i in seq_along(lif)){
  tmp <- read.table(file = paste0("data/daily_networks/",lif[i]),head=TRUE,sep=" ",stringsAsFactors = FALSE)
  li_net[[i]] <- graph_from_adjacency_matrix(as.matrix(tmp),mode="undirected",weighted = TRUE)
  names(li_net)[i] <- substr(lif[i],8,15)
  rm(tmp)
}

#compute centrality metrics for each bird, for each day
centr <- ldply(li_net,function(g) data.frame(PIT_TAG=attr(strength(g),"names"),betw = betweenness(g, directed = FALSE),
                                             eigen = eigen_centrality(g)$vector,
                                             deg = degree(g, mode = "all"),
                                             strength = strength(g)))

#load bird informations
bird <- read.table("data/bird_infos.csv",sep=",",head=TRUE,stringsAsFactors = FALSE)
bird$Year <- ifelse(bird$Period == "Autumn2015","2016",ifelse(bird$Period == "Autumn2016","2017",""))

# some data formatting
centr %>%
  rename(Date = .id) %>%
  filter(!is.na(betw) | !is.na(strength) | !is.na(deg)) %>%
  mutate(PIT_TAG = substr(PIT_TAG,2,11)) %>%
  mutate(Year = ifelse(Date < "20160430","2016","2017")) %>%
  left_join(bird[,c(2,3,9:18)],by=c("PIT_TAG","Year")) %>%
  filter(!is.na(MASS) & !is.na(SEX) & !is.na(AGE) & !is.na(SPEC)) -> cent_dd

# add network size for every day
size_l <- ldply(li_net, function(g) data.frame(Size = vcount(g)))
size_l %>%
  rename(Date = .id) %>%
  right_join(cent_dd, by = "Date") %>%
  filter(Date > 20161201) -> cent_dd2

# compute repeatability
m_rpt_b <- rpt(betw ~ Size + (1|PIT_TAG),grname = "PIT_TAG",data = cent_dd2, datatype = "Gaussian", npermut = 1000)
m_rpt_e <- rpt(eigen ~ Size + (1|PIT_TAG),grname = "PIT_TAG",data = cent_dd2, datatype = "Gaussian", npermut = 1000)
m_rpt_d <- rpt(deg ~ Size + (1|PIT_TAG),grname = "PIT_TAG",data = cent_dd2, datatype = "Gaussian", npermut = 1000)
m_rpt_s <- rpt(strength ~ Size + (1|PIT_TAG),grname = "PIT_TAG",data = cent_dd2, datatype = "Gaussian", npermut = 1000)

# the output plot
png("figures/repeatability_permutations.png",width=1200,height=1200)
par(mfrow=c(2,2),mar=c(5.1,5.1,4.1,2.1))
plot(m_rpt_b,type="permut",main="Permutation repeatabilities for\nbetwenness, mean repeatability: 0.16 [0.13 - 0.20]",cex.axis=1.7,cex.lab=1.7,cex.main=1.8)
plot(m_rpt_e,type="permut",main="Permutation repeatabilities for\neigenvector, mean repeatability: 0.21 [0.17 - 0.25]",cex.axis=1.7,cex.lab=1.7,cex.main=1.8)
plot(m_rpt_d,type="permut",main="Permutation repeatabilities for\ndegree, mean repeatability: 0.35 [0.30 - 0.40]",cex.axis=1.7,cex.lab=1.7,cex.main=1.8)
plot(m_rpt_s,type="permut",main="Permutation repeatabilities for\nstrength, mean repeatability: 0.39 [0.34 - 0.45]",cex.axis=1.7,cex.lab=1.7,cex.main=1.8)
dev.off()


# Figure S1

library(deming)
library(quantreg)
library(mvoutlier)
library(gamlss)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("GSE65682_series_all_mortality.Rdat")

# pool CAP and Sepsis patients
pheno$d2 <- as.character(pheno$d)
pheno$d2[pheno$d2 == "other"] <- "cap"

# Let's further trim lowly expressed / noisy genes
out <- sign2(affyData, explvar = 0.888265, qcrit = 1-1e-8)
affyData_out2 <- affyData[out$wfinal01 == 0, ]
# Compare
# plot(density(unlist(affyData[out$wfinal01 == 1, ])), xlim = c(1,14))
# lines(density(unlist(affyData[out$wfinal01 == 0, ])), col=2)

delta <- apply(affyData_out2, 1, function(x) {
  # calculate value of t test for each gene (CAP/Sepsis vs healthy)
  df <- data.frame( y = as.numeric(x), x =  pheno$d2)
  res <- t.test(y ~ x, df)
  # calculate difference for each gene (CAP/Sepsis vs healthy)
  d <- as.numeric(-diff(res$estimate))
  # estimate difference in variances for each gene (CAP/Sepsis vs healthy)
  m0 <- gamlss(y ~ 0 + x, sigma.fo = ~ 0 + x, data=df, family=NO)
  dv <- -diff(exp(m0$sigma.coefficients)^2)
  res <- c(d = d, p = res$p.value, t = res$statistic, dv = dv, v = var(df$y), mu = mean(df$y))
  res
})
delta <- data.frame(t(delta))
delta$padj <- p.adjust(delta$p, "bonferroni")

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

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")

pdf("FigureS1.pdf", width=11, height=8.5)

par(mfrow=c(2,3))
dfd <-  data.frame(v = delta$v, d = abs(delta$d))
R_dfd <- cor.test(dfd$d, dfd$v, method="spearman")
plot(d ~ v, data=dfd, las=1, xlab="variance", ylab="difference", xlim=c(0.05,10), ylim=c(0.01,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ v,, data =  log10(dfd)[ sign2(log10(dfd), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfd$estimate, 3)), paste0("p = ", round(R_dfd$p.value, 5)) ) )

dft <- data.frame(v = delta$v, t = abs(delta$t))
R_dft <- cor.test(dft$t, dft$v, method="spearman")
plot(t ~ v, data=dft, las=1, xlab="variance", ylab="t value", xlim=c(0.05,10), ylim=c(0.05,100), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(t ~ v,, data =  log10(dft)[ sign2(log10(dft), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dft$estimate, 3)), paste0("p = ", round(R_dft$p.value, 5)) ) )

dfp <- na.omit(data.frame(v = delta$v, p = -log10(delta$p)))
dfp <- dfp[dfp$p >0,]
R_dfp <- cor.test(dfp$p, dfp$v, method="spearman")
plot(p ~ v, data=dfp, las=1, xlab="variance", ylab="-log10(p)", xlim=c(0.05,10), ylim=c(0.005, 500), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(p ~ v,, data =  log10(dfp)[ sign2(log10(dfp), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfp$estimate, 3)), paste0("p = ", round(R_dfp$p.value, 5)) ) )

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

dfd <-  data.frame(mu = delta$mu, d = abs(delta$d))
R_dfd <- cor.test(dfd$d, dfd$mu, method="spearman")
plot(d ~ mu, data=dfd, las=1, xlab="mean", ylab="difference", xlim=c(2,15), ylim=c(0.01,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ mu, data = log10(dfd), 0.5), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfd$estimate, 3)), paste0("p = ", round(R_dfd$p.value, 5)) ) )

dft <- data.frame(mu = delta$mu, t = abs(delta$t))
R_dft <- cor.test(dft$t, dft$mu, method="spearman")
plot(t ~ mu, data=dft, las=1, xlab="mean", ylab="t value", xlim=c(2,15), ylim=c(0.05,100), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(t ~ mu, data = log10(dft), 0.5), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dft$estimate, 3)), paste0("p = ", round(R_dft$p.value, 5)) ) )

dfp <- na.omit(data.frame(mu = delta$mu, p = -log10(delta$p)))
dfp <- dfp[dfp$p >0,]
R_dfp <- cor.test(dfp$p, dfp$mu, method="spearman")
plot(p ~ mu, data=dfp, las=1, xlab="mean", ylab="-log10(p)", xlim=c(2,15), ylim=c(0.005, 500), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(p ~ mu, data = log10(dfp), 0.5), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfp$estimate, 3)), paste0("p = ", round(R_dfp$p.value, 5)) ) )

dev.off()


#' distransam.
#'
#'#' Randomly samples a time series groups and plates/sites to get equal N's for both
#' plates/sites and samples from each group
#'
#' Takes a data frame containing a time series, a column name for the grouping variable,
#' a column name for the plates/sites variable, and a column name for the sample id's.
#' Returns one with equal N's for both plates/sites and samples from each group.
#'
#' For unequal site numbers, it finds the minimum site number from the smallest group,
#' and randomly selects that number of sites from each group. For unequal sample sizes
#' between sites, it finds the minimum sample size from the smallest site, and randomly
#' selects that number of samples from each group. The returned object is a dataframe,
#' with all the same columns as the original data frame.
#'
#' @name distransam
#' @docType package
NULL


# 3. faza: Vizualizacija podatkov
library(rgdal)
library(rgeos)
library(mosaic)
library(maptools)
library(munsell)
library(StatMeasures)

#
#primerjava reakcijskih casov po disciplinah
#

#stolpicni graf stevilo medalj po lesku
graf.medalje <- ggplot(data = medalje %>% filter(stevilo>=8), mapping = aes(x=reorder(drzava, -stevilo), y=stevilo, fill=factor(lesk))) +
  labs(x="Država", y="Število") +
  scale_fill_manual("Lesk", values = c("zlato" = "gold", "srebro" = "gray50", "bron" = "peru")) +
  ggtitle("Število medalj posamezne države po lesku") +
  geom_bar(stat = 'identity', position = position_dodge2(preserve = "single")) +
  theme(axis.text.x = element_text(angle = 90, size = 8))

#graf povprecnega stevila prebivalcev
populacija$prebivalstvo <- round(populacija$prebivalstvo / 1000000, 2)
graf.prebivalstvo <- ggplot(data = populacija %>% filter(prebivalstvo>=60),
                            aes(x=reorder(drzava, -prebivalstvo), y=prebivalstvo)) +
  labs(x="Država", y="Število prebivalcev v milijonih") +
  ggtitle("Prebivalstvo") +
  geom_bar(stat = "identity") +
  theme(axis.text.x = element_text(angle = 90, size = 8))

#
# Uvozimo zemljevid sveta
#

zemljevid <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",

                             "ne_50m_admin_0_countries",mapa="./zemljevidi") %>% fortify()

# spremenit moras imena drzav v tabeli, da se bodo ujemala
# st.medalj$drzava %in% zemljevid$SOVEREIGNT
# bivših držav za katere imamo podatke ne bo na zemljevidu

st.medalj <- medalje %>% group_by(drzava) %>% summarise(st_medalj=sum(stevilo))

#zemljevid stevilo medalj
zemljevid.medalje <- ggplot() + geom_polygon(data=left_join(zemljevid,st.medalj, by=c("SOVEREIGNT"="drzava")),
                        aes(x=long, y=lat, group=group, fill=st_medalj), colour="black", size=0.1) +
  labs(x="", y="", fill="Število medalj") +
  ggtitle("Države glede na skupno število medalj")

#zemljevid: stevilo medalj na prebivalca
medalje.na.preb <- left_join(x=st.medalj, y=populacija, by="drzava")
medalje.na.preb$medalje_na_preb <- (medalje.na.preb$st_medalj / medalje.na.preb$prebivalstvo)
medalje.na.preb$skupina <- decile(medalje.na.preb$medalje_na_preb, decreasing = TRUE)

barva <- colorRampPalette(c("#71bfff", "#00132f"))

zemljevid.medalje.preb <- ggplot() + geom_polygon(data = left_join(zemljevid, medalje.na.preb, by=c("SOVEREIGNT"="drzava")),
                                                  aes(x=long, y=lat, group=group, fill=factor(skupina)), colour="black", size=0.1) +
  labs(x="", y="", fill="Skupina") +
  ggtitle("Število medalj na prebivalca po skupinah") +
  scale_fill_manual(values = barva(10), na.value = "grey50")


structure(list(Sepal.Length = c(5.1, 4.9, 4.7, 4.6, 5, 5.4, 4.6,
5, 4.4, 4.9, 5.4, 4.8, 4.8, 4.3, 5.8, 5.7, 5.4, 5.1, 5.7, 5.1,
5.4, 5.1, 4.6, 5.1, 4.8, 5, 5, 5.2, 5.2, 4.7, 4.8, 5.4, 5.2,
5.5, 4.9, 5, 5.5, 4.9, 4.4, 5.1, 5, 4.5, 4.4, 5, 5.1, 4.8, 5.1,
4.6, 5.3, 5, 7, 6.4, 6.9, 5.5, 6.5, 5.7, 6.3, 4.9, 6.6, 5.2,
5, 5.9, 6, 6.1, 5.6, 6.7, 5.6, 5.8, 6.2, 5.6, 5.9, 6.1, 6.3,
6.1, 6.4, 6.6, 6.8, 6.7, 6, 5.7, 5.5, 5.5, 5.8, 6, 5.4, 6, 6.7,
6.3, 5.6, 5.5, 5.5, 6.1, 5.8, 5, 5.6, 5.7, 5.7, 6.2, 5.1, 5.7,
6.3, 5.8, 7.1, 6.3, 6.5, 7.6, 4.9, 7.3, 6.7, 7.2, 6.5, 6.4, 6.8,
5.7, 5.8, 6.4, 6.5, 7.7, 7.7, 6, 6.9, 5.6, 7.7, 6.3, 6.7, 7.2,
6.2, 6.1, 6.4, 7.2, 7.4, 7.9, 6.4, 6.3, 6.1, 7.7, 6.3, 6.4, 6,
6.9, 6.7, 6.9, 5.8, 6.8, 6.7, 6.7, 6.3, 6.5, 6.2, 5.9), Sepal.Width = c(3.5,
3, 3.2, 3.1, 3.6, 3.9, 3.4, 3.4, 2.9, 3.1, 3.7, 3.4, 3, 3, 4,
4.4, 3.9, 3.5, 3.8, 3.8, 3.4, 3.7, 3.6, 3.3, 3.4, 3, 3.4, 3.5,
3.4, 3.2, 3.1, 3.4, 4.1, 4.2, 3.1, 3.2, 3.5, 3.6, 3, 3.4, 3.5,
2.3, 3.2, 3.5, 3.8, 3, 3.8, 3.2, 3.7, 3.3, 3.2, 3.2, 3.1, 2.3,
2.8, 2.8, 3.3, 2.4, 2.9, 2.7, 2, 3, 2.2, 2.9, 2.9, 3.1, 3, 2.7,
2.2, 2.5, 3.2, 2.8, 2.5, 2.8, 2.9, 3, 2.8, 3, 2.9, 2.6, 2.4,
2.4, 2.7, 2.7, 3, 3.4, 3.1, 2.3, 3, 2.5, 2.6, 3, 2.6, 2.3, 2.7,
3, 2.9, 2.9, 2.5, 2.8, 3.3, 2.7, 3, 2.9, 3, 3, 2.5, 2.9, 2.5,
3.6, 3.2, 2.7, 3, 2.5, 2.8, 3.2, 3, 3.8, 2.6, 2.2, 3.2, 2.8,
2.8, 2.7, 3.3, 3.2, 2.8, 3, 2.8, 3, 2.8, 3.8, 2.8, 2.8, 2.6,
3, 3.4, 3.1, 3, 3.1, 3.1, 3.1, 2.7, 3.2, 3.3, 3, 2.5, 3, 3.4,
3), Petal.Length = c(1.4, 1.4, 1.3, 1.5, 1.4, 1.7, 1.4, 1.5,
1.4, 1.5, 1.5, 1.6, 1.4, 1.1, 1.2, 1.5, 1.3, 1.4, 1.7, 1.5, 1.7,
1.5, 1, 1.7, 1.9, 1.6, 1.6, 1.5, 1.4, 1.6, 1.6, 1.5, 1.5, 1.4,
1.5, 1.2, 1.3, 1.4, 1.3, 1.5, 1.3, 1.3, 1.3, 1.6, 1.9, 1.4, 1.6,
1.4, 1.5, 1.4, 4.7, 4.5, 4.9, 4, 4.6, 4.5, 4.7, 3.3, 4.6, 3.9,
3.5, 4.2, 4, 4.7, 3.6, 4.4, 4.5, 4.1, 4.5, 3.9, 4.8, 4, 4.9,
4.7, 4.3, 4.4, 4.8, 5, 4.5, 3.5, 3.8, 3.7, 3.9, 5.1, 4.5, 4.5,
4.7, 4.4, 4.1, 4, 4.4, 4.6, 4, 3.3, 4.2, 4.2, 4.2, 4.3, 3, 4.1,
6, 5.1, 5.9, 5.6, 5.8, 6.6, 4.5, 6.3, 5.8, 6.1, 5.1, 5.3, 5.5,
5, 5.1, 5.3, 5.5, 6.7, 6.9, 5, 5.7, 4.9, 6.7, 4.9, 5.7, 6, 4.8,
4.9, 5.6, 5.8, 6.1, 6.4, 5.6, 5.1, 5.6, 6.1, 5.6, 5.5, 4.8, 5.4,
5.6, 5.1, 5.1, 5.9, 5.7, 5.2, 5, 5.2, 5.4, 5.1), Petal.Width = c(0.2,
0.2, 0.2, 0.2, 0.2, 0.4, 0.3, 0.2, 0.2, 0.1, 0.2, 0.2, 0.1, 0.1,
0.2, 0.4, 0.4, 0.3, 0.3, 0.3, 0.2, 0.4, 0.2, 0.5, 0.2, 0.2, 0.4,
0.2, 0.2, 0.2, 0.2, 0.4, 0.1, 0.2, 0.2, 0.2, 0.2, 0.1, 0.2, 0.2,
0.3, 0.3, 0.2, 0.6, 0.4, 0.3, 0.2, 0.2, 0.2, 0.2, 1.4, 1.5, 1.5,
1.3, 1.5, 1.3, 1.6, 1, 1.3, 1.4, 1, 1.5, 1, 1.4, 1.3, 1.4, 1.5,
1, 1.5, 1.1, 1.8, 1.3, 1.5, 1.2, 1.3, 1.4, 1.4, 1.7, 1.5, 1,
1.1, 1, 1.2, 1.6, 1.5, 1.6, 1.5, 1.3, 1.3, 1.3, 1.2, 1.4, 1.2,
1, 1.3, 1.2, 1.3, 1.3, 1.1, 1.3, 2.5, 1.9, 2.1, 1.8, 2.2, 2.1,
1.7, 1.8, 1.8, 2.5, 2, 1.9, 2.1, 2, 2.4, 2.3, 1.8, 2.2, 2.3,
1.5, 2.3, 2, 2, 1.8, 2.1, 1.8, 1.8, 1.8, 2.1, 1.6, 1.9, 2, 2.2,
1.5, 1.4, 2.3, 2.4, 1.8, 1.8, 2.1, 2.4, 2.3, 1.9, 2.3, 2.5, 2.3,
1.9, 2, 2.3, 1.8), Species = structure(c(1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
3L), .Label = c("setosa", "versicolor", "virginica"), class = "factor")), .Names = c("Sepal.Length",
"Sepal.Width", "Petal.Length", "Petal.Width", "Species"), class = "data.frame", row.names = c(NA,
-150L))


# Para identificar el tipo de variables que se obtuvieron con read.csv2
# y saber cuáles cambiar:
# str(cpnac2017)

# Para ver un resumen de una variable y comprobar que la conversión es correcta:
# summary(cpnac2017$cp_k413)
# no    si
# 8212 22431

# Si deseo observar el conteo de solo una de las causas de pérdida, debo
# convertir el vector en una tabla de contingencia usando la función table():
# tablaCausaPerdida <- table(cpnac2017$cp_k412)
# tablaCausaPerdida[names(tablaCausaPerdida)=="Sequía"]
# Sequía
#     79

# Para extraer únicamente las variables o columnas numéricas:

# library(dplyr)
# select_if(cpnac2017, is.numeric)


library(tidyr)
library(dplyr)
library(readr)
library(stringr)

data <- read_file("input.txt") %>%
  str_replace_all("(?<!\n)\n(?!\n)",",") %>%
  str_replace_all("\n\n","\n") %>%
  read_csv(col_names = FALSE) %>%
  unite("answers",c("X1","X2","X3","X4","X5"), remove = FALSE, na.rm = TRUE, sep = "") %>%
  mutate(answers = unique(str_split(answers, boundary("character"))))

# Part 1
data$part1_total <- 0
for(i in 1:nrow(data)) {
  data$answers[[i]] <- unique(data$answers[[i]])
  data$total[i] <- length(data$answers[[i]])
}
print(sum(data$total))

# Part 2
part2 <- tibble(data[2:6])
part2$count <- 0
part2$total <- 0
for(i in 1:nrow(part2)) {
  for(j in 1:5) {
    if(!is.na(part2[i,j])) {
      part2[i,6]<- part2[i,6] + 1
    }
  }
  for(letter  in letters) {
    match <- TRUE
    for(x in 1:as.numeric(part2[i,6])) {
      if(!str_detect(part2[i,x], letter)) {
        match <- FALSE
      }
    }
    if(match) {
      part2[i,7] <- part2[i,7] + 1
    }
  }
}
print(sum(part2$total))


#' @export
#' @title cor.prob
#' @description couldn't accurately describe
#' @param \code{X}
#' @param \code{dfr} degrees of freedom
#' @return \code{}
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
cor.prob <- function(X, dfr = nrow(X) - 2) {
	 R <- cor(X)
	 above <- row(R) < col(R)
	 r2 <- R[above]^2
	 Fstat <- r2 * dfr / (1 - r2)
	 R[above] <- 1 - pf(Fstat, 1, dfr)
	 R
}


# Baseball Data Wrangling w/ Vagrant, R, and Retrosheet Data

bdat <- inner_join(events, days, by='gameid') %>%
  mutate(HR=as.numeric(result==23)) %>%
  mutate(Year=substr(date, 1, 4)) %>%
  mutate(Month=substr(date, 5, 6)) %>%
  mutate(Day=substr(date, 7,8)) %>%
  mutate(RDate = as.Date(paste(Year, Month, Day, sep='-')))

luzinski <- bdat %>%
  filter(batterid=='luzig001') %>%
  select(HR, RDate) %>%
  arrange(RDate) %>%
  mutate(Total_HR=cumsum(HR)) %>%
  mutate(name='Greg Luzinski')

schmidt <- bdat %>%
  filter(batterid=='schmm001') %>%
  select(HR, RDate) %>%
  arrange(RDate) %>%
  mutate(Total_HR=cumsum(HR)) %>%
  mutate(name='Mike Schmidt')

ggplot()+
  geom_line(data=luzinski, aes(x=RDate, y=Total_HR,color=name))+
  geom_line(data=schmidt, aes(x=RDate, y=Total_HR,color=name))+
  xlab('Date')+
  ylab('Home Runs')+
  ggtitle('Schmidt/Luzinski 1975 HR Race')


###############################
## SetUp & Data Acquisition
###############################
###############################
## IMPORTS & WORKING DIRECTORY
###############################
imports <- c('xts','pROC','formula.tools', 'e1071')
invisible(lapply(imports, require, character.only = TRUE))
###############################
## DATA MINING - FROM STOOQ.COM
###############################
basket <- c('spy','qqq', 'tsla', 'pypl', 'sq', 'aapl', 'v', 'fb', 'amd','iq', 'uvxy')
basket2 <- c('tsla', 'pypl', 'sq', 'aapl', 'v', 'fb', 'amd')
start.date <- '20181001'
end.date <- '20190123'
###############################
## DATA MANIPULATION
###############################
stocks.df <- lapply(basket, GrabData, from = start.date, to = end.date)
names(stocks.df) <- basket
stocks.xts <- lapply(stocks.df, Frame2Xts) #Turn Data Frame int XTS Object
stocks.xts <- lapply(stocks.xts, PLag4) # Calcualte Lags
stocks.xts <- lapply(stocks.xts, na.omit) # Remove Entries with N/As
##############################
## TRAIN TEST SPLIT
##############################
c.stocks.xts <- as.xts(Reduce(merge, stocks.xts))
data.split <- TTSplit(c.stocks.xts['2018-10-11/2019-01-10'], p = 0.75)
oos.xts <- LiveTestSplit(c.stocks.xts,"01/14/19","01/18/2019") # Out of Sample/Live Test


CREATE TABLE buildingcentroids AS
SELECT osm_id, amenity, name, st_transform(st_centroid(way),32737)::geometry(point,32737) AS geom
FROM planet_osm_polygon
WHERE amenity NOT IN ('hospital', 'clinic') OR amenity IS null;

CREATE TABLE passableroads AS
(SELECT *, st_transform(way,32737)::geometry(linestring, 32737) AS geom
FROM planet_osm_line
WHERE highway IS NOT null
AND NOT highway = 'path'
AND NOT highway ='footway');

ALTER TABLE passableroads
DROP COLUMN way;

  SELECT buildingcentroids.*, st_distance(a.roadgeom, buildingcentroids.geom) AS roadaccess
FROM buildingcentroids CROSS JOIN lateral (
	SELECT passableroads.osm_id AS roadid, passableroads.geom AS roadgeom
	FROM passableroads
	ORDER BY passableroads.geom <-> buildingcentroids.geom
	LIMIT 1) a;

CREATE TABLE hospitalpolygons AS
SELECT *
FROM planet_osm_polygon
WHERE amenity = 'hospital'
OR amenity = 'clinic';

CREATE TABLE hospitalcentroids AS
SELECT *, st_transform(st_centroid(way),32737)::geometry(point,32737) AS geom
FROM hospitalpolygons;

ALTER TABLE hospitalcentroids
DROP COLUMN way;

ALTER TABLE buildingcentroids
ADD COLUMN ward varchar;

CREATE TABLE wardsreproject AS
SELECT *, st_transform(wards.geom,32737)::geometry(multipolygon,32737) AS geomw
FROM wards;

ALTER TABLE wardsreproject
DROP COLUMN geom;

UPDATE buildingcentroids
SET ward = ward_name
FROM wardsreproject
WHERE st_intersects(buildingcentroids.geom, wardsreproject.geomw);

CREATE TABLE hospitalaccess AS
SELECT buildingcentroids.*, st_distance(a.hospitalgeom, buildingcentroids.geom) AS hospitalaccess
FROM buildingcentroids CROSS JOIN lateral (
SELECT hospitalcentroids.osm_id AS hospitalid, hospitalcentroids.geom AS hospitalgeom
FROM hospitalcentroids
ORDER BY hospitalcentroids.geom <-> buildingcentroids.geom
LIMIT 1) a;

CREATE TABLE ambulanceaccess AS
SELECT hospitalaccess.*, buildingroadaccess.roadaccess AS roadaccess
FROM hospitalaccess LEFT JOIN buildingroadaccess
ON hospitalaccess.osm_id = buildingroadaccess.osm_id;

CREATE TABLE wardsummary AS
SELECT ward, avg(hospitalaccess) AS avghospitaldist, avg(roadaccess) AS avgroadaccess, count(osm_id) AS count
FROM ambulanceaccess
GROUP BY ward;


#Plot level aggregation.
#Getting plot, site and global means and sd's for all observations made at the plot level.
#This is currently total basal area and %ECM trees.
#clear environment, source paths.
rm(list=ls())
source('paths.r')
source('NEFI_functions/hierarch_plot.means_JAGS.r')

#load data.----
plot_data <- readRDS(dp1.10098.00_plot.level.path)
#micronutrient data.
nut <- readRDS(micronutrient_converted.path)

#y-values to constrain some things.
core_obs <- readRDS(core_obs.path)

#get plot level uncertainty on relEM.----
#if relEM <= 0, logit transform to -10.
#if relEM => 1, logit transform to  10.
relEM.sim <- list()
for(i in 1:1000){
  all <- rnorm(nrow(plot_data),plot_data$basal_live, plot_data$basal_live_sd)
   EM <- rnorm(nrow(plot_data),plot_data$basal_ECM , plot_data$basal_ECM_sd)
   relEM <- EM / all
   for(k in 1:length(relEM)){
     if(relEM[k] < 0.0001){relEM[k] <- 0.0001}
     if(relEM[k] > 0.9999){relEM[k] <- 0.9999}
   }
   b.relEM <- boot::logit(relEM)
   relEM.sim[[i]] <- b.relEM
}
relEM.sim <- do.call(cbind,relEM.sim)
b.relEM <- rowMeans(relEM.sim)
b.relEM_sd <- matrixStats::rowSds(relEM.sim)

#plot level output.----
plot.out <- plot_data
plot.out$b.relEM <- b.relEM
plot.out$b.relEM_sd <- b.relEM_sd

#aggregate up to site and glboal level.----
#tree data.
basal_live_ag <- hierarch_plot.means_JAGS(x_mu = plot_data$basal_live, plot_site = plot_data$siteID)
basal_dead_ag <- hierarch_plot.means_JAGS(plot_data$basal_dead, plot_site = plot_data$siteID)
basal_ECM_ag  <- hierarch_plot.means_JAGS(plot_data$basal_ECM , plot_site = plot_data$siteID)
basal_bECM_ag <- hierarch_plot.means_JAGS(plot.out$b.relEM   , plot_site = plot.out$siteID)
#micronutrient data.
 P_ag <- hierarch_plot.means_JAGS(x_mu = nut$P, x_sd = nut$P_sd, plot_site = nut$siteID)
 K_ag <- hierarch_plot.means_JAGS(x_mu = nut$K, x_sd = nut$K_sd, plot_site = nut$siteID)
Ca_ag <- hierarch_plot.means_JAGS(x_mu = nut$Ca, plot_site = nut$siteID)
Mg_ag <- hierarch_plot.means_JAGS(x_mu = nut$Mg, plot_site = nut$siteID)

#add plots to plot-level that are in y-observations but not present in this data product yet.----
to_add <- as.character(unique(core_obs[!(core_obs$plotID %in% plot.out$plotID),]$plotID))
to_add.site <- substring(to_add,1,4)
to_add <- data.frame(to_add.site, to_add)
colnames(to_add) <- c('siteID','plotID')
plot.out <- plyr::rbind.fill(plot.out, to_add)
nut$siteID <- NULL
plot.out <- merge(plot.out, nut, by = 'plotID', all = T)
plot.out$siteID <- substr(plot.out$plotID, 1, 4)

#site and global level output.
basal_live.site <- basal_live_ag$site.table[,c('siteID','Mean','SD')]
basal_live.glob <- basal_live_ag$glob.table[,c('Mean','SD')]
colnames(basal_live.site)[2:3] <- c('basal_live','basal_live_sd')
basal_dead.site <- basal_dead_ag$site.table[,c('siteID','Mean','SD')]
basal_dead.glob <- basal_dead_ag$glob.table[,c('Mean','SD')]
colnames(basal_dead.site)[2:3] <- c('basal_dead','basal_dead_sd')
basal_ECM.site  <- basal_ECM_ag$site.table [,c('siteID','Mean','SD')]
basal_ECM.glob  <- basal_ECM_ag$glob.table [,c('Mean','SD')]
colnames(basal_ECM.site)[2:3] <- c('basal_ECM','basal_ECM_sd')
basal_bECM.site <- basal_bECM_ag$site.table[,c('siteID','Mean','SD')]
basal_bECM.glob <- basal_bECM_ag$glob.table[,c('Mean','SD')]
colnames(basal_bECM.site)[2:3] <- c('b.relEM','b.relEM_sd')
P.site <- P_ag$site.table[,c('siteID','Mean','SD')]
P.glob <- P_ag$glob.table[,c('Mean','SD')]
colnames(P.site)[2:3] <- c('P','P_sd')
K.site <- K_ag$site.table[,c('siteID','Mean','SD')]
K.glob <- K_ag$glob.table[,c('Mean','SD')]
colnames(K.site)[2:3] <- c('K','K_sd')
Ca.site <- Ca_ag$site.table[,c('siteID','Mean','SD')]
Ca.glob <- Ca_ag$glob.table[,c('Mean','SD')]
colnames(Ca.site)[2:3] <- c('Ca','Ca_sd')
Mg.site <- Mg_ag$site.table[,c('siteID','Mean','SD')]
Mg.glob <- Mg_ag$glob.table[,c('Mean','SD')]
colnames(Mg.site)[2:3] <- c('Mg','Mg_sd')

#site level merge.
site.out <- merge(basal_live.site, basal_dead.site, all = T)
site.out <- merge(site.out, basal_ECM.site, all = T)
site.out <- merge(site.out, basal_bECM.site, all = T)
site.out <- merge(site.out, P.site, all = T)
site.out <- merge(site.out, K.site, all = T)
site.out <- merge(site.out, Ca.site, all = T)
site.out <- merge(site.out, Mg.site, all = T)

#add in sites in y data not present here.
to_add <- as.character(unique(core_obs[!(core_obs$siteID %in% site.out$siteID),]$siteID))
to_add <- data.frame(to_add)
colnames(to_add) <- 'siteID'
site.out <- plyr::rbind.fill(site.out,to_add)

#global level merge.
glob.out <- rbind(basal_live.glob,basal_dead.glob,basal_ECM.glob, basal_bECM.glob, P.glob, K.glob, Ca.glob, Mg.glob)
pred <- c('basal_live','basal_dead','basal_ECM','b.relEM','P','K','Ca','Mg')
glob.out <- cbind(pred,glob.out)

#save output.----
saveRDS(plot.out, plot_plot.path)
saveRDS(site.out, plot_site.path)
saveRDS(glob.out, plot_glob.path)