# 도수분포표 : 빈도수(table), 비율(prop.table), 합계구하기(addmargins) 누적비율 등 제시하고 그래프 그리기

freq <- read.csv("0301.frequency.csv",
                 header = TRUE,
                 na.strings = ".")
str(freq)

freq$grade <- factor(freq$grade,
                     levels = c(1:5),
                     labels = c("F","D","C","B","A"))

str(freq)

###################################
# 돗수분포표 만들기(일변량)

# attach(시작) ~ detach(끝) : 데이터 프레임 활성화
# freq라는 데이터 프레임을 고정적으로 인식하고 그 안의 변수만을 가지고 작업하고 싶을 때, 이 함수를 사용 하여 작업량 단축
# 항상 attach() detach() 함께 입력하고 데이터 작업 수행 - 에러메시지 뜨면 detach 후 다시 입력

attach(freq)

# table을 이용한 빈도수 확인, 그래프 만들 때에는 원데이터를 사용하는 것이 아니라 필요한 부분을 table로 인식해야 한다.

# grade.n <- table(freq$grade) # attach 없을때

grade.n <- table(grade)

table(grade)

#상대빈도(%) : 데이블을 만들어 놓고, 테이블에서 빈도를 입력하여 결정한다.

grade.p <- prop.table(grade.n)
grade.p

#빈도 + 상대빈도 : 빈도와 비율을 합치고자 할때 사용 bind

grade.t <- cbind(grade.n,grade.p) # cbind 옆으로 나열하라 (옆에 열추가)
grade.t

grade.t1 <- rbind(grade.n,grade.p) #  rbind 아래로 나열하라 (아래 행추가)
grade.t1

#빈도 + 상대빈도 + 합계

grade.a <- addmargins(grade.t, 1) # cbind에서는 기본 세팅으로 1을 하면 좋을 것 같다.
# grade.a <- addmargins(grade.t, margin =1) 그냥 1로해도 나온다. 옵션을 알 때 유용하겠군
grade.a

#margin=1 : 열 합계
#margin=2 : 행 합계
#margin=NULL : 전체 합계

rm(grade.t1)

detach(freq) # 항상 마무리

ch03 - 기초통계/도수분포표.r

ch03 - 기초통계/도수분포표.r

ch03 - 기초통계/도수분포표.r


model_ptsoil <- function (evapoTranspirationPriestlyTaylor = 120.0,
         Alpha = 1.5,
         tau = 0.9983,
         tauAlpha = 0.3){
    #'- Name: PtSoil -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: PtSoil EnergyLimitedEvaporation Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA Montpellier
    #'            * ExtendedDescription: Evaporation from the soil in the energy-limited stage
    #'            * ShortDescription: Evaporation from the soil in the energy-limited stage
    #'- inputs:
    #'            * name: evapoTranspirationPriestlyTaylor
    #'                          ** description : evapoTranspiration Priestly Taylor
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 120
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: Alpha
    #'                          ** description : Priestley-Taylor evapotranspiration proportionality constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.5
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: tau
    #'                          ** description : plant cover factor
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.9983
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: tauAlpha
    #'                          ** description : Fraction of the total net radiation exchanged at the soil surface when AlpaE = 1
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.3
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'- outputs:
    #'            * name: energyLimitedEvaporation
    #'                          ** description : energy Limited Evaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    if (tau < tauAlpha)
    {
        AlphaE <- 1.0
    }
    else
    {
        AlphaE <- Alpha - ((Alpha - 1.0) * (1.0 - tau) / (1.0 - tauAlpha))
    }
    energyLimitedEvaporation <- evapoTranspirationPriestlyTaylor / Alpha * AlphaE * tau
    return (list('energyLimitedEvaporation' = energyLimitedEvaporation))
}


# Load packages
library(networkD3)
library(glasso)
library(d3heatmap)
library(igraph)

################### Function Definiton Begin ####################
# convert inverse covariance matrix to links
wi2link <- function(mat) {
  mat <- abs(mat)
  diag(mat) <- 0
  min <- min(mat)
  max <- max(mat)
  links <- data.frame(from = NA, to = NA, weight = NA)
  for (i in 1:nrow(mat)) {
    for (j in 1:ncol(mat)) {
      if (mat[i,j] != 0 & i != j) {
        links <- rbind(links, c(i-1,j-1,range01(mat[i,j],min,max)))
      }
    }
  }
  return(links[-1,])
}

# scale to range [0,1]
range01 <- function(var, min, max) {
  res <- (var-min)/(max-min)
  return(res)
}

################### Function Definiton END ####################

################### Logic Begin ###################
# Prepare data
nodes <- read.csv(file = "AAL_Yan.csv")
measure = c("Assortivity", "Cliques", "Transitivity")
statsTable <- data.frame(measure, value = rep(NA, length(measure)),
                         meaning = c("The assortativity coefficient is positive is similar vertices (based on some external property) tend to connect to each, and negative otherwise.",
                                     "The size of the largest clique",
                                     "Transitivity measures the probability that the adjacent vertices of a vertex are connected. This is sometimes also called the clustering coefficient."))

# shiny server
shinyServer(function(input, output) {
  ### sharable data
  inputdata <- reactive({
    inFile <- input$inputFile
    if (is.null(inFile)) {
      return(NULL)
    }
    tmp <- read.csv(inFile$datapath, header = TRUE)
    tmp[,nodes$name]
  })

  # generate inverse covariance matrix given lambda
  wi <- reactive({
    tmp <- glasso(s = cov(inputdata()), rho = input$lambda)
    tmp <- tmp$wi
  })

  # update statistical table
  statsTable2 <- reactive({
    tmp <- wi()
    tmp[which(tmp!=0)] <- 1
    tmp.g <- graph.adjacency(tmp, mode = "undirected") # create igraph object given adjacency matrix
    # update graph statistics
    statsTable[statsTable$measure=="Assortivity","value"] <- assortativity_degree(tmp.g)
    statsTable[statsTable$measure=="Cliques","value"] <- clique_num(tmp.g)
    statsTable[statsTable$measure=="Transitivity","value"] <- transitivity(tmp.g, type = "undirected")
    statsTable
  })

  ### output
  # output: data table
  output$sampletable <- renderTable({
    tmp <- inputdata()
    tmp[1:10, 1:10]
  })

  # output: interactive network plot
  networkPlot <- eventReactive(input$updateNet, {
    links <- wi2link(wi())
    forceNetwork(Nodes = nodes, Links = links,
                Source = "from", Target = "to",
                Value = "weight", NodeID = "name",
                Group = "region", zoom = TRUE)
  })
  output$networkPlot <- renderForceNetwork({
    networkPlot()
  })

  # output: checkbox network plot
  checkboxPlot <- eventReactive(input$updateNet, {
    tmp <- wi()
    tmp[which(tmp!=0)] <- 1
    diag(tmp) <- 0
    d3heatmap(tmp, Rowv = FALSE, Colv = "Rowv", colors = grey(c(1, 0)),
                labRow = nodes$name, labCol = nodes$name)
  })
  output$checkboxPlot <- renderD3heatmap({
    checkboxPlot()
  })

  # output: statistics
  stats <- eventReactive(input$updateNet, {
    statsTable2()
  })
  output$stats <- renderTable({
    stats()
  })

  ## download
  output$downloadStats <- downloadHandler(
    filename = c('brain_connectivity.csv'),
    content = function(file) {
      write.csv(statsTable2(), file)
    }
  )
})
################### Logic END ###################


x <- 1:20
y <- log2(x)

svg("logarithmic.svg")

plot(x, y, type = "b", xlab = "Input Size", ylab = "Runtime / Complexity", pch = 20)


library(cmdstanr)
library(rstan)
stanfit <- function(fit) rstan::read_stan_csv(fit$output_files())

impala <- c(15, 20, 21, 23, 26)
waterbuck <- c(53, 57, 66, 67, 72)

stan.data <- list(x = impala, n = length(impala), kappa_1 = 1, kappa_2 = 1)

raftery  <- cmdstanr::cmdstan_model("stan/raftery.stan")

fit <- stanfit(raftery$sample(data = stan.data,
                                  max_treedepth = 15,
                                  adapt_delta = .99,
                                  parallel_chains = 4))

fit


# load data
depdata = read.csv("C:\\Users\\gaya\\prog\\workspace\\TutorialRecommender\\tutorials\\dependencies\\Probs\\jtStat.csv")

depdata$positive = as.numeric(depdata$positive)
depdata$negative = as.numeric(depdata$negative)
depdata$functional = as.numeric(depdata$functional)
depdata$structural = as.numeric(depdata$structural)
depdata$descriptive = as.numeric(depdata$descriptive)
depdata$instruction = as.numeric(depdata$instruction)
depdata$interCLT = as.numeric(depdata$interCLT)
depdata$other = as.numeric(depdata$other)

library(sqldf)
depstat = sqldf("select governor, relation, dependent, sum(positive) as npositive, count(*)  as nobs from depdata group by governor, relation, dependent")
# Compute population statistic
prc.positive.total <- sum(depstat$npositive) / sum(depstat$nobs)

expected.positive <- depstat$nobs * prc.positive.total

delta.positive <- depstat$npositive - expected.positive

# The standard deviation of a binomial variable
std.deviation <- sqrt(depstat$nobs * prc.positive.total * (1 - prc.positive.total))

depstat$z.score <- delta.positive / std.deviation


winRatios <- get.WinRatios(data)

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

data.analysis <- winRatios[, c("ratio.win3zz", "data.ZZ")]
data.analysis <- data.analysis[complete.cases(data.analysis), ]

x <- 0:9
avg <- c()
sdev <- c()

for (i in 0:9) {
    avg <- c(avg, mean(data.analysis$ratio.win3zz[data.analysis$data.ZZ == i], na.rm = T))
    sdev <- c(sdev, sd(data.analysis$ratio.win3zz[data.analysis$data.ZZ == i], na.rm = T))
}

avg.3zz <- avg

file <- file.path(outdir, "win3-special.png")
png(file, bg = "white", width = 600, height = 400)
plot(x, avg,
    xlim = c(-0.2, 9.5),
    # ylim=range(c(avg-sdev, avg+sdev)),
    ylim = c(0.7, 1.5),
    pch = 19,
    xlab = "Special number", ylab = "Pick frequency",
    main = "Pick frequency of special numbers"
)
axis(1, at = x, labels = x)
text(x + 0.3, avg, labels = round(avg, 2), cex = 0.7)
arrows(x, avg - sdev, x, avg + sdev, length = 0.05, angle = 90, code = 3)
dev.off()

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

data.analysis <- winRatios[, c("ratio.win4zz", "data.ZZ")]
data.analysis <- data.analysis[complete.cases(data.analysis), ]

x <- 0:9
avg <- c()
sdev <- c()

for (i in 0:9) {
    avg <- c(avg, mean(data.analysis$ratio.win4zz[data.analysis$data.ZZ == i], na.rm = T))
    sdev <- c(sdev, sd(data.analysis$ratio.win4zz[data.analysis$data.ZZ == i], na.rm = T))
}

avg.4zz <- avg

file <- file.path(outdir, "win4-special.png")
png(file, bg = "white", width = 600, height = 400)
plot(x, avg,
    xlim = c(-0.2, 9.5),
    # ylim=range(c(avg-sdev, avg+sdev)),
    ylim = c(0.7, 1.5),
    pch = 19,
    xlab = "Special number", ylab = "Pick frequency",
    main = "Pick frequency of special numbers"
)
axis(1, at = x, labels = x)
text(x + 0.3, avg, labels = round(avg, 2), cex = 0.7)
arrows(x, avg - sdev, x, avg + sdev, length = 0.05, angle = 90, code = 3)
dev.off()


setwd("~/Projects/Income-Prediction-Model")
pData= read.table("Data/adult.data",sep = ",",header = F)
colnames(pData)= c("age","Wcls","fnlwt","edu","eduNum","marStat","ocupp","relation","race","sex","capGain","capLoss","hperW","nCountry","sal")
dim(pData)
names(pData)
str(pData)
cor(pData)
attach(pData)
contrasts(sal)
pData$sal <- factor(pData$sal,levels = c(1,2), labels = c("L", "H"))
#### Logistic Refression ######################
sal01 =rep(0,length(sal))
sal01[levels(sal)==2]= 1  # <=50K
sal01[1:20]
glm.fit=glm(sal01~age+fnlwt+edu+eduNum+capGain+capLoss+hperW+sex
  +race+Wcls+marStat+relation+ocupp,data=pData,family="binomial")

glm.probs=predict(glm.fit,type="response")
glm.probs[1:10]

glm.pred=rep(0,length(sal))
glm.pred[glm.probs> .5]=1
salDirection =  rep(0, length(sal))
salDirection[sal01==1] = 1
table(glm.pred,salDirection)
mean(glm.pred!=salDirection)


# the very first Bubba R script  2021-02-28 (bbq)
#
# Following along with Introduction to R by Robert J. Hijmans
# version of 2020-03-23
#

a <- 7
print(a)
a <- 1:10
class(a)
a <- as.integer(7)
class(a)
a <- 7L
class(a)
b <- c(1.25, 2.9, 3.14)
b
d <- 6:9
d
8:2
e <- seq(from = 5, to = 14, by = 3)
e
f <- rev(e)
f
rep(8, times = 8)
rep(6:9, times = 5)
x <- 'Yi'
y <- 'Liang'
class(x)
x
countries <- c('China', 'China', 'Japan', 'South Korea', 'Japan')
countries
length(countries)
nchar(countries)
z <- letters
z
zup <- toupper(z)
zup
girl <- "Mary"
boy <- "John"
paste(girl, "likes", boy)
paste(countries, collapse=' -- ')
substr('Hello World', 7, 11)
gsub('l', '!!', 'Hello World')
sub('l', '!!', 'Hello World')
gsub('Hello', 'bye bye', "Hello World")
d <- c('az20', 'az21', 'az22', 'ba30', 'ba31', 'ba32')
i <- grep('b', d)
i
d[i]
i <- grep('2', d)
d[i]
i
grep('2$', d)
grep('^b', d)
z <- FALSE
z
x <- 5
x > 3
x == 5
y <- TRUE
y + 1
as.logical(0)
as.logical(3.14)
f1 <- as.factor(countries)
f1
f2 <- c(5:7, 5:7, 5:7)
f2
f2 <- as.factor(f2)
f2
as.integer(f2)
# factors are typed lists
fc2 <- as.character(f2)
# casting to characters implied by the list
fc2
as.integer(fc2)
# casting to integers implied by the list values
m <- c(2, NA, 5, 2, NA, 2)
m
# now it's time for time
d1 <- as.Date('2015-4-11')
d2 <- as.Date('2015-3-11')
class(d1)
d1 - d2
as.POSIXlt(d1)
as.POSIXct(d1)
#
#  Hijmans chapter 1.3   Basic Data Structures  p.10
#
matrix(ncol=3, nrow=2)
matrix(1:6, ncol=3, nrow=2)
matrix(1:6, ncol=3, nrow=2, byrow = TRUE)
a <- c(1,2,3)
a
b <- 5:7
b
m1 <- cbind(a, b)
m1
m2 <- rbind(a, b)
m2
m3 <- cbind(b, b, a)
m3
m <- cbind(m1, m3)
m
ncol(m)
nrow(m)
dim(m)
length(m)
colnames(m)
rownames(m)
colnames(m) <- c('ID', 'X', 'Y', 'v1', 'v2')
m
rownames(m) <- paste0('rw_', 1:nrow(m))
m
cbind(vchar=c('a','b'), vnumb=1:2)
#                       List    p 13
list(1:3)
e <- list(c(2,5), 'abc')
e
names(e) <- c('first' , 'last')
e
m <- matrix(1:6, ncol=3, nrow=2)
m
f <- list(e, m, 'abc')
f
m <- matrix(1:9, nrow=3, ncol=3, byrow = TRUE)
colnames(m) <- c('a', 'b', 'c')
m
m[2,2]
m[1,3]
m[3,2]
m[2:3, 2:3]
m[2,]
m[,3]
m[, 'b']
m[,c('a', 'c')]
m[5]
m[7]
m[3]
m[2,]
m[,2, drop=FALSE]
diag(m)
m
diag(m) <- 0
m
#
# index access to lists
#
m <- matrix(1:9, nrow=3, ncol=3, byrow = TRUE)
m
colnames(m) <- c('a', 'b', 'c')
m
e <- list(list(1:3), c('a', 'b', 'c', 'd'), m)
e
e[2]
e[[2]]
e[1]
e[[3]]
names(e) <- c('zzz', 'xyz', 'abc')
e
e$xyz
e$zzz
e$zzz[1]

m
d <- data.frame(m)
d
class(d)
d[,2]
d[2]
d[,'b']
d['b']
d$b
d[, 'b', drop=FALSE]
x <- 10:21
x
i <- which(x > 15)
i
x[i]
x
b <- x > 15
b
x[b]
j <- c(7, 9, 11, 13)
j %in% x
which(j %in% x)
match(j, x)
match(x, j)

#
#  Chapter 1.5   Algebra   p 20
#
m <- matrix(1:6, nrow=2, ncol=3, byrow = TRUE)
m
n <- matrix(1:6, nrow=3, ncol=2)
n
m %*% n
n %*% m
a <- 4:11
r <- runif(11)
r <- rnorm(5, mean=11,  sd=1)
r
set.seed(14)
runif(5)
runif(5)

set.seed(14)
runif(5)
u = matrix(1, ncol=3, nrow=3)
u
u <- u * runif(length(u))
u
#
# Chapter 1.6   Read and write files   p 24
#
txt <- "Here be an example\nwith newline to boot\n\tand taubularity\n"
txt
message(txt)
f1 <- "/home/darb/github/learn_R_2021/foost.csv"
file.exists(f1)
d <- data.frame(id=1:10, name=letters[1:10], value=seq(10,28,2))
d
write.csv(d, 'test.csv', row.names=FALSE)
write.table(d, 'test.dat', row.names=FALSE)
file.exists('test.csv')
file.exists('test.dat')
getwd()
file.path(getwd(), 'test.csv')
d <- read.csv('test.csv', stringsAsFactors=FALSE)
d
d <- read.table('test.dat', stringsAsFactors=FALSE)
d
d <- read.table('test.dat', header=TRUE, stringsAsFactors=FALSE)
d
d <- readLines('test.csv')
class(d)
webpage <- readLines("http://bq.bz", warn=FALSE)
head(webpage)
webpage[10:55]

list.files()
list.files(pattern = 'csv$')


 ZHEGV Example Program Results

 Eigenvalues
       -5.9990    -2.9936     0.5047     3.9990
 Eigenvectors
             1          2          3          4
 1      1.7405    -0.6626     0.2835     1.2378
        0.0000     0.2258    -0.5806     0.0000

 2     -0.4136    -0.1164    -0.3769    -0.5608
       -0.4689    -0.0178    -0.3194    -0.3729

 3     -0.8404     0.9098    -0.3338    -0.6643
       -0.2483     0.0000    -0.0134    -0.1021

 4      0.3021    -0.6120     0.6663     0.1589
        0.6103    -0.5348     0.0000     0.8366

 Estimate of reciprocal condition number for B
        2.5E-03

 Error estimates for the eigenvalues
        6.7E-13    4.1E-13    1.9E-13    5.0E-13

 Error estimates for the eigenvectors
        1.2E-12    1.1E-12    8.5E-13    9.4E-13


#This takes a matrix of x values, fits c/p/s hierarchically.
#clear environment, load runjags.
rm(list = ls())
library(runjags)

#10 sites, 10 plots per site, 10 observations per plot.
n.site <- 10
n.plot <- 9
n.core <- 10
siteID <- sort(rep(LETTERS[1:n.site],n.plot*n.core))
plotID <- rep(1:n.plot,n.site*n.core)
plotID <-paste(siteID,plotID,sep = '_')
site.means <- runif(n.site,10,25)
plot.means <- list()
for(i in 1:length(site.means)){
  plot.means[[i]] <- rnorm(n.plot,site.means[i],2)
}
plot.means <- unlist(plot.means)

#get observations for each plot, based on a mean, and a sd of 2
obs <- list()
for(i in 1:length(plot.means)){
  obs[[i]] <- rnorm(n.core, mean = plot.means[i], sd = 2)
}
x1 <- unlist(obs)
obs <- list()
for(i in 1:length(plot.means)){
  obs[[i]] <- rnorm(n.core, mean = plot.means[i], sd = 2)
}
x2 <- unlist(obs)

#create true data frame.
dat <- data.frame(siteID,plotID)
dat <- dat[order(plotID),]
dat$x1 <- x1
dat$x2 <- x2
X <- as.matrix(dat[,c('x1','x2')])

#indexing.
plotindex <- as.factor(dat$plotID)
siteindex <- list()
for(i in 1:n.site){
  siteindex[[i]] <- rep(LETTERS[i],n.plot)
}
siteindex <- as.factor(unlist(siteindex))

jags.model = "
model {
  #priors
  for(m in 1:n.X){
      global[m] ~ dnorm(0,1.0E-4) #global level parameter prior.
    site.tau[m] ~ dgamma(0.1,0.1)
    plot.tau[m] ~ dgamma(0.1,0.1)
    core.tau[m] ~ dgamma(0.1,0.1)
    }

  #estimate means
  for(m in 1:n.X){
    for(i in 1:N.site){ site[i,m] ~ dnorm(global[m], site.tau[m])}           ## estimate global mean
    for(j in 1:N.plot){ plot[j,m] ~ dnorm(site[siteindex[j],m],plot.tau[m])} ## estimate site means
    for(k in 1:N.core){ core[k,m] ~ dnorm(plot[plotindex[k],m],core.tau[m])} ## estimate plot means
  }

} #end model
"
#specify data object.
jags.data <- list(core = X, n.X = ncol(X),
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)
#fit model.
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                               monitor = c('plot','site'))
out <- summary(jags.out)
#compare estimate plot/site means to true values. All w/in 95% credible interval.
par(mfrow = c(2,2))
fit.plot.means <- out[grep('plot',rownames(out)),][,4]
fit.site.means <- out[grep('site',rownames(out)),][,4]
plot(plot.means ~ fit.plot.means[1:90], main = 'plot-level fit x1'); abline(0,1,lwd=2, lty=2)
plot(plot.means ~ fit.plot.means[91:180], main = 'plot-level fit x2'); abline(0,1,lwd=2, lty=2)
plot(site.means ~ fit.site.means[1:10], main = 'site-level fit x1'); abline(0,1,lwd=2, lty=2)
plot(site.means ~ fit.site.means[11:20], main = 'site-level fit x2'); abline(0,1,lwd=2, lty=2)

#check uncertainty values
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('core.tau','plot.tau','site.tau','global'))
summary(jags.out)

#create data with missing observations.
missing <- dat
#remove 3 observations within a plot in site A.
missing[2:4,3] <- NA
missing[4:7,4] <- NA
#remove an entire plot in site B.
missing[missing$plotID == 'B_1',3] <- NA
missing[missing$plotID == 'B_2',4] <- NA
#remove all observations in site C.
missing[missing$siteID == 'C'  ,3] <- NA
missing[missing$siteID == 'B'  ,4] <- NA

X <- as.matrix(missing[,3:4])

#creat new jags data object.
jags.data <- list(core = X, n.X = ncol(X),
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)

#fit, see what the model estimates for core level values.
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('core','plot','site'))

out <- summary(jags.out)
comp <- dat

###FROM here on has not been modded for multivariate case.
comp$pred <- out[grep('core',rownames(out)),4]
comp$removed <- missing$x
z <- comp[is.na(comp$removed),]

#how are the core level predcitions compared to true values? in range.
cbind(out[2:4,],dat$x[2:4])

#how about the missing plot?
zz <- cbind(out[grep('core',rownames(out)),],missing,dat$x)
zz[zz$plotID == 'B_1',]

#how about the missing site?
zz[zz$siteID == 'C',]

testing_development/implement_missing_data_ddirch/matrix of missing data.r


pca.analyse.data = function( X, t0=NULL, t1=NULL,
  fname="sorted.anomalies", title="Years", vars=NULL, newnames=NULL,
  colscheme="redgreen", addscores=TRUE, sortdecreasing=FALSE, scaledata=TRUE, plotdata=TRUE) {

  if (!is.null(vars)) X = X[, vars ]
  if (!is.null(newnames) ) names(X) = newnames

  if (!is.null(t0) & !is.null(t1)) {
    X = X[ which( rowSums( X, na.rm=T) !=0 ) ,]
    X = X[ which( as.numeric(rownames(X)) >= t0 ) ,]
    X = X[ which( as.numeric(rownames(X)) <= t1 ) ,]
  }

  if (scaledata) X = scale( X, center=TRUE, scale=TRUE )

  yvals=rownames(X)
  vars =colnames(X)
  years= as.numeric(yvals)
  yrange = range(years)

  of1 = paste(fname, "PC1.pdf", sep=".")
  of2 = paste(fname, "PC2.pdf", sep=".")
  of3 = paste(fname, "anomalies.pdf", sep=".")

  cm = cor( X, use="pairwise.complete.obs" ) # set up a correlation matrix ignoring NAs
  cm[ is.na(cm) ] = 0

  s = svd(cm)  # eigenanalysis via singular value decomposition
  evec = s$v # eigenvectors
  eval = s$d # eigenvalues

  # i.e., X %*% evec  .. force a multiplication ignoring NAs
  nfac = 2
  ndat = dim(X)[1]
  scores = matrix(0, nrow=ndat, ncol = nfac)
  for (j in 1:nfac) {
    for (i in 1:ndat) {
      scores[i,j] = sum ( X[i,] * t(evec[,j]), na.rm=T )
    }
  }

  x = cbind( scores[,1] / sqrt(eval[1] ), scores[,2] / sqrt( eval[2]) )
  y = cbind( evec[,1] * sqrt(eval[1] ) , evec[,2] * sqrt( eval[2]) )

  outscores = data.frame(x)
  outscores$yr = as.numeric(yvals)

  X.stats = list( id=yvals, vars=vars, correlation.matrix=cm,
    eigenvectors=evec, eigenvalues=eval, projections.id=x, projections.vars=y )

  print( str( X.stats))

  if (plotdata) {

    par(cex=2, lty=2)

    plot.new()
    plot( yvals, x[,1], xlab="Years", ylab=paste("PCA1 (", round(eval[1]/sum(eval)*100, 1), "%)", sep="") )
    lines( lowess(yvals, x[,1], f=1/5 ) )
    dev.print ( pdf, file=of1, width=12, height=8 )
    dev.off()

    plot.new()
    plot( yvals, x[,2], xlab="Years", ylab=paste("PCA2 (", round(eval[2]/sum(eval)*100, 1), "%)", sep="" ) )
    lines( lowess(yvals, x[,2], f=1/5) )
    dev.print ( pdf, file=of2, width=12, height=8 )
    dev.off()

    # form residual variations figure based upon a sorting of ordination scores
    varloadings = NULL
    varloadings = as.data.frame( cbind( y, vars ) )

    q = as.data.frame( t( as.matrix( X ) ) )
    q$vars = rownames( q )
    q = merge( x=q, y=varloadings, by.x="vars", by.y="vars", all=T )
    ordered = sort( as.numeric( as.character( q$V1 ) ), index.return=T, decreasing=sortdecreasing )
    qq = q[ ordered$ix, ]

    if (addscores) {
      varnames = paste(qq$vars, " {", round(as.numeric(as.character(qq$V1)),2), ", ",
                 round(as.numeric(as.character(qq$V2)),2), "}", sep="")
    } else {
      varnames = qq$vars
    }

    qq$vars = qq$V1 = qq$V2 = NULL
    qq = as.data.frame( t( qq ) )
    colnames( qq ) = varnames
    Z = as.matrix( qq )

    a = max( abs( min(Z, na.rm=T) ), abs( max( Z, na.rm=T) ) )
    br = seq( -a, a, .1)

    plot.new()
    par( mai=c(2, 6, 1, 0.5), cex=2 )

    if (colscheme=="rainbow")  {
      cols=rainbow(length(br)-1, start=0, end=1/3)
    } else if (colscheme=="redgreen") {
      cols=rev(green.red(length(br)))
    } else if (colscheme=="bluered") {
      cols=rev(blue.red(length(br)))
    } else if (colscheme=="heat") {
      cols=rev(heat.colors(length(br)-1))
    } else {
      cols=colscheme
    }

    image(z=Z, x=years, breaks=br, col=cols, xlab=title, ylab="", axes=F )

    for (i in seq(range(yrange)[1], range(yrange)[2], by=10)) abline( v=i-0.5, col="slategray")
    for (i in seq(range(yrange)[1], range(yrange)[2], by=1)) abline( v=i-0.5, col="slategray1")

    z = 1/(dim(Z)[2] - 1)
    for (i in seq(0, 1, by=z*10)) abline( h=i-(z/2), col="slategray")
    for (i in seq(0, 1, by=z)) abline( h=i-(z/2), col="slategray1")

    par(las=1)
    axis( 1 )

    vars = colnames(Z)
    par(cex=1.4)
    axis( 2, at=seq(0,1,length=length(vars)), labels=vars)
    write.table(Z, file="anomalies.dat", quote=F, sep=";")
    dev.print (pdf, file=of3, width=20, height=20)
    dev.off()
  }

  return( X.stats )
}


##########################################################################
# github : https://github.com/jiankaiwang/DetailScience
# classification : math
# description : calculate the network in matrix
#
# class description :
# - networkAfterRemoveNodesRetData
#		(1) net : perserve the network after removing nodes recursively
#		(2) sel : perserve the origin nodes for absolutely deletion
#		(3) rmv : perserve nodes for deletion finally
#
# function description :
# - networkAfterRemoveNodes
#   (1) directed : row is the source and column is the target (or destination)
#		(2) return : returned object is "networkAfterRemoveNodesRetData" data type
#
# function usage :
# - networkAfterRemoveNodesRetData networkAfterRemoveNodes(matrix originNetwork, vector selectedNodes, logical isDirected)
#   (1) originNetwork (as matrix) : a matrix conserving edge information
#   (2) selectedNodes (as vector) : a vector listing all nodes are removed
#   (3) isDirected (as boolean) : whether the matrix is directed or not
#
# function example :
# - leftNetwork <- networkAfterRemoveNodes(net,selected,TRUE)
#
# > net
#    A B C D E F G H I
#  A 0 0 1 1 0 0 0 1 0
#  B 0 0 0 0 0 0 0 0 0
#  C 0 0 0 0 0 1 0 0 0
#  D 0 1 0 0 1 0 0 0 0
#  E 0 0 0 0 0 0 0 1 0
#  F 0 0 0 0 0 0 1 0 0
#  G 0 0 0 1 1 0 0 0 0
#  H 0 0 0 0 0 0 0 0 0
#  I 0 0 0 0 0 0 0 0 0
#
# > leftNetwork
# An object of class "classNetAfterNodeRevData"
#	Slot "net":
#		A B C D E F G H I
#	A 0 0 0 1 0 0 0 1 0
#	B 0 0 0 0 0 0 0 0 0
#	C 0 0 0 0 0 0 0 0 0
#	D 0 0 0 0 0 0 0 0 0
#	E 0 0 0 0 0 0 0 0 0
#	F 0 0 0 0 0 0 0 0 0
#	G 0 0 0 0 0 0 0 0 0
#	H 0 0 0 0 0 0 0 0 0
#	I 0 0 0 0 0 0 0 0 0

#	Slot "sel":
#	[1] "B" "C" "E"

#	Slot "rmv":
#	[1] "B" "C" "E" "F" "G"
##########################################################################

networkAfterRemoveNodesRetData <- setClass(
  # Set the name for the class
  "classNetAfterNodeRevData",

  # Define the slots
  slots = c(
    net = "matrix",
    sel = "vector",
    rmv = "vector"
  ),

  # Set the default values for the slots. (optional)
  prototype=list(
    net = matrix(c(1:4),nrow=2,ncol=2,dimnames = list(c("A","B"),c("A","B"))),
    sel = c("A"),
    rmv = c("A")
  ),

  # Make a function that can test to see if the data is consistent.
  # This is not called if you have an initialize function defined!
  validity=function(object)
  {
    if((length(object@net) < 1) || (length(object@sel) < 1) || (length(object@rmv) < 1)) {
      return("Either one of net, selected or removed is not empty.")
    }
    return(TRUE)
  }
)

networkAfterRemoveNodes <- function(originNetwork, selectedNodes, isDirected) {

  # continuously reconstruct the network
  net <- originNetwork

  # construct mask network
  maskOperated <- originNetwork

  # selected items
  selected <- selectedNodes

  # initial flag
  continueFlag = 1

  while(continueFlag == 1) {

    # initial mask matrix
    maskOperated[,] <- 0

    # drug would cause edge missing
    maskOperated[selected,] <- 1
    if(! isDirected) {
      maskOperated[,selected] <- 1
    }

    left <- matrix(
      bitwAnd(net,maskOperated),
      nrow=nrow(net),
      ncol=ncol(net),
      dimnames = list(
        rownames(net),
        colnames(net)
      )
    )

    fetNew <- which(left[,] == 1)
    sourceName <- rownames(net)
    itemName <- colnames(net)
    newSelect <- selected

    # check whether new node is found
    for(item in fetNew) {
      # r default is column-based, not row-based
      sourceNode <- sourceName[item %% nrow(net)]
      checkNode <- itemName[ceiling(item / nrow(net))]

      if(length(which(net[,checkNode] == 1)) > 1) {
        # there are others existing source
        # origin Network must be modified to remove the edge singlely
        # but the node does not be removed
        net[sourceNode,checkNode] <- 0
        next
      }

      # no matter whether node is removed, edge must be removed
      net[sourceNode,checkNode] <- 0

      # there are no other source, this node should be added for removing
      if(checkNode %in% newSelect) {
        next
      } else {
        # add new selected nodes
        newSelect <- c(newSelect,checkNode)
      }

    }

    if(length(newSelect) != length(selected)) {
      # new nodes are added
      selected <- newSelect
    } else {
      # not found new nodes
      continueFlag <- 0
    }

    #print(newSelect)
  }

  # restore the network
  mask <- originNetwork
  mask[,] <- 1
  mask[selected,] <- 0
  # if the destination node is removed
  # the edge between the source and the destination is also removed
  mask[,selected] <- 0
  leftNet <- matrix(
    bitwAnd(originNetwork,mask),
    nrow=nrow(originNetwork),
    ncol=ncol(originNetwork),
    dimnames = list(
      rownames(originNetwork),
      colnames(originNetwork)
    )
  )

  return(networkAfterRemoveNodesRetData(net=leftNet,sel=selectedNodes,rmv=selected))
}


#testing calculating DIC from deviance scores vs. dic.samples()
#clear environment, load packages
rm(list=ls())
library(runjags)

#generate a linear relatioship
set.seed(1234)
n <- 100
x <- rnorm(n)
y <- x + rnorm(n)

#make JAGS data object
jags.data <- list(n = n, x =  x, y = y)

#write JAGS model
jags.model = "
model {
  #parameter priors
      m  ~ dnorm(0, 1E-3)
    tau <- pow(sigma, -2)
  sigma  ~ dunif(0, 100)

  #model
  for(i in 1:n){
        y[i]  ~ dnorm(y.hat[i], tau)
    y.hat[i] <- x[i]*m
  }
} #end model loop.
"

#model for running with fixed parameter values.
fix.model = "
model {
  #model
  for(i in 1:n){
        y[i]  ~ dnorm(y.hat[i], tau)
    y.hat[i] <- x[i]*m
  }
} #end model loop.
"

jags.out <- run.jags(model = jags.model,
                    data = jags.data,
                    n.chains = 3,
                    adapt = 100,
                    burnin = 100,
                    sample = 1000,
                    monitor = c('m','deviance','tau'))
jags.sum <- summary(jags.out)

#grab mean deiviance and parameter means.
jags.deviance.mu <- jags.sum[2,4]
               m <- jags.sum[1,4]
             tau <- jags.sum[3,4]

#new jags data
jags.data <- list(y=y, x=x, n=n, m=m, tau = tau)

#get pD which is deviance at mean parameter values.
pD.out <- run.jags(model = fix.model,
                   data = jags.data,
                   n.chains = 3,
                   adapt = 100,
                   burnin = 100,
                   sample = 1000,
                   monitor = c('deviance'))
pD.sum <- summary(pD.out)
pD <- pD.sum[1,3]

#Calculate DIC.
dic_A <- 2*jags.deviance.mu - pD

#get deviance using dic.samples
dic_B <- extract(jags.out,'DIC')

#compare calculated DIC scores.
dic_A #deviance calculated by rerunning model with parameters set to their mean values.
dic_B #deviance calculated from dic.samples()


##Shape=vector point
##enestacolumnaestaelrinde=field Shape
##Poligono=vector polygon
##Distancia_busqueda=number 40
##showplots
##output=output raster

#output_plots_to_html
##showplots

library(sp)
library(spdep)
library(gstat)

crs_imagen<-st_crs(Shape)
datos <- as_Spatial(Shape)
poligono <- as_Spatial(Poligono)

proj4string(datos) <- CRS(proj4string(datos))

>print("ARMO GRILLA DE MUESTREO")
poligono <- buffer(poligono, width=100)
grdpts <- makegrid(poligono, cellsize = 5)
spgrd <- SpatialPoints(grdpts, proj4string = CRS(proj4string(poligono)))
spgrdWithin <- SpatialPixels(spgrd[poligono,])
par(mfrow= c(1,1))
>plot(spgrdWithin,col = "red", pch = 10, cex = 0.2,xlab="X",ylab="Y")
gri<-spgrdWithin
print(str(gri))
print(CRS(proj4string(poligono)))

>print("ARMO VARIOGRAMA")
require(gstat)

semivariograma <- variogram(get(enestacolumnaestaelrinde)~1, datos, cutoff=250)

sill<-max(semivariograma$gamma)
nugget<-semivariograma[1,3]
Limite_distancia<-max(semivariograma$dist)

modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,"Sph",Limite_distancia,nugget))
error1<-attr(modelovgm , 'SSErr')
>print(paste("Error inicial",error1))
modelo_final = "Sph"

seleccion_modelo<-function(){
	modelos<-c("Sph","Exp","Lin","Gau","Ste","Mat")
		for (i in 1:length(modelos)){
                print(i)
		modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,modelos[i],Limite_distancia,nugget))
	 	error<-(attr(modelovgm , 'SSErr'))
			print(modelos[i])
			print(error)
			if(error < error1){
                        modelo_final <<- modelos[i]
		        error1<-error
 			>print(paste("Por ahora el mejor modelo es",modelo_final))

                        }
            }
}

suppressWarnings(seleccion_modelo())
>print(paste("Modelo final",modelo_final))
modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,modelo_final,Limite_distancia,nugget))
plot(semivariograma,modelovgm ,main="",xlab="Distancia",ylab="Semivarianza")

data2<-remove.duplicates(datos)
>print("Datos originales")
>print(nrow(datos))
>print("Datos filtrados")
>print(nrow(data2))

#Sileciado 16/07
#crs(data2)<-NA
#crs(gri)<-NA

Kg_wls <- krige(get(enestacolumnaestaelrinde)~1, data2, gri, model = modelovgm, debug.level=-1,maxdist=Distancia_busqueda)

print("Armamos el Raster para ver en QGIS")
raster<- raster(Kg_wls,layer=1)
crs(raster)<-crs(poligono)
output <- raster


wtd.t.test <- function(x, y=0, weight=NULL, weighty=NULL, samedata=TRUE){
  if(is.null(weight)){
    weight <- rep(1, length(x))
  }
  if(length(y)!=length(x) & length(y)>1){
    samedata <- FALSE
    warning("Treating data for x and y separately")
    if(is.null(weighty)){
       warning("y has no weights")
     }
  }
  if(is.null(weighty) & samedata==TRUE){
    weighty <- weight
  }
  if(is.null(weighty) & samedata==FALSE){
    weighty <- rep(1, length(y))
  }
  require(Hmisc)
  n <- sum(!is.na(x))
  mx <- wtd.mean(x, weight, na.rm=TRUE)
  vx <- wtd.var(x, weight, na.rm=TRUE)
  if(length(y)==1){
    dif <- mx-y
    sx <- sqrt(vx)
    se <- sx/sqrt(n)
    t <- (mx-y)/se
    df <- n-1
    p.value <- (1-pt(abs(t), df))*2
    coef <- c(t, df, p.value)
    out2 <- c(dif, mx, y, se)
    names(coef) <- c("t.value", "df", "p.value")
    names(out2) <- c("Difference", "Mean", "Alternative", "Std. Err")
    out <- list("One Sample Weighted T-Test", coef, out2)
    names(out) <- c("test", "coefficients", "additional")
  }
  if(length(y)>1){
    n2 <- sum(!is.na(y))
    my <- wtd.mean(y, weighty, na.rm=TRUE)
    vy <- wtd.var(y, weighty, na.rm=TRUE)
    dif <- mx-my
    sxy <- sqrt((vx/n)+(vy/n2))
    df <- (((vx/n)+(vy/n2))^2)/((((vx/n)^2)/(n-1))+((vy/n2)^2/(n2-1)))
    t <- (mx-my)/sxy
    p.value <- (1-pt(abs(t), df))*2
    coef <- c(t, df, p.value)
    out2 <- c(dif, mx, my, sxy)
    names(coef) <- c("t.value", "df", "p.value")
    names(out2) <- c("Difference", "Mean.x", "Mean.y", "Std. Err")
    out <- list("Two Sample Weighted T-Test (Welch)", coef, out2)
    names(out) <- c("test", "coefficients", "additional")
  }
  out
}


## Created on Thursday, September  2, 2021 at 3:18pm EDT by Weekend Editor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

toolsDir <- "../../tools"                              # Random tools available from the author
source(file.path(toolsDir, "graphics-tools.r"))        # Various graphics tools

doit <- function(k = 15100000, N = 438000000, pmin = 0.03440, pmax = 0.03455, clps = c(0.025, 0.975),
                 plotFile = "./2021-09-02-vaccine-waste.png") {
  withPNG(plotFile, 400, 400, FALSE, function() {      # Capture graphics to a file
    withPars(function() {                              # Save/restore graphics parameters
      ps        <- seq(from = pmin, to = pmax, length.out = 1000)
      betaProbs <- sapply(ps, function(p) { dbeta(p, k + 1, N - k + 1) })
      plot(x = ps, y = betaProbs, type = "l", col = "blue",
           xlim = c(pmin, pmax), xlab = "p", ylab = "Posterior Beta",
           main = "Bayesian Posterior: Waste Probability")
      sapply(clps, function(p) {                       # Draw lines at 95% confidence limits
        cl <- qbeta(p, k + 1, N - k + 1)               # Next confidence limit
        abline(v = qbeta(p, k + 1, N - k + 1), lty = "dashed")
        text(x = cl, y = 0.5 * max(betaProbs), srt = 90, pos = 1,
             labels = sprintf("%.1f%% CL: %.5f", 100.0 * p, cl))
      })                                               #
    }, pty = "m",                                      # Maximal plotting area
       bg  = "white",                                  # White background
       mar = c(3, 3, 2, 1),                            # Pull in on margins a bit
       mgp = c(1.7, 0.5, 0),                           # Axis title, labels, ticks
       ps  = 16)                                       # Larger type size for file capture
  })                                                   #
  invisible(NA)                                        # Return nothing of interest
}                                                      #


# 3.2. land use regression
mod.min  <- lm(pm25 ~ 1, data=mon.data)
mod.full <- lm(pm25 ~ long + lat + log10.m.to.a1 + log10.m.to.a2 + log10.m.to.a3
                + log10.m.to.road + km.to.coast + s2000.pop.div.10000, data=mon.data)

step(mod.min, direction="both", scope=list(lower = ~1, upper = mod.full), test="F")

# output of step has the coefficients.  Can use that to get the list??

mod <- lm(pm25 ~ km.to.coast + log10.m.to.a1 + log10.m.to.a2 + lat, data=mon.data)

# 3.2.1. leave-one-out cross-validation
for(i in 1:nrow(mon.data)){
  train <- mon.data[-i,]
  test <- mon.data[i,]
  train.lm <- lm(pm25 ~ km.to.coast + log10.m.to.a1 + log10.m.to.a2 + lat, data=train)
  X <- cbind(1,matrix(unlist(test[,names(train.lm$model)[-1]]),nrow=1))
  pred.1 <- X %*% train.lm$coef
  if(i==1) pred <- pred.1 else pred <- c(pred,pred.1)
}

mse.lur <- mean( (mon.data$pm25 - pred)^2 )
r2.lur <- 1 - mse.lur/var(mon.data$pm25)
mse.lur
r2.lur


# A approximate construction (you dn't get continuum-s with a computer)
# of the standard Brownian Motion from random walks
# 23-04-2015
# Killian Martin--Horgassan

# Arguments :
# - t : a nonnegative real number, as we want to check the distribution
#       of B^(n)(t) = brokenLine(nt)/sqrt(n)
# - h : increment size

brownianMotion = function(t,h) {

	return(brokenLine((1/h)*t)/sqrt(1/h))
}


###################################################################################
# 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: linear increase.
#
# 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 <- "lininc" # type of increase in propagule pressure, required for output file; here: linear increase

## Define temporal development of propagule pressure ###########################################################
m <- seq(0,mean(m)*2,length.out=t_max) # linear increase
timeaxis <- seq(1,t_max/1000,length.out=t_max) # for plotting

# 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_Linear.r


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 12, 2016
# ref: http://harding.edu/fmccown/r/
# clear; Rscript autosBarplot.r ; rm *~

# inputs: data/autos.dat
# outputs: figures/autosBarplot.eps,autosBarplot2.eps

# set the working directory
setwd("~/Copy/Programming/R/rprograms/plotting/2dplots/")

# Read values from tab-delimited autos.dat
autos_data <- read.table("data/autos.dat", header=T, sep="\t")

# Start device driver to save output to figure.pdf
#postscript(file="figures/autosBarplot.eps", height=3.5, width=5)

# simple plot 1
# Graph cars with specified labels for axes.  Use blue
# borders and diagnal lines in bars.
barplot(autos_data$cars, main="Cars", xlab="Days",
   ylab="Total", names.arg=c("Mon","Tue","Wed","Thu","Fri"),
   border="blue", density=c(10,20,30,40,50))

# another plot

# Graph autos with adjacent bars using rainbow colors
barplot(as.matrix(autos_data), main="Autos", ylab= "Total",
   beside=TRUE, col=rainbow(5))

# Place the legend at the top-left corner with no frame
# using rainbow colors
legend("topleft", c("Mon","Tue","Wed","Thu","Fri"), cex=0.6,
   bty="n", fill=rainbow(5));

# Turn off device driver (to flush output)
#dev.off()

#####################################################################################
# a stacked bar chart and place the legend outside of the plot area:
# Read values from tab-delimited autos.dat
autos_data <- read.table("data/autos.dat", header=T, sep="\t")

# Start device driver to save output to figure.pdf
#postscript(file="figures/autosBarplot2.eps", height=3.5, width=5)

# Expand right side of clipping rect to make room for the legend
par(xpd=T, mar=par()$mar+c(0,0,0,4))

# Graph autos (transposing the matrix) using heat colors,
# put 10% of the space between each bar, and make labels
# smaller with horizontal y-axis labels
barplot(t(autos_data), main="Autos", ylab="Total",
   col=heat.colors(3), space=0.1, cex.axis=0.8, las=1,
   names.arg=c("Mon","Tue","Wed","Thu","Fri"), cex=0.8)

# Place the legend at (6,30) using heat colors
legend(6, 30, names(autos_data), cex=0.8, fill=heat.colors(3));

# Turn off device driver (to flush output)
#dev.off()

# Restore default clipping rect
par(mar=c(5, 4, 4, 2) + 0.1)


##### Chapter 9: Clustering with k-means -------------------

## Example: Finding Teen Market Segments ----
## Step 2: Exploring and preparing the data ----
teens <- read.csv("snsdata.csv")
str(teens)

# look at missing data for female variable
table(teens$gender)
table(teens$gender, useNA = "ifany")

# look at missing data for age variable
summary(teens$age)

# eliminate age outliers
teens$age <- ifelse(teens$age >= 13 & teens$age < 20,
                     teens$age, NA)

summary(teens$age)

# reassign missing gender values to "unknown"
teens$female <- ifelse(teens$gender == "F" &
                         !is.na(teens$gender), 1, 0)
teens$no_gender <- ifelse(is.na(teens$gender), 1, 0)

# check our recoding work
table(teens$gender, useNA = "ifany")
table(teens$female, useNA = "ifany")
table(teens$no_gender, useNA = "ifany")

# finding the mean age by cohort
mean(teens$age) # doesn't work
mean(teens$age, na.rm = TRUE)

# age by cohort
aggregate(data = teens, age ~ gradyear, mean, na.rm = TRUE)

# calculating the expected age for each person
ave_age <- ave(teens$age, teens$gradyear,
                 FUN = function(x) mean(x, na.rm = TRUE))

teens$age <- ifelse(is.na(teens$age), ave_age, teens$age)

# check the summary results to ensure missing values are eliminated
summary(teens$age)

## Step 3: Training a model on the data ----
interests <- teens[5:40]
interests_z <- as.data.frame(lapply(interests, scale))

teen_clusters <- kmeans(interests_z, 5)

## Step 4: Evaluating model performance ----
# look at the size of the clusters
teen_clusters$size

# look at the cluster centers
teen_clusters$centers

## Step 5: Improving model performance ----
# apply the cluster IDs to the original data frame
teens$cluster <- teen_clusters$cluster

# look at the first five records
teens[1:5, c("cluster", "gender", "age", "friends")]

# mean age by cluster
aggregate(data = teens, age ~ cluster, mean)

# proportion of females by cluster
aggregate(data = teens, female ~ cluster, mean)

# mean number of friends by cluster
aggregate(data = teens, friends ~ cluster, mean)


setwd('~/Code/UGRU/non_rectangles/')

multivac = 'asimov_the_last_question.txt'
# this is a file with the text from a short story by Isaac Asimov:
# 'The last question'

csv_try = read.csv(multivac)
#it gets confused because we told it to read a csv, but there are just random
#commas interspersed throughout the lines...
csv_try

lines = readLines(multivac)

#note:
#library('tidyverse')
#lines = read_lines(multivac)
#is also a viable play

summary(lines)
is.vector(lines)

lines[1:2]

lines[length(lines)]

#Questions to answer:

#####################
# 1. how many lines of dialogue are there?:
# hint: look at lines 27, 29, 36, 90
# efficiency hint: can you write a generic function to answer this and question 2?
i= 27
lines[i]
grepl("\"" , lines[i])

dialouge = 0
for(i in 1:length(lines)){
	if(grepl("\"" , lines[i])){
		dialouge = dialouge + 1
	}
}

dialouge

#####
# OR - this method is GENERIC and therefore more efficient
#####
IsIn = function(subject, query){
	# == index position
	return(	grepl(subject , query))
}

dialouge_list = lapply(lines, function(x){IsIn("\"", x)})

dialouge_list = grepl("\"", lines)

length(dialouge_list[dialouge_list == TRUE])

#####################
# 2. a. what is the first question in the text?

# The advantage of the second method for question 1 is that we get to reuse the funciton.
# Looking for the last question is the same pattern as looking for dialouge

question_bool = lapply(lines, function(x){IsIn("\\?", x)})

question_list = lines[question_bool==TRUE]

question_list[1]

# b. what is the last question?

question_list[length(question_list)]

#####################
# 3. build a dataframe with the following columns (and data types)

#Line	is_dialogue	is_question	word_count	text
#int	Bool		Bool		int			string

WordCount = function(str){
	words = strsplit(str, "\\s+")[[1]]
	return(length(words))#int
}

wc = lapply(lines, function(x){WordCount(x)})
unlist(wc)

# limitations of R
# we cant have a function that makes two outputs...
# which is a pretty standard thing :(

# in a perfect world this would work:

WordCount = function(str){
	words = strsplit(str, "\\s+")[[1]]
	return(len(words), words)#int
}

# wc_list, words = lapply(lines, function(x){WordCount(x)})

question_df = data.frame(line= 1:length(lines),
						is_dialouge = unlist(dialouge_list),
						is_question = unlist(question_bool),
						word_count = unlist(wc),
						text = lines)

head(question_df)

#####################
# 4. finally answer the following:
# The Hemingway-Kafka index is a measure of how long an author's sentences are.
# It is a simply the average number of words in a sentence from a given text.
	# For the purpose of today's exercise, lines of dialogue are counted as a single sentence.

# a. What is the HK-index for 'The Last Question'?
mean(question_df$word_count)

# 24 years after writing 'The Last Question', our boy Isaac wrote another short story
# titled 'The Last Answer' which is found in the following text file:
last_answer = readLines('asimov_the_last_answer.txt')

# getting the data to build a new matching dataframe is easy when
# we have generic functions written
ans_dialouge_list = lapply(last_answer, function(x){IsIn("\"", x)})
ans_question_bool = lapply(last_answer, function(x){IsIn("\\?", x)})
ans_wc = lapply(last_answer, function(x){WordCount(x)})

answer_df = data.frame(line= 1:length(last_answer),
						is_dialouge = unlist(ans_dialouge_list),
						is_question = unlist(ans_question_bool),
						word_count = unlist(ans_wc),
						text = last_answer)

mean(answer_df$word_count)

# Given the HK-index of the two texts, is there statistical evidence of Isaac Asimov getting more long winded with age?
head(question_df)
head(answer_df)

hk_test = t.test(question_df$word_count, answer_df$word_count,
					alternative="less", var.equal=TRUE)

hk_test
#looks like he did get more long winded with age!

#closing remarks on good practices for using functions:

#move them all to the top of the file
#include a brief comment that describes the input and output and what the function accomplishes

# if you're working across multiple files, you don't need to copy and paste functions over
# use the source function to import functions from other script files!
source('./path_to_file/import_test.r')
?source
#then any functions defined in 'import_test.r' would be avaliable in the current script


## Library loading
library(reshape2);
library(vegan);
library(dplyr)
library(ade4);
library(plotly)
library(compositions);
library(pracma);
library(DESeq2);
library(fpc);
library(tidyverse)
library(purrr)
library(cluster)
library(RColorBrewer)
library(ape)

# Migrate to location of repository and downloaded test data:
# setwd($PATH/analyzing_microbiome_timeseries/module1_clustering/)
load("TESTDATA_DIEL18S.RData",verbose=T)

# To address ecological questions, you may need to perform some quality
# control on your OTU data. (1) Below, first global singletons are removed.
# This is unwanted noise in the form of OTUs which only have one sequence
# in the entired dataset.
# (2) Then, any OTUs assigned a Metazoan taxonomic identity are removed. This
# is because the methods used to generate this 18S data are not suitable
# to capture the metazoan community.
# (3) Finally, while we are mainly working with OTU.IDs throughout this tutorial
# we want to eventually add back in the taxonomic identities. So we make a taxonomy
# key dataframe ('tax_key')
#
# (1) Remove global singletons (where a single OTU appears with only 1 sequence in the entire dataset)
rowsum<-apply(test_data[2:20],1,sum) # sum numerics in OTU table by row
counts.no1 = test_data[ rowsum>1, ]  # remove rows that sum to 1 or less
dim(test_data)[1] - dim(counts.no1)[1] # report total number of singletons removed
#
# (2) Filter out OTUs which belong to the metazoa:
counts.filtered<-counts.no1[-(which(counts.no1$Level3 %in% "Metazoa")),] # Remove from counts
dim(counts.no1);dim(counts.filtered) # Test data should be left with 1984 total OTUs
#
# (3) Create taxonomy key:
names(counts.filtered)
seq_counts<-counts.filtered[1:20]
tax_key<-counts.filtered[c(1,21:31)]; head(tax_key[1:2,])
# Modify seq_counts data frame so row.names = OTU.ID and all values are numeric
row.names(seq_counts)<-seq_counts$OTU.ID
seq_counts$OTU.ID<-NULL; head(seq_counts[1:2,])

# Because these data are compositional, they are on a simplex.
# The data being on a simplex means, if we know the abundances of all of the OTUs except for one, we still have the
# same amount of information as if we knew all of the OTUs.
# Evidence:
# Estimate covariance matrix for OTUs
covariance_matrix<-as.matrix(seq_counts)%*%t(seq_counts)
# Evaluate determinant of covariance matrix
cov_determinant<-det(covariance_matrix)
cov_determinant #0
# The determinant of the covariance matrix (what we just calculated) is equivalent to the product of the
# proportion of variance explained by every PCA axis. If the determinant is 0, that means there is an axis which
# explains 0 variance that we can't separate from the other axes. The data need to be transformed to be suitable
# for PCA.

## Another approach to PCA ordination w/Compositional Data: Log-Ratio Transformations
# Log-ratio
log_rats<-data.frame(compositions::ilr(t(seq_counts)))
# These are complicated to interpret however because you move from D simplex to D-1 euclidean
# But using these we can see we are now in invertible covariance regime

## Checking the difference the log-ratio made on the data characteristics
new_covdet<-det(as.matrix(log_rats)%*%t(log_rats))
cov_determinant #Original Count Data
new_covdet # After doing a log ratio, you see that none of the axes are equal to 0

# AND change command so its the same.
lograt_pca<-prcomp(log_rats)
# Look at this
lograt_variances<-lograt_pca$sdev^2/sum(lograt_pca$sdev^2)
barplot(lograt_variances,
        main='Log-Ratio PCA Screeplot',
        xlab='PC Axis',
        ylab='% Variance',
       col=c(rep('black',1),rep('grey',18)),
       cex.names=1.5,cex.axis=1.5,cex.lab=1.5,cex.main=1.5)
legend('topright',fill=c('black','grey'),c('Should Present','??? Judgment Call'))

## We conclude a more faithful representation is to plot this ordination in 2D because the 3rd and 4th axes appear
## very similar, and we can't construct a 4D plot
pca_lograt_frame<-data.frame(lograt_pca$x,
                          time_of_day=gsub('^.*_','',rownames(lograt_pca$x)))
ggplot(pca_lograt_frame)+
    geom_point(aes(x=PC1,y=PC2,col=time_of_day))+
    ylab(paste0('PC2 ',round(lograt_variances[2]*100,2),'%'))+
    xlab(paste0('PC1 ',round(lograt_variances[1]*100,2),'%'))+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    ggtitle('Log-Ratio PCA Ordination')+
    coord_fixed(ratio=lograt_variances[2]/lograt_variances[1])+
    theme_bw()

# So let's start by looking at PCoA. PCoA is doing a PCA on a distance matrix constructed from the data.
# We then need a distance matrix.
# Different distance metrics emphasize separate attributes/factors in microbial community comparison
# For instance, if we want to prioritize differences in presence/absence between samples
jac_dmat<-vegdist(t(seq_counts),method="jaccard") # p/a example
pcoa_jac<-ape::pcoa(jac_dmat) #perform PCoA
# Now we need to inspect how the PCoA turned out. We look at a Screeplot for this.
# The screeplot shows the amount of variance explained by each axis
samp_no<-dim(seq_counts)[2]
jac_variances<-pcoa_jac$values$Relative_eig
par(mar=c(5,6,4,1)+.1)
barplot(jac_variances,
        xlab='Principal Coordinate Axis',
        ylab='% Variance',
       col=c(rep('black',2),'darkgrey',rep('lightgrey',16)),
       cex.names=2,cex.axis=2,cex.lab=2,cex.main=1,
       names.arg=as.character(1:18))
legend('topright',fill=c('black','darkgrey','lightgrey'),c('Should Present','Judgment Call','Unnecessary to Present'),cex=2)
# How to read this plot: Before we plot the actual ordination, we need to decide which axes to present.
# We need to select as few axes as possible (so we can visualize) which capture large amounts of variance.
# In this example, we see the first axis captures most of the variance, so we definitely will show that one.
# Then the next two axes show less, but a similar amount, and the remaining all show way less in comparison.
# Therefore, we can exclude everything after the 3rd axis. Because axes 2 and 3 capture similar amounts of variance,
# if we show one, we need to show the other one to be faithful to the data.

# Performing the log-ratio transformation makes the data all occupy a similar dynamic range, so we can use
# magnitude-sensitive distances like euclidean distance

euc_dmat<-dist(log_rats)

## Conduct ordination w/distance matrix
pcoa_euc<-ape::pcoa(euc_dmat)
#euc_variances<-pcoa_euc$sdev^2/sum(pcoa_euc$sdev^2)
euc_variances<-pcoa_euc$values$Relative_eig
par(mar=c(5,6,4,1)+.1)
barplot(euc_variances,
        xlab='Principal Coordinate Axis',
        ylab='% Variance',
       col=c(rep('black',2),rep('darkgrey',2),rep('lightgrey',17)),
       cex.names=2,cex.axis=2,cex.lab=2,cex.main=1,
       names.arg=as.character(1:18))
legend('topright',fill=c('black','darkgrey','lightgrey'),c('Should Present','Judgment Call','Unnecessary'),cex=2)
#
# By trying 2 different metrics, we see a differences in ordination output.
# For Jaccard distance, we see we need 3 axes to present the ordination. Using euclidean distance,
# because of the complex covariance structure of the relative compositions, the data do not easily
# ordinate into 2 or 3 dimensions.

# How dissimilar are my samples with respect to diversity?
## P/A is recommended when asking questions about the ENTIRE community
# Does the active microbial community change depending on time of day?
# To emphasize changes in presence/absence, we elect to use Jaccard distance for ordination.
# Our ordination indicates the data are most suitably summarized
# with 3 dimensions.
#pcoa_jac_frame<-data.frame(pcoa_jac$x,
#                           time_of_day=gsub('^.*_','',rownames(pcoa_jac$x)))
pcoa_jac_frame<-data.frame(pcoa_jac$vectors,time_of_day=gsub('^.*_','',rownames(pcoa_jac$vectors)))
eigenvalues<-round(jac_variances,4)*100
plot_ly(pcoa_jac_frame,type='scatter3d',mode='markers',
        x=~Axis.2,y=~Axis.3,z=~Axis.1,colors=~brewer.pal(6,'Set1'),color=~time_of_day)%>%
  layout(font=list(size=18),
         #title='PCoA Jaccard Distance',
         scene=list(xaxis=list(title=paste0('Co 2 ',eigenvalues[2],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         yaxis=list(title=paste0('Co 3 ',eigenvalues[3],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         zaxis=list(title=paste0('Co 1 ',eigenvalues[1],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
        aspectratio = list(x=3*eigenvalues[2]/eigenvalues[1])), y=3*eigenvalues[3]/eigenvalues[1], z=3)

## To compare with the euclidean distance ordination representing differences in relative composition
#pcoa_euc_frame<-data.frame(pcoa_euc$x,
#                          time_of_day=gsub('^.*_','',rownames(pcoa_euc$x)))
pcoa_euc_frame<-data.frame(pcoa_euc$vectors,time_of_day=gsub('^.*_','',rownames(pcoa_euc$vectors)))
euc_eigenvalues<-round(euc_variances,4)*100
plot_ly(pcoa_euc_frame,type='scatter3d',mode='markers',
        x=~Axis.3,y=~Axis.2,z=~Axis.1,colors=~brewer.pal(6,'Set1'),color=~time_of_day)%>%
  layout(font=list(size=18),
         #title='PCoA Euclidean Distance',
         scene=list(xaxis=list(title=paste0('Co 3 ',euc_eigenvalues[3],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         yaxis=list(title=paste0('Co 2 ',euc_eigenvalues[2],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         zaxis=list(title=paste0('Co 1 ',euc_eigenvalues[1],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
                   aspectratio = list(x=3*euc_eigenvalues[3]/euc_eigenvalues[1],
                                      y=3*euc_eigenvalues[2]/euc_eigenvalues[1],
                                      z=3)))
## Further note: If your ordination has data which align in a 'T' or '+' shape perpendicular to the axes
## this is often diagnostic of covariance attributed to the higher dimensions which are not plotted

# To corroborate the 3-D plot, use a simple average
## hierarchical clustering and plot the dendrogram.
## Some of the same pattern emerge, but it is not as
## clear as the 3-D representation.
cluster_ex<-hclust(vegdist(t(seq_counts),method='jaccard'),method="complete") #Using Jaccard distance so apples to apples
plot(cluster_ex,main='Jaccard Hierarchical Agglomerative Clustering',xlab='',sub='')

# Although our statistical ordinations appear to require at least 3 dimensions to communicate the data.
# However, we don't always have the budget for a 3D plot. So we may want to impose the condition on an ordination
# technique that the answer MUST go in 2D. We turn to NMDS here.
#
set.seed(071510) # setting random seed to assure NMDS comes out the same every time
## So we can compare the relative composition based distance metric to the presence/absence based distance metric
euc_nmds<-metaMDS(euc_dmat,k=2,autotransform=FALSE)
jac_nmds<-metaMDS(jac_dmat,k=2,autotransform=FALSE)

# Take a look at stress - overall this value is not extremely informative, but know that the
# closer stress is to 1 the less representative of your actual data the NMDS is
euc_nmds$stress #Stress ~0.075
jac_nmds$stress #Stress ~0.073 So the Jaccard NMDS is a ***slightly*** more parsimonious ordination.

# Additionally, the axes for NMDS are totally arbitrary, so axis scaling does not matter
# and data can be rotated/reflected about axes and the NMDS is still the same
euc_frame<-data.frame(euc_nmds$points,
                         time_of_day=gsub('^.*_','',rownames(log_rats)))
jac_frame<-data.frame(jac_nmds$points,
                     time_of_day=gsub('^.*_','',rownames(log_rats)))
## Plotting euclidean distance NMDS
ggplot(euc_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=2)+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+ggtitle('Euclidean Distance NMDS')
## Plotting Jaccard distance NMDS
ggplot(jac_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=2)+
        scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+ggtitle('Jaccard Distance NMDS')
## For paper figures
euc_fig<-ggplot(euc_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=10)+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+theme(legend.position='none',text=element_text(size=24))+
xlab('NMDS 1')+ylab('NMDS 2')
jac_fig<-ggplot(jac_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=10)+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+theme(legend.position='none',text=element_text(size=24))+
xlab('NMDS1')+ylab('NMDS2')
euc_fig
jac_fig

## Before we can cluster temporal dynamics, we must make sure species are intercomparable.
## We need to perform normalization steps to ensure intercomparability between species.
## Put another way, the count data are heteroskedastic --
## the mean is correlated with the variance.
within_seq_means<-apply(t(seq_counts),2,mean)
within_seq_vars<-apply(t(seq_counts),2,var)
plot(within_seq_means,within_seq_vars,log='xy',
    main='Heteroskedastic Data',
    xlab='Mean # Counts',
    ylab='Var # Counts')
# Variance (in the amount of times an OTU shows up) is correlated to average count.
# This attribute (common to count data) violates the assumption of constant variance in errors
# which is necessary for standard linear modeling. To use z-scores for comparisons and to detrend our timeseries
#(a kind of linear model), we have to deal with this.

## We stabilize the variances so that they are no longer correlated to the species abundances.
transformed_counts<-DESeq2::varianceStabilizingTransformation(as.matrix(seq_counts))

## Check to see how the transformation did
within_trans_means<-apply(transformed_counts,1,mean)
within_trans_vars<-apply(transformed_counts,1,var)
# Plot:
plot(within_trans_means,within_trans_vars)
# See how now most of the variances are the same between otus?
# This means the data are more intercomparable using a z-score transformation + detrending

# Since the goal is to identify repeating day/night patterns, we need to remove trends we are not considering,
# i.e., linear trends
#?pracma::detrend() for more information
transformed_detrended<-apply(transformed_counts,1,pracma::detrend)
# Now we rescale so numbers are again intercomparable and now overdispersion has been
# dealt with
trans_dt_scaled<-apply(transformed_detrended,2,scale)
## We lost rownames so tack those back on
rownames(trans_dt_scaled)<-colnames(transformed_counts)
#
## Comparing the distribution of the data along every step of the pipeline -- notice how by the time we get to the
## z-scores we're looking more like a standard normal
hist(transformed_counts,
    main='VST Sequence Count Observations',
    xlab='# Total Observations',
    ylab='Frequency')
hist(transformed_detrended,
    main='VST+Detrended Data',
    xlab='Total Observations Accounting for Linear Trends',
    ylab='Frequency')
hist(trans_dt_scaled,
    main='VST+Detrended+Scaled Data (Z-scores)',
    xlab='Expression Level Relative to per-OTU Avg',
    ylab='Frequency')

# Now we're ready to generate a distance matrix for clustering
# Recall what we previously learned about different distance metrics.
# We use euclidean distance below:
temporal_dmat<-dist(t(trans_dt_scaled))
n_clusts<-2:20 # This sets the range of # clusters we divide the data into
# First, the classic hierarchical agglomerative clustering
hc_full_cluster<-hclust(temporal_dmat)
hc_clusts<-lapply(n_clusts,function(x) cutree(hc_full_cluster,x))
## Now we try k-medoids, also a very popular clustering method
## This particular implementation is not optimized for speed, so this may take a minute or so
kmed_clusts<-lapply(n_clusts, function(x) cluster::pam(temporal_dmat,k=x))

## Comparing cluster outcomes
hc_stats<-lapply(hc_clusts,function(x) fpc::cluster.stats(temporal_dmat,
                                                          clustering=x))
kmed_stats<-lapply(kmed_clusts, function(x) fpc::cluster.stats(temporal_dmat,
                                                             clustering=x$clustering))

## We write a helper function to be less redundant
ripping_stats<-function(list,func){
  ## Essentially all this function does is implements a function (func) on a list
  ## and coerces the output to a column vector (this will be handy when we want to make a data frame)
  output<-do.call(rbind,lapply(list,func))
  return(output)
}
func_list<-rep(list(function(x) x$cluster.number,
                function(x) x$within.cluster.ss,
                function(x) x$avg.silwidth,
                function(x) x$ch),2)
stats_list<-rep(list(hc_stats,kmed_stats),each=4)
collected_stats<-purrr::map2(stats_list,func_list,ripping_stats)
nclusts<-rep(n_clusts,length(collected_stats))
method<-rep(c('hc_agg','kmed'),each=length(n_clusts)*length(collected_stats)/2)
ind_name<-rep(c('n','ss','sil','ch'),each=length(n_clusts)) %>%
  rep(2)

## Collecting outputs for plotting
index_frame<-data.frame(index=do.call(rbind,collected_stats),
                        nc=nclusts,
                        Method=method,
                        ind=ind_name)
index_frame %>%
  filter(ind=='ss') %>%
  ggplot(aes(x=nc,y=index,col=Method)) +
  geom_point() +
  geom_line(aes(group=Method)) +
  ylab('Within Cluster Sum Square Error') +
  xlab('Number Clusters')+
  theme_bw()
## Interpretation of plots:
# As we add more clusters (yaxis), we want the sum square error to decrease
# As we allow for more clusters, we are able to describe more of the variability in the data
# so the sum square error decreases.
## trade-off - it will always decrease when you add clusters, but we want to
## add as fewer clusters as possible, hence in this example kmed > hc
# for any given amount of clusters, kmed has less error. So we will continue using kmed approach.

## Plotting out the calinski-harabasz indices for each clustering
## We want this number to be high
index_frame %>%
  filter(ind=='ch') %>%
  ggplot(aes(x=nc,y=index,col=Method)) +
  geom_point() +
  geom_line(aes(group=Method)) +
  ylab('C-H Stat') +
  xlab('Number Clusters')+
theme_bw()

## Silhouette profile: Looking at species variability w/in our 8 clusters
## Extract silhouette profile for the clustering we select
silhouette_profile_kmed8<-cluster::silhouette(kmed_clusts[[7]])
## Reformat for easier plotting
silhouette_frame<-data.frame(cluster=silhouette_profile_kmed8[,1],
                             neighbor=silhouette_profile_kmed8[,2],
                             dist=silhouette_profile_kmed8[,3],
                             otu_id=rownames(silhouette_profile_kmed8))

## Sorting by cluster and ranking by silhouette width
new_silframe<-silhouette_frame %>%
  arrange(dist) %>%
  group_by(cluster) %>%
  mutate(idno=1:n(),
         tot_num=n())

## Plotting silhouette profile of OTUs for each cluster
ggplot(new_silframe,aes(x=idno,y=dist))+
  geom_bar(stat='identity') +
  coord_flip() +
  ggtitle('Silhouette Profiles for Individual Clusters') +
  facet_wrap(~cluster)

## In order to interpret the silhouette profiles, we can compare the width (x-axis) and height (y-axis) of each
## profile. For instance, comparing cluster #3 vs #8: Cluster 3 is much taller (has more species in it) compared to
# cluster 8, but also is much broader (there are more species with intermediate values on the x-axis). This means
# on the whole cluster 3 is less coherent than cluster 8.
## Also keep an eye out for species w/negative silhouette distances -- this means that they have a nearby neighbor
## who belongs in a different cluster and therefore may be only marginally similar to their cluster on the whole

# What is the taxonomic composition of each of the 8 clusters?
## To make ecological sense of the temporal clusters,
## we can pull out a representative species and use their signal over time
## to summarize the temporal trends across the whole cluster
medoid_otus<-kmed_clusts[[7]]$medoids
## Extracting those time series
medoid_dynamics<-trans_dt_scaled[,medoid_otus]

# Using the output from:
head(silhouette_frame)
# We can re-build what the taxonomic composition of each
## of these clusters is.
range(silhouette_frame$cluster) # n=8 clusters with test data

# Join cluster information with taxonomic information
colnames(tax_key)[1]<-"otu_id"
tax_bycluster<-left_join(silhouette_frame, tax_key, by="otu_id") # Recall the taxonomy key we made from above?
head(tax_bycluster[1:2,])

# Summarize taxa with cluster information
tax_bycluster_sum<-tax_bycluster %>%
    group_by(cluster, Taxa) %>%
    summarise(richness =  n()) %>% #Get richness information
    group_by(Taxa) %>%
    mutate(n_per_tax=sum(richness)) %>% #Figure out total number of OTUs assigned to each taxon
    as.data.frame
tax_bycluster_sum$Taxa[which(tax_bycluster_sum$Taxa=='Opisthokonts')]<-'Opisthokont' # Cleaning this up
head(tax_bycluster_sum)

# Plot cluster-to-cluster taxonomic differences
## Values are equal to the total number of OTUs
## belonging to each taxonomic group
#
tax_color<-c("#67000d","#e31a1c","#dd3497","#fcbba1","#fed976","#fc8d59","#a63603","#addd8e","#7f2704","#238b45","#a1d99b","#081d58","#1f78b4","#a6cee3","#8c6bb1","#9e9ac8","#984ea3","#081d58","#662506","#ffffff","#969696","#525252","#000000")
#
ggplot(tax_bycluster_sum, aes(x=cluster, y=richness, fill=Taxa))+
    geom_bar(color="black", stat="identity")+
    coord_flip()+
    scale_fill_brewer(palette='Set3')+
    theme_minimal()+
    scale_x_continuous(breaks=1:8,labels=as.character(1:8),name='Cluster #')+
    scale_y_continuous(name='# Species')+
theme(legend.position='bottom',text=element_text(size=18))+ ## Make the cluster #s happen
guides(fill=guide_legend(nrow=3,byrow=TRUE))

## Demonstrating medoid dynamics for each cluster
medoid_dyn_long<-as.data.frame(t(medoid_dynamics)) %>%
mutate(otu_id=colnames(medoid_dynamics),
      clust_num=1:8) %>%
gather(timepoint,z_score,'1_6PM':'19_6PM') %>%
mutate(time_numeric=as.numeric(gsub('_.*$','',timepoint)),
      plotting_timepoint=paste('Day',ceiling(time_numeric/6),gsub('^.*_','',timepoint)))
#
## We're plotting the y axis as z-scores so that transcripts with different baseline levels are
# more readily intercomparable. Read a z-score y-axis this like this:
# 0 is the average transcript level
# negative numbers are below-average numbers of transcripts
# positive numbers are above-average levels of transcripts
# 1 unit is 1 standard deviation away from the mean (So a value of 1 corresponds to mean+1sd, -1 is mean-1sd)

ggplot()+
geom_point(size=4,
           shape=21,
           color="white",
           aes(fill=factor(clust_num),
              x=time_numeric,
              y=z_score),
          data=medoid_dyn_long)+
geom_line(data=medoid_dyn_long,
          aes(x=time_numeric,
              y=z_score,
              group=otu_id,
              col=factor(clust_num)),size=1.25,linetype=5)+
facet_wrap(~clust_num,ncol=2)+
scale_color_brewer(palette='Set2',name='Cluster #')+
scale_fill_brewer(palette='Set2',guide=FALSE)+
scale_x_continuous(breaks=seq(1,19,by=6),labels=unique(medoid_dyn_long$plotting_timepoint)[c(1,7,13,19)])+
scale_y_continuous(name='Z-score Expression',limits=c(-2,4.5))+
theme(axis.text.x=element_text(angle=90,hjust=0.5,size=18),
      panel.background=element_rect(fill='white'),
     panel.grid.major=element_line(color='gray'),
     axis.title.x=element_blank(),
     text=element_text(size=18))+
geom_rect(data=data.frame(ymin=rep(-2,4),
          ymax=rep(4.5,4),
          xmin=seq(1,19,by=6),
         xmax=c(seq(4,19,by=6),19)),
          aes(xmin=xmin,ymin=ymin,xmax=xmax,ymax=ymax),
          col='gray',
          alpha=0.25)


rm(list = ls())

# reloading data using paste function ======================================================

# create root directory address
root.wd <- 'Y:/MI/Workshops - Trainnings/R-Beginners/r.training'
setwd(root.wd)

# create data directory address
data.folder <- paste(root.wd, '/2.data/2.salmon/', sep ='' )

# use data directory to load data
salmon <- read.table(paste(data.folder, 'salmonTidy.csv', sep = ''),
                     header = TRUE, sep = ',')

# use apply and tapply =============================================================

#subset for numerical columns
salmon.num <- salmon[ , c('year', 'julian.day', 'length', 'weight')]
salmon.num <- subset(salmon, select = c('year', 'julian.day', 'length', 'weight'))

# create 10 * 10 matrix
r.matrix<- matrix(rnorm(100),
                  nrow = 10,
                  ncol = 10)

# use apply accross columns
apply(r.matrix, MARGIN = 2, FUN = mean)
#apply(FUN = mean, X = r.matrix, MARGIN = 2)

# use apply, quantiles and special arguments
apply(r.matrix, MARGIN = 2,
      FUN = quantile,
      probs = seq(from = 0.2, to = 0.8, by = 0.2))

# introduce NA values
salmon$length[seq(from = 1, to = length(salmon$length), by = 100)] <- NA

# use tapply on salmon data to compute mean lengthes by combination of factors
tapply(X = salmon$length, INDEX = list(salmon$year, salmon$river),
       FUN = mean, na.rm = TRUE)

# LOOPS ===============================================================================================

for(a in c('may', 'april', 'june')){
  print(a)
}

for(a in seq(3, 25, 2.5)){
  result <- paste('result =', a + 3, sep = ' ')
  print(result)
}

##
rivers <- levels(salmon$river) ## unique river names

r <- rivers[1]
salmon.river <- salmon[salmon$river == r, ]
#unique(salmon.river$river)
file.name <- paste0('salmon.', r, '.txt')
write.table(x = salmon.river, file = file.name,
            sep = ',', dec = '.', row.names = FALSE)

for(r in rivers){
  salmon.river <- salmon[salmon$river == r, ]
  #unique(salmon.river$river)
  file.name <- paste0('salmon.', r, '.txt')
  write.table(x = salmon.river, file = file.name,
              sep = ',', dec = '.', row.names = FALSE)
}

#### plot per column

cc <- 6

class(salmon[ , cc]) == 'numeric'

boxplot(salmon[ , cc],
        main = colnames(salmon)[cc])

for(cc in 1:dim(salmon)[2]){

  if(class(salmon[ , cc]) == 'numeric'){

    pdf(paste0(colnames(salmon)[cc], '.pdf'))

    boxplot(salmon[ , cc],
            main = colnames(salmon)[cc])

    dev.off()

  }else{

    pdf(paste0(colnames(salmon)[cc], '.pdf'))

    barplot(table(salmon[ , cc]))

    dev.off()

  }

}


int main()
{
int a; #men 2,4
float b; #men 4
double c; #men 8
char d; #men 1

  cin>>a;
  cout<<a;
  getch();
}
# R programming
#no data type
a=12
class(a)

b="Hello"
class(b)

c="this is demo class"
class(c)
typeof(c)

no1=15L
class(no1)
typeof(no1)

no2=18.63
class(no2)
typeof(no2)

no3=85
class(no3)
typeof(no3)

no4=15.25L
class(no4)
typeof(no4)

#assignment operator
#"=" , "<-" , "->"
var1=85
#85=var2  can't use = as right hand operator
var2<-25
100->var3

#datatypes in R Programming
#vectors
#list
#array
#matrices
#data frames
#factors

#Basic Datatypes
#logical data type
c(10,50,205)-> var2

v1=TRUE
v1
class(v1)

#Numeric
v2=23.1
class(v2)

#Integer
v3=5L
class(v3)

#complex
v4=5+2i
class(complex)

#character
v5="12"
class(v5)

#Raw
v6=charToRaw("Hello")
v6
class(v6)

#to convert raw
v7=rawToChar(v6)
v7
class(v7)

#vectors c()
vec1<-c(10,20,52,86,36)
vec1
class(vec1)

vec2<-c(10,12.53,"Hello")
vec2
class(vec2)

vec3<-c(10+0i,12.53,58)
vec3
class(vec3)

vec4<-c(10,10L,12.53,58)
vec4
class(vec4)

vec5=c(1,2,3,4,5,6,7,8,9,10,12,13,14,15,16)
vec6=1:50
vec5
vec6
class(vec5)
class(vec6)

#but two function is not requried
#it will lead to take more time to
#execute (about below function)
vec7=c(1:50)
vec7
class(vec7)

#coerced function
vec8=0.5:10.5
vec8
class(vec8)

#list
numeric ->
1.integer "L"
2.decimal
l1=list(10,12.53,"Hello")
l1
l1[3]

l2=list(c(10,20,15),85.63,c("a","Hello","Hi"),charToRaw("savleen"))
l2
class(l2)
typeof(l2[[3]])
l2[[4]]

#matrix
m=matrix(c(12,5,10),nrow=3,ncol=3)
m
#warming not error
m1=matrix(c(10,2),nrow=3,ncol=3)
m1
m2=matrix(c(10,2),nrow=2,ncol=3)
m2
m3=matrix(c(10,2),nrow=2,ncol=3,byrow=T)
m3

#arrays
a=array(c(10,12,15),dim=c(3,2,4))
a
a1=array(1:25,dim=c(3,2,4))
a1
a2=array(1:25,dim=c(5,3,2))
a2

#factor
color=c('red','yellow','green','blue','green','red','Red')
f1=factor(color)
f1

f=factor(c("Orange","Grapes","Mango","Grapes","orage","Mango"))
f

f2=factor(c(1,12,13,15,18,6))
f2
gender=c("M","F","M","F","M","F","M","M","M")
gender
f3=factor(gender)
f3

#dataframe
d=data.frame(Regno=c(1,2,3,4) ,
             Name=c("amit","ron","raj","rits"),
             gender=c("m","m","m","f"),
             age=c(19,20,23,25))
d

vec =c(12,13,14)
print(vec)
print(vec,10)
print("Vactor value is",vec)
cat("vector value is ",vec,"\n","this is single data type in r")

#operator in R

v1=c(12,15,18,20)
v2=c(10,20,30,40,50)
v1+v2
v1-v2
v1*v2
v1/v2

v1=c(12,15,18,20)
v2=c(10,20,30,40)
v1+v2
v1-v2
v1*v2
v1/v2
v1%%v2#remainder
v1%/%v2#quotient
v1==v2#complete division
v1!=v2
# -,*,/
v1=c(12,0,F,20)
v2=c(2,1,3,2)
v1|v2
!v1
v3=c(0,1,0,1)
v4=c(1,1,0,1)
v3&v4
v3|v4

#Decision stmt
x=c(8,20,"ok","TU")
if("LPU"%in% x){
  print("Value Found")
}else if("lpu" %in% x){
  print("Value 2 Found")
}else{

}
a <<- 50 ; a #left
80 ->> b; b #right
#misc operator
c=0.1:15.5;c
# %in%
x=c(8,20,"ok","TU")
test=25

test %in% c(27,18,45,60)
#%8% matrix multiplication
m=matrix(c(2,3,4,5),nrow=2,ncol=2)
m
dim(m)
m1=t(m)
dim(m1)
m%*%m1

#decision stmt
x=c(8,20,"ok","TU")
str(x)

if("LPU" %in% x){
  print("value found")
}

#switch stmt
#ssyntax :- switch(expr,casel,case2,case3,....)
switch(3,"Hello","LPU","Welcome","Great")
switch(10,"Hello","LPU","Welcome","Great")
#ex
#repeat loop while loop for loop
#syntax:
repeat{
  print(vec)
  cnt=cnt+1
  if(cnt>=6){
    break
  }

}

#missing some code of one class

#Accessing element of matrix
mat1
mat1[,]
mat1[,1:2]
mat1[3,3]
mat1[c(1,3),]
mat1[c(1,3),2]
mat1[1,3]

#matrix manipulation
(m1<-matrix(c(4,-10,9,5,6,8),nrow=2,byrow=T))
(m2<-matrix(10:15,nrow=2))

#size of matrix should same
(add<-m1+m2)
(div<-m1/m2)
(sub<-m1-m2)

#transverse of matrix
(m4=t(m1))

#no of col for mat1 should be equal to no of row for mat2
m1*m4 #m1 dim 2 3 #m4 dim 3 2

m1*m2 #wrong way to do matrix multiplication
m1 #dim 2 3 no of col=3
m4 #dim 3 2 no of row=3
m1%*%m4


rm(list=ls())

file.results    <- commandArgs()[4]
numof.cases     <- as.numeric(commandArgs()[5])
numof.controls  <- as.numeric(commandArgs()[6])
title           <- commandArgs()[7]
qqman           <- commandArgs()[8]
gwas<-read.table(file=file.results,header=T,stringsAsFactor=F)

source(qqman)

# calc vector of quantiles
# version 1, lambda
q <- qchisq(gwas$P, df=1, ncp=0, lower.tail = FALSE, log.p = FALSE)
lambda = median(q)/0.456
print(lambda)

## version 2, lambda
#library(snpMatrix)
#retval = qq.chisq(q, overdisp=TRUE, slope.one=FALSE, main=basename(file.results), slope.lambda=TRUE)
#lambda <- as.numeric(retval[3])
#print(lambda)
lambda_1000 <- 1.0 + (lambda - 1.0) * ( (1/numof.cases + 1/numof.controls) / (1/1000 + 1/1000) )
print(lambda_1000)

## version 3, lambda
#library('GenABEL')
#res <- estlambda(gwas$P, method="median", plot=TRUE, df=1, main="", sub="")
#print(format(res$estimate, digits=3, scientific=FALSE))

# plot QQ
jpeg(file=paste(file.results, ".qqplot.pval.2.jpg", sep=""), quality=100,width=700,height=700)
qq(gwas$P, title=title, lambda=lambda, lambda_1000=lambda_1000)
dev.off()


#' Get the pairwise matrix of p-values testing for cointegration
#'
#' @param x a data.frame, matrix, or xts object
#' @return An upper triangular matrix where each entry corresponds to the
#' p-value from McKinnons's test assuming no time trend. Note that if one
#' stock in a pair-wise cointegration is constant the return value will be 1.
#' @examples
#' data(aapl_fix)
#' data(a_fix)
#' aapl_cons = consolidate_prices(aapl_fix$sys_date, aapl_fix$sys_time,
#'  aapl_fix$td_price, aapl_fix$td_size)
#' a_cons = consolidate_prices(a_fix$sys_date, a_fix$sys_time,
#'  a_fix$td_price, a_fix$td_size)
#' trades = merge(aapl_cons$price, a_cons$price)
#' trades = carry_prices_forward(trades)
#' names(trades) = c("aapl", "a")
#' cointegration_p_matrix(trades)
#' @export
cointegration_p_matrix = function(x) {
  r = NA
  x = na.omit(x)
  if (nrow(x) > 0) {
    if (is.null(colnames(x))) colnames(x) = paste("V", 1:ncol(x), sep="")
    cs = combn(colnames(x), 2)
    if (is.null(getDoParName())) registerDoSEQ()
    r=foreach(it=isplitCols(cs,chunks=getDoParWorkers()),.combine=`+`) %do% {
      # Create the sparse matrix for this process.
      m = Matrix(data=0, nrow=ncol(x), ncol=ncol(x), sparse=TRUE,
                 dimnames=list(names(x), names(x)))
      for (j in 1:ncol(it)) {
        # Fit the cointegration.
        p_val = 1
        y_vec = as.matrix(x)[,it[1,j],drop=FALSE]
        x_vec = cbind(as.matrix(x)[,it[2,j],drop=FALSE], rep(1, nrow(y_vec)))
        # Get the summed differences for y and x. If either is a vector
        # of constant value, handle it.
        tol = 1e-8
        x_sum_diff = sum(diff(x_vec[,1]))
        y_sum_diff = sum(diff(y_vec))
        if (abs(x_sum_diff) > tol && abs(y_sum_diff) > tol ) {
          # Neither vector is constant. Test for cointegration.
          qr_x = Matrix::qr(x_vec)
          if (qr_x$rank < 2) {
            x_vec = x_vec[, 1, drop=FALSE]
            qr_x = Matrix::qr(x_vec)
          }
          qr_solve = qr.solve(x_vec, y_vec)
          qr_coef = qr.coef(qr_x, y_vec)
          resids = na.omit(y_vec - x_vec %*% qr_coef)
          if (sum(resids^2) < 1e-6) {
            warning("Residuals are zero. Returning NA.")
            pval = NA
          } else {
            p_val = as.vector(unitrootTest(resids, type="nc")@test$p.value[1])
          }
        }
        m[it[1,j], it[2,j]] = p_val
      }
      m
    }
    r[lower.tri(r)]=0
  }
  r
}

#' Get cointegration information for time series data.
#'
#' @param x a data.frame, matrix, or xts object
#' @return a list containting the pairwise cointegration p-values, the
#'         p-value of the Kolmogorov-Smirnov test for uniformity in the p-values
#'         (null is uniformity), and a measure of the "cointegratedness" of
#'         the time series vectors (100 indicates all are cointegrated zero
#'         indicates they are all independent).
#' @examples
#' data(aapl_fix)
#' data(a_fix)
#' aapl_cons = consolidate_prices(aapl_fix$sys_date, aapl_fix$sys_time,
#'  aapl_fix$td_price, aapl_fix$td_size)
#' a_cons = consolidate_prices(a_fix$sys_date, a_fix$sys_time,
#'  a_fix$td_price, a_fix$td_size)
#' # Make the times for AAPL overlap A.
#' time(aapl_cons) = time(a_cons)[1:nrow(aapl_cons)]
#' trades = merge(aapl_cons$price, a_cons$price)
#' names(trades) = c("aapl", "a")
#' cointegration_info(trades)
#' @export
cointegration_info= function(x) {
  ps = cointegration_p_matrix(x)
  ret = NA
  if (inherits(ps, "Matrix")) {
    p_vals = suppressMessages(ps[upper.tri(ps)])
    ret = list(p_matrix=p_vals,
         p_stat=100*sum(1-p_vals)/length(p_vals))
  }
  ret
}

#' Get the cointegration measure for a rolling windows of stocks.
#'
#' @param x an xts object of stock prices.
#' @param interval the width of the cointegration window.
#' @param dr the dimension reduction technique: "none", "svd", "nmf"
#' @param dr_rank if dr is "svd" or "nmf" then this specifies the rank of the subspace
#' to project onto.
#' @export
coint_measure = function(x, interval=minutes(5), dr=c("none", "svd", "nmf"),
                         dr_rank) {
  if (!(dr[1] %in% c("none", "svd", "nmf")))
    stop("Unknown dimension reduction type")
  if (dr != "none" && missing(dr_rank))
    stop("You must specify a rank for dimension reduction")

  dr_fun = switch(dr[1],
    "none" = function(x) x,
    "svd" = function(x) {
      x_mat = as.matrix(x)
      x_ret = x_mat %*% svd(x_mat)$v[,1:dr_rank]
      xts(x_ret, order.by=time(x))
    },
    "nmf" = function(x) {
      x_mat = as.matrix(x)
      x_ret = tcrossprod(x_mat, nmf(x_mat, rank=dr_rank)@fit@H)
      xts(x_ret, order.by=time(x))
    })

  ci_info=foreach(it=inclusive_window_gen(time(x), interval=interval)) %dopar% {
    a = dr_fun(x[it,])
    ci = cointegration_info(a)
    xts(ci$p_stat, order.by=time(x)[tail(it, 1)])
  }
  ret = Reduce(rbind, ci_info)
  indexTZ(ret) = Sys.getenv("TZ")
  colnames(ret) = "p_stat"
  ret
}


suppressMessages(library(kazaam, quietly=TRUE))

source("./utils.r")
data = read.iris("./iris.csv")
iris = data$iris
iris = cbind(shaq(1, nrow=nrow(iris), ncol=1), iris) # add intercept
is.setosa = (data$species == 1)*2 - 1 # code to +/- 1

mdl = svm(iris, is.setosa)
w = mdl$par

pred = sign(DATA(iris) %*% w)
acc.local = sum(pred == DATA(is.setosa))
acc = allreduce(acc.local) / nrow(iris) * 100

comm.print(acc)

finalize()


# Exercise 4

# Answer the following questions about the iris dataset:

# 1) Who collected this data and when was it collected?

# Answer: Anderson, Edgar (1935)

# 2) What type of data structure is iris?

# Answer:
class(iris)
# "data.frame"

# 3) Take a look at the structure of iris. How many variables are there? What type are they?

# Answer:
str(iris)

# 4) The command used to answer the previous question returns the number of observations and
# the number of variables, which effectively tells you the dimensions of the data set. There
# is another function in R that will explicitly return the dimensions of an object. See if
# you can find it and run it on iris.

# HINT: Use line completion in the console window.

# Answer:
dim(iris)
# 150 5

# The output confirms that there are 150 rows and 5 columns.

# 5) What is the mean petal length across all species of iris?

# Answer:
summary(iris$Petal.Length)
# Mean   :3.758

# 6) Create a new data frame containing only the first five rows of the iris dataset.

# Answer:
first_five_iris <- head(iris, n = 5)


# Plotting matrices using the `lattice` R package

# import required libraries
library("lattice")
library("colorspace")

# set plot resolution
options(repr.plot.res = 200)

# set seed to generate reproducible examples
set.seed(999)

# generate 5 by 5 matrix, with values between 0 and 100
m1 <- matrix(sample(1:100, 5 * 5, replace = TRUE), 5, 5)

# view the matrix
m1

# plot the matrix
levelplot(
    t(m1),
    col.regions = divergingx_hcl("PiYG", n = 100),
    cuts = 99,
    xlab = "column",
    ylab = "row"
)

# do the same with a larger matrix
m2 <- matrix(sample(1:100, 50 * 50, replace = TRUE), 50, 50)

m2

levelplot(
    t(m2),
    col.regions = divergingx_hcl("PuOr", n = 100),
    cuts = 99,
    xlab = "column",
    ylab = "row"
)


library(qrng)
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))

d <- 1;
mat <- matrix(0,20,4);
mat[,1] <- 2^(1:20);
trials <- 40;

for (i in c(1:20)){
    cat(paste('2^',i,'\n'))
    n = mat[i,1];
    # Sobol
    t0 <- Sys.time();
    for (j in (1:trials)){
        x <- sobol(n, d, randomize='digital.shift',seed=7);}
    mat[i,2] <- (Sys.time() - t0)/trials;
    # GHalton
    t0 <- Sys.time();
    for (j in (1:trials)){
        x <- ghalton(n, d, method='generalized');}
    mat[i,3] <- (Sys.time() - t0)/trials;
    # Korobov
    t0 <- Sys.time();
    for (j in (1:trials)){
        x <- korobov(n, d, generator=c(1),randomize='shift');}
    mat[i,4] <- (Sys.time() - t0)/trials;}
df <- as.data.frame(mat);
names(df) <- c('n','Sobol','GHalton','Korobov');
df
write.table(df,file='out/r_sequences.csv',row.names=FALSE,sep=',');


require(Hmisc)
set.seed(177)
sex <- factor(sample(c("m","f"), 500, rep=TRUE))
age <- rnorm(500, 50, 5)
bp  <- rnorm(500, 120, 7)
units(age) <- 'Years'; units(bp) <- 'mmHg'
label(bp) <- 'Systolic Blood Pressure'
L <- .5*(sex == 'm') + 0.1 * (age - 50)
y <- rbinom(500, 1, plogis(L))
png('/tmp/summaryRc.png', height=750)
spar(mfrow=c(3,2), top=2, cex.axis=1)
summaryRc(y ~ age + bp)
# For x limits use 1st and 99th percentiles to frame extended box plots
summaryRc(y ~ age + bp, bpplot='top', datadensity=FALSE, trim=.01)
summaryRc(y ~ age + bp + stratify(sex),
          label.curves=list(keys='lines'), nloc=list(x=.1, y=.05))
dev.off()


library(rqPen)
library(splines)

n <- 100
p <- 8
x <- matrix(rnorm(n*p),ncol=p)
z1 <- runif(n)
z2 <- runif(n)

y <- 1 + x[,1] + x[,3] - x[,8] + z1^3 + exp(z2) + rnorm(n)

x <- cbind(x, bs(z1,5),bs(z2,5))

cv_model <- cv.rq.pen(x,y,tau=.25,penalty="SCAD", penVars=seq(1,p))
bic_model <- cv.rq.pen(x,y,tau=.25,penalty="SCAD",criteria="BIC", penVars=seq(1,p))
large_p_bic <-  cv.rq.pen(x,y,tau=.25,penalty="SCAD",criteria="PBIC", penVars=seq(1,p))


A -> D (3): 0
A -> B (3): 1
A -> C (0): 0
B -> C (4): 2
B -> A (0): 2
B -> E (0): 0
C -> A (3): 3
C -> D (1): 0
C -> E (2): 1
C -> B (0): 2
D -> E (2): 2
D -> F (6): 2
D -> A (0): 3
D -> C (0): 1
E -> B (1): 1
E -> G (1): 0
E -> C (0): 1
E -> D (0): 0
F -> G (9): 5
F -> D (0): 4
G -> E (0): 1
G -> F (0): 4