# install.packages("rlist")

# library(data.table)
# library(rlist)
# library(dplyr)
# library(MutationalPatterns)
# library(gridExtra)
# library(grid)
# library(ggplot2)
# library(lattice)

# Creata a list of path of the count matrix files

list_matrix <- list.files (path = "../Candidate_gene_analysis/helmsman/AtpE_helmsman", recursive = TRUE, full.name = TRUE, pattern = "subtype_count_matrix_spectra.txt")

list_matrix

# reading vcf files

mu_counts <- vector(mode = "list", length = length(list_matrix))

for (i in 1:length(list_matrix)) {
mu_counts [[i]] <- read.table(list_matrix[[i]], header=T, stringsAsFactors=F)
    }

# Drop ID column to retain only numeric

subset_df <- vector(mode = "list", length = length(list_matrix))

for (i in 1:length(list_matrix)) {
mu_counts [[i]] <- subset(mu_counts[[i]], select=-c(ID))
    }

# Finding norm of each column

df_t <- vector(mode = "list", length = length(list_matrix))

for (i in 1:length(list_matrix)) {

    temp_col_norm <- vector(mode = "list", length = length(mu_counts[[i]]))

    for (j in 1:length(mu_counts[[i]])){

        temp_col_norm[j] <- sqrt(sum(mu_counts[[i]][j]^2))
        }

   df_t[[i]] <- as.data.frame(temp_col_norm, col.names = colnames(mu_counts[[i]]))
}

# Add the first column to the transposed dataframe

library(rlist)

for (i in 1:length(list_matrix)) {
    filename_vec <- strsplit(list_matrix[[i]], split = "/")[[1]]
    filename_vec_2 <- strsplit(filename_vec[[5]], split = "_")[[1]]
    ID <- filename_vec_2[[1]]
    df_t[[i]]<- cbind(ID,df_t[[i]])
}
filename_vec
filename_vec_2
head(df_t[[1]])

# Format dataframe compatible to MutationalPatterns package

library(musigtools)
msm_MutationalPatterns <- vector(mode = "list", length = length(list_matrix))

for (i in 1:length(list_matrix)) {
msm_MutationalPatterns[[i]] <- format_counts(df_t[[i]], "MutationalPatterns")
    }

# Combine columns of msm_MutationalPatterns

library(rlist)
msm_MutationalPatterns_combined <- list.cbind(msm_MutationalPatterns)

library(MutationalPatterns)
pdf(file="plot_96_profile.pdf")
plot_96_profile(msm_MutationalPatterns_combined[,c(1,2)],condensed = TRUE, ymax=0.3)
dev.off()

library("NMF")

msm_MutationalPatterns_combined_nmf <- msm_MutationalPatterns_combined + 0.0001

estimate <- nmf(msm_MutationalPatterns_combined_nmf, rank= 1:10, method="brunet", nrun=10, seed=123456)
pdf(file="Nmf_rank.pdf")
plot(estimate)
dev.off()

nmf_res_2<- extract_signatures(msm_MutationalPatterns_combined_nmf, rank = 2, nrun = 10)

colnames(nmf_res_2$signatures) <- c("Signature A", "Signature B")
rownames(nmf_res_2$contribution) <- c("Signature A", "Signature B")

pdf(file="96_profile_Signature_2.pdf")
plot_96_profile(nmf_res_2$signatures, condensed = TRUE, ymax=0.1)
dev.off()

library(gridExtra)

pc1 <- plot_contribution(nmf_res_2$contribution, nmf_res_2$signature,
                          mode = "relative")
pc2 <- plot_contribution(nmf_res_2$contribution, nmf_res_2$signature,
                          mode = "absolute")
pdf(file="signature_2.pdf")
grid.arrange(pc1, pc2)
dev.off()

plot_contribution(nmf_res_2$contribution, nmf_res_2$signature,
                   mode = "absolute", coord_flip = TRUE)

pch1 <- plot_contribution_heatmap(nmf_res_2$contribution,
sig_order = c("Signature A", "Signature B"))
pch2 <- plot_contribution_heatmap(nmf_res_2$contribution, cluster_samples=FALSE)
pdf(file="contribution_heatmap_2.pdf")
grid.arrange(pch1, pch2, ncol = 2, widths = c(2,1.6))
dev.off()


My.dir<-file.path(root,'bw-sam-2014','sam')
run<-'run'
#run<-'baserun'

# make summary_table_raw.out file from SAM output
fit<-read.fit(file=file.path(My.dir,run,'sam'))
summary(fit)
a<-data.frame(Species.n=1,Year=fit[['years']], Rec=fit[['R']][,1] ,SSB=fit[['ssb']][,1],TSB=fit[['tsb']][,1],SOP=0,SOP.hat=1,mean.F=fit[['fbar']][,1])
write.table(a,file=file.path(data.path,'summary_table_raw.out'),row.names = F, quote = F)

minAge<-min(fit$res[,3])
maxAge<-max(fit$res[,3])
noN<-maxAge-minAge+1
noFleet<-max(fit$res[,2])

setwd(file.path(My.dir,'data'))

read.ices<-function(filen){
  # Function to read ices data files
  head<-scan(filen, skip=1, n=7, quiet=TRUE)
  minY<-head[3]
  maxY<-head[4]
  minA<-head[5]
  maxA<-head[6]
  C<-as.matrix(read.table(filen, skip=5, header=F))
  C<-C[,1:(maxA-minA+1)]
  rownames(C)<-minY:maxY
  colnames(C)<-minA:maxA
  return(C)
}

# MV variable names are changed, and obs yield is calculated
C<-read.ices('cn.dat')
WECA<-read.ices('cw.dat')
WEST<-read.ices('sw.dat')
propmat<-read.ices('mo.dat')
M<-read.ices('nm.dat')
obsYield<- apply(C*WECA[1:nrow(C),],1,sum)

setwd(data.path)

dimC<-dimnames(C)
dimCplus<-dimC
dimCplus[[1]]<-c(dimCplus[[1]],max(as.numeric(dimCplus[[1]]))+1)

FF<-exp(fit$stateEst[-nrow(fit$stateEst),-c(1:noN)])
FF<-cbind(FF,FF[,dim(FF)[[2]]]) # add age 10 as copy og age 9

N<-exp(fit$stateEst[,c(1:noN)])
#N<-exp(fit$stateEst[-nrow(fit$stateEst),c(1:noN)])
dimnames(N)<-dimCplus

#M<-rbind(M[dimC[[1]],],rep(-1,noN))
#WEST<-rbind(WEST[dimC[[1]],],rep(-1,noN))
#WECA<-rbind(WECA[dimC[[1]],],rep(-1,noN))
#propmat<-rbind(propmat[dimC[[1]],],rep(-1,noN))

dimnames(FF)<-dimC
FF<-rbind(FF[dimC[[1]],],rep(-1,noN))
CCC<-rbind(C[dimC[[1]],],rep(-1,noN))
dimnames(CCC)<-dimCplus
a<-data.frame(Year=rep(dimCplus[[1]],each=noN),
                 Quarter=1,Species.n=1,Age=rep(dimC[[2]],times=length(dimCplus[[1]])),
                 M1=0,
                  M=as.vector(t(M)),
                  M2=0,
                  C.obs=CCC,
                  F=as.vector(t(FF)),
                  N=as.vector(t(N)),
               west=as.vector(t(WEST)),
               weca=as.vector(t(WEST)),    # should use WECA, but they are identical
            propmat=as.vector(t(propmat))
            )

a<-data.frame(a,Z=a$M+a$F,N.bar=a$N*(1-exp(-a$M-a$F))/(a$M+a$F),BIO=a$N*a$west)
a<-data.frame(a,SSB=a$BIO*a$propmat,C.hat=a$N.bar*a$F,Yield=a$N.bar*a$F*a$weca)
write.table(a,file=file.path(data.path,'summary.out'),row.names = F, quote = F)

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

FF<-exp(fit$stateEst[-nrow(fit$stateEst),-c(1:noN)])
colnames(FF)<-paste(1:ncol(FF),c(rep('',ncol(FF)-1),'+'),sep='')
rownames(FF)<-fit.current$years[-length(fit.current$years)]

rw<-FF[-1,1]-FF[1:dim(FF)[1]-1,]

qpl<-function(x) {
 #cleanup()
 print(hist(x))
 X11()
 qqnorm(x)
 qqline(x)
}
qpl(rw)

Rec<-fit$R[,1]

rw<-Rec[-1]-Rec[1:length(Rec)-1]
qpl(rw)

a<-read.table( file=file.path(My.dir,'sam.std'),header=F,skip=1)
names(a)=c('no','param','value','std')
head(a)

a$expval<-exp(a$value)
head(a)

a$low<-exp(a$value-2*a$std)*1000
a$high<-exp(a$value+2*a$std)*1000
a$CV<-(a$high-a$low)/4/a$expval
head(a)


library(ggvis)
data(diamonds, package = "ggplot2")

shinyServer(function(input, output, session) {

  values <- reactiveValues(selected = rep(TRUE, nrow(diamonds)))

  diamonds %>% ggvis(~carat) %>%
    layer_histograms(fill.hover := "red", width = 0.1) %>%
    handle_hover(function(data, ...) {
      values$selected <- diamonds$carat >= data$xmin_ &
        diamonds$carat < data$xmax_
    }) %>%
    set_options(width = 400, height = 200) %>%
    bind_shiny("plot1")

  # Sub-histogram
  reactive(diamonds[values$selected, , drop = FALSE]) %>%
    ggvis(~carat) %>%
    layer_histograms(width = 0.01) %>%
    set_options(width = 400, height = 200) %>%
    bind_shiny("plot2")

})


source("cfg.r")
graphics.off()

expIDS = c(2, 3, 17, 16, 5, 8:15)

TC_impact_tab <- function(fire_dataset, pr_dataset, drought_var, ExpID = NULL, ...) {
    print(pr_dataset)
    print(drought_var)
    out = makeOrLoadEnsembles(fire_dataset = fire_dataset,
                              pr_dataset = pr_dataset, drought_var = drought_var, ...)
    control = out[[1]]
    if (!is.null(ExpID)) Toff = out[ExpID] else Toff = out

    extractTC <- function(i) layer.apply(i, function(i) i[[1]])

    Toff = lapply(Toff, extractTC)
    control  = extractTC(control)

    diffArea <- function(r) {
        r = r * raster::area(r[[1]])
        out = layer.apply(r, sum.raster, na.rm = TRUE)
        return(unlist(out))
    }

    Tofft = lapply(Toff, diffArea)
    controlt = diffArea(control)

    pot = lapply(Tofft, function(i) 100*(i - controlt)/i)
    pot_mean = sapply(pot, mean)
    pot_sd = sapply(pot, sd)

    out = rbind(pot_mean, pot_sd)
    rownames(out) = paste(pr_dataset, drought_var, c('mean', 'sd'), sep = '_')
    return(out)
}

outs = runAll_fire_pr_droughts(TC_impact_tab)

outs_out = c()
for (i in outs) for (j in i) for (k in j) {
    k = k[, expIDS]
    k[2, ] = k[2,]/k[1,]
    outs_out = cbind(outs_out, as.vector(k))
    colnames(outs_out) = c(head(colnames(outs_out), -1),
                           strsplit(rownames(k)[1], '_mean'))
}

rownames(outs_out) = paste(rep(expNames[expIDS], each = 2), c('mean', 'sd'))
write.csv(outs_out, file = 'outputs/TCimpactTab.csv')


context("Breaks - log")

test_that("Five ticks over 10^4 range work", {
  expect_equal(breaks_log()(10^(1:5)), 10^(1:5))
})

test_that("behaves nicely when inputs are wacky", {
  expect_equal(breaks_log()(c(0, NA)), 0)

  expect_equal(breaks_log()(c(0, Inf)), numeric())
  expect_equal(breaks_log()(c(NA, NA)), numeric())
  expect_equal(breaks_log()(c(-Inf, Inf)), numeric())
  expect_equal(breaks_log()(numeric(0)), numeric())
})

test_that("use integer base powers when at least 3 breaks are within range", {
  base <- 10
  expect_equal(
    breaks_log(base = base)(base^c(0, 2)),
    base^(0:2)
  )
  base <- 4
  expect_equal(
    breaks_log(base = base)(base^c(0, 2)),
    base^(0:2)
  )
  base <- 2
  expect_equal(
    breaks_log(base = base)(base^c(0, 2)),
    base^(0:2)
  )
})

test_that("add intermediate breaks when more breaks are needed", {
  base <- 10
  expect_equal(
    breaks_log(base = base)(base^c(2, 4) + c(1, -1)),
    c(100, 300, 1000, 3000, 10000)
  )
  expect_equal(
    breaks_log(base = base)(base^c(2, 3) + c(1, -1)),
    c(100, 200, 300, 500, 1000)
  )
  base <- 4
  expect_equal(
    breaks_log(base = base)(base^c(2, 4) + c(1, -1)),
    c(16, 32, 64, 128, 256)
  )
  base <- 3
  expect_equal(
    breaks_log(base = base)(base^c(2, 4) + c(1, -1)),
    c(9, 18, 27, 54, 81)
  )
  base <- 2
  expect_equal(
    breaks_log(n = 5, base = 2)(c(3, 100)),
    c(2, 4, 8, 16, 32, 64, 128)
  )
})

test_that("breaks_log arguments are forcely evaluated on each call #81", {
  subfun1 <- breaks_log(n = 5, base = 10)
  subfun2 <- breaks_log(n = 20, base = 5)

  subfuns <- list()
  cases_n <- c(5, 20)
  cases_base <- c(10, 5)
  for (i in 1:2) {
    subfuns[[i]] <- breaks_log(n = cases_n[i], base = cases_base[i])
  }
  expect_equal(subfun1(1:1000), subfuns[[1]](1:1000))
  expect_equal(subfun2(1:1000), subfuns[[2]](1:1000))
})

test_that("breaks_log with very small ranges fall back to extended_breaks", {
  expect_equal(
    breaks_log(n = 5, base = 10)(c(2.001, 2.002)),
    extended_breaks(n = 5)(c(2.001, 2.002))
  )
  expect_equal(
    breaks_log(n = 5, base = 10)(c(0.95, 1.1)),
    extended_breaks(n = 5)(c(0.95, 1.1))
  )

  # The switch to extended_breaks occurs at approximately the half-log point
  expect_equal(
    breaks_log(n = 5, base = 10)(c(0.95, 2.9)),
    extended_breaks(n = 5)(c(0.95, 2.9))
  )
  expect_false(identical(
    breaks_log(n = 5, base = 10)(c(0.95, 3)),
    extended_breaks(n = 5)(c(0.95, 3))
  ))
})


args <- commandArgs(trailingOnly = TRUE)
intab <- args[1]

data=read.table(intab, sep="\t", header=TRUE)

summary(data)
order=c("X50k_13", "X50k_7", "X100k_13", "X100k_7")
t.test(data[,1], data[,3])
t.test(data[,2], data[,4])

library(ggplot2)
pdf("geneCnts.pdf")
p=ggplot(data=data) + geom_violin(aes(x="X50k_13", y=data[,1])) + geom_violin(aes(x="X100k_13", y=data[,2])) + geom_violin(aes(x="X50k_7", y=data[,3])) + geom_violin(aes(x="X100k_7", y=data[,4])) + scale_x_discrete(limits=order) + labs (y = "Count of genes near cCRE")
p
dev.off()

q()


movies <- read.csv('movies_original.csv')

summary(movies$imdb_score)


temp<-read.csv(file.path(data.path,'Temp_data_August.csv'))
a<-data.frame(year=1974:2010,SSB=gem.SSB,REC.obs=gem.REC.obs,REC.hat=gem.REC.hat)
a<-merge(a,temp)
a$residual<-a$REC.obs- a$REC.hat

cleanup()
X11()
 par(mfcol=c(2,2))
plot(a$year,a$temp,type='b')
plot(a$year,a$REC.obs,type='b')

plot(a$SSB,a$REC.obs,type='p')

X11()
 par(mfcol=c(2,2))
plot(a$year,a$residual,type='b')
plot(a$temp,a$residual,type='p')
plot(a$SSB,a$residual,type='p')
plot(a$SSB,a$REC.obs,type='p')


require(graphics)
require(Matrix)

pdf(file="plots/Experiment2a.pdf",
  width=4.5, height=4.0, family="serif", pointsize=14)

data0 = read.table("results/Experiment2_Adult.dat", sep=",")[,2:3]
data1 = t(as.matrix(data0))

plot_colors <- c("cornflowerblue","black")

print(ncol(data1))

barplot( data1,
         space = c(0, 0.3),
         xlab = "",
         ylab = "",
         col=plot_colors,
         ylim = c(0,12500),
         log = "",
         axes = FALSE,
         names.arg = c("1","2","3","4","5","6","7","8","9","10","11","12","13"),
         args.legend = list(x="topright", bty="n", bty="n", ncol=1),
         legend.text = c("Evaluated", expression(paste("Valid (",sigma,")"))),
         beside = TRUE,
         line=-0.9
)

axis(2, las=1)
mtext(2,text="# Enumerated Slices",line=3.1)
mtext(1,text="Lattice Level L",line=1)

box()	              # box around plot
dev.off()


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(ggplot2)
library(plyr)
library(dplyr)
library(tidyr)
library(readr)
source('./_function_task_expand_name.r')
source('./_function_task_table.r')

best.range = 5000

best.model.step.fn = function (errors) {
  best.step = max(length(errors) - best.range, 0) + which.min(tail(errors, best.range))
  if (length(best.step) == 0) {
    return(length(errors))
  } else {
    return(best.step)
  }
}

first.solved.step = function (steps, errors, threshold) {
  index = first(which(errors < threshold))
  if (is.na(index)) {
    return(NA)
  } else {
    return(steps[index])
  }
}

t.confidence.interval = function (alpha, vec) {
  return(abs(qt((1 - alpha) / 2, length(vec) - 1)) * (sd(vec) / sqrt(length(vec))))
}

safe.median = function (vec) {
  if (length(vec) == 0) {
    return(NA)
  } else {
    return(median(vec))
  }
}

eps = read_csv('../results/function_task_static_mse_expectation.csv') %>%
  filter(simple == FALSE & parameter == 'default') %>%
  mutate(
    operation = revalue(operation, operation.full.to.short)
  ) %>%
  select(operation, input.size, overlap.ratio, subset.ratio, extrapolation.range, threshold)

name.input = '../results/function_task_static_ablation.csv'

dat = expand.name(read_csv(name.input)) %>%
  merge(eps)

dat$model = as.character(dat$model)
dat$model = ifelse(dat$regualizer == 0, paste0(dat$model, ', no $\\mathcal{R}_{bias}$'), dat$model)
dat$model = ifelse(dat$regualizer.oob == 0, paste0(dat$model, ', no W-clamp'), dat$model)

dat.last = dat %>%
  group_by(name) %>%
  #filter(n() == 201) %>%
  summarise(
    threshold = last(threshold),
    best.model.step = best.model.step.fn(metric.valid.interpolation),
    interpolation.last = metric.valid.interpolation[best.model.step],
    extrapolation.last = metric.test.extrapolation[best.model.step],
    interpolation.step.solved = first.solved.step(step, metric.valid.interpolation, threshold),
    extrapolation.step.solved = first.solved.step(step, metric.test.extrapolation, threshold),
    sparse.error.max = sparse.error.max[best.model.step],
    solved = replace_na(metric.test.extrapolation[best.model.step] < threshold, FALSE),
    model = last(model),
    operation = last(operation),
    seed = last(seed),
    size = n()
  )

dat.last.rate = dat.last %>%
  group_by(model, operation) %>%
  summarise(
    rate.interpolation = mean(interpolation.last < threshold),
    rate.extrapolation = mean(solved),

    median.interpolation.solved = safe.median(interpolation.step.solved[solved]),
    mean.interpolation.solved = mean(interpolation.step.solved[solved]),

    median.extrapolation.solved = safe.median(extrapolation.step.solved[solved]),
    mean.extrapolation.solved = mean(extrapolation.step.solved[solved]),
    ci.extrapolation.solved = t.confidence.interval(0.95, extrapolation.step.solved[solved]),

    median.sparse.error.max = safe.median(sparse.error.max[solved]),
    mean.sparse.error.max = mean(sparse.error.max[solved]),
    ci.sparse.error.max = t.confidence.interval(0.95, sparse.error.max[solved]),

    size = n()
  )

print(dat.last.rate)

save.table(
  dat.last.rate,
  "function-task-static-ablation",
  "Shows the success-rate for $\\mathcal{L}_{\\mathbf{W}_1, \\mathbf{W}_2} < \\mathcal{L}_{\\mathbf{W}_1^\\epsilon, \\mathbf{W}_2^*}$, at what global step the model converged at and the sparsity error for all weight matrices, with 95\\% confidence interval. The dataset is the multiplication problem with default parameters.",
  "../paper/results/function_task_static_ablation.tex",
  show.operation=FALSE,
  highlight.best=FALSE
)


library("nnet")
library("pmml")
library("httr")
library("RCurl")

HiddenAmount <- GET(paste("127.0.0.1:8012/?s=",symbol,sep=""))
RawData <- GET(paste("127.0.0.1:8011/?s=",symbol,sep=""))
HABsNet <- nnet(Rate~. , data = RawData , size = as.numeric(HiddenAmount))
pmml(HABsNet)

root.url<-'https://gist.githubusercontent.com/fawda123'
raw.fun<-paste(
  root.url,
  '5086859/raw/cc1544804d5027d82b70e74b83b3941cd2184354/nnet_plot_fun.r',
  sep='/'
)
script<-getURL(raw.fun, ssl.verifypeer = FALSE)
eval(parse(text = script))
rm('script','raw.fun')
plot(HABsNet)

save(HABsNet, file = "HABsPMML.pmml")


############################################CLIMATE GENERATOR MODEL####################################################
CLIMATE_GENERATOR <- function(mean_prcp_change_percent,mean_temp_change_celsius,num_year,climateData) {    #THIS SCRIPT PRODUCES MONTHLY CLIMATE DATA
    library(maps)
    library(mapproj)
    library(psych)
    library(MASS)
    #############################################GENERATE AVG ANNUAL CLIMATE OVER SPACE OF INTEREST#########################

    CLIMATE_AVG <- BASIN_CLIMATE_AVERAGING(climateData)
    #########################################KNN ON REGIONAL CLIMATE DATA###########################################
    SIMULATED_PRCP_ANNUAL_FINAL <- read.table("Prec_Gen_1.txt",header=TRUE)

    CLIMATE_AVG_LOWER <- read.table("CLIMATE_AVG_LOWER.txt",header=TRUE)
    WARM_PRCP_REGIONAL <- SIMULATED_PRCP_ANNUAL_FINAL
    OBS_PRCP_REGIONAL <- CLIMATE_AVG_LOWER[,1:2]
    YEARS <- OBS_PRCP_REGIONAL[,1]
    num_sim <- dim(WARM_PRCP_REGIONAL)[2]
    num_months <- num_year*12
    climate_var <- c("PRCP","TMAX","TMIN","TAVG")

    DISTANCE_SAMPLES <- array(NA,c(num_year,num_sim))
    AVG_MONTHLY_CLIMATE_VAR <- array(NA,c(num_months,length(climate_var),num_sim))

    for (samp in 1:num_sim) {
        for (j in 1:num_year) {
            Distance_Climate <- sqrt((WARM_PRCP_REGIONAL[j,samp] - OBS_PRCP_REGIONAL[,2])^2)
            FINAL_DISTANCES <- cbind(YEARS,Distance_Climate)
            FINAL_DISTANCES_SORTED <- FINAL_DISTANCES[which(rank(FINAL_DISTANCES[,2])%in% 1:8),]
            ORDERED_YR_PRCP <- cbind(FINAL_DISTANCES_SORTED[,1],OBS_PRCP_REGIONAL[match(FINAL_DISTANCES_SORTED[,1],YEARS),2])
            SAMPLING_WEIGHTS <- (1/FINAL_DISTANCES_SORTED[,2])^2/sum((1/FINAL_DISTANCES_SORTED[,2])^2) #inverse distance squared
            DISTANCE_SAMPLES[j,samp] <- sample(ORDERED_YR_PRCP[,1],size=1,prob=SAMPLING_WEIGHTS,replace=FALSE)
            AVG_MONTHLY_CLIMATE_VAR[((1+12*(j-1)):(12+12*(j-1))),,samp] <- data.matrix(CLIMATE_AVG[which(DISTANCE_SAMPLES[j,samp]==CLIMATE_AVG[,2]),3:6])
        }
    }
    #####################################GENERATE CLIMATE CHANGE TRENDS######################################################
   sim_length <- 50

    num_month_sim <- length(AVG_MONTHLY_CLIMATE_VAR[,1,1])
    YEAR_M <- rep(YEARS,each=12)
    MONTH_M <- rep(1:12,length(YEARS))

    sim <- sample(1:50,1)
    CLIMATE_TAVG <- AVG_MONTHLY_CLIMATE_VAR[,4,sim]
    CLIMATE_TMIN <- AVG_MONTHLY_CLIMATE_VAR[,3,sim]
    CLIMATE_TMAX <- AVG_MONTHLY_CLIMATE_VAR[,2,sim]
    CLIMATE_PRCP <- AVG_MONTHLY_CLIMATE_VAR[,1,sim]

    for (t in 1:length(mean_temp_change_celsius)) {
        for (p in 1:length(mean_prcp_change_percent)) {
            dir_ending <- paste("PRCP_MEAN_CHANGES",mean_prcp_change_percent[p],"TEMP_CHANGES",mean_temp_change_celsius[t],sep="_")

            TAVG_CLIM_SEQ <- seq(0,mean_temp_change_celsius[t],length.out=num_month_sim) + CLIMATE_TAVG
            TMIN_CLIM_SEQ <- seq(0,mean_temp_change_celsius[t],length.out=num_month_sim) + CLIMATE_TMIN
            TMAX_CLIM_SEQ <- seq(0,mean_temp_change_celsius[t],length.out=num_month_sim) + CLIMATE_TMAX
            PRCP_CLIM_SEQ <- seq(1,mean_prcp_change_percent[p],length.out=num_month_sim)*CLIMATE_PRCP

            FINAL_STOCHASTIC_MONTHLY <- cbind(YEAR_M,MONTH_M,PRCP_CLIM_SEQ,TMAX_CLIM_SEQ,TMIN_CLIM_SEQ,TAVG_CLIM_SEQ)
            colnames(FINAL_STOCHASTIC_MONTHLY) <- c("YEAR","MONTH","PRCP","TMAX","TMIN","TAVG")
            name <- paste(dir_ending,sep="")
            dirr <- paste(name,sep="/")
            write.table(FINAL_STOCHASTIC_MONTHLY,dirr)
        }
    }

    return(AVG_MONTHLY_CLIMATE_VAR)
}


################################
##
## virtal Class: rSpace
##
################################

## Access methods
setMethod("name", "rSpace", function(object) object@name)
## Replace methods
setReplaceMethod("name", "rSpace",
                 function(object, value){ object@name <- value; object})

################################
##
## Class: EuclideanSpace
##
################################

EuclideanSpace <- function(dimension = 1){
    new("EuclideanSpace", dimension = dimension)
}

## Access methods
setMethod("dimension", "EuclideanSpace", function(object) object@dimension)
## Replace methods
setReplaceMethod("dimension", "EuclideanSpace",
                 function(object, value){ object@dimension <- value; object})

## Initialize method
setMethod("initialize", "EuclideanSpace",
          function(.Object, dimension = 1) {
            .Object@dimension <-  dimension
            .Object@name <- gettext("Euclidean Space")
            validObject(.Object)
            .Object
          })

setValidity("EuclideanSpace", function(object){
  if(dimension(object) < 1)
    stop("dimension has to be a natural greater than 0")
  if(!identical(floor(dimension(object)), dimension(object)))
    stop("dimension has to be a natural greater than 0")
})

## extra methods

setMethod("liesIn", signature(object = "EuclideanSpace", x = "numeric"),
          function(object, x){
            if(dimension(object) ==  length(x))
              return(TRUE)
            return(FALSE)
          })

Reals <- function(){ new("Reals") }

################################
##
## Class: Naturals
##
################################

Naturals <- function(){ new("Naturals") }

setMethod("liesIn", signature(object = "Naturals", x = "numeric"),
          function(object, x){
            if(length(x) !=  1)
              return(FALSE)
            if(x <= 0)
              return(FALSE)
            if(!identical(floor(x), x+ 0.0))
              return(FALSE)
            else return(TRUE)
          })

################################
##
## Class: Lattice
##
################################

Lattice <- function(pivot = 0, width = 1, Length = 2, name = "a lattice")
   {
   L <- Length; w <- width; p <- pivot
   if(!identical(L+0.0,floor(L)) || length(L)>1 || L<1)
       stop("Length must be a positive integer")  ### may be Inf!!!
   if(length(w)>1 || (abs(width) <= getdistrOption("DistrResolution")) ||
                    !is.finite(w) )
       stop("width must be a non-zero, finite numeric of length 1")
   if(length(p)>1 || !is.finite(p))
       stop("pivot must be a finite numeric of length 1")
   new("Lattice", pivot=pivot, width = width, Length = Length,  name = name)
    }

setMethod("Length","Lattice", function(object) object@Length)
setMethod("width","Lattice", function(object) object@width)
setMethod("pivot","Lattice", function(object) object@pivot)

setReplaceMethod("Length","Lattice", function(object,value)
   {if(!identical(value,floor(value)) || length(value)>1 || value<1)
               stop("Length must be a positive integer")
    object@Length <- value; object})

setReplaceMethod("width","Lattice", function(object,value)
    {if(length(value)>1 || (abs(value) <= getdistrOption("DistrResolution")) ||
                    !is.finite(value) )
       stop("width must be a non-zero, finite numeric of length 1")
    object@width <- value; object})

setReplaceMethod("pivot","Lattice", function(object,value)
    {if(length(value)>1 || !is.finite(value))
       stop("pivot must be a finite numeric of length 1")
     object@pivot <- value; object})


vcontext("z-order")

# Utility functions
# =====================================================================

# Make an empty frame for use later, with 2x2 grid of 2x2cm squares
gtf <- gtable_matrix("gtf",
  matrix(rep(list(circleGrob(gp = gpar(fill = "grey95"))), 4), nrow = 2),
  widths  = unit(rep(4, 2), "cm"),
  heights = unit(rep(4, 2), "cm"))

# Make a list of four colored circleGrobs
circle_grobs <- function() {
  grobs <- list()
  for (i in 1:4) {
    grobs[[i]] <- circleGrob(
      r  = unit(3, "cm"),
      gp = gpar(fill = gray(i/4))
    )
  }
  grobs
}

# Turn a list of grobs into a 2-row gtable
# 'size' is the height/width of each cell, in cm
make_gtable <- function(name, grobs, size = 4) {
  gtable_matrix(name, matrix(grobs, nrow = 2),
    widths  = unit(rep(size, length(grobs)/2), "cm"),
    heights = unit(rep(size, 2), "cm"),
    clip = "off")
}

# No justification
# =====================================================================

# Make the colored grobs and put them in a gtable
gt <- make_gtable("gt", circle_grobs())

save_vtest2("overlapping circles, default z-order (lighter is higher)", {
  grid.newpage()
  grid.draw(gtf)
  grid.draw(gt)
})

gt$layout$z <- c(2, 4, 3, 1)
save_vtest2("overlapping circles, z-order 2 4 3 1", {
  grid.newpage()
  grid.draw(gtf)
  grid.draw(gt)
})

end_vcontext()


#########################################
## Exercise 2 Answers in R
## remember to read the comments
##
## Ken Benoit
#########################################

###### (5)

# Load in word frequency data
wfm <- read.csv("wordfreqm.csv", header=TRUE)
# move the first column to rownames
rownames(wfm) <- wfm[,1]
# drop first column of wfm so that wfm is only frequencies
wfm <- wfm[,-1]

###### (7a) total number of "types" (unique words) per document
(n.types <- colSums(wfm>0))

###### (7b) total number of words ("tokens") per document
(n.tokens <- colSums(wfm))

###### (7c) vocab diversity per document
n.types/n.tokens

###### (7d) median word freq per document
wfm.na <- wfm               # make a copy
wfm.na[wfm.na==0] <- NA     # replace 0's with NA
apply(wfm.na, 2, median, na.rm=TRUE)

###### (7e) most frequently used word among all documents
total <- rowSums(wfm)
total <- sort(total, decreasing=TRUE)

###### demonstrate Zipf's law
plot(log10(1:100), log10(total[1:100]),
     xlab="log(rank)", ylab="log(frequency)", main="Top 100 Words")
# regression to check if slope is approx -1.0
regression <- lm(log10(total[1:100]) ~ log10(1:100))
summary(regression)
confint(regression)


library(pbdPAPI)
library(Rcpp)

badcode <- "
#include <Rcpp.h>

// [[Rcpp::export]]
Rcpp::NumericMatrix bad(const int n)
{
  int i, j;
  Rcpp::NumericMatrix x(n, n);

  for (i=0; i<n; i++)
    for (j=0; j<n; j++)
      x(i, j) = 1.;

  return x;
}
"

goodcode <- "
#include <Rcpp.h>

// [[Rcpp::export]]
Rcpp::NumericMatrix good(const int n)
{
  int i, j;
  Rcpp::NumericMatrix x(n, n);

  for (j=0; j<n; j++)
    for (i=0; i<n; i++)
      x(i, j) = 1.;

  return x;
}
"

### Compile, link, load into R
sourceCpp(code=badcode)
sourceCpp(code=goodcode)

n <- 10000L

### Summary of cache misses
system.cache(bad(n))
system.cache(good(n))

### Ratio of total cache misses to total cache accesses
system.cache(bad(n), events="l2.ratio")
system.cache(good(n), events="l2.ratio")


# install necessary packages ----
library(ggplot2)
library(ggradar)
suppressPackageStartupMessages(library(dplyr))
library(scales)

#load necessary data
field_radar <- read_csv('field_radar.csv')

# data processing ----
fifa_radar <- fifa_radar %>%
  #as_tibble(rownames = 'classification') %>%
  mutate_at(vars(-'classification'),function(x) x/100)%>%

# visualization radar plot ----
ggradar(field_radar) +
  ggsave("field_radar_plot.png")


# run it from particular experiment data folder
# for example /1645703267
# before, make sure to run ./process.sh script
episode01_pulse <- read.csv("pulseTS1.csv", header = FALSE)
episode02_pulse <- read.csv("pulseTS2.csv", header = FALSE)
plot(episode01_pulse$V2, episode01_pulse$V1, type = 'l')
plot(episode02_pulse$V2, episode02_pulse$V1, type = 'l')

# total observations count
length(episode01_pulse$V1)

#install.packages("IDPmisc")
library(IDPmisc)

##
# example for peaks
##
## Analyses of Mass Spectrum between 12000 and 100'000
## without smoothing, without baseline substraction
data(MS)
MS1 <- log10(MS[MS$mz>12000&MS$mz<1e5,])
P <- peaks(MS1, minPH=0.02, minPW=0.001)
plot(MS1, type="l", xlab="log10(mz)", ylab="log10(I)")
points(P,col="blue",cex=1.6)

episode01_pulse1 <- log10(episode01_pulse[episode01_pulse$V1>300,])
pks02 <- peaks(x=episode01_pulse1$V1,y=episode01_pulse1$V2,minPH=0.02)
plot(episode01_pulse1, type="l", ylab="log10(mz)", ylab="log10(I)")
points(pks02,col="blue",cex=1.6)


#' Function for generating mean vector of SPECT image brightness values in different regions of the brain
#'
#' This function generates and plots a vector containing the mean SPECT image brightness value sin different regions of the brain.
#' @param data Accepts a list with first row containing adult data and second row containing child data.
#' @keywords Mean
#' @export
#' @examples
#' Mean_Vectors()

Mean_Vectors <- function(data){
	require(graphics)
	require(ggplot2)
	require(reshape)

	#Split data
	data_adults <- data[[1]]
	data_children <-data[[2]]

	#Isolate columns of interest
	data_adults <- data_adults[,c(381:636)]
	data_children <- data_children[,c(381:636)]

	#Separate data
	data_adults_baseline <- data_adults[,c(1:128)];
	data_adults_concentration <- data_adults[,c(129:256)];
	data_children_baseline <- data_children[,c(1:128)];
	data_children_concentration <- data_children[,c(129:256)];

	#Find mean vectors
	mean_adults_baseline = colMeans(data_adults_baseline, na.rm = TRUE)
	mean_adults_concentration = colMeans(data_adults_concentration, na.rm = TRUE)
	mean_children_baseline = colMeans(data_children_baseline, na.rm = TRUE)
	mean_children_concentration = colMeans(data_children_concentration, na.rm = TRUE)

	#Find standard errors
	se_mean_adults_baseline = apply(data_adults_baseline, 2, sd,  na.rm = TRUE) / sqrt(dim(data_adults_baseline)[2]);
	se_mean_adults_concentration = apply(data_adults_baseline, 2, sd,  na.rm = TRUE) / sqrt(dim(data_adults_baseline)[2]);
	se_mean_children_baseline = apply(data_adults_baseline, 2, sd,  na.rm = TRUE) / sqrt(dim(data_adults_baseline)[2]);
	se_mean_children_concentration = apply(data_adults_baseline, 2, sd,  na.rm = TRUE) / sqrt(dim(data_adults_baseline)[2]);

	#Convert to data frame
	df_mean_adults_baseline = data.frame(x = c(1:length(mean_adults_baseline)), y = mean_adults_baseline, ymax = mean_adults_baseline + se_mean_adults_baseline,
		ymin = mean_adults_baseline - se_mean_adults_baseline)
	df_mean_adults_concentration = data.frame(x = c(1:length(mean_adults_concentration)), y = mean_adults_concentration, ymax = mean_adults_concentration + se_mean_adults_concentration, 		ymin = mean_adults_concentration - se_mean_adults_concentration)
	df_mean_children_baseline = data.frame(x = c(1:length(mean_children_baseline)), y = mean_children_baseline, ymax = mean_children_baseline + se_mean_children_baseline, ymin = mean_children_baseline - se_mean_children_baseline)
	df_mean_children_concentration = data.frame(x = c(1:length(mean_children_concentration)), y = mean_children_concentration, ymax = mean_children_concentration + se_mean_children_concentration, ymin = mean_children_concentration - se_mean_children_concentration)

	#Plot vectors
	print(ggplot(df_mean_adults_baseline,aes(x,y)) + geom_point() + geom_errorbar(aes(ymax = ymax,ymin = ymin)) + geom_line() + xlab('Category Number') + ylab('Mean') + ggtitle('Adult Baseline Mean Vector'))

	print(ggplot(df_mean_adults_concentration,aes(x,y)) + geom_point() + geom_errorbar(aes(ymax = ymax,ymin = ymin)) + geom_line() + xlab('Category Number') + ylab('Mean') + ggtitle('Adult Concentration Mean Vector'))

	print(ggplot(df_mean_children_baseline,aes(x,y)) + geom_point() + geom_errorbar(aes(ymax = ymax,ymin = ymin)) + geom_line() + xlab('Category Number') + ylab('Mean') + ggtitle('Children Baseline Mean Vector'))

	print(ggplot(df_mean_children_concentration,aes(x,y)) + geom_point() + geom_errorbar(aes(ymax = ymax,ymin = ymin)) + geom_line() + xlab('Category Number') + ylab('Mean') + ggtitle('Children Concentration Mean Vector'))
}


model.asr <- readRDS(test_path("data", "model_asr.rds"))

test_that("vario_df produces a dataframe", {
    vg <- vario_df(model.asr)
    expect_equal(nrow(vg), 72)
    expect_equal(round(vg[1:6, "gamma"], 3), c(0.000, 50.171, 54.679, 91.463, 101.107, 96.750))
    expect_s3_class(vg, c("variogram", "data.frame"))
    expect_type(vg, "list")
})

test_that("variogram produces a plot", {
    expect_warning(
        v1 <- variogram(model.asr),
                   "Removed 81 rows containing non-finite values \\(stat_contour\\)")
    expect_type(v1, "list")
    expect_s3_class(v1, "ggplot")
    skip_on_os(c("windows", "mac"))
    vdiffr::expect_doppelganger(title = "Variogram produced", v1)
})

test_that("vario produces an error for other models and data types", {
    model.lm <- lm(Petal.Length~Petal.Width, data = iris)
    expect_error(variogram(model.lm), "model.obj must be an asreml model object")
    expect_error(variogram(1:3), "model.obj must be an asreml model object")
})


#download csv and have it in working directory
library(tidyverse)
library(dplyr)
library(ggplot2)
library(scales)
library(reshape2)

df <- read.csv('publish-performance.csv')

#convert start date into days
df$start_date <- substr(df$PublishStartDate,1,10)
df$start_date <- as.Date(df$start_date, '%Y-%m-%d')

#remove NAs
df <- df[!is.na(df$start_date),]

#make sure data is numeric
df$FileCount <- as.numeric(df$FileCount)
df$FileSize <- as.numeric(df$FileSize)
df$Duration <- as.numeric(df$Duration)

df_scheduled <- df[!(df$Type == "scheduled"),]
df_manual <- df[!(df$Type == "manual"),]

#pivot to get values
pivot <- df %>%
  group_by(start_date) %>%
  summarise(sumFileCount = sum(FileCount), sumFileSize = sum(FileSize)/100000, maxDuration = max(Duration), aveDuration = mean(Duration), count = n()*1000)

pivot_scheduled <- df_scheduled %>%
  group_by(start_date) %>%
  summarise(sumFileCount = sum(FileCount), sumFileSize = sum(FileSize)/100000, maxDuration = max(Duration), aveDuration = mean(Duration), count = n()*1000)

pivot_manual <- df_manual %>%
  group_by(start_date) %>%
  summarise(sumFileCount = sum(FileCount), sumFileSize = sum(FileSize)/100000, maxDuration = max(Duration), aveDuration = mean(Duration), count = n()*1000)

#get count of entries

#entries <- df %>%
#  group_by(start_date) %>%
#  summarise(count = n())

#melted <- melt(pivot, id=c("start_date"))

# graph the pivot table by month
#ggplot(data = melted, aes(x=`strftime(start_date, "%Y/%m")`, y=value, colour=variable)) + geom_line(aes(group=variable)) + geom_smooth(method = "lm", aes(group=variable)) + xlab("Month") + ylab("Words") + ggtitle("Number of words by page type by month") + scale_y_continuous(label=comma)

pivot_x <- pivot[!(pivot$maxDuration > 100000),]
pivot_x_scheduled <- pivot_scheduled[!(pivot_scheduled$maxDuration > 100000),]
pivot_x_manual <- pivot_manual[!(pivot_manual$maxDuration > 100000),]

pivot_gathered <- pivot_x %>%
  gather(key = 'key', value = 'value', -start_date)
pivot_gathered_scheduled <- pivot_x_scheduled %>%
  gather(key = 'key', value = 'value', -start_date)
pivot_gathered_manual <- pivot_x_manual %>%
  gather(key = 'key', value = 'value', -start_date)

ggplot(pivot_gathered, aes(x = start_date, y = value, color = key)) + geom_line() + geom_smooth(method="lm", aes(group=key)) + scale_y_continuous(sec.axis = sec_axis(~./1000))
ggplot(pivot_gathered_scheduled, aes(x = start_date, y = value, color = key)) + geom_line() + geom_smooth(method="lm", aes(group=key)) + scale_y_continuous(sec.axis = sec_axis(~./1000))
ggplot(pivot_gathered_manual, aes(x = start_date, y = value, color = key)) + geom_line() + geom_smooth(method="lm", aes(group=key)) + scale_y_continuous(sec.axis = sec_axis(~./1000))


###################################################################################
# R-script submitted as Supplementary Information to Seebens et al. (2016) No
# saturation in the accumulation of alien species worldwide. Nature Communications ....
#
# The script is called by the file Rcode_Seebens-etal_InvasionModel_PropPress_MAIN.r
# which reproduces the modelling results shown in Supplementary Fig. 5 of the article.
#
# This file simulates the model scenario: increase related to trade.
#
# The model implemented here describes the temporal development of the
# accumulation of alien species on an island, which were randomly depicted
# from an arbitrary mainland community. The probability of depicting a species
# may change during the simulation depending on the scenario to account for increases
# in propagule and colonisation pressures due to e.g. increases of trade volumes.
# For further details, consult the article.
# Five scenarios were simulated assuming different increases in the rate of
# introduction (constant, linear or exponential increase, related to import
# volumes or the number of founded botanic gardens).
#
# The code is free of use as long as the article is properly cited.
#
# Author of code: Hanno Seebens, Frankfurt, Germany
# 25. August, 2016
###################################################################################

##### Defintion of objects/variables for simulation ##############################

n_spec <- 50000 # number of species of the mainland community
t_max <- 202000 # max simulation time

n_bins <- 1000 # number of steps abundances of the mainland community are stored

add <- "trade" # type of increase in propagule pressure, required for output file

## Define temporal development of propagule pressure ###########################################################

## calculate propagule pressure as a function of trade volumes ###################
# Data of trade volumes exchanged between countries was obtained from
# Barbieri, K., Keshk, O. M. G. & Pollins, B. M. Trading Data: Evaluating our Assumptions
# and Coding Rules. Confl. Manag. Peace Sci. 26, 471–491 (2009)
# which can be obtained from the website of the Correlates of War project
# (http://cow.dss.ucdavis.edu/). We summed all import volumes during one year to get the following data set:
tradevolumes <- c(2824.36,3302.72,3498.57,4690.643348,4243.107772,4068.074288,4265.26402,4286.86385885,4308.4636977,4587.5280831,4457.3046798,4726.150118,4885.889034,4903.74268,4693.7286749,4251.1395468,4500.3876928,4708.2539095,4937.7313703,5261.3497903,5080.4954238,5356.2268168,5079.613416,5093.1870353,4675.09837839,4837.43,5542.2243267,5763.3489549,6113.871366,5946.8215987,6242.7125746,6043.0085968,6754.6609193,7207.1072126,7375.9590973,8890.8977095,9170.8353218,9700.6230691,9228.9249001,9416.8472911,11240.2178793,11142.0550889,12975.6087907,13650.9465671,663.99,688.8,850.85,1075.19,1014.16,1270.36,27001.5138406,16286.0630189,16431.4365836781,16789.958921,19942.4734399,23888.0553001,20045.7220522,25222.9514053,23930.5159105,25086.4668921,11304.4970258,15019.9187484,9560.822894,9724.3340318,13035.9453153,14262.0444,15136.7524288,19026.9543212,17037.236,908.59,836.17,803.83,858.83,929.33,1009.93,597.53,466.2400144,603.43000954,40964.5,38619.85,39562.519969,53415.8399789,53996.2748928,51440.4099831,53098.6399775,76576.4078413,86172.4998896,95784.2299971,84142.5598223,89642.9100396,103640.689967,111659.0499831,121784.3900075,132980.1804195,151777.1102024,165709.5600991,185027.489732,195069.4204046,219573.6206776,250473.3996974,289814.4701202,325607.6204952,384882.8989409,533155.7094613,779430.579651,819736.9712403,922389.9912038,1056641.7618211,1221401.0726998,1535430.0977182,1878929.0305306,1860191.3669799,1741758.8243669,1686503.6873806,1785857.3082899,1837419.8368386,1992144.7418941,2317998.8068929,2645574.9642046,2881269.4555296,3261169.9802596,3367026.7160529,3577351.8521061,3509237.3084483,4002362.9411779,4772371.1229506,5003356.0049492,5189842.805272,5158905.031539,5611173.347778,6322589.161256,6102383.715763)
importyears <- 1870:2001
trade_ts <- cbind(importyears,tradevolumes)
colnames(trade_ts) <- c("Year","Import")

# Trade data before 1870 are lacking. For comparison with the other model scenarios, we filled the gaps from 1800 to 1869
# with a constant value obtained in the year 1870. The value is likely to be too high, but given the still very low value
# compared to recent ones, it has no effect on the simulation outcome.
add_trade <- cbind(1800:1869,trade_ts[1,2]) # create arbitrary time series before 1870
colnames(add_trade) <- c("Year","Import")
trade_ts <- rbind(add_trade,trade_ts) # combine with original data set

trade_interpol <- approx(trade_ts[,1],trade_ts[,2],n=t_max)  # interpolate annual values to achieve a continuous development of increasing propagule pressure according to the simulation time steps
timeaxis <- trade_interpol[[1]] # identify time axis (for plotting)

# rescale accumulation of botanic gardens to get a propagule pressure comparable to other scenario runs
m_trade <- trade_interpol[[2]]
m_trade <- m_trade/mean(m_trade)*0.05 # mean propagule pressure 0.05 per step
m <- m_trade
####################################################################################################

# define basic characteristics of community size ###################################################
mlog <- seq(-3,1,length.out=5) # size of communities (defined as mean of log-normal distribution) for different model scenarios
sdlog <- 300 # standard deviation of log-normal distribution, constant
run_tot <- length(mlog)*length(sdlog) # number of model scenarios

######### SIMULATION ################################################################

island <- matrix(0,nr=t_max,nc=run_tot+1) # results file
island[,1] <- 1:t_max # include time axis in first column
all_main <- matrix(0,nr=n_bins,nc=run_tot) # store communities (abundances and species)
x <- 0 # counter
for (j in 1:length(mlog)){# loop through model scenarios depending on the number of defined means
  for (i in 1:length(sdlog)){# loop through model scenarios depending on the number of defined standard deviations
    x <- x + 1 # increase counter

    ## define mainland community ###############################################
    specabund <- dlnorm((seq(0.1,2,length.out=n_bins)),meanlog=mlog[j],sdlog=1)*10000
    axis1 <- seq(10,10000,length.out=n_bins) # steps of storing individuals per species (for plotting)
    specabund <- ceiling(specabund) # avoid decimals in abundances
    specabund <- round(specabund/sum(specabund)*n_spec) # rescale numbers

    tot_spec <- sum(specabund) # number of species
    abundances <- rep(axis1,round(specabund)) # set abundances
    tot_abund <- sum(abundances) # number of individuals
    all_main[,x] <- specabund # store community
    print(tot_spec)
    print(tot_abund)

    #### simulation ############################################################################
    for (t in 1:t_max){ # loop through time steps

      ## select individual from mainland community and transfer it on the island
      if (runif(1)<m[t]){  # determine if new individual arrives, depending on propagule pressure m at time t
        ind <- runif(1)*tot_abund # if individual arrives, determine new individual
        spec <- max(which(c(0,cumsum(abundances))<=ind)) # select species accordingly
        # if (spec==-Inf) break #
        island[t,x+1] <- spec # store species entry at time t and scenario x
      }
    }
    ## process time series of arriving individuals
    dupl <- duplicated(island[,x+1]) # identify duplicated entries of species in time series
    island[which(dupl),x+1] <- 0 # set all duplicated entries to zero (i.e., remove all entries after the first occurrence of that species)
    island[which(!dupl),x+1] <- 1  # set all species numbers to 1 (species identity is not required any more)
  }
}

## calculate number of first records per year #####################
ts_round <- round(timeaxis) # get an annual time axis
isl_agg <- matrix(NA,nr=length(unique(ts_round)),nc=dim(island)[2]-1) # results files
for (i in 2:dim(island)[2]){
  isl_agg[,i-1] <- tapply(island[,i],ts_round,sum) # sum up number of new species per year
}

### output (only the information which is required to create the plot) ######################################
write.table(isl_agg,paste("SimInvAcc_VarMain_island_",add,".csv",sep=""),sep=";",row.names=F)
write.table(unique(ts_round),paste("SimInvAcc_VarMain_realtime_",add,".csv",sep=""),sep=";",row.names=F)
write.table(all_main,paste("SimInvAcc_VarMain_allmain_",add,".csv",sep=""),sep=";",row.names=F)
write.table(axis1,paste("SimInvAcc_VarMain_axis1_",add,".csv",sep=""),sep=";",row.names=F)
write.table(timeaxis[seq(1,t_max,length.out=200)],paste("SimInvAcc_VarMain_timeaxis_",add,".csv",sep=""),sep=";",row.names=F)
write.table(m[seq(1,t_max,length.out=200)],paste("SimInvAcc_VarMain_PropPress_",add,".csv",sep=""),sep=";",row.names=F)

information/Seebens - 2017 - No saturation in the accumulation of alien species/Rcode_Seebens-etal_InvasionModel_Trade.r


library(data.table)
library(stringr)

cmd_args <- commandArgs()
CURRENTDIR <- dirname(regmatches(cmd_args, regexpr("(?<=^--file=).+", cmd_args, perl=TRUE)))
ROOTDIR <- dirname(dirname(CURRENTDIR))
OUTDIR <- file.path(ROOTDIR, "output")

# OUTDIR <- "../output"

SUBOUTDIR <- "SMMALA"

nmcmc <- 110000
nburnin <- 10000
npostburnin <- nmcmc-nburnin

ci <- 4
pi <- 2

chains <- t(fread(
  file.path(OUTDIR, SUBOUTDIR, paste("chain", str_pad(ci, 2, pad="0"), ".csv", sep="")), sep=",", header=FALSE
))

chainmean <- mean(chains[, pi])

pdf(file=file.path(OUTDIR, SUBOUTDIR, "logit_smmala_traceplot.pdf"), width=10, height=6)

plot(
  1:npostburnin,
  chains[, pi],
  type="l",
  ylim=c(-1.2, 3),
  col="steelblue2",
  xlab="",
  ylab="",
  cex.axis=1.8,
  cex.lab=1.7,
  yaxt="n"
)

axis(
  2,
  at=seq(-1, 3, by=1),
  labels=seq(-1, 3, by=1),
  cex.axis=1.8,
  las=1
)

lines(
  1:npostburnin,
  rep(chainmean, npostburnin),
  type="l",
  col="black",
  lwd=2
)

dev.off()


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Technical Analysis Functions
# Copyright (C) 2011  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Backfill NA's with last non NA value, similar to na.locf(y,na.rm=FALSE)
# http://r.789695.n4.nabble.com/Vector-replace-0-elements-without-using-a-loop-td2
###############################################################################

###############################################################################
#' @export
###############################################################################
ifna.prev <- function(y)
{
	y1 = !is.na(y)

	# in case y starts with NA
	y1[1]=T

	return( y[cummax( (1:length(y)) * y1 )]	)
}

# index of non NAs filled from left to right
###############################################################################
#' @export
###############################################################################
ifna.prevx <- function(y) {
	y1 = !is.na(y)

	# in case y starts with NA
	y1[1]=T

	return( cummax( (1:length(y)) * y1 ) )
}

# index of non NAs filled from right to left
###############################################################################
#' @export
###############################################################################
ifna.prevx.rev <- function(y) {
	y1 = !is.na(y)

	y1[length(y)] = T
	y1[!y1] = Inf

    rev(cummin(rev((1:length(y)) * y1)))
}

# test
ifna.prevx.test <- function() {
	y = c(NA,1,1,NA,2,2,NA,NA)

	y[ifna.prevx(y)]
	y[ifna.prevx.rev(y)]
}

###############################################################################
# Cross - gives a "1" or true on the day that ARRAY1 crosses above ARRAY2. Otherwise the result is "0".
# To find out when ARRAY1 crosses below ARRAY2, use the formula cross(ARRAY2, ARRAY1)
# http://www.amibroker.com/guide/afl/afl_view.php?id=34
#' @export
###############################################################################
cross <- function( array1, array2, eq=F ) {
	iif(eq, array1 >= array2, array1 > array2) & iif(len(array1) > 1, mlag(array1), array1) < iif(len(array2) > 1, mlag(array2), array2)
}

#' @export
cross.up <- function( array1, array2 ) { cross( array1, array2 ) }

#' @export
cross.dn <- function( array1, array2 ) { cross( array2, array1 ) }

#' @export
cross.up.eq <- function( array1, array2 ) { cross( array1, array2, T ) }

#' @export
cross.dn.eq <- function( array1, array2 ) { cross( array2, array1, T ) }

###############################################################################
# Percentile Rank over given window, works for both single column and matrix
# If data is matrix, lookup value in the first column across all columns
#' @export
###############################################################################
percent.rank <- function
(
	data, 	# data
	n=252	# window length
)
{
	# simple percent rank function
    pctRank <- function(x,i) sum(x[i,1] >= x[(i- (n-1) ):i,])

    out = data

    # Apply the percent rank function to the coredata of our results
    data = coredata(data)
    	if( is.null(dim(data)) ) dim(data) = c(len(data),1)
    rng = n:len(data)

    out[] = c( rep(NA,(n-1)), sapply(rng, function(i) pctRank(data, i) / n) )

    return(out)
}

###############################################################################
# Percentile Rank over given window, multiple arrays version
#' @export
###############################################################################
percent.rankM <- function
(
	..., 	# data
	n = 252	# window length
)
{
	data = variable.number.arguments( ... )

    out = data[[1]]

	for(j in 1:len(data)) data[[j]] = coredata(data[[j]])

	rank.data = data[[ len(data) ]]

	# simple percent rank function
    pctRank <- function(x,i) sum(rank.data[i] >= x[(i- (n-1) ):i])

    # Apply the percent rank function to the coredata of our results
    rng = n:len(rank.data)

    out[] = 0
    for(j in 1:len(data))
    	out[] = out[] + c( rep(NA,(n-1)), sapply(rng, function(i) pctRank(data[[j]], i) / n) )

    return(out/len(data))
}

###############################################################################
# DV2 indicator (DVB)
# http://blog.fosstrading.com/2009/07/david-varadis-rsi2-alternative.html
# http://davesbrain.blogs.com/mindmoneymarkets/2010/08/dvib-combo-.html
#' @export
###############################################################################
DV <- function
(
	HLC, 			# HLC data
	n=2, 			# window length
	bounded=FALSE	# flag to compute percentrank
)
{
	# Calculate each day's high/low mean
  	hlMean = rowMeans( HLC[,-3] )

  	# Calculate the running Mean of the Close divided by the high/low mean
  	res = runMean( HLC[,3] / hlMean, n ) - 1

  	# If we want the bounded DV...
  	if(bounded) res = percent.rank(res, 252)

  	return(res)
}

###############################################################################
# DVI indicator
# http://cssanalytics.wordpress.com/2010/07/29/dvi-and-spy-performance/
# http://marketsci.wordpress.com/2010/07/29/exploring-the-dvi-indicator-extreme-readings/
# http://marketsci.wordpress.com/2010/07/27/css-analytics%E2%80%99-dvi-indicator-revealed/
# http://dvindicators.cssanalytics.com/community/?vasthtmlaction=viewtopic&t=47.0
# http://quantingdutchman.wordpress.com/2010/07/28/dvi-indicator-for-amibroker/
# http://davesbrain.blogs.com/mindmoneymarkets/2010/08/dvib-combo-.html
#' @export
###############################################################################
DVI <- function
(
	x, 				# prices
	n=250 			# window length
)
{
	# Calculate return
	ColumnC = ( x / runMean(x,3) ) - 1
	ColumnD = ( runMean( ColumnC , 5 ) + ( runMean( ColumnC , 100 ) / 10 ) ) / 2
	ColumnE = runMean( ColumnD , 5 )

	ColumnF = iif( x > mlag(x) , 1 , -1 )
	ColumnG = ( runSum( ColumnF , 10 ) + ( runSum( ColumnF , 100 ) / 10 ) ) / 2
	ColumnH = runMean( ColumnG , 2 )

	DVI.magnitude = percent.rank( ColumnE , n )
	DVI.stretch = percent.rank( ColumnH, n )
	DVI = ( 0.8 * DVI.magnitude ) + ( 0.2 * DVI.stretch )

	return(list(DVI=DVI, DVI.magnitude=DVI.magnitude, DVI.stretch=DVI.stretch))
}

###############################################################################
# TSI indicator
# http://engineering-returns.com/tsi/
#' @export
###############################################################################
TSI <- function
(
	HLC, 	# HLC data
	n=10	# window length
)
{
	HLC = apply(HLC, 2, ifna.prev)

	ratio = ( HLC[,3] - mlag(HLC[,3], n) ) / ATR( HLC , n )[, "atr"]
	out = SMA( SMA( ratio , n ), 100 )
	return(out)
}

###############################################################################
# Ulcer Index: alternative to Standard Devation
# http://en.wikipedia.org/wiki/Ulcer_index
# http://stockcharts.com/school/doku.php?id=chart_school:technical_indicators:ulcer_index
#' @export
###############################################################################
ulcer.index <- function
(
	x, 		# prices
	n=14	# window length
)
{
	#sqrt(runSum((100*( x - runMax(x,n) ) / runMax(x,n))^2, n) / n)
	sqrt(runSum(( x / runMax(x,n) -1 )^2, n) / n)
}

###############################################################################
# Rolling EV Ratio: A Trend Indicator or Performance Measurement Statistic
# cumulative W% (up periods/total periods) x W/L ratio (sum of wins/sum of losses)
# http://cssanalytics.wordpress.com/2010/06/02/rolling-ev-ratio-a-trend-indicator-or-performance-measurement-statistic/
# http://davesbrain.blogs.com/mindmoneymarkets/2010/07/will-mean-reversion-bounce-back.html
#' @export
###############################################################################
ev.ratio <- function
(
	data, 	# data
	n = 252	# window length
)
{
	ret = coredata(data / mlag(data) - 1)

    rng = n:len(data)

    out = data
   	out[] = c( rep(NA,(n-1)), sapply(rng,
   		function(i) {
			r = ret[(i- (n-1) ):i]
    		-sum(r > 0) / n * sum(r[r > 0]) / sum(r[r < 0])
    	}))
	return(out)
}

###############################################################################
# Sample rotation Strategies
###############################################################################
# Select top N for each period
# http://www.etfscreen.com/sectorstrategy.php
#' @export
###############################################################################
ntop <- function
(
	data,		# matrix with observations
	topn = 1, 	# top n
	dirMaxMin = TRUE
)
{
	# work with matrix
	temp = coredata(data)
	if(is.logical(temp)) temp[] = iif(!temp,NA,temp)

	# equal weight all assets special case
	if(topn == ncol(data)) {
		index = is.na(temp)
			temp[index] = 0
			temp[!index] = 1

		out = data
		out[] = ifna(temp / rowSums(temp),0)
		return( out )
	}

	index.n = rowSums(!is.na(temp))
	for( i in 1:nrow(data) ) {
		if( index.n[i] > 0 ) {
			o = sort.list(temp[i,], na.last = TRUE, decreasing = dirMaxMin)
			temp[i,] = 0
			n = min(topn, index.n[i])
			temp[i,o[1:n]] = 1/n
		} else temp[i,] = 0
	}

	# work with xts
	out = data
	out[] = temp
	out
}

#' @export
ntop.helper <- function
(
	x, 		# matrix with observations
	n=1, 	# top n
	dirMaxMin = TRUE
)
{
	x = as.vector(x)
	index.n = sum(!is.na(x))

	if( index.n > 0 ) {
		o = sort.list(x, na.last=TRUE, decreasing = dirMaxMin)
		x[] = 0
		n = min(n, index.n)
		x[o[1:n]] = 1/n
	} else x[] = 0

	x
}

ntop.speed.test <- function()
{
	#to.monthly(IEF, indexAt='endof')
	#IEF = adjustOHLC(IEF, use.Adjusted=TRUE)

	load.packages('quantmod')
	tickers = spl('XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU,IWB,IWD,IWF,IWM,IWN,IWO,IWP,IWR,IWS,IWV,IWW,IWZ')

	data <- new.env()
	getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
		for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)
	bt.prep(data, align='keep.all', dates='1970::2011')

	prices = data$prices
	n = len(tickers)

	a = coredata(prices)
	b = a
	c = a

tic(12)
	for( i in 1:nrow(b) ) {
		b[i,] = ntop.helper(b[i,], n, T)
	}
toc(12)

	# working directly with xts is alot slower
tic(12)
	d = prices
	for( i in 1:nrow(c) ) {
		d[i,] = ntop.helper(c[i,], n, T)
	}
toc(12)

	range(b-d)

}

###############################################################################
# Select top N for each period, and keep them till they drop below keepn rank
# http://www.etfscreen.com/sectorstrategy.php
#' @export
###############################################################################
ntop.keep <- function
(
	data, 		# matrix with observations
	topn = 1, 	# top n
	keepn = 1, 	# keep n
	dirMaxMin = TRUE
)
{
	# work with matrix
	temp = coredata(data)
	if(is.logical(temp)) temp[] = iif(!temp,NA,temp)
	index.n = rowSums(!is.na(temp))

	for( i in 1:nrow(temp) ) {
		if( index.n[i] > 0 ) {
			x = temp[i,]
			o = sort.list(x, na.last = TRUE, decreasing = dirMaxMin)
			x[] = 0
			n = min(topn, index.n[i])
			x[o[1:n]] = 1

			# keepn logic
			if( i >= 2 ) {
				y = temp[(i-1),]		# prev period selection
				n1 = min(keepn, index.n[i])
				y[-o[1:n1]] = 0		# remove all not in top keepn

				index1 = y != 0
					index1.n = sum(index1)
				if( index1.n > 0 ) {
					x[] = 0
					x[index1] = 1

					for( j in 1:n ) {
						if( sum(x) == topn ) break
						x[o[j]] = 1
					}
				}
			}
			temp[i,] = x/sum(x)
		} else temp[i,] = 0
	}

	# work with xts
	out = data
	out[] = temp
	out
}

###############################################################################
# Rank observations in each row
#' @export
###############################################################################
br.rank <- function(x)
{
	t(apply(coredata(-x), 1, rank, na.last='keep'))
}

#' @export
bt.rank <- function(x, dirMaxMin = TRUE, do.sort = F )
{
res = NA * x
res[] = {
	if(!do.sort) {
		if(dirMaxMin)
			t(apply(coredata(-x), 1, rank, na.last='keep'))
		else
			t(apply(coredata(x), 1, rank, na.last='keep'))
	} else {
		index = 1:ncol(x)
		x = coredata(x)
		out = t(apply(x, 1, function(y) {
			temp = sort.list(y, na.last = TRUE, decreasing = dirMaxMin)
			temp[temp] = index
			temp
			}
		))
		out[is.na(x)] = NA
		out
	}
}
res
}

###############################################################################
# SuperSmoother filter 2013 John F. Ehlers
# http://www.stockspotter.com/files/PredictiveIndicators.pdf
#' @export
###############################################################################
super.smoother.filter <- function(x) {
    a1 = exp( -1.414 * pi / 10.0 )
    b1 = 2.0 * a1 * cos( (1.414*180.0/10.0) * pi / 180.0 )
    c2 = b1
    c3 = -a1 * a1
    c1 = 1.0 - c2 - c3

    x = c1 * (x + mlag(x)) / 2
        x[1] = x[2]

    out = x * NA
        out[] = filter(x, c(c2, c3), method='recursive', init=c(0,0))
    out
}

# out = 0*x
# for(i in 3:len(x))
#    out[i] = c1 * (x[i] + x[(i-1)])/2 + c2* out[(i-1)]+ c3* out[(i-2)]

# Roofing filter 2013 John F. Ehlers
#' @export
roofing.filter <- function(x) {
    # Highpass filter cyclic components whose periods are shorter than 48 bars
    alpha1 = (cos((0.707*360 / 48) * pi / 180.0 ) + sin((0.707*360 / 48) * pi / 180.0 ) - 1) / cos((0.707*360 / 48) * pi / 180.0 )

    x = (1 - alpha1 / 2)*(1 - alpha1 / 2)*( x - 2*mlag(x) + mlag(x,2))
        x[1] = x[2] = x[3]

    HP = x * NA
    HP[] = filter(x, c(2*(1 - alpha1), - (1 - alpha1)*(1 - alpha1)), method='recursive', init=c(0,0))

    super.smoother.filter(HP)
}

# My Stochastic Indicator 2013 John F. Ehlers
#' @export
roofing.stochastic.indicator  <- function(x, lookback = 20) {
    Filt = roofing.filter(x)

    HighestC = runMax(Filt, lookback)
        HighestC[1:lookback] = as.double(HighestC[lookback])
    LowestC = runMin(Filt, lookback)
        LowestC[1:lookback] = as.double(LowestC[lookback])
    Stoc = (Filt - LowestC) / (HighestC - LowestC)

    super.smoother.filter(Stoc)
}

# Quantile over moving window
#' @export
runQuantile = function(x, k, probs) {
	load.packages('caTools')
	temp = rep.col(x * NA, len(probs))
	temp[k:len(x),] = runquantile(as.vector(coredata(x)), k, probs, endrule='trim')
	temp
}


library(protr)
library(Peptides)

args <- commandArgs(trailingOnly = TRUE)
input <- args[1]
output <- args[2]

proteinseq <- read.csv(input)
pureseq <- proteinseq$sequence

properties <- function(proteins){
  df <- data.frame( 1:length(pureseq),
                    pI(proteins,  pKscale = "EMBOSS"), lengthpep(proteins), hydrophobicity(proteins, scale = "KyteDoolittle"),
                    mw(proteins, monoisotopic = FALSE, label = "none", aaShift = NULL), aIndex(proteins) )

  names(df) <- c('ID', 'isoelectricity', 'length', 'hydrophobicity', 'weight', 'aliphatic')

  return(df)
}

prop <- properties(pureseq)
write.csv(properties(pureseq), args[2])


#####

p = ggplot(SSRatioDF, aes(x = numCenters, y = SSRatio, col = clarity)) +
  geom_point() +
  geom_line() +
  scale_x_discrete(limits = as.character(1:10)) +
  ggtitle("Identifying Elbows in Plots of SSRatio VS. Number of Centers",
          subtitle = "M = 40, N = 20, univ = 1, lambda = 0 (bad), 20 (ok), 100 (good)")

dev.new()
plot(p)

p = ggplot(dredd, aes(x = numCenters, y = SSE, group = runID, col = clarity)) + geom_point(alpha = 0.4) + geom_line(alpha = 0.4) + scale_x_discrete(limits = as.character(1:10)) + geom_smooth(aes(x = numCenters, y = SSE, group = clarity, col = clarity), method = loess, se = FALSE, size = 1.5, span = 0)


context("idropwhile iterator")

test_that("Apply idropwhile to an integer sequence", {
  not_too_large <- function(x) {
    x <= 3
  }
  it <- idropwhile(not_too_large, 1:10)

  expect_equal(nextElem(it), 4)
  expect_equal(nextElem(it), 5)
  expect_equal(nextElem(it), 6)
  expect_equal(nextElem(it), 7)
  expect_equal(nextElem(it), 8)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 10)
  expect_error(nextElem(it), "StopIteration")
})

test_that("Apply idropwhile to an integer sequence using anonymous function", {
  it <- idropwhile(function(x) x <= 10, seq(2, 20, by=2))

  expect_equal(nextElem(it), 12)
  expect_equal(nextElem(it), 14)
  expect_equal(nextElem(it), 16)
  expect_equal(nextElem(it), 18)
  expect_equal(nextElem(it), 20)
  expect_error(nextElem(it), "StopIteration")
})


# This file compares the `original-w-po` version of `aphylo` with the new-using-pseq
# version of it in which. The using-po uses the pruning sequence as generated
# by ape::postorder. Moreover, it removes all the po-related classes and
# methods as these are no longer required. A simplier version of the package

rm(list = ls())

# Generating data
set.seed(1)
n <- 20
tree <- ape::rtree(n)
ann  <- data.frame(fun = sample(c(0,9,1), n, TRUE))

# New estimates
system("git checkout loglike-using-po")
devtools::load_all()

dat_new  <- new_aphylo(tree=tree, tip.annotation = ann)
ans_new <- aphylo_mle(
  dat_new,
  par     = rep(.01, 5),
  lower   = 1e-4,
  upper   = 1 - 1e-4
  )

# Old estimates
system("git checkout original-w-po")
devtools::unload("aphylo")
devtools::load_all()

dat_old  <- new_aphylo(
  edges = tree$edge,
  annotations = cbind(1:(2*n-1),rbind(ann, cbind(fun=rep(9, tree$Nnode))))
  )
ans_old <- aphylo_mle(
  dat_old,
  par     = rep(.01, 5),
  lower   = 1e-4,
  upper = 1 - 1e-4
  )


#' This function takes input to the lagr or lagr.tune function, returning a model matrix, coordinates, weights, and response.
#'
#'
lagr.parse.model.frame = function(formula, data, family, weights, coords, fit.loc, longlat, na.action, contrasts) {
    # Get the exponential family of the response
    if(is.character(family))
        family <- get(family, mode = "function", envir = parent.frame())
    if(is.function(family)) family <- family()
    if(is.null(family$family)) {
        print(family)
        stop("'family' not recognized")
    }

    # Determine whether coords was supplied as a character vector or as a symbolic expression
    coords.is.char = FALSE
    try(coords.is.char <- is.character(coords), silent=TRUE)

    # If coords was supplied as a character vector, then mave sure we include the named variables in the model.frame
    if (coords.is.char)
        vars = unlist(c("formula", "data", "weights", "na.action"), coords)
    else
        vars = c("formula", "data", "weights", "na.action")

    # Match the variables that are referenced in the function call
    mf = match.call(expand.dots=FALSE)
    m <- match(vars, names(mf), 0)
    mf <- mf[c(1, m)]

    # We need to evaluate the function call in the next environment up because we've added a level of abstraction with this function.
    mf[[1]] <- as.name("model.frame")
    mf <- eval.parent(substitute_q(mf, env=sys.frame(sys.parent())))
    mt <- attr(mf, "terms")

    # If the data was provided as a spatial data frame, then extract both the data and the coordinates.
    if (is(data, "Spatial")) {
        if (!missing(coords))
            warning("data is Spatial* object, ignoring coords argument")
        coords <- coordinates(data)
        if ((is.null(longlat) || !is.logical(longlat)) && !is.na(is.projected(data)) && !is.projected(data))
            longlat <- TRUE
        else longlat <- FALSE
    } else {
        # Make sure coordinates were specified
        if (missing(coords))
            stop("Observation coordinates have to be given")

        # Get the coords from the data:
        if (coords.is.char) {
            coords = cbind(data[,coords, drop=FALSE])
        } else {
            coords.expression = substitute(coords, env=sys.frame(sys.parent()))
            coords.expression[[1]] = as.name('cbind')
            coords = eval(coords.expression, data)
        }

        # Only interpret the coordinates as latitude/longitude values if the longlat variable is TRUE
        if (is.null(longlat) || !is.logical(longlat))
            longlat <- FALSE
    }

    # Get the matrices of distances and weights
    coords = as.matrix(coords, dimnames=list(NULL, colnames(coords)))
    q = ncol(coords)
    D.coords = rbind(coords, fit.loc)
    n = nrow(D.coords)

    #Two dimensional effect modifying parameter:
    if (q==2 && longlat) {
        #If data was specified in terms of latitude/longitude, use earth distance
        D = as.matrix(earth.dist(D.coords),n,n)
    } else {
        #Otherwise, use the pythagorean distance
        squaredist = matrix(0,n,n)
        D.coords = as.matrix(D.coords)

        for (c in 1:q) {
            this.coord = matrix(rep(D.coords[,c], times=n), n, n)
            squaredist = squaredist + (this.coord-t(this.coord))**2
        }
        D = sqrt(squaredist)
    }

    max.dist = 10 * max(D)
    min.dist = 0 #max.dist / 3000

    # Get the data and the weights
    y <- model.response(mf, "numeric")
    x <- model.matrix(mt, mf, contrasts)
    w <- model.weights(mf)

    # Check for problems with the (prior) weights
    if (!is.null(w) && !is.numeric(w))
        stop("'weights' must be a numeric vector")
    if (is.null(w))
        w <- rep(1, nrow(data))
    if (any(is.na(w)))
        stop("NAs in weights")
    if (any(w < 0))
        stop("negative weights")

    return(list(x=x, y=y, w=w, family=family, coords=coords, dist=D, max.dist=max.dist, min.dist=min.dist, mt=mt, dim=q))
}


setwd("~/gits/paper/2021-nlp4re/evaluation/")

trainingData <- read.csv("CONDEC-NLP4RE2021.csv")
summary(trainingData)
trainingData[880,]

numIssues <- table(trainingData$isIssue)[2] # 392
numDecisions <- table(trainingData$isDecision)[2] # 332
numAlternatives <- table(trainingData$isAlternative)[2] # 218
numPros <- table(trainingData$isPro)[2] # 288
numCons <- table(trainingData$isCon)[2] # 238

numRelevant <- numIssues + numDecisions + numAlternatives + numPros + numCons # 1468
numIrrelevant <- nrow(trainingData) - numRelevant # 220

# get parts of text per type
rowsWithIrrelevantText <-
  which(
    trainingData$isIssue == 0 &
      trainingData$isDecision == 0 &
      trainingData$isCon == 0 &
      trainingData$isPro == 0 & trainingData$isAlternative == 0
  )
trainingData[rowsWithIrrelevantText,]

rowsWithIssues <- which(trainingData$isIssue == 1)
trainingData[rowsWithIssues,]

rowsWithDecisions <- which(trainingData$isDecision == 1)
trainingData[rowsWithDecisions,]

rowsWithAlternatives <- which(trainingData$isAlternative == 1)
trainingData[rowsWithAlternatives,]

rowsWithCons <- which(trainingData$isCon == 1)
trainingData[rowsWithCons,]

rowsWithPros <- which(trainingData$isPro == 1)
trainingData[rowsWithPros,]


#' @import data.table
NULL

#' Load a Matrix
#'
#' This function loads a file as a matrix. It assumes that the first column
#' contains the rownames and the subsequent columns are the sample identifiers.
#' Any rows with duplicated row names will be dropped with the first one being
#' kepted.
#'
#' @importFrom stats as.formula lm
#'
#' @param x Path to the input file
#' @param y Path to the input file
#' @param data Path to the input file
#' @param covars Path to the input file
#' @return A matrix of the infile
#' @export
linreg.ancon <- function(x, y, data, covars) {
  reg <- lm(formula = paste0(y, " ~ ", "`", x, "` + ", covars), data = data)
  dt <- data.table(
    Exposure = x,
    BETA = summary(reg)$coef[2, 1],
    SE = summary(reg)$coef[2, 2],
    P = summary(reg)$coef[2, 4],
    F_stat = summary(reg)$fstatistic[1]
  )
  return(dt)
}

#' Load a Matrix
#'
#' This function loads a file as a matrix. It assumes that the first column
#' contains the rownames and the subsequent columns are the sample identifiers.
#' Any rows with duplicated row names will be dropped with the first one being
#' kepted.
#'
#' @importFrom stats as.formula glm binomial
#'
#' @param x Path to the input file
#' @param y Path to the input file
#' @param data Path to the input file
#' @param covars Path to the input file
#' @return A matrix of the infile
#' @export
logreg.ancon <- function(x, y, data, covars) {
  reg <- glm(formula = paste0(y, " ~ ", "`", x, "` + ", covars), data = data, family = binomial)
  dt <- data.table(
    Exposure = x,
    Outcome = "breast_cancer",
    BETA = summary(reg)$coef[2, 1],
    SE = summary(reg)$coef[2, 2],
    P = summary(reg)$coef[2, 4]
  )
  return(dt)
}

#' Load a Matrix
#'
#' This function loads a file as a matrix. It assumes that the first column
#' contains the rownames and the subsequent columns are the sample identifiers.
#' Any rows with duplicated row names will be dropped with the first one being
#' kepted.
#'
#' @param data Path to the input file
#' @param x Path to the input file
#' @param y Path to the input file
#' @param reg_type Path to the input file
#' @param covars Path to the input file
#' @param num_cores Path to the input file
#' @return A matrix of the infile
#' @export
parallel.reg <- function(data, x, y, reg_type = c("lm"), covars, num_cores) {
  if (reg_type == "lm") {
    reg_type = get("linreg.ancon")
  } else if (reg_type == "lg") {
    reg_type = get("logreg.ancon")
  } else stop("Incorrect reg_type selected.")
  dt_list <- list()
  for (i in 1:length(y)) {
    y <- y[i]
    print(paste0("Current trait: ", y))
    res <- rbindlist(
      pbmcapply::pbmclapply(
        X = x,
        FUN = reg_type,
        y = y,
        data = data,
        covars = covars,
        mc.style = "txt",
        mc.cores = num_cores
      )
    )
  res$Outcome <- y
  dt_list[[i]] <- res
  }
  return(rbindlist(dt_list))
}


#!/usr/bin/Rscript

# Prints a formatted Markdown table of measurement results, and improvement over
# a previous measurement. To be used together with the bench_decode example.
# Columns in the input data should be p10, p50, p90, average, and throughput.

# Usage:
#
#  ./stats.r baseline.dat new.dat
#  ./stats.r baseline.dat new.dat

prev <- read.table(commandArgs(trailingOnly = TRUE)[1])
data <- read.table(commandArgs(trailingOnly = TRUE)[2])

# Note: `sapply` is like `Map` with arguments reversed,
# but it also produces a different data structure as a
# result. Sapply happens to be the convenient thing to
# use here.
dataMean <- sapply(data, mean)
prevMean <- sapply(prev, mean)
dataSd   <- sapply(data, sd)
prevSd   <- sapply(prev, sd)

# Estimates the absolute error in (a ± aErr) / (b ± bErr).
# See also https://en.wikipedia.org/wiki/Propagation_of_uncertainty.
propErr <- function(a, b, aErr, bErr)
{
  # The new relative variance is the sum of the relative variances of a and b.
  relA2 <- (aErr / a) * (aErr / a)
  relB2 <- (bErr / b) * (bErr / b)
  return(abs(b / a) * sqrt(relA2 + relB2))
}

frac <- dataMean / prevMean
fracSd <- propErr(prevMean, dataMean, prevSd, dataSd)

# Make a format string for GH-flavored Markdown.
makeFormat <- function(label, unit)
{
  return(paste('|', label, '| %5.1f ± %3.1f', unit, '| %.3f ± %.3f |\n'))
}

# Mu is for mean, tau for throughput.
cat(sprintf(makeFormat('p10', 'ns   '), dataMean[1], dataSd[1], frac[1], fracSd[1]))
cat(sprintf(makeFormat('p50', 'ns   '), dataMean[2], dataSd[2], frac[2], fracSd[2]))
cat(sprintf(makeFormat('p90', 'ns   '), dataMean[3], dataSd[3], frac[3], fracSd[3]))
cat(sprintf(makeFormat('μ  ', 'ns   '), dataMean[4], dataSd[4], frac[4], fracSd[4]))
cat(sprintf(makeFormat('τ  ', 'MiB/s'), dataMean[5], dataSd[5], frac[5], fracSd[5]))


library(tm)
library(SnowballC)

doc1 <- "Mia Thermopolis has just found out that she is the heir apparent to the throne of Genovia. With her friends Lilly and Michael Moscovitz in tow, she tries to navigate through the rest of her sixteenth year."
doc2 <- "Danny Ocean and his eleven accomplices plan to rob three Las Vegas casinos simultaneously."
doc3 <- "A Lion cub crown prince is tricked by a treacherous uncle into thinking he caused his fathers death and flees into exile in despair, only to learn in adulthood his identity and his responsibilities."
doc4 <- "When his secret bride is executed for assaulting an English soldier who tried to rape her, Sir William Wallace begins a revolt against King Edward I of England."
doc5 <- "The aliens are coming and their goal is to invade and destroy Earth. Fighting superior technology, mankinds best weapon is the will to survive."
doc6 <- "The cross-country adventures of two good-hearted but incredibly stupid friends."

# query <- "my alien stupid friends"
# query <- ""
query <- doc6

docList <- list(doc1, doc2, doc3, doc4, doc5)
nDocs <- length(docList)
names(docList) <- paste0("doc", c(1:nDocs))

#A vector source interprets each element of the vector x as a document.
docs <- VectorSource(c(docList, query))
docs$Names <- c(names(docList), "query")

# Corpora are collections of documents containing (natural language) text.
corpus <- Corpus(docs)
corpus <- tm_map(corpus, stripWhitespace)
corpus <- tm_map(corpus, removePunctuation)
corpus <- tm_map(corpus, content_transformer(tolower))
corpus <- tm_map(corpus, removeWords, stopwords("english"))
corpus <- tm_map(corpus, stemDocument, language='english')

corpus

tdm <- TermDocumentMatrix(corpus)
inspect(tdm)
m <- as.matrix(tdm)

computeTFIDF <- function(row) {
        df = sum(row[1:nDocs] > 0)
        w = rep(0, length(row))
        w[row > 0] = (1 + log2(row[row > 0])) * log2(nDocs/(df + 1))
    return(w)
}

n <- t(apply(m, 1, FUN=computeTFIDF))
colnames(n) <- colnames(m)

# Vetor de normas
sqrt(colSums(n^2))

# FunÃ§Ã£o scale aplicada na matriz
n <- scale(n, center=FALSE, scale=sqrt(colSums(n^2)))

# Ranqueamento via produto escalar (assumindo vetores jÃ¡ normalizados)
query <- n[, nDocs + 1]
n <- n[, 1:nDocs]

scores <- t(query) %*% n

results <- data.frame(doc = names(docList), score = t(scores))
results <- results[order(results$score, decreasing = TRUE),]

results


# check fits of 16S Bahram taxonomic and functional group models.

rm(list=ls())
source('paths.r')
library(runjags)
library(betareg)
library(coda)
library(ddpcr) # for quiet()
source('NEFI_functions/crib_fun.r')

#Load JAGS model.
allfits <- readRDS(bahram_16S_prior_dmulti.ddirch_all.group_JAGSfits)
allfits <- readRDS("/fs/data3/caverill/NEFI_data/16S/scc_gen/JAGS_output/bahram_16S_prior_dmulti.ddirch_fg_JAGSfits")

# has everything converged? print any high prsf scores for all groups.
for (i in 1:length(allfits)) {
  print(names(allfits)[i])
  fit <- allfits[[i]]
  quiet(s <- summary(fit$jags_model))
  print(s[which(s[,11] > 1.1),])
}
fit$species_parameter_output

# save plots.
pdf("/fs/data3/caverill/NEFI_data/16S/pecan_gen/figures/prior_fit_dmulti_ddirch_all_groups.pdf")

#check the plots.
par(mfrow = c(2,2))
for (p in 1:length(allfits)) {
  fit <- allfits[[p]]

  for(i in 1:ncol(fit$predicted)) {
    if (colnames(fit$predicted)[i]=="other") next
    plot(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i],
         pch = 16, xlab="predicted abundance", ylab="observed abundance")
    Axis(x="predicted", side=2)
    abline(0,1,lwd = 2)
    abline(lm(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i]), lty = 2, col = 'purple')
    mod <- betareg::betareg(crib_fun(fit$observed[,i]/rowSums(fit$observed)) ~ crib_fun(fit$predicted[,i]))
    rsq <-round(summary(mod)$pseudo.r.squared, 3)
    mtext(colnames(fit$predicted)[i], side = 3)
    mtext(paste0('R2=',rsq), side = 3, line = -1.5, adj = 0.05)
  }
}
dev.off()


#' @importFrom reshape2 dcast
#' @importFrom reshape2 melt

RR_model_func <- function(taxa_data, species_name, space_time,
                          overdispersion = FALSE, verbose = FALSE,
                          site_effect = TRUE, list_length = FALSE,
                          model_formula = NULL, family = 'Binomial'){

  # Run model and return model object
  MM <- modelBuilder(taxa_data,
                     species_name,
                     space_time,
                     list_length,
                     site_effect,
                     overdispersion,
                     model_formula,
                     family,
                     verbose)

  # Check that it worked
  if(class(MM)[1] == "try-error"){ # If there is an error catch what data we can
    coefs <- list(species_name = as.character(species_name),
                  observations = sum(as.numeric(attr(MM, 'dataset')$taxa)),
                  error_message = MM[1])
  } else { # Create a list of all our parameters

    # Turn the coefficients table into a list with nice names
    summary_melt <- melt(summary(MM)$coefficients)
    summary_melt$name <- reformatCoefNames(paste(summary_melt$Var1, summary_melt$Var2, sep = '.'))
    coefs <- as.list(summary_melt$value)
    names(coefs) <- summary_melt$name

    # Add other data to this list
    coefs <- c(species_name = as.character(species_name),
               coefs,
               observations = sum(as.numeric(attr(MM, 'dataset')$taxa)))

  }

  return(coefs)

}


#num_states <- 4

error_bound <- 0.001

state_log_lik <- function(p_increment, mu, sigma_mu, volume, eta, sigma_eta, xi, sigma_xi){
  return (-0.5 * (((p_increment - mu)/sigma_mu)^2 + ((volume - eta)/sigma_eta)^2) - log(2 * pi * sigma_mu * sigma_eta))
}

EM <- function (p_increment, volume, p_absolute, num_states){
  #format of p_increment: N X T matrix, N = number of days in training data,
  # T = number of steps in a day
  #format of volume: N X T matrix, same as above
  #format of prob matrix for each time: m x T x N matrix, m is the number of possible states
  #Prob. matrix initialized so that each state has equal prob.
  N = dim(p_increment)[1]
  Tnum = dim(p_increment)[2]
  P = array(rep(1 / num_states, num_states * N * Tnum), c(num_states, Tnum, N))

  #transition prob. matrix is m x m matrix, initialized such that each state goes to itself with prob ~1.
#   A = matrix(0, num_states, num_states)
#   for (i in 1: num_states){
#     for (j in 1 : num_states){
#         if (i == j) A[i,j] = 0.9
#         else A[i,j] = (1 - 0.9)/(num_states - 1)
#     }
#   }
  A = matrix(1/num_states, nrow = num_states, ncol = num_states)

  #all mu's initialized to avg of p_increment, all sigma)mu's initialized to std of p_increment
  qt0 <- seq(0, 1, length.out = num_states + 1)
  qt <- (qt0[1:num_states] + qt0[2:(num_states+1)]) / 2
  mu = quantile(as.vector(p_increment), qt)
  sigma_mu = rep(sqrt(var(as.vector(p_increment))), num_states)
  #same for eta and sigma_eta
  eta = quantile(as.vector(volume), qt)
  sigma_eta = rep(sqrt(var(as.vector(volume))), num_states)
  #same for xi and sigma_xi
  xi = quantile(as.vector(p_absolute), qt)
  sigma_xi = rep(sqrt(var(as.vector(p_absolute))), num_states)

  max_iter_num = 500
  for (i in 1:max_iter_num){
    old_mu <- mu
    old_eta <- eta
    old_xi <- xi
    old_sigma_mu <- sigma_mu
    old_sigma_eta <- sigma_eta
    old_sigma_xi <- sigma_xi
    old_A <- A

    log_alpha = calc_forward(num_states, N, Tnum, A, p_increment, mu, sigma_mu, volume, eta, sigma_eta, p_absolute, xi, sigma_xi)
    log_beta = calc_backward(num_states, N, Tnum, A, p_increment, mu, sigma_mu, volume, eta, sigma_eta, p_absolute, xi, sigma_xi)
    P <- calc_P(num_states, N, Tnum, log_alpha, log_beta)
    mu = update_mu(num_states, P, p_increment)
    sigma_mu = update_sigma_mu(num_states, P, p_increment, mu, N, Tnum)
    eta = update_eta(num_states, P, volume)
    sigma_eta = update_sigma_eta(num_states, P, volume, eta, N, Tnum)
    xi = update_xi(num_states, P, p_absolute)
    sigma_xi = update_sigma_xi(num_states, P, p_absolute, xi, N, Tnum)

    if (i == 5){
      l1 <- 1
    }
    A = update_A(num_states, N, Tnum, P, log_alpha, log_beta, A, p_increment, mu, sigma_mu, volume, eta, sigma_eta, p_absolute, xi, sigma_xi)

    diff_mu <- sum(abs(old_mu - mu)) / sum(abs(old_mu))
    diff_eta <- sum(abs(old_eta - eta)) / sum(abs(old_eta))
    diff_xi <- sum(abs(old_xi - xi)) / sum(abs(old_xi))
    diff_sigma_mu <- sum(abs(old_sigma_mu - sigma_mu)) / sum(abs(old_sigma_mu))
    diff_sigma_eta <- sum(abs(old_sigma_eta - sigma_eta)) / sum(abs(old_sigma_eta))
    diff_sigma_xi <- sum(abs(old_sigma_xi - sigma_xi)) / sum(abs(old_sigma_xi))
    diff_A <- sum(abs(old_A - A)) / sum(abs(old_A))
    if (diff_mu < error_bound && diff_eta < error_bound && diff_xi < error_bound && diff_sigma_mu < error_bound &&
        diff_sigma_eta < error_bound && diff_sigma_xi && diff_A < error_bound ){
      break
    }
  }
  data_A <- data.frame(A)
  data_mu <- data.frame(mu)
  data_sigma_mu <- data.frame(sigma_mu)
  data_eta <- data.frame(eta)
  data_sigma_eta <- data.frame(sigma_eta)
  data_xi <- data.frame(xi)
  data_sigma_xi <- data.frame(sigma_xi)

  params <- list(data_A, data_mu, data_sigma_mu, data_eta, data_sigma_eta, data_xi, data_sigma_xi)
  names(params) <- c('A', 'mu', 'sigma_mu', 'eta', 'sigma_eta', 'xi', 'sigma_xi')

  return(params)
}

calc_forward <- function(num_states, N, Tnum, A, p_increment, mu, sigma_mu, volume, eta, sigma_eta, p_absolute, xi, sigma_xi){
  if (N == 1){
    dim(p_increment) <- c(1, length(p_increment))
    dim(volume) <- c(1, length(volume))
    dim(p_absolute) <- c(1, length(p_absolute))

  }
  log_alpha <- array(0, c(num_states, Tnum, N))
  #get the initial prob
  log_alpha[, 1, ] <- state_log_lik(matrix(p_increment[,1], nrow = num_states, ncol = dim(p_increment)[1], byrow = TRUE),
                               mu, sigma_mu,
                               matrix(volume[,1], nrow = num_states, ncol = dim(volume)[1], byrow = TRUE),
                               eta, sigma_eta,
                               matrix(p_absolute[,1], nrow = num_states, ncol = dim(p_absolute)[1], byrow = TRUE),
                               xi, sigma_xi)

  if (dim(p_absolute)[2] > 1){
    for (t in 2: dim(p_absolute)[2]){

      log_diff <- exp(log_alpha[, t-1, ] - matrix(apply(matrix(log_alpha[, t-1, ], nrow = num_states, ncol = N), 2, max), nrow = num_states, ncol = dim(volume)[1], byrow = TRUE))
      log_alpha[, t, ] <- t(log(t(log_diff) %*% A)) + matrix(apply(matrix(log_alpha[, t-1, ], nrow = num_states, ncol = N), 2, max), nrow = num_states, ncol = dim(volume)[1], byrow = TRUE) +
        state_log_lik(matrix(p_increment[,t], nrow = num_states, ncol = dim(p_increment)[1], byrow = TRUE),
                      mu, sigma_mu,
                      matrix(volume[,t], nrow = num_states, ncol = dim(volume)[1], byrow = TRUE),
                      eta, sigma_eta,
                      matrix(p_absolute[,t], nrow = num_states, ncol = dim(p_absolute)[1], byrow = TRUE),
                      xi, sigma_xi)

    }
  }
  return (log_alpha)
}

calc_backward <- function(num_states, N, Tnum, A, p_increment, mu, sigma_mu, volume, eta, sigma_eta, p_absolute, xi, sigma_xi){
  log_beta <- array(0, c(num_states, Tnum, N))
  log_beta[, Tnum, ] <- 0
  for (t in (Tnum - 1) : 1){
    log_diff <- exp(log_beta[, t+1, ] - matrix(apply(log_beta[, t+1, ], 2, max), nrow = num_states, ncol = dim(volume)[1], byrow = TRUE))
    tt <- state_log_lik(matrix(p_increment[,t+1], nrow = num_states, ncol = dim(p_increment)[1], byrow = TRUE),
                        mu, sigma_mu,
                        matrix(volume[,t+1], nrow = num_states, ncol = dim(volume)[1], byrow = TRUE),
                        eta, sigma_eta,
                        matrix(p_absolute[,t+1], nrow = num_states, ncol = dim(p_absolute)[1], byrow = TRUE),
                        xi, sigma_xi)

    log_beta[, t, ] <- log(A %*% exp(log_diff * state_log_lik(matrix(p_increment[,t+1], nrow = num_states, ncol = dim(p_increment)[1], byrow = TRUE),
                                                mu, sigma_mu,
                                                matrix(volume[,t+1], nrow = num_states, ncol = dim(volume)[1], byrow = TRUE),
                                                eta, sigma_eta,
                                                matrix(p_absolute[,t+1], nrow = num_states, ncol = dim(p_absolute)[1], byrow = TRUE),
                                                xi, sigma_xi
                                                ))) + matrix(apply(log_beta[, t+1, ], 2, max), nrow = num_states, ncol = dim(volume)[1], byrow = TRUE)
  }
  return (log_beta[,1:Tnum,])
}

calc_P <- function(num_states, N, Tnum, log_alpha, log_beta){
  temp <- log_alpha + log_beta
  temp2 <- array(0, c(num_states, Tnum, N))
  P <- array(0, c(num_states, Tnum, N))
  for (t in 1: Tnum){
    temp2[,t,] = exp(temp[,t,] - matrix(apply(temp[,t,], 2, max), nrow = num_states, ncol = N, byrow = TRUE))
    P[,t,] <- temp2[,t,] / matrix(colSums(temp2[,t,]), nrow = num_states,ncol = N, byrow = TRUE)
  }
  return (P)
}

update_A <- function(num_states, N, Tnum, P, log_alpha, log_beta, A, p_increment, mu, sigma_mu, volume, eta, sigma_eta, p_absolute, xi, sigma_xi){
  conditional_tp <- array(0, c(N, (Tnum - 1), num_states, num_states))
  for (n in 1:N){
    if (n == 71){
      l2 <- 1
    }
    for(t in 1:(Tnum - 1)){
      temp_a <- matrix(rep(log_alpha[, t, n], num_states), ncol = num_states, nrow = num_states)
      temp_b <- log_beta[,t+1,n] + state_log_lik(p_increment[n, t+1], mu, sigma_mu, volume[n, t+1], eta, sigma_eta)
      temp_bb <- matrix(t(temp_b), nrow = num_states, ncol = num_states, byrow = TRUE)
      temp_c <- temp_a + temp_bb + log(A)
      temp_c = exp(temp_c - temp_c[which.max(temp_c)])
      conditional_tp[n,t,,] <- temp_c / sum(temp_c)
    }
  }
  new_A <- matrix(0, nrow = num_states, ncol = num_states)
  for (i in 1:num_states){
    for (j in 1:num_states){
      new_A[i,j] <- sum(conditional_tp[,,i,j])/sum(conditional_tp[,,i,])
    }
  }
  return (new_A)
}

update_mu <- function(num_states, P, p_increment){
  new_mu <- rep(0, num_states)
  for (i in 1: num_states){
    new_mu[i] <- sum(P[i,,] * t(p_increment)) / sum(P[i,,])
  }
  return(new_mu)
}

update_sigma_mu <- function(num_states, P, p_increment, mu, N, Tnum){
  new_sigma_mu <- rep(0, num_states)
  for(i in 1: num_states){
    new_sigma_mu[i] <- sqrt(sum(t(p_increment - mu[i])^2 * P[i,,]) * N * Tnum / ((Tnum * N - 1) * sum(P[i,,])))
  }
  return(new_sigma_mu)
}

update_eta <- function(num_states, P, volume){
  new_eta <- rep(0, num_states)
  for (i in 1: num_states){
    new_eta[i] <- sum(P[i,,] * t(volume)) / sum(P[i,,])
  }
  return(new_eta)
}

update_sigma_eta <- function(num_states, P, volume, eta, N, Tnum){
  new_sigma_eta <- rep(0, num_states)
  for(i in 1: num_states){
    new_sigma_eta[i] <- sqrt(sum(t(volume - eta[i])^2 * P[i,,]) * N * Tnum / ((N * Tnum - 1) * sum(P[i,,])))
  }
  return(new_sigma_eta)
}

update_xi <- function(num_states, P, p_absolute){
  new_xi <- rep(0, num_states)
  for (i in 1: num_states){
    new_xi[i] <- sum(P[i,,] * t(p_absolute)) / sum(P[i,,])
  }
  return(new_xi)
}

update_sigma_xi <- function(num_states, P, p_absolute, mu, N, Tnum){
  new_sigma_xi <- rep(0, num_states)
  for(i in 1: num_states){
    new_sigma_xi[i] <- sqrt(sum(t(p_absolute - xi[i])^2 * P[i,,]) * N * Tnum / ((Tnum * N - 1) * sum(P[i,,])))
  }
  return(new_sigma_xi)
}


#' Decomposing the subclonal structure of tumors with two-way mixture models on copy number aberrations.
#'
#' A R package for deconvoluting subclonal copy number and mutational cellular prevalence.
#'
#' @name CloneDeMix
#' @author An-Shun Tai \email{daansh13@gmail.com}
#' @param tumor A G by N count matrix of tumor samples, where G is the gene number and N is the sample size.
#' @param threshold The threhold of convergence. Default is 10^-5.
#' @param CNVstate A vector of considered copy number state.
#' @param normal A vector of length s. It's DNA profile from the paired normal sample. If it's empty, the baseline is calculated from sample mean.
#' @param iterationC Maximum number of iterations. Default is 1000.
#' @param method The criteria for the final clone number.
#' @return A list is containing an estimated CNV matrix, MCP matrix, and the number of predicted clone number.
#' @export
#' @examples
#' data("ESCC_chr1")
#' res <- CloneDeMix(tumor=ESCC_chr1$tumor, normal=ESCC_chr1$normal)
#' head(res$CNV); head(res$MCP)
CloneDeMix <- function(tumor, normal=NULL, threshold=10^-5, iterC=10^3,CNVstate=c(0:10),method="aic"){
  if(is.null(normal)){base <- round(rowMeans(tumor)/2)
  warning("Baseline is calculated by sample mean")}else{
  base <- round(normal/2)
  }

  CNV.est <- matrix(NA,nrow(tumor),ncol(tumor))
  prop.est <- matrix(NA,nrow(tumor),ncol(tumor))

  for(j in 1:ncol(tumor)){
    X <- round(tumor[,j])

    filterU <- X/base < max(CNVstate)  ; filterL <- X/base > 0.05
    filter <- filterU & filterL

    ic <- c()
    for(n.clone in 2:max(CNVstate)){
      f <- CloneDeMix_core(dataX=X[filter],threshold=threshold,CNVstate=CNVstate,numbG=n.clone, baseline=base[filter],iterationC=iterC)
      if(method=="aic"){
        ic[n.clone-1] <- f$AIC
      }
      if(method=="bic"){
        ic[n.clone-1] <- f$BIC
      }
    }

    f.n.clone <- which.min(ic)+1
    f <- CloneDeMix_core(dataX=X[filter],threshold=threshold,CNVstate=CNVstate,numbG=f.n.clone, baseline=base[filter],iterationC=iterC)

    MatrixL <- matrix(1:(f.n.clone*length(CNVstate) ),length(CNVstate),f.n.clone)
    detCNV <- function(x){
      output <- matrix(NA,length(CNVstate),f.n.clone)
      output[MatrixL] <- x
      which.max(rowSums(output))
    }
    detR <- function(x){
      output <- matrix(NA,length(CNVstate),f.n.clone)
      output[MatrixL] <- x
      which.max(colSums(output))
    }

    CNV.est[filter,j] <- apply(f$Weigh,2,detCNV)-1
    prop.est[filter,j] <- f$r[apply(f$Weigh,2,detR)]

    CNV.est[which(filterU==F),j] <- max(CNVstate)
    CNV.est[which(filterL==F),j] <- 0
  }

  #### correction ####
  prop.est[is.na(prop.est)]<-1

  #test for non-normal
  Pvalue_n <- matrix(NA,nrow(tumor),ncol(tumor))

  for(j in 1:ncol(tumor)){
    X <- round(tumor[,j])
    Pvalue_n[,j] <- ppois(X,2*base)
  }

  Pvalue_n[Pvalue_n>0.5] <- 1-Pvalue_n[Pvalue_n>0.5]
  CNV.est.f <- CNV.est
  CNV.est.f[Pvalue_n>0.001] <- 2
  prop.est.f <- prop.est
  prop.est.f[CNV.est.f==2] <- 0

  colnames(CNV.est.f) <- colnames(prop.est.f) <- colnames(tumor)
  rownames(CNV.est.f) <- rownames(prop.est.f) <- rownames(tumor)
  n.clone <- matrix(apply(prop.est.f,2,function(x)length(unique(x))-1),ncol(tumor),1)
  colnames(n.clone) <- "clone number"
  rownames(n.clone) <- colnames(tumor)

  structure(list(CNV=CNV.est.f, MCP=prop.est.f,n.clone=n.clone))
}


require(haven)
require(dplyr)
#require(ggplot2)

lookfor <- function(data,
                    keywords = "weight|sample",
                    labels = TRUE,
                    ignore.case = TRUE) {
  # search scope
  n <- names(data)
  if(!length(n)) stop("there are no names to search in that object")
  # search function
  look <- function(x) { grep(paste(keywords, collapse="|"), x, ignore.case = ignore.case) }
  # names search
  x <- look(n)
  variable <- n[x]
  # foreign objects
  l <- attr(data, "variable.labels")
  if(is.null(l)) l <- attr(data, "var.labels")
  # memisc objects
  if(grepl("data.set|importer", class(data))) {
    suppressMessages(suppressWarnings(require(memisc)))
    l <- as.vector(description(data))
  }
  if(length(l) & labels) {
    # search labels
    y <- look(l)
    # remove duplicates, reorder
    x <- sort(c(x, y[!(y %in% x)]))
    # add variable labels
    variable <- n[x]
    label <- l[x]
    variable <- cbind(variable, label)
  }
  # output
  if(length(x)) return(as.data.frame(variable, x))
  else message("Nothing found. Sorry.")
}

# Read in wave 4 of Understanding Society survey
surveyDir <- "/home/luke/Documents/E_FEM_clean/Understanding_Society/UKDA-6614-stata/stata/stata11_se/ukhls_w2/"
ind_name <- paste0(surveyDir, "b_indresp.dta")
US_w2 <- read_dta(ind_name)
#names(US_w2)

# Remove anyone under 50
US_w2 <- filter(US_w2, b_dvage>49)
# Keep only those who live in England (1==England)
US_w2 <- filter(US_w2, b_country=='1')

# Get table showing original values (including negatives/missing)
US_smok <- table(US_w2$b_smnow)

# Replace all negative values with NA
US_w2$b_smnow[US_w2$b_smnow < 0] <- NA

# Calculate proportion of smokers in wave 2 (binary smoke/no smoke)
US_smok_prop <- prop.table(table(US_w2$b_smnow))

US_smok_norm <- US_smok / max(US_smok)
boxplot(US_smok_norm)
barplot(US_smok_norm)

# Read in Harmonized ELSA
ELSA_dir <- "/home/luke/Documents/E_FEM/UKDA-5050-stata/stata/stata11_se/"
ELSA_name <- paste0(ELSA_dir, "h_elsa.dta")
H_ELSA <- read_dta(ELSA_name)
names(H_ELSA)

lookfor(US_w2, "age")
lookfor(H_ELSA, "smoke")
lookfor(H_ELSA, "year")

boxplot(H_ELSA$r5smokef, horizontal=TRUE, main='Smoking Now in ELSA')
hist(H_ELSA$r5smoken, breaks=10)

table(H_ELSA$r5smoken)
table(US_w2$b_smnow)
summary(US_w2$b_smnow)

barplot(table(H_ELSA$r5smoken))

chisq.test(H_ELSA$r5smoken, US_w2$b_smnow)

smoke_df <- data.frame()


suppressPackageStartupMessages(library(ggplot2))
qplot(mpg, wt, data = mtcars)


poiss_norm_analysis <- function (z, mu_mu, mu_tau, tau_r, tau_glambda, poi_r, poi_glambda,
									num_samples, burn_cycles, num_adapt, num_thin)
{
  # Separate z into ones ('ones') and non-ones ('z2')
  ones_i = 0
  ones = list()
  z2_i = 0
  z2 = list()
  for (i in 1:length(z))
  {
    if (z[i] == 1)
    {
      ones_i = ones_i + 1
      ones[ones_i] = 0
    } else {
      z2_i = z2_i + 1
      z2[z2_i] = z[i]
    }
  }
  if (num_thin<1)
  {
    num_thin = 1
  }
  # Call JAGS to generate a model
	mc.mod <- jags.model("Combined Model.txt",
						 data = list('ones' = ones, 'z2' = z2, 'M' = ones_i, 'N'=z2_i, 'mu_mu'=mu_mu, 'mu_tau'=mu_tau,
						             'tau_r'=tau_r, 'tau_glambda'=tau_glambda, 'poi_r'=poi_r, 'poi_glambda'=poi_glambda),
						 n.chains = 1,
						 n.adapt = num_adapt)
	if (burn_cycles > 0)
	{
	  update(mc.mod, n.iter=burn_cycles)
	}
	# Call JAGS to generate posterior samples
	mclist.samples <- jags.samples(mc.mod,
								c('hidden_mu', 'hidden_tau', 'hidden_lambda'),
								num_samples,
								thin = num_thin)
	# Lists of the sampled points (for mu, tau, and lambda)
	est_mus <- mclist.samples$hidden_mu
	est_taus <- mclist.samples$hidden_tau
	est_lambdas <- mclist.samples$hidden_lambda
	return (list(est_mus, est_taus, est_lambdas))
}