# Expected relative proportion of breakthrough hospitalized dengue by serostatus in populations vaccinated with the CYD- tetravalent dengue vaccine in the Philippines
# written by Stefan Flasche using R version 3.5.3

# load packages
require(tidyverse)

# Data --------------------------------------------------------------------

# data: cumulative incidence over 5yrs observed in the trial and its stratification into
#       seropositive and seronegative using PRNT50 with multiple imputation (in per 100). from Shridar Table S10
df <- tibble(no=1:8,
             randomisation = c("vacc","vacc","control","control","vacc","vacc","control","control"),
             serostatus = c("pos","neg","pos","neg","pos","neg","pos","neg"),
             outcome = c(rep("hosp",4),rep("severe",4)),
             incidence.ph.mid = c(.375,1.571,1.883,1.093,0.075,0.404,0.48,0.174),
             incidence.ph.lo = c(.263,1.125,1.536,.526,0.034,0.218,0.335,0.036),
             incidence.ph.hi = c(.535,2.193,2.307,2.265,0.165,0.749,0.688,0.834))

#seroprevalence Phil
sp=.70

# Cumulative proportion of 9-16y olds hospitalised with Dengue over time (0m - 60m). Digitalised from Sridhar Figure 3
df.time <- tibble(time = rep(c(0,6,12,18,24,30,36,42,48,54,60),4),
                  randomisation = c(rep("vacc",11*2),rep("control",11*2)),
                  serostatus = rep(c(rep("pos",11),rep("neg",11)),2),
                  incidence = c(0,0.031,0.051,0.061,0.113,0.153,0.184,0.235,0.276,0.307,0.368,
                                0,0.061,0.143,0.205,0.348,0.512,0.757,0.982,1.289,1.432,1.535,
                                0,0.143,0.307,0.573,0.982,1.125,1.350,1.514,1.678,1.739,1.862,
                                0,0.082,0.164,0.399,0.471,0.522,0.583,0.696,0.757,0.757,1.033),
                  No.at.Risk =c(1503,1490,1462,1453,1447,1434,1422,1403,1351,1284,1226,
                                375,374,368,366,364,361,358,350,339,322,311,
                                730,725,705,699,695,689,688,686,658,615,592,
                                207,207,201,199,199,195,194,192,185,174,167))

# plot data
p.data <- df %>% ggplot(aes(x= serostatus, y = incidence.ph.mid, ymin = incidence.ph.lo, ymax = incidence.ph.hi,color=randomisation)) +
  geom_linerange(position=position_dodge(width = 0.5)) +
  geom_point(position=position_dodge(width = 0.5)) +
  facet_grid(.~outcome, scales = "free") +
  coord_flip() + ylab("incidence per 100") +
  labs(y = "Incidence per 100", x = "Serostatus", color = "Randomisation")
ggsave(filename = "Pics\\Fig_Data.tiff",p.data ,unit="cm", width = 14, height = 5, compression = "lzw", dpi = 300)

### analyses on cumulative 5y estimates
vph = subset(df, randomisation=="vacc" & serostatus == "pos" & outcome =="hosp")$incidence.ph.mid
vnh = subset(df, randomisation=="vacc" & serostatus == "neg" & outcome =="hosp")$incidence.ph.mid
cph = subset(df, randomisation=="control" & serostatus == "pos" & outcome =="hosp")$incidence.ph.mid
cnh = subset(df, randomisation=="control" & serostatus == "neg" & outcome =="hosp")$incidence.ph.mid
vps = subset(df, randomisation=="vacc" & serostatus == "pos" & outcome =="severe")$incidence.ph.mid
vns = subset(df, randomisation=="vacc" & serostatus == "neg" & outcome =="severe")$incidence.ph.mid
cps = subset(df, randomisation=="control" & serostatus == "pos" & outcome =="severe")$incidence.ph.mid
cns = subset(df, randomisation=="control" & serostatus == "neg" & outcome =="severe")$incidence.ph.mid

#increase in seroneg vaccinees
vnh/cnh
vns/cns #severe

#RR in seropo / seroneg controls
cph/cnh
cps/cns #severe

#reduction in seropos vaccinees
1-vph/cph
1-vps/cps#severe

#cases averted in seropos vacc per 1 seroneg vacc case
sp*(cph-vph) / ((1-sp)*(vnh-cnh))
sp*(cps-vps) / ((1-sp)*(vns-cns))#severe

# breakthrough among all hospitalised
sp*vph  / (sp*vph + (1-sp)*vnh)
sp*vps  / (sp*vps + (1-sp)*vns)#severe

#proportion of excess cases among the cases in seronegatives
1-cnh/vnh
1-cns/vns#severe

#proportion of excess cases among all cases
(1-(sp*vph  / (sp*vph + (1-sp)*vnh))) * (1-cnh/vnh)
(1-(sp*vps  / (sp*vps + (1-sp)*vns))) * (1-cns/vns)#severe

# proportion of cases averted through vacc
1 - (sp*vph+(1-sp)*vnh) / (sp*cph+(1-sp)*cnh)
1 - (sp*vps+(1-sp)*vns) / (sp*cps+(1-sp)*cns)

#calculate  time dependent proportion of cases attributeable to breakthrough in seropositive, and excess cases n seronegative vaccinees
  #proportion of excess cases among the cases in seronegatives by time
  excess.prop = 1 - subset(df.time, randomisation=="control" & serostatus=="neg")$incidence / subset(df.time, randomisation=="vacc" & serostatus=="neg")$incidence
  excess.prop = excess.prop * (excess.prop>0)

df.prop = tibble(serostatus = c("neg","pos"),
                 prop = c(1-sp,sp))
data.time = df.time %>% merge(df.prop) %>%
  mutate(cases = incidence*prop*830000/100) %>%
  select(serostatus:randomisation, cases) %>%
  spread(serostatus, cases) %>%
  mutate(propSeroNeg = neg/(pos+neg)) %>%
  filter(randomisation=="vacc") %>%
  mutate(propVaccINduced = propSeroNeg * excess.prop) %>%
  mutate(propSeroNeg = propSeroNeg - propVaccINduced) %>%
  mutate(propSeroPos = 1-propSeroNeg-propVaccINduced) %>%
  gather(key = "key", value="prop", -(time:pos))
data.time$key = factor(data.time$key, levels = c("propSeroPos","propSeroNeg","propVaccINduced"))
data.time %>%
  ggplot(aes(x=time, y=prop, fill=key))+
  geom_area(alpha=.7) +
  coord_cartesian(ylim=c(0,1)) +
  scale_y_continuous(labels = scales::percent) +
  scale_fill_manual(values = c("#009E73","#E69F00","#D55E00"), name = "", labels = c("breakthrough cases in\nseropositive vaccinees\n", "cases in\nseronegative vaccinees\n", "vaccine attributable cases in\nseronegative vaccinees\n"))+
  theme_bw() +
  xlab("month since first vaccine dose") + ylab("percentage of all\nhospitalised cases")
ggsave(filename = "Pics\\Fig_PropCases.tiff",unit="cm", width = 17, height = 7, compression = "lzw", dpi = 300)


# Function arguments

# A. Default arguments
# 1. Numeric defaults
# Set the default for n to 5. Remember to only set for numeric detail arguments and not data arguments
cut_by_quantile <- function(x, n = 5, na.rm, labels, interval_type) {
  probs <- seq(0, 1, length.out = n + 1)
  qtiles <- quantile(x, probs, na.rm = na.rm, names = FALSE)
  right <- switch(interval_type, "(lo, hi]" = TRUE, "[lo, hi)" = FALSE)
  cut(x, qtiles, labels = labels, right = right, include.lowest = TRUE)
}

# Remove the n argument from the call
cut_by_quantile(
  n_visits,
  na.rm = FALSE,
  labels = c("very low", "low", "medium", "high", "very high"),
  interval_type = "(lo, hi]"
)

# 2. Logical defaults
# Set the default for na.rm to FALSE
cut_by_quantile <- function(x, n = 5, na.rm = FALSE, labels, interval_type) {
  probs <- seq(0, 1, length.out = n + 1)
  qtiles <- quantile(x, probs, na.rm = na.rm, names = FALSE)
  right <- switch(interval_type, "(lo, hi]" = TRUE, "[lo, hi)" = FALSE)
  cut(x, qtiles, labels = labels, right = right, include.lowest = TRUE)
}

# Remove the na.rm argument from the call
cut_by_quantile(
  n_visits,
  labels = c("very low", "low", "medium", "high", "very high"),
  interval_type = "(lo, hi]"
)

# 3. NULL defaults
# Set the default for labels to NULL. Remember to specify in the function documentation the reason for this behaviour
cut_by_quantile <- function(x, n = 5, na.rm = FALSE, labels = NULL, interval_type) {
  probs <- seq(0, 1, length.out = n + 1)
  qtiles <- quantile(x, probs, na.rm = na.rm, names = FALSE)
  right <- switch(interval_type, "(lo, hi]" = TRUE, "[lo, hi)" = FALSE)
  cut(x, qtiles, labels = labels, right = right, include.lowest = TRUE)
}

# Remove the labels argument from the call
cut_by_quantile(
  n_visits,
  interval_type = "(lo, hi]"
)

# 4. Categorical defaults
# Set the categories for interval_type to "(lo, hi]" and "[lo, hi)"
cut_by_quantile <- function(x, n = 5, na.rm = FALSE, labels = NULL,
                            interval_type = c("(lo, hi]", "[lo, hi)")) {
  # Match the interval_type argument. match.arg() is used to apply the setting. Default will be the first option in the list
  interval_type <- match.arg(interval_type)
  probs <- seq(0, 1, length.out = n + 1)
  qtiles <- quantile(x, probs, na.rm = na.rm, names = FALSE)
  right <- switch(interval_type, "(lo, hi]" = TRUE, "[lo, hi)" = FALSE)
  cut(x, qtiles, labels = labels, right = right, include.lowest = TRUE)
}

# Remove the interval_type argument from the call
cut_by_quantile(n_visits)

# B. Passing arguments between functions
# 1. Harmonic mean
# From previous steps
get_reciprocal <- function(x) {
  1 / x
}
calc_harmonic_mean <- function(x) {
  x %>%
    get_reciprocal() %>%
    mean() %>%
    get_reciprocal()
}

std_and_poor500 %>%
  # Group by sector
  group_by(sector) %>%
  # Summarize, calculating harmonic mean of P/E ratio
  summarize(hmean_pe_ratio = calc_harmonic_mean(pe_ratio))

# 2. Dealing with missing values
# From previous step. Can adjust the function signature and then update the detail argument within the mean function
calc_harmonic_mean <- function(x, na.rm = FALSE) {
  x %>%
    get_reciprocal() %>%
    mean(na.rm = na.rm) %>%
    get_reciprocal()
}

std_and_poor500 %>%
  # Group by sector
  group_by(sector) %>%
  # Summarize, calculating harmonic mean of P/E ratio
  summarize(hmean_pe_ratio = calc_harmonic_mean(pe_ratio, na.rm = TRUE))

# 3. Passing arguments with ..., helps to provide more flexibility. Caution should be used here incase an explicit detail argument should be put in place
calc_harmonic_mean <- function(x, ...) {
  x %>%
    get_reciprocal() %>%
    mean(...) %>%
    get_reciprocal()
}

std_and_poor500 %>%
  # Group by sector
  group_by(sector) %>%
  # Summarize, calculating harmonic mean of P/E ratio
  summarize(hmean_pe_ratio = calc_harmonic_mean(pe_ratio, na.rm = TRUE))

# C. Checking arguments
# Always makes logical sense to check for errors before running the function method to attempt and return a result
# 1. Throwing errors with bad arguments
calc_harmonic_mean <- function(x, na.rm = FALSE) {
  # Assert that x is numeric
  assert_is_numeric(x)
  x %>%
    get_reciprocal() %>%
    mean(na.rm = na.rm) %>%
    get_reciprocal()
}

# See what happens when you pass it strings
calc_harmonic_mean(std_and_poor500$sector)

# 2. Custom error logic
calc_harmonic_mean <- function(x, na.rm = FALSE) {
  assert_is_numeric(x)
  # Check if any values of x are non-positive
  if(any(is_non_positive(x), na.rm = TRUE)) {
    # Throw an error
    stop("x contains non-positive values, so the harmonic mean makes no sense.")
  }
  x %>%
    get_reciprocal() %>%
    mean(na.rm = na.rm) %>%
    get_reciprocal()
}

# See what happens when you pass it negative numbers
calc_harmonic_mean(std_and_poor500$pe_ratio - 20)

# 3. Fixing function arguments
# Update the function definition to fix the na.rm argument
calc_harmonic_mean <- function(x, na.rm = FALSE) {
  assert_is_numeric(x)
  if(any(is_non_positive(x), na.rm = TRUE)) {
    stop("x contains non-positive values, so the harmonic mean makes no sense.")
  }
  # Use the first value of na.rm, and coerce to logical
  na.rm <- coerce_to(use_first(na.rm), target_class = "logical")
  x %>%
    get_reciprocal() %>%
    mean(na.rm = na.rm) %>%
    get_reciprocal()
}

# See what happens when you pass it malformed na.rm
calc_harmonic_mean(std_and_poor500$pe_ratio, na.rm = 1:5)


library(shiny)
library(rsconnect)
library(ggplot2)

#############################################################
# Set the baseline parameters
#############################################################
base_sI <- .2
base_gL <- .01
base_gA <- .02
base_delta <- .05
base_alpha <- .3
base_A <- 10
base_kalstar <- (base_sI/(base_gL+base_gA+base_delta))^(1/(1-base_alpha))
base_K <- base_kalstar*base_A
base_kystar <- base_sI/(base_gL+base_gA+base_delta)

#############################################################
# Define UI ----
#############################################################
ui <- fluidPage(
  withMathJax(),
  titlePanel("Level of BGP"),

  mainPanel(

      #hr(),

      h4("Set parameters"),

      fixedRow(
        column(4,
        sliderInput("alt_sI", h6('New capital share of GDP \\(s_I\\)'),
                    min = 0, max = .5, value = base_sI, ticks = FALSE, step=.01),
        sliderInput("alt_gL", h6("Population growth rate \\(g_L\\)"),
                    min = -.05, max = .05, value = base_gL, ticks = FALSE, step=.01),
        sliderInput("alt_gA", h6("Productivity gorwth rate \\(g_A\\)"),
                    min = -.05, max = .1, value = base_gA, ticks = FALSE, step=.01),
        sliderInput("alt_delta", h6("Depreciation rate \\(\\delta\\)"),
                    min = 0, max = .1, value = base_delta, ticks = FALSE, step=.01),
        sliderInput("alt_alpha", h6("Capital elasticity \\(\\alpha\\)"),
                    min = 0, max = 1, value = base_alpha, ticks = FALSE, step=.01),
        sliderInput("alt_A", h6("Baseline productivity \\(A_0\\)"),
                    min = 0, max = 30, value = base_A, ticks = FALSE, step=.1),
        br(),
        actionButton("reset", "Reset all to baseline")
        ),
        column(8,
        plotOutput("lnygraph",width = "100%"),
        )
      ) # end FluidRow
      ) # end main panel
  ) # end ui
#############################################################
# Define server logic ----
#############################################################
server <- function(input, output, session) {

  # Reset parameters
  observeEvent(input$reset, {
    updateSliderInput(session,'alt_sI',value = base_sI)
    updateSliderInput(session,'alt_gL',value = base_gL)
    updateSliderInput(session,'alt_gA',value = base_gA)
    updateSliderInput(session,'alt_delta',value = base_delta)
    updateSliderInput(session,'alt_alpha',value = base_alpha)
    updateSliderInput(session,'alt_A',value = base_A)
  })

  output$lnygraph <- renderPlot(
    {
      t <- c(0:100)
      df <- data.frame(t)
      kystar = input$alt_sI/(input$alt_gL+input$alt_gA+input$alt_delta)
      df$lny <- (input$alt_alpha/(1-input$alt_alpha))*log(kystar) + log(input$alt_A) + input$alt_gA*df$t

      ggplot(df, aes(x=t)) +
        geom_line(aes(y = lny),size=1) +
        xlab("Time") +
        ylab("Log GDP per capita") +
        theme_light() +
        ylim(0,7.5)
    }
  ) # end gky graph

} # end server

# Run the app ----
shinyApp(ui = ui, server = server)


#!/usr/bin/Rscript

library(XML)

tree <- xmlParse("pedv.xml", getDTD=F)

rval <- rexp(n=1,rate=2)
invisible(xpathApply(tree, "/beast/siteModel/gammaShape/parameter", 'xmlAttrs<-', value=c(value=rval)))

rval <- exp(rnorm(n=1, mean=1, sd=1.25))
invisible(xpathApply(tree, "/beast/HKYModel/kappa/parameter", 'xmlAttrs<-', value=c(value=rval)))

rval <- runif(4)
rval <- rval/sum(rval)
rval <- paste(rval, collapse=' ')
invisible(xpathApply(tree, "/beast/HKYModel/frequencies/frequencyModel/frequencies/parameter", 'xmlAttrs<-', value=c(value=rval)))

rval <- rnorm(n=1, mean=7e-4, sd=1e-4)
while(rval <= 0){
    rval <- rnorm(n=1, mean=7e-4, sd=1e-4)
}
invisible(xpathApply(tree, "/beast/strictClockBranchRates/rate/parameter", 'xmlAttrs<-', value=c(value=rval)))

rval <- rgamma(n=1, shape=3, scale=0.3)
invisible(xpathApply(tree, "/beast/constantSize/populationSize/parameter", 'xmlAttrs<-', value=c(value=rval)))

cat(saveXML(xmlRoot(tree)), '\n')


# suppressMessages(library(knn, quietly=TRUE))
# suppressMessages(library(class, quietly=TRUE))

set.seed(1)

train_ind = 1:25
x = rbind(
  subset(iris, Species=='setosa')[train_ind, ],
  subset(iris, Species=='versicolor')[train_ind, ],
  subset(iris, Species=='virginica')[train_ind, ]
)

test_ind = 26:50
test = rbind(
  subset(iris, Species=='setosa')[test_ind, ],
  subset(iris, Species=='versicolor')[test_ind, ],
  subset(iris, Species=='virginica')[test_ind, ]
)

x$Species = NULL
test$Species = NULL

y <- factor(c(rep("s", 25), rep("c", 25), rep("v", 25)))

k = 1
# c1 = class::knn(x, test, y, k=k, prob=FALSE)
c1 <-
structure(c(2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 3L, 3L, 1L, 3L, 3L, 3L, 3L, 3L, 1L, 3L, 3L,
3L, 3L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), .Label = c("c",
"s", "v"), class = "factor")
c2 = knn::knn(x, y, test, k=k)
stopifnot(all.equal(c1, c2))

k = 3
# c1 = class::knn(x, test, y, k=k, prob=FALSE)
c1 <-
structure(c(2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 3L, 1L,
1L, 1L, 1L, 1L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 3L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 1L, 3L, 3L,
3L, 3L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), .Label = c("c",
"s", "v"), class = "factor")
c2 = knn::knn(x, y, test, k=k)
stopifnot(all.equal(c1, c2))


# Obtem o dataset arbuthnot
source("http://www.openintro.org/stat/data/arbuthnot.R")

# Imprime o dataset no console
arbuthnot

# Imprime as dimensões do dataset
dim(arbuthnot)

# Imprime os nomes das colunas
names(arbuthnot)

# Imprime os dados apenas da coluna boys
arbuthnot$boys

# Plotando um grafico de meninas por ano (tipo dispersão por default)
plot(x = arbuthnot$year, y = arbuthnot$girls)

# Plotando o mesmo gráfico por linha
plot(x = arbuthnot$year, y = arbuthnot$girls, type = "l")

# Doc sobre a função plot
?plot

# Somando todos os batismos por ano
arbuthnot$boys + arbuthnot$girls

# Plotando o numero total de batismos por ano
plot(arbuthnot$year, arbuthnot$girls + arbuthnot$boys, type = "l")

# Razao do numero de meninos por meninas
arbuthnot$boys / arbuthnot$girls

# Proporção do meninos
arbuthnot$boys / (arbuthnot$boys + arbuthnot$girls)

# Plot de proporção dos meninos por ano
plot(arbuthnot$year, arbuthnot$boys / (arbuthnot$boys + arbuthnot$girls), type = "l")

arbuthnot$boys > arbuthnot$girls


urlData = "https://github.com/CriticalPathTraining/PBI365/raw/master/Student/Data/SalesByCustomer.csv"
customers <- read.csv(urlData)

# give columns prettier names
names(customers) = c("Customer","State","Gender","Age","Sales")

# Gender single charactor values

# install packages if they are not installed
if(!('plyr' %in% rownames(installed.packages()))){
  install.packages("plyr")
}

library(plyr)
customers$Gender <- mapvalues(customers$Gender, from = c("Male", "Female"), to = c("M", "F"))

# sort the data
customers <- customers[ order(customers$Age, decreasing=TRUE),  ]

florida.customers = subset(customers, State == "FL", c("Customer", "Age") )

hist(florida.customers$Age,
     main = "Florida Customer Count by Age",
     col="lightblue",
     border="black",
     ylab="Customer Count",
     xlab="Customer Age",
     xlim = c(20, 100),
     breaks=50 )


# 1.	Naive Bayes using e1071 package

require('e1071')

#2.	Use the EmployeeCleanedDataset.csv

mydata<-read.csv("C:/Users/Harsh Darji/Desktop/EmployeeCleanedData.csv")
#Reading the csv file

head(mydata)

library(caret)

library(e1071)

#3.	Split the set into train and test

intrain<-createDataPartition(y=mydata$gender,p=0.7,list=FALSE) #spiting 70-30
training<-mydata[intrain,]
testing<-mydata[-intrain,]

#split <- sample(nrow(mydata), nrow(mydata) * 2/3)
#train <- mydata[split, ]
#test <- mydata[-split, ]

head(training)

# 4.	Convert the variables to factors

str(training)

head(testing)

str(training)

#training[] <- lapply(training, factor)
#testinng[] <- lapply(testing, factor)

# 5.	Using Naïve Bayes on training data set. With the flag for Laplace as 1, which means it will use Laplace smoothing for zero probabilities.

nb_default <- naiveBayes(Attrition ~., laplace = 1, data = training, na.action = na.pass)

# 6.	Fit the model on test data

nb_predict <- predict(nb_default, testing[,-(10)], type = c("class"))

# 7.	Get the confusion matrix and accuracy

matrix <- table(nb_predict, testing$Attrition)

matrix

# 8.	Print accuracy

accuracy <- sum(diag(matrix)) / sum(matrix)

accuracy

###EXTRA

table(training$Attrition)

table(testing$Attrition)


print(50 %gcd% 75)


# earthquakic data set -------------------------
# Number of applicants -------------------------

library(data.table)
library(rMGLReg)
devtools::load_all()
dtnew <- fread("D:/Rpackages/rMGLReg/data-raw/dtnew_copula.csv")
dtnew$ynew <- NULL
dtnew <- dtnew[year %in% seq(1990, 2015)]
dtadjust <- fread("D:/Rpackages/rMGLReg/data-raw/dtcpi.csv", header = T)
dtadjust <- dtadjust[year %in% seq(1990, 2015)]
dtadjust
dtadjust[, CPI_factor := 1 / (CPI / 615.2)]

setkey(dtadjust, year)
setkey(dtnew, year)
dt <- merge(dtnew, dtadjust)
dt[is.na(y)]$y <- median(dt$y, na.rm = T)
dt[, ynew := y * CPI_factor]

dtnew <- dt[, .(year,
  yraw = y,
  y1 = ynew, magnitude, death, inj, intensity,
  y2 = death + inj
)]
dtnew

# marginal distribution for y1
y <- dtnew$y1
Xsigma <- model.matrix(~1, data = dtnew)
Xb <- model.matrix(~1, data = dtnew)
LLlogmoyalGA3 <- function(y, pars, Xsigma, Xb) {
  sigma <- exp(Xsigma %*% pars[1:dim(Xsigma)[2]])
  b <- exp(Xb %*% pars[(dim(Xsigma)[2] + 1):(dim(Xsigma)[2] + dim(Xb)[2])])
  a <- exp(pars[dim(Xsigma)[2] + dim(Xb)[2] + 1])
  ll <- -0.5 * log(2 * pi) - log(sigma) + a * log(b) + lgamma(a + 0.5) - lgamma(a) - (1 / (2 * sigma) + 1) * log(y) - (a + 0.5) * log(0.5 * (1 / y)^(1 / sigma) + b)

  loglike <- -sum(ll)
  return(loglike)
}
mlogmoyalGA3 <- optim(
  fn = LLlogmoyalGA3, Xsigma = Xsigma,
  Xb = Xb,
  y = y, hessian = T,
  control = list(maxit = 50000),
  # method = 'Nelder-Mead',
  # par = c(-1,-0.1,0.5,-2,-1))
  par = c(-1, -1, -1)
)
# modout(mlogmoyalGA3)
#
pars <- mlogmoyalGA3$par
sigma <- exp(Xsigma %*% pars[1:dim(Xsigma)[2]])
b <- exp(Xb %*% pars[(dim(Xsigma)[2] + 1):(dim(Xsigma)[2] + dim(Xb)[2])])
a <- exp(pars[dim(Xsigma)[2] + dim(Xb)[2] + 1])
ufit <- c()
for (i in 1:length(y)) {
  ufit[i] <- pGLMGA(y[i], sigma = sigma[i], a = a, b = b[i])
}
resLMGA3 <- qnorm(ufit)
u1 <- ufit
f1 <- c()
for (i in 1:length(y)) {
  f1[i] <- dGLMGA(y[i], sigma = sigma[i], a = a, b = b[i])
}

## ----message=TRUE, warning=FALSE------------------------
library(gamlss)
library(gamlss.tr)
library(evd)
library(extRemes)
library(ggplot2)
library(qqplotr)
library(patchwork)
umin <- 20
gen.trun(par = umin + 1, type = "right", name = "tr", family = "NBI")
gen.trun(par = umin + 1, type = "right", name = "tr", family = "PO")
gen.trun(par = umin + 1, type = "right", name = "tr", family = "ZINBI")
gen.trun(par = umin + 1, type = "right", name = "tr", family = "ZIP")
dt2 <- dtnew[y2 <= umin]
m.NB <- gamlss(y2 ~ 1, family = NBItr, data = dt2, method = mixed(2, 10000))
summary(m.NB)
pars <- c(coef(m.NB, what = "mu"), coef(m.NB, what = "sigma"))
summary1 <- summary(m.NB)
summary(m.NB)
logLik(m.NB)
mu.NB <- exp(coef(m.NB))
sigma.NB <- exp(coefficients(m.NB, what = "sigma"))

newtheme <- theme_bw() + theme(
  axis.line = element_line(colour = "black"),
  axis.text.x = element_text(margin = margin(t = 0.25, unit = "cm")),
  axis.text.y = element_text(
    margin = margin(r = 0.25, unit = "cm"),
    size = 10,
    vjust = 0.5,
    hjust = 0.5
  ),
  axis.ticks.length = unit(-0.1, "cm"),
  plot.title = element_text(hjust = 0.5),
  legend.direction = "vertical",
  legend.position = c(.95, .99),
  legend.justification = c("right", "top"),
  legend.box.just = "right",
  legend.text = element_text(size = 10)
)

# par(mfrow = c(1, 2), tcl = 0.3, mgp = c(1.5,0,0))
# qqnorm(res.death, ylim = c(-3,3), xlim = c(-3,3), main = '')
# abline(0,1, col = 'red')

res.death <- residuals(m.NB, what = "z-scores")
df <- data.table(y = res.death)
v1 <- ggplot(df, aes(sample = y)) +
  stat_qq_point() +
  # stat_qq_band(bandType = "ks", fill = "#8DA0CB", alpha = 0.4, conf = 0.95) +
  stat_qq_line(col = "red", identity = TRUE) +
  newtheme +
  labs(title = "Causalities below the threshold", x = "Standard Normal Quantiles", y = "Sample Quantiles") +
  scale_x_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  scale_y_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  geom_abline(slope = 1, col = "red", lwd = 1)

# v1
# =========================================================================
# death > umin
# ==========================================================================
X1 <- model.matrix(~1, data = dtnew[y2 > umin])
X2 <- model.matrix(~1, data = dtnew[y2 > umin])
y2new <- dtnew[y2 > umin]$y2
GPD.MLE <- fevd(
  x = y2,
  scale.fun = ~1,
  shape.fun = ~1,
  threshold = umin, method = "MLE", use.phi = F,
  type = "GP", data = dtnew
)
GPD.MLE
# plot(GPD.MLE)
GPD.par <- GPD.MLE$results$par
pars <- GPD.MLE$results$par
GPD.hessian <- GPD.MLE$results$hessian
GPD.se <- sqrt(diag(solve(GPD.hessian)))
GPD.Z <- GPD.par / GPD.se ##  Z缁熻???
GPD.p <- ifelse(GPD.Z >= 0, pnorm(GPD.Z, lower = F) * 2, pnorm(GPD.Z) * 2) ## p???
cbind(GPD.par, GPD.se, GPD.p)

scale <- (X1 %*% pars[1:dim(X1)[2]])
shape <- X2 %*% pars[c((dim(X1)[2] + 1):(dim(X1)[2] + dim(X2)[2]))]
ufit <- 0
for (i in 1:length(y2new)) {
  ufit[i] <- evd::pgpd(y2new[i], loc = umin, scale = scale[i], shape = shape[i])
}
resGPD.death <- qnorm(ufit)
# qqnorm(resGPD.death, ylim = c(-3, 3), xlim = c(-3, 3),
#        main = '')
# abline(0, 1, col = 'red')

df <- data.table(y = resGPD.death)
v2 <- ggplot(df, aes(sample = y)) +
  stat_qq_point() +
  # stat_qq_band(bandType = "ks", fill = "#8DA0CB", alpha = 0.4, conf = 0.95) +
  stat_qq_line(col = "red", identity = TRUE) +
  newtheme +
  labs(title = "Causalities above the threshold", x = "Standard Normal Quantiles", y = "Sample Quantiles") +
  scale_x_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  scale_y_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  geom_abline(slope = 1, col = "red", lwd = 1)
# v2

v0 <- v1 + v2 + plot_layout(ncol = 2)
v0

# ======================================================================================
# GPD and negative binom
y <- dtnew$y2
X0 <- model.matrix(~1, data = dtnew)
X1 <- model.matrix(~1, data = dtnew) # GP
X2 <- model.matrix(~1, data = dtnew) # GP
par1 <- GPD.MLE$results$par
par2 <- c(coef(m.NB, what = "mu"), coef(m.NB, what = "sigma"))
p1 <- nrow(dt2) / nrow(dtnew)
scale <- X1 %*% par1[1:dim(X1)[2]]
shape <- X2 %*% par1[c((dim(X1)[2] + 1):(dim(X1)[2] + dim(X2)[2]))]
dtu2 <- data.table(
  mu = as.vector(exp(X0 %*% par2[1:dim(X0)[2]])),
  sigma = exp(par2[length(par2)]),
  scale = as.vector(X1 %*% par1[1:dim(X1)[2]]),
  shape = as.vector(X2 %*% par1[c((dim(X1)[2] + 1):(dim(X1)[2] + dim(X2)[2]))]),
  y = y, y_ = y - 1,
  y__ = y - 2
)
dtu2[y_ < 0]$y_ <- 0
dtu2[y__ < 0]$y__ <- 0
dtu2
u <- with(dtu2, {
  u2 <- u2_ <- u2__ <- u0 <- 0
  for (i in 1:length(y)) {
    if (y[i] <= umin) {
      u2[i] <- p1 * as.vector(pNBItr(y[i], mu = mu[i], sigma = sigma[i]))
    } else {
      u2[i] <- p1 + (1 - p1) * evd::pgpd(y[i], loc = umin, scale = scale[i], shape = shape[i])
    }

    if (y_[i] <= umin) {
      u2_[i] <- p1 * as.vector(pNBItr(y_[i], mu = mu[i], sigma = sigma[i]))
    } else {
      u2_[i] <- p1 + (1 - p1) * evd::pgpd(y_[i], loc = umin, scale = scale[i], shape = shape[i])
    }

    if (y__[i] <= umin) {
      u2__[i] <- p1 * as.vector(pNBItr(y__[i], mu = mu[i], sigma = sigma[i]))
    } else {
      u2__[i] <- p1 + (1 - p1) * evd::pgpd(y__[i], loc = umin, scale = scale[i], shape = shape[i])
    }
    u0 <- pNBItr(umin, mu = mu[i], sigma = sigma[i])
  }
  u <- cbind(u2, u2_, u2__, u0)
  u
})
u2 <- u[, 1]
u2_ <- u[, 2]
u2__ <- u[, 3]
u2_[which(dtnew$y2 - 1 < 0)] <- 0
u2__[which(dtnew$y2 - 2 < 0)] <- 0
dtu2$u2 <- u2
dtu2$u2_ <- u2_
dtu2$u2__ <- u2__
dtu2

# =========================================================================================
# density of y2 --------------------------------------------------------------------------
dtu2$f2 <- with(dtu2, {
  f <- 0
  for (i in 1:length(y)) {
    if (y[i] <= umin) {
      f[i] <- p1 * as.vector(dNBItr(y[i], mu = mu[i], sigma = sigma[i]))
    } else {
      f[i] <- (1 - p1) * evd::dgpd(y[i], loc = umin, scale = scale[i], shape = shape[i])
    }
  }
  f
})
f2 <- dtu2$f2

dtnew$f1 <- f1
dtnew$f2 <- dtu2$f2
dtnew$u1 <- u1
dtnew$u2 <- dtu2$u2
dtnew$u2_ <- dtu2$u2_

# plot
dtnew[, magnitude.f := cut(magnitude, c(3.9, 5.2, 6, 9))]
dtnew[, .(corc = cor(u1, u2)), by = magnitude.f]
summary(dtnew$magnitude)
table(dtnew$magnitude.f)
library(latex2exp)
df <- dtnew
m1 <- ggplot(df, aes(
  x = u1, y = u2, group = magnitude.f,
  col = magnitude.f,
  shape = magnitude.f
)) +
  geom_point() +
  theme_bw() +
  theme(
    axis.line = element_line(colour = "black"),
    axis.text.x = element_text(margin = margin(t = 0.25, unit = "cm")),
    axis.text.y = element_text(
      margin = margin(r = 0.25, unit = "cm"),
      size = 10,
      vjust = 0.5,
      hjust = 0.5
    ),
    axis.ticks.length = unit(-0.1, "cm"),
    plot.title = element_text(hjust = 0.5),
    # legend.direction = 'vertical',
    # legend.position = c(.95, .99),
    # legend.justification = c("right", "top"),
    # legend.box.just = "right",
    legend.text = element_text(size = 10)
  ) +
  labs(
    title = "Scatterplot of Losses-Casualties",
    x = TeX("$u_1$"),
    y = TeX("$u_2$")
  ) +
  # scale_colour_discrete(breaks = c(1,2,3)) +
  scale_x_continuous(
    limits = c(0, 1),
    breaks = seq(0, 1, by = 0.2)
  ) +
  scale_y_continuous(
    limits = c(0, 1),
    breaks = seq(0, 1, by = 0.2)
  ) +
  labs(col = "magnitude", shape = "magnitude")

m1

# write.csv(dtnew, "data-raw/earth-model.csv")
earthqCHI <- dtnew
earthqCHI$magnitude.f <- NULL
usethis::use_data(earthqCHI, overwrite = TRUE)


context("hdm calculator")
library("data.tree")

test_that("HDM Weights correctly calculated", {
  print(paste0("Running tests from ",getwd()))

  comboFrames <- readRDS("calculateHDMWeights-comboFrames.rds")
  tree <- readRDS("calculateHDMWeights-tree.rds")
  #calculate!
  calculatedTree <- calculateHDMWeights(tree, comboFrames)
  print(calculatedTree, "norm", "weight","inconsistency")

  easyNode <- FindNode(node=calculatedTree,name = "easy")

  #make sure everything is calculating
  expect_equal(easyNode$norm,0.67000000)
  expect_equal(easyNode$weight,0.596300000)
})

test_that("Agree to disagree", {
  #build matrix
#  val1  val2  val3
#  expert1 0.010 0.010 0.010
#  expert2 0.012 0.012 0.012
#  expert3 0.200 0.010 0.200
  testMatrix <- matrix(c(.01,.012,.2,.01,.012,.01,.01,.012,.2),nrow = 3, ncol = 3)
  colnames(testMatrix) <- c("val1","val2","val3")
  rownames(testMatrix) <- c("expert1","expert2","expert3")

  dis <- calculateExpertDisagreement(testMatrix)

  expect_equal(0.0366, dis)
})


library(ape)
library(nlme)
library(caper)
library(optparse)

setwd("I:\\Vlinders\\Phylogeny")

# Read tree
butterflies <- read.nexus("grafted.pruned.nex")
names(butterflies)
plot(butterflies)
axisPhylo()

data<-read.csv("DataGLS.csv", header=TRUE, as.is=TRUE)
attach(data)

# Analysis of Range size

# exclude rows with NA
sel <- is.na(Range.size)
drop <- Range.size[!sel]
data_rangesize <- data[!sel, ]

# Plot
rownames(data_rangesize) <- data_rangesize$Species_in_Phylo
PC.C12 <- data_rangesize$PC.C1*data_rangesize$PC.C1
PC.C22 <- data_rangesize$PC.C2*data_rangesize$PC.C2
plot(data_rangesize$PC.B1,data_rangesize$Range.size)

# Trim the tree and keep the tips for the species with trait data
sel <- butterflies$tip.label %in% data_rangesize$Species_in_Phylo
drop <- butterflies$tip.label[!sel]
butterflies.trim <- drop.tip(butterflies,drop)
plot(butterflies.trim)

# Weight for non-ultrametric tree
# see http://blog.phytools.org/2012/04/using-nlmegls-for-phylogenetic.html
weight<-diag(vcv.phylo(butterflies.trim))

# GLS Range size

# GLS using ape

cor.matrix <- corBrownian(phy=butterflies.trim)
modelA <- gls(Range_size ~ PC.B1+PC.B2+PC.B3+PC.C1+PC.C12+PC.C2+PC.C22,data=data_rangesize,correlation=cor.matrix,weights=varFixed(~weight),method="REML")
summary(modelA)
hist(residuals(modelA))
R2A <- cor(data_rangesize$Range_size,predict(modelA))^2
R2A

modelA <- gls(Range_size ~ PC.B1+PC.B2+PC.B3+PC.C1+PC.C12+PC.C2+PC.C22,data=data_rangesize,correlation=cor.matrix,weights=varFixed(~weight))
summary(modelA)
hist(residuals(modelA))
R2A <- cor(data_rangesize$Range_size,predict(modelA))^2
R2A

modelB <- gls(Range.size ~ PC.B1+PC.B2+PC.B3+PC.C1+PC.C12+PC.C2+PC.C22,data=data_rangesize)
summary(modelB)
hist(residuals(modelB))
R2B <- cor(data_rangesize$Range.size,predict(modelB))^2
R2B

# PGLS using caper

# merge into a comparative data object
cdat <- comparative.data(
  phy=butterflies.trim,
  data=data_rangesize,
  names.col="tip.label", # column to join on
  vcv=TRUE, # create variance/covariance matrix, needed for pgls
  na.omit=FALSE, # do NOT omit species with missing data
  warn.dropped=TRUE # warn about any species not shared by tree & data
);

model.pgls.range_size<-pgls(Range_size~PC.B1+PC.B2+PC.B3+PC.C1+PC.C12+PC.C2+PC.C22,data=cdat,lambda="ML");
summary(model.pgls.range_size);

# Analysis of Habitat specificity

# exclude rows with NA
sel <- is.na(SSI)
drop <- SSI[!sel]
data_SSI <- data[!sel, ]

# Plot
rownames(data_SSI) <- data_SSI$Species_in_Phylo
PC.C12 <- data_SSI$PC.C1*data_SSI$PC.C1
PC.C22 <- data_SSI$PC.C2*data_SSI$PC.C2
plot(data_SSI$PC.B1,data_SSI$SSI)

# Trim the tree and keep the tips for the species with trait data
sel <- butterflies$tip.label %in% data_SSI$Species_in_Phylo
drop <- butterflies$tip.label[!sel]
butterflies.trim <- drop.tip(butterflies,drop)
plot(butterflies.trim)

# GLS SSI
cor.matrix <- corBrownian(phy=butterflies.trim)
modelA <- gls(SSI ~ PC.B1+PC.B2+PC.B3+PC.C1+PC.C12+PC.C2+PC.C22,data=data_SSI,correlation=cor.matrix)
summary(modelA)
hist(residuals(modelA))
R2A <- cor(data_SSI$SSI,predict(modelA))^2
R2A

modelB <- gls(SSI ~ PC.B1+PC.B2+PC.B3+PC.C1+PC.C12+PC.C2+PC.C22,data=data_SSI)
summary(modelB)
hist(residuals(modelB))
R2B <- cor(data_SSI$SSI,predict(modelB))^2
R2B


## From Jerome Asselin  https://github.com/harrelfe/rms/issues/32
require(rms)
df <- data.frame(y=rnorm(21), day=weekdays(Sys.Date()-(1:21), abbr=TRUE))
df$day.ordered <-
  with(df, factor(as.character(day),
                  levels=c("Sun","Mon","Tue","Wed","Thu","Fri","Sat"),
                  ordered=TRUE))
options(contrasts=c("contr.treatment", "contr.treatment"))
fit1 <- ols(y ~ day, data=df)
fit2 <- ols(y ~ day.ordered, data=df)
df.char <- df
df.char$day.ordered <- as.character(df.char$day.ordered)
w <- cbind(orig          = predict(fit1),
      orig.newdata       = predict(fit1, newdata=df),
      ordered            = predict(fit2),
      ordered.newdata    = predict(fit2, newdata=df),
      ordered.workaround = predict(fit2, newdata=df.char))
round(w[, -1] - w[, 1], 3)


 DTRCON Example Program Results

 Estimate of condition number =  1.16E+02


## Taking age data from here:
## https://ourworldindata.org/mortality-risk-covid#case-fatality-rate-of-covid-19-by-age

## The data below is a breakdown of CFR by age group across various
## countries. It shows very large differences of the CFR by age. This
## data is based on the number of confirmed cases and deaths in each
## age group as reported by national agencies.

## The data come from the:

## 1) Chinese Center for Disease Control and Prevention (CDC) as of
##    17th February;

## 2) Spanish Ministry of Health as of 24th March;

## 3) Korea Centers for Disease Control and Prevention (KCDC) as of
##    24th March; and

## 4) Italian National Institute of Health, as presented in the paper
##    by Onder et al. (2020) as of 17th March.17,18

## case_fatality_rate_of_covid_19_by_age
cfrbyage <-
    c(
        0.00, 0.00, 0.00, 0.00, #  0 to  9 years
        0.00, 0.00, 0.20, 0.00, # 10 to 19 years
        0.00, 0.22, 0.20, 0.00, # 22 to 29 years
        0.11, 0.14, 0.20, 0.30, # 30 to 39 years
        0.08, 0.30, 0.40, 0.40, # 40 to 49 years
        0.50, 0.40, 1.30, 1.00, # 50 to 59 years
        1.80, 1.90, 3.60, 3.50, # 60 to 69 years
        6.30, 4.80, 8.00, 12.8, # 70 to 79 years
        13.0, 15.6, 14.8, 20.2  # 80+      years
    )

## Knowing R, there is probably a cleaner way to do this...
cfrbyage.m <- matrix(cfrbyage, 9, byrow=TRUE)
cfrbyage.m

rownames(cfrbyage.m) <- c(
    "0-9",
    "10-19",
    "22-29",
    "30-39",
    "40-49",
    "50-59",
    "60-69",
    "70-79",
    "80+"
)

colnames(cfrbyage.m) <- c(
    "Korea", "Spain", "China", "Italy"
)

cfrbyage.m

## In order to match the plot at Our World in Data, we turn the matrix
## 'upside down' and 'back to front' ...
cfrbyage.m.plot <-
    cfrbyage.m[ nrow(cfrbyage.m):1, ncol(cfrbyage.m):1 ]

barplot(t(cfrbyage.m.plot), beside=TRUE, horiz=TRUE, col=c(5,6,7,4),
        xlab='Case fatality rate (%)', ylab='Years')

## There is no such thing as the 'average CFR'... ... ... Hey! Lets
## pretend there is!
cfronavg <- 0.1

## Calculate the Odds Ratio
cfrbyage.m / cfronavg

## Mean Odds Ratio across all studies
or.mean <-
    apply(cfrbyage.m / cfronavg, 1, mean)
or.mean

or.sd <-
    apply(cfrbyage.m / cfronavg, 1, sd)
or.sd

x <- barplot(or.mean)

my.ylim <-
    c(min(or.mean-or.sd), max(or.mean+or.sd))

barplot(or.mean, ylim=my.ylim)
points(x, or.mean+or.sd)
points(x, or.mean-or.sd)

## Cludge in a log scale...
barplot(log(or.mean+0.01))

## Trying a different way

## We add a very small CFR to allow for 0% CFR conversion to Log Odds
lod <- log((cfrbyage.m + 0.01) / cfronavg)
lod

barplot(t(lod), beside=TRUE, horiz=TRUE,
        col=c(5,6,7,4))

## To add insult to injury, lets average over all four studies...

means <-
    apply(lod, 1, mean)
stdevs <-
    apply(lod, 1, sd)

x <-
    barplot(means, ylim=c(-3, 6))

points(x, means+stdevs)
points(x, means-stdevs, pch=2)

## Me no stats good? Unprobable!
barplot(rbind(means+stdevs, means,
              means-stdevs), beside=TRUE)

## Got the age Odds Ratios above.

## The SNP Odds Ratios are...
baseline.cfr = 0.1

## TT at rs12329760 = 0
rs12329760.tt = 0.146*0 / baseline.cfr

## CT at rs12329760 = 0.146
rs12329760.ct = 0.146*1 / baseline.cfr

## CC at rs12329760
rs12329760.cc = 0.146*2 / baseline.cfr

## CC at rs75603675
rs75603675.cc = 0.148*0 / baseline.cfr
rs75603675.ac = 0.148*1 / baseline.cfr
rs75603675.aa = 0.148*2 / baseline.cfr

## Produce some nice plots...

install.packages("dotwhisker")

library(dotwhisker)
library(broom)
library(dplyr)

m1 <- lm(mpg ~ wt + cyl + disp + gear, data = mtcars)

m1
tidy(m1)

dwplot(m1)
dwplot(tidy(m1))

m1.df <-
    tidy(m1)

m1.df
m1.df$p.value <- 0
m1.df$statistic <- 0

dwplot(m1, style="distribution")

age <- '10-19'
age <- '50-59'
age <- '60-69'

ex1 <-
    data.frame(
        term=c('age (10-19)', 'rs12329760', 'rs75603675'),
        estimate=c(
            or.mean[age],
            rs12329760.ct,
            rs75603675.ac
        ),
        std.error=c(
            sqrt(or.sd[age]),
            3, 3)
    )
ex1

dwplot(ex1, style="distribution")


=begin
= Algebra::AlgebraicParser
((*(文字列の代数的評価クラス)*))

== ファイル名:
* ((|algebraic-parser.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

なし

== クラスメソッド:
--- Algebra::AlgebraicParser.eval(string, ring)
    ((|string|)) の四則演算式を ((|ring|)) 上で計算します。

== メソッド:

なし

== 仕様

=== 評価の手順

変数の値は、その変数名を引数として ((|ring|)) のクラスメソ
ッド ((|indeterminate|)) の引数として渡され、その戻り値
として評価されます。また数値は ((|ring.ground|)) のクラス
メソッド ((|indterminate|)) で評価されます。

      require "algebraic-parser"
      class A
        def self.indeterminate(str)
          case str
          when "x"; 7
          when "y"; 11
          end
        end
        def A.ground
          Integer
        end
      end
      p Algebraic::AlgebraicParser.eval("x * y - x^2 + x/8", A)
          #=> 7*11 - 7**2 + 7/8 = 28

ここで、Integer の indeterminate は algebraic-parser.rb が require
している algebra-supplement.rb で次のように定義されています。

        def Integer.indeterminate(x)
          eval(x)
        end

=== 識別子
識別子は、「英字1文字＋数字0文字以上」で定義されます。したがって

        "a13bc04def0"

は、

        "a13 * b * c04 * d * e * f0"

と解釈されます。

=== 演算子
演算子を結合の弱い順に並べます。

  ;       中間評価
  +, -    和, 差
  +, -    単項 +, 単項 -
  *, /    積, 商
  並置    積
  **, ^   冪

=== 用例
クラス ((|Algebra::Polynomial|))、クラス ((|Algebra::MPolynomial|)) には適
切に ((|indeterminate|)), ((|ground|))
が定義されています。したがって次のように文字列評価ができます。

      require "algebraic-parser"
      require "rational"
      require "m-polynomial"
      F = Algebra::MPolynomial(Rational)
      p Algebra::AlgebraicParser.eval("- (2*y)**3 + x", F) #=> -8y^3 + x

((|Algebra::MPolynomial|)) では、((|indeterminate|)) は変数を表現するオブジェ
クトの登録も行うので、登録順が変数間の順序になります。したがって ; を
使って先に変数を評価させる事によって、順序の変更をする事ができます。

      F.variables.clear
      p Algebra::AlgebraicParser.eval("x; y; - (2*y)**3 + x", F) #=> x - 8y^3

=end


#1 Data Collection and preparation
BANEScarparking <- read.csv("/Users/Austeja/Desktop/BANES_Historic_Car_Park_Occupancy.csv", header=TRUE)
BANEScarparking$Name[1:10] # takes the column called Name
BANEScarpark <- BANEScarparking
head(BANEScarpark,1) #view one line

# create a data frame with the columns we will be using
library(dplyr)
df <- select(BANEScarpark,Name,LastUpdate,Capacity,Status,Occupancy,Percentage,DateUploaded) %>%
mutate(LastUpdate = as.POSIXct(LastUpdate, format = "%d/%m/%Y %I:%M:%S %p")) %>%
mutate(DateUploaded = as.POSIXct(DateUploaded, format = "%d/%m/%Y %I:%M:%S %p"))
head(df,3) #view 3 lines

# (Explanation of the code)
#    pipe %>%  it will pass whatever you've just done to the direction of arrow
#    mutate(LastUpdate = ) will write over on top of LastUpdate
#    POSIXct is a data format in R - but look at strptime for all the abbreviations
#    mutate - changing data in some way (mutating)
#    turning text into date

# Explore data
summary(df$Name)
summary(df$Capacity)
summary(df$Status)
summary(df$Occupancy) # includes negative!
summary(df$Percentage)  #includes negative!
summary(df$DateUploaded)

# remove negative Occupancy
df <- subset( df, df$Occupancy > 0)
# remove negative Percentage
df <- subset( df, df$Percentage >0)
# also remove percentage over 100 to simplify the data
df <- subset( df, df$Percentage <101)

# clean occupancy - remove duplicates

#rename carparks for simplicity
df <- mutate(df, Name = recode(Name, "Avon Street CP" = "Avon",
                                       "Charlotte Street CP" = "Charlotte",
                                       "Lansdown P+R" = "Lansdown",
                                       "Newbridge P+R" = "Newbridge",
                                       "Odd Down P+R" = "OddDown",
                                       "Podium CP" = "Podium",
                                       "SouthGate General CP" = "SouthGate",
                                       "SouthGate Rail CP" = "SouthgateRail",
                                       "test car park" = "testcarpark"))

#modify the time from exact hours to morning/daytime/evening for simplicity
df <- mutate(df, Morning=(hour(LastUpdate)<=12),
             Midday =(hour(LastUpdate)>12 & hour(LastUpdate)<=15 ) ,
             Evening=(hour(LastUpdate)>15 & hour(LastUpdate)<=18),
             Night  =(hour(LastUpdate)>18),
             IsWeekend=(wday(LastUpdate)==7 | wday(LastUpdate)==1))

# Pick which carpark to work on
library(lubridate)
Avondf <- filter(df,Name == "Avon")  #Make a data frame only for Avon carpark
hist(Avondf$Percentage) #can see that this carpark is barely full
# try another carpark
SouthGatedf <- filter(df,Name == "SouthGate") #Make a data frame only for SouthGate carpark
hist(SouthGatedf$Percentage) #this carpark seems more interesting to work with
summary(SouthGatedf)

# Try some basic linear models for SouthGate carpark - but is linear modelling appropriate here?
linreg1<-lm( Percentage ~ wday(LastUpdate)+hour(LastUpdate), data=SouthGatedf) #?
summary(linreg1)
linreg2 <- lm(Percentage ~ IsWeekend + Morning + Midday + Evening + Night, data=SouthGatedf)  #?
summary(linreg2)

# Comment - But in the future when we will want to predict, we will need to
#           factors such as the time, day of week, weather, special events and holidays.
#           free carparking times

# Exploratory data analysis (EDA) - make plots to explore data
March16SG <- filter(SouthGatedf,month(DateUploaded)==3,year(DateUploaded)==2016) #lubridate pulled out month from DateUploaded
plot(Percentage ~ LastUpdate, data=March16SG) # plot for March 2016 SouthGate carpark

March4th16SG <- filter(SouthGatedf,month(DateUploaded)==3,year(DateUploaded)==2016, day(DateUploaded)==4)
weekdays(March4th16SG$LastUpdate) #shows it is a Friday
plot(Percentage~LastUpdate, data=March4th16SG, main="04/03/2016 Friday") #busy lunch time
m<-nls(Percentage~a*LastUpdate/(b+LastUpdate))  #not right
lines(LastUpdate,predict(m),lty=2,col="red",lwd=3)

March11th16SG <- filter(SouthGatedf,month(DateUploaded)==3,year(DateUploaded)==2016, day(DateUploaded)==11) #try another Friday
weekdays(March11th16SG$LastUpdate) #Friday
plot(Percentage~LastUpdate, data=March11th16SG, main="11/03/2016 Friday")  #busy lunch time and 8-9pm

March5th16SG <- filter(SouthGatedf,month(DateUploaded)==3,year(DateUploaded)==2016, day(DateUploaded)==5)
weekdays(March5th16SG$LastUpdate) #Saturday
plot(Percentage~LastUpdate, data=March5th16SG, main="05/03/2016 Saturday") #busy 10-5pm, 8-9pm and random

March6th16SG <- filter(SouthGatedf,month(DateUploaded)==3,year(DateUploaded)==2016, day(DateUploaded)==6)
weekdays(March6th16SG$LastUpdate) #Sunday
plot(Percentage~LastUpdate, data=March6th16SG, main="06/03/2016 Sunday")  #busy 12-3pm

Bathhalf16 <- filter(SouthGatedf,month(DateUploaded)==3,year(DateUploaded)==2016, day(DateUploaded)==13)
weekdays(Bathhalf16$LastUpdate) #Sunday
plot(Percentage~LastUpdate, data=Bathhalf16, main="13/03/2016 Sunday, Bath Half Marathon")
# Comments - It reached its maximum occupancy 32% by 12:14 noon. Reached 30% by 10:44am.
#            That could be when the marathon starts.
#            Further reading - http://bathhalf.co.uk/race-day/travel-information/

# More Linear Models
a1 <- lm(log(Percentage)~LastUpdate, data=March4th16SG) #try to linearise the model by transforming the data?
plot(log(Percentage)~LastUpdate, data=March4th16SG)
abline( lm(log(Percentage)~LastUpdate, data=March4th16SG) )  #not good enough

# ML
# Approach 1 (as in Google research paper)
# Predict carparking availability (not exact numbers!) using logistic regression
# Idea from a Google research paper https://research.googleblog.com/2017/02/using-machine-learning-to-predict.html
# Example - Percentage <30=easy, 30-60=less easy, 60-90=hard, 90>Limited availability
# Supervised learning to predict future occupancy percentage, hence regression algorithm.

# GLM -

glm1 <- glm(Percentage/100 ~ IsWeekend + Morning + Midday + Evening + Night,
            data=SouthGatedf, family = binomial)
summary(glm1)

# Approach 2
# Predict occupancy percentage using glm

# Approach 3
# Decision tree algorithms
# CART - classification and regression trees

# Approach 4
# Time series forcasting (after glm)
# https://www.analyticsvidhya.com/blog/2015/12/complete-tutorial-time-series-modeling/


###################################################################################
# R-script submitted as Supplementary Information to Seebens et al. (2016) No
# saturation in the accumulation of alien species worldwide. Nature Communications ....
#
# The script reproduces the modelling results shown in Fig. 5 of the article.
#
# 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
# increased exponentially during the simulation to account for increases in
# propagule and colonisation pressures due to e.g. increases of trade volumes.
# For further details, consult the article.
#
# The code is free of use as long as the article is properly cited.
#
# Author of code: Hanno Seebens, Frankfurt, Germany
# 25. August, 2016
###################################################################################

graphics.off() # close windows
rm(list=ls()) # clear R environment

options(scipen=5)

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

t_max <- 50000 # max simulation time
res <- 1/100 # resolution of time steps
n_steps <- t_max*1/res # total simulation time steps

n_bins <- 100 # n_spec/bins = number of bins

n_spec <- 10^seq(2,5,0.5) # species number for different model scenarios

## define temporal variation of propagule pressure ###################
m <- rev(exp(-0.7*seq(0,10,length.out=n_steps))) # exponential increase
m <- m-min(m) # normalise
m <- m/max(m) # normalise

## define x-axis for plotting
timeaxis <- seq(1,t_max,length.out=n_steps) # for plotting

## define object to store temporal dynamics of species accumulation on island:
## an empty matrix (rows: time steps, columns: different scenarios)
island <- matrix(0,nr=n_steps,nc=length(n_spec)+1)
island[,1] <- 1:(n_steps)

## define object to store the shape of the communities
all_pop <- matrix(0,nr=n_bins,nc=length(n_spec))

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

out_list <- list() # output file
x <- 0 # counter
for (i in 1:length(n_spec)){ # loop through all scenarios consisting of different community sizes
  x <- x + 1 # increase counter

  ## define mainland community from a log-normal distribution
  specabund <- dlnorm((seq(0.1,2,length.out=n_bins)),meanlog=-1,sdlog=1)*100000000
  axis1 <- seq(10,1000,length.out=n_bins) # for plotting
  specabund <- ceiling(specabund) # round values to avoid decimals
  specabund <- round(specabund/sum(specabund)*n_spec[i]) # rescale numbers

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

  #### simulation ############################################################################
  for (t in 1:n_steps){ # 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
      island[t,x+1] <- spec # store species entry at time t and scenario x
    }
  }

  ## consider an Allee effect ###############################################################
  ## A species is only considered to be able to establish a population on the island
  ## if certain number of individuals (defined in variable 'allee') exists simultaneously
  ## during a time window of size 'window'. That is, a species is considered as established on the
  ## island if the number of individuals of that species living simultaneously on the island
  ## within the time window 'window' exceeds the Allee threshold 'allee'.

  data <- as.integer(island[,x+1]) # time series of species accumulation without the consideration of an Allee effect
  window <- 100000 # time window for the calculation of total population size
  step <- 1 # time step for the assessments of Allee effects (each time)
  allee <- 10 # minimum population for an established population, Allee threshold

  total <- length(data) # length of data set
  spots <- seq(from=1, to=(total-window), by=step) # starting values of the time windows
  out <- matrix(NA,nc=1,nr=tot_spec) # results file

  isl_spec <- 0
  for(j in which(data[1:(length(data)-window)]!=0)){ # loop through time series and check moving time windows

    dat <- data[spots[j]:(spots[j]+window)] # extract individuals of all species during the respective time window
    tab <- tabulate(dat[dat!=0]) # calculate population sizes for all species
    abund_spec <- which(tab>allee) # check if population sizes exceed Allee threshold

    new_spec <- abund_spec[!abund_spec%in%isl_spec] # select species, which populations exceed the Allee threshold
    out[new_spec] <- j # store the date, when species was recognised to have an established population on the island
    isl_spec <- (c(isl_spec,new_spec)) # store all species on the island
    if (length(isl_spec)==tot_spec) break # break if all species reached the island
  }
  out_list[[x]] <- out # store result
  ######################################################################################

  ## process time series without Allee effect
  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)
  island[,x+1] <- cumsum(island[,x+1]) # calculate accumulation of species numbers on the island
}
out_ls <- lapply(out_list,function(s) sort(s,na.last=T)) # sort time when species exceeded the Allee threshold (for plotting)

### PLOT results (Fig. 5 in the main text) ###############################################################################################

x11(width=3.5,height=6) # define size of plot window
layout(matrix(c(1:3),nr=3)) # define layout of plot
op <- par(oma=c(0,3.5,0,1),mar=c(3,2,0.5,0.5),las=1,cex=0.9,mgp=c(2.5,0.35,0),tck=-0.02,xaxs="i",yaxs="i") # some additional options

## panel a: plot communities on mainland, one for each model scenario ##################################
matplot(axis1,all_pop,type="p",log="yx",pch=1,cex=0.7,col=rainbow(length(n_spec),start=0,end=4/6),lty=1,ylab="Species",xlab="",xaxt="n",yaxt="n")
axis(1,at=10^seq(0,4,1))
axis(1,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
axis(2,at=10^seq(0,5,1),las=1)
axis(2,at=(1:10*rep(10^seq(0,5,1)/10,each=10)),labels=F,tcl=-0.3)
mtext("Individuals per species",side=1,line=1.5)
mtext("a",side=3,adj=-0.45,line=-0.5,font=2)
mtext("Species",side=2,line=2.5,cex=0.9,las=0)
mtext("Mainland",side=2,las=0,cex=1,font=2,line=4)

## panel b: plot temporal development of propagule pressure (exponential increase) #####################
plot(timeaxis[seq(1,n_steps,length.out=200)],m[seq(1,n_steps,length.out=200)],xlim=c(0,t_max),ylim=c(0,1),xlab="",ylab="Rate of introduction",type="l")
mtext("Simulation time",side=1,line=2)
mtext("b",side=3,adj=-0.45,line=-0.5,font=2)
mtext("Probability",side=2,line=2.5,cex=0.9,las=0)
mtext("Translocation",side=2,las=0,cex=1,font=2,line=4)

## panel c: plot temporal development of species accumulation on island ################################
## without Allee effect
matplot(seq(1,t_max,length.out=200),island[seq(1,n_steps,length.out=200),(1:length(n_spec))+1],yaxt="n",type="l",xlim=c(0,t_max),ylim=c(1,100000),log="y",col=rainbow(length(n_spec),start=0,end=4/6),lty=1,xlab="",ylab="Species")
mtext("Simulation time",side=1,line=2)
axis(2,at=10^seq(0,5,1),las=1)
axis(2,at=(1:10*rep(10^seq(0,5,1)/10,each=10)),labels=F,tcl=-0.3)

## with Allee effect
for (i in 1:length(out_ls)){
  lines(out_ls[[i]]*res,1:length(out_ls[[i]]),lty=2,col=rainbow(length(n_spec),start=0,end=4/6)[i])
}
mtext("c",side=3,adj=-0.45,line=-0.5,font=2)
mtext("Species",side=2,line=2.5,cex=0.9,las=0)
mtext("Island",side=2,las=0,cex=1,font=2,line=4)

par(op)

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


\docType{data}
\name{elmaslar}
\alias{elmaslar}
\title{50 bin adetten fazla yuvarlak kesim elmasın fiyatları}
\format{53.940 gözlem ve 10 değişkenden oluşan bir data.frame
\describe{
\item{karat}{Elmasın ağırlığı (0,2-5,01 ct)}
\item{kesim}{Kesim kalitesi (Vasat, İyi, Çok iyi, Birinci sınıf, İdeal)}
\item{renk}{Elmas rengi, D'den (en iyi) J'ye (en kötü)}
\item{berraklık}{Elmasın berraklık ölçüsü (I1 (en kötü), SI1, SI2, VS1, VS2, VVS1, VVS2, IF (en iyi))}
\item{derinlik}{Toplam derinlik yüzdesi = z / mean(x, y) = 2 * z / (x + y) (43-79)}
\item{yüzey}{Elmasın düz üst yüzeyinin genişliği (43-95 mm)}
\item{fiyat}{Amerikan doları cinsinden fiyat (326$-18.823$)}
\item{x}{Uzunluk (mm)}
\item{y}{Genişlik (mm)}
\item{z}{Derinlik (mm)}
}}
\usage{elmaslar}
\description{Neredeyse 54 bin elmasın fiyatlarını ve diğer özelliklerini içeren bir veri kümesi.}
\seealso{\code{\link[ggplot2]{diamonds}}}
\keyword{datasets}


#testing for observation uncertainty at the site level for fungal functional groups.
rm(list=ls())
source('paths.r')
source('NEFI_functions/tic_toc.r')
library(doParallel)
library(DirichletReg)

#set output path.----
output.path <- HARV_sampling_effort_analysis.path

#detect and register cores.----
n.cores <- detectCores()
registerDoParallel(cores=n.cores)

#load data - focus on Harvard Forest (HARV) - 50 unique soil cores.----
dat <- readRDS(NEON_ITS_fastq_taxa_fg.path)
dat <- dat$abundances
dat$site <- substr(dat$geneticSampleID, 1, 4)
all.dat <- dat
sites <- unique(dat$site)
dat <- dat[dat$site == 'HARV',]
dat <- dat[,c('other','Ectomycorrhizal','Arbuscular','Saprotroph','Pathogen')]
dat <- (dat + 1)
dat <- dat/rowSums(dat)

#sampling depths and number of trials.
potential.n.samp <- c(3,5,6, 8, 10, 15, 20, 30, 40, 50)
n.trial <- 1000

#run simulation.----
cat(paste0('Running bootstrap simulation for ',n.trial,' iterations across ',length(sites),' sites...\n'))
tic()
super.super.out <- list()
for(k in 1:length(sites)){
  dat <- all.dat[all.dat$site == sites[k],]
  dat <- dat[,c('other','Ectomycorrhizal','Arbuscular','Saprotroph','Pathogen')]
  dat <- (dat + 1)
  dat <- dat/rowSums(dat)
  n.samp <- potential.n.samp[potential.n.samp <= nrow(dat)]
  super.out <-
    foreach(j = 1:n.trial) %dopar% {
      output <- list()
      for(i in 1:length(n.samp)){
        #sample your dataset.
        sample <- data.frame(dat[sample(nrow(dat), size = n.samp[i], replace = F),])
        sample$Y <- DR_data(sample[,1:ncol(sample)])
        #fit dirichlet interecept.
        mod <- DirichReg(Y ~ 1, data = sample)
        mult <- sum(mod$fitted.values$alpha[1,])
        output[[i]] <- mult
      }
      output <- unlist(output)
      return(output)
    }
  super.out <- do.call(rbind, super.out)
  colnames(super.out) <- n.samp
  #expand super.out into 2 column- y and n.samp.
  y <- as.vector(super.out)
  lab <- list()
  for(i in 1:length(n.samp)){
    lab[[i]] <- rep(n.samp[i],n.trial)
  }
  lab <- unlist(lab)
  super.out2 <- data.frame(y, lab)
  colnames(super.out2) <- c('mu','n.samp')
  super.super.out[[k]] <- super.out2
  cat(paste0(k,' of ',length(sites),' sites fitted.\n'))
}
names(super.super.out) <- sites
cat('Simulation complete.');toc()

#Save output for downstream analysis.----
saveRDS(super.super.out, output.path)


# spare linear regression using stan
library(distbayesianmc)
if(F){
  ssplits <- 4

  iter <- 10
  scale <- 1
  fileName <- "./stan_files/sparse_linear_reg_laplace.stan"
  stan_code <- readChar(fileName, file.info(fileName)$size)
  mod <- stan_model(model_code = stan_code, auto_write = T, verbose=T)

  dataset <- "sparse_reg_2"
  dataset_loaded <- f_dataset_loader(dataset, nobs=4000, highcorr = T)
  splitted_data <- f_pack_split_data(dataset_loaded$X, dataset_loaded$y, P=2, ssplits=ssplits, iseed=iter, typesplit="random")
  splitted_data <- f_prep_prior_logistic(splitted_data, scale = scale)

  res <-  f_stan_sampling_splitted_data(mod, splitted_data, dataset = dataset, i_seed = iter, iter = iter, typesplit = "random", typeprior = "laplace_normal", nchain=4000)
  f_plot_grid_params_dens(res, dataset_loaded$betastar)

  # check that the normalising constant is correct
  res$normconstcombined
  index_vars <-  3
  betaval <- res$mat_means[index_vars,]
  cov_diag <- diag(res$mat_cov[,,1])
  n_prop <- 10**5
  var_factor <- 2

  log_laplace_prior <- function(betaval, ssplits){
    pparams <- length(betaval)
    res_lik <- sum(dlaplace(betaval[1:(pparams-2)], m = 0, s = scale*ssplits, log = T)) + dnorm(x = betaval[(pparams-1)], mean = 0, sd = (scale*ssplits)**0.5, log = T) +
    dnorm(x = betaval[(pparams)], mean = 0, sd = (scale*ssplits)**0.5, log = T)
    return(res_lik)
  }
  log_lik_sparse <- function(betaval, dataset_loaded){
    pparams <- length(betaval)
    mat_prod <- dataset_loaded$X %*% betaval[1:(pparams-2)]
    y <- dataset_loaded$y
    res_lik <- sum(dnorm(x = (y-mat_prod), mean =  betaval[(pparams-1)], sd = exp(betaval[(pparams)])**0.5, log = T))
    return(res_lik)
  }
  log_posterior <- function(betaval, dataset_loaded, ssplits) log_laplace_prior(betaval, ssplits)+log_lik_sparse(betaval, dataset_loaded)
  #log_posterior(betaval, splitted_data[[index_vars]])
  proposal_samples <- rmvnorm(n = n_prop, mean = betaval, sigma = var_factor*res$mat_cov[,,index_vars])
  log_prop_weights <- dmvnorm(proposal_samples, mean = betaval, sigma = var_factor*res$mat_cov[,,index_vars], log = T)
  log_post_weights <- sapply(1:n_prop, FUN = function(i) log_posterior(proposal_samples[i,], splitted_data[[index_vars]], ssplits))
  log_sum_exp(log_post_weights-log_prop_weights)-log(n_prop)
  res$vec_logsubpost
}

if(T){
  setwd("~/R_programming/distbayesianmc")
  source("~/R_programming/distbayesianmc/params_simulation/params_sparse.R")
  stan_code <- readChar(fileName, file.info(fileName)$size)

  mod <- rstan::stan_model(model_code = stan_code, auto_write = T)
  setwd("/scratch/alexander/distbayesianmc_sparselinear/")
  library(doParallel)
  registerDoParallel(cores=6)
  for(dataset in vec_datasets){
    for(ssplits in vec_splits){
      foreach(i_iter = 1:iters) %dopar% {
        #for(i_iter in 1:20){

        dataset_loaded <- f_dataset_loader(dataset, highcorr = highcorr, nobs = nobs)
        splitted_data <- f_pack_split_data(dataset_loaded$X, dataset_loaded$y, Pparams = Pparams, ssplits=ssplits, iseed=i_iter, typesplit=typesplit)
        splitted_data <- f_prep_prior_logistic(splitted_data, scale = scale)
        f_stan_sampling_splitted_data(mod, splitted_data, dataset = dataset, i_seed = i_iter, iter = i_iter, typesplit = typesplit, nchain = nchain, typeprior=typeprior)

      }
    }
  }
}

df <- f_combine_const_data_in_frame(vec_splits, vec_datasets, vec_types_splits, 10)
#f_plot_res_data_frame(df)
f_plot_res_data_frame(df, vec_datasets = vec_datasets)
save(df, file="res_sparselinear_ultrasmall.Rda")

if(F){
  df_reduced <- df %>% select(c(normconstcombined, iter, splits, dataset))

  true_mean <- df_reduced %>% filter(splits == 1)  %>% group_by(splits, dataset) %>% summarise(true_mean = mean(normconstcombined))
  sd_one_split <- df_reduced %>% filter(splits == 1)  %>% group_by(splits, dataset) %>% summarise(std = var(normconstcombined)**0.5)

  df_reduced <- df_reduced %>% mutate(true_mean = ifelse(dataset ==  vec_datasets[1], (true_mean %>% filter(dataset ==  vec_datasets[1]))$true_mean,
                                                         ifelse(dataset ==  vec_datasets[2], (true_mean %>% filter(dataset ==  vec_datasets[2]))$true_mean, NA)))

  df_reduced <- df_reduced %>% mutate(sqerror = (true_mean-normconstcombined)**2)

  df_true_means <- df_reduced %>% group_by(splits, dataset) %>% summarise(true_mean_all = mean(true_mean))

  average_error <- df_reduced %>% group_by(splits, dataset) %>% summarise(MSE = mean(sqerror), VAR = var(normconstcombined))  %>% mutate(srerror = round(MSE**0.5, 3))

  average_error[['percenterror']] <- round((average_error$srerror/df_true_means$true_mean_all*100), 4)

  average_error[["bias_var_ratio"]] <- round(average_error$MSE/average_error$VAR-1, 2)

  write.table(t(as.matrix(
    average_error %>% filter(dataset == vec_datasets[1]) %>% select(splits, srerror, percenterror, bias_var_ratio)
  )), "table1.txt", quote=FALSE, eol="\\\\\n", sep=" & ")

  write.table(t(as.matrix(
    average_error %>% filter(dataset == vec_datasets[2]) %>% select(splits, srerror, percenterror, bias_var_ratio)
  )), "table2.txt", quote=FALSE, eol="\\\\\n", sep=" & ")

}


#Thanaphon Sukkasem 63130500048
#Library
library('dplyr','readr','ggplot2')

#Dataset
cs_book <- read.csv("https://raw.githubusercontent.com/safesit23/INT214-Statistics/main/datasets/prog_book.csv")

# Explore the dataset
cs_book %>% glimpse()
cs_book %>% summary()

is.na(cs_book) %>% table()

# Learning function from Tidyverse & Transform data with dplyr and finding insight the data

#1.
top_type <- cs_book %>%
  select(Type, Rating) %>%
  group_by(Type) %>%
  summarise(mean_rating = mean(Rating)) %>%
  arrange(desc(mean_rating))

#2.
price_paperback <- cs_book %>%
  filter(Type == 'Paperback') %>%
  select(Price) %>%
  summary()

price_paperback

#3.
book_totalPercent <- cs_book  %>%
  select(Type) %>%
  group_by(Type) %>%
  summarise(pct = n()) %>%
  mutate(pct = formattable::percent(pct/sum(pct)))
book_totalPercent

#4.
price_minmax <- cs_book %>%
  select(Type,Price) %>%
  group_by(Type) %>%
  summarise(minPrice = min(Price), maxPrice = max(Price))
price_minmax

#5.
topRating_price <- cs_book %>%
  select(Book_title,Rating,Price) %>%
  arrange(desc(Rating)) %>%
  head(n=10)
topRating_price

#6.
book_pageless200 <- cs_book %>%
  filter(Number_Of_Pages < 200) %>%
  summarize(num_books = n())
book_pageless200

# Visualization with GGplot2

pricePerType_boxplot <-  ggplot(cs_book, aes(x=Type, y=Price, fill=Type)) + geom_boxplot()
pricePerType_boxplot

countbyPrice_areaplot <- ggplot(cs_book,aes(x=Price)) +  geom_area(stat = "bin",color = "#e76f51", fill="#ffd7ba", size = 1.5) + geom_vline(aes(xintercept=mean(Price)),color="#ee9b00", linetype="dashed", size=2, alpha = 0.6)
countbyPrice_areaplot


#' Triadic Edges
#'
#' Identifies which edges in a network are part of a triad.
#'
#' @param g An igraph graph
#' @export
#' @examples
#' get.edge.network(g)

triadic.edges <- function(g) {
  all.triads <- graph.get.subisomorphisms.vf2(g, graph.ring(3))
  convert.nl.to.el <- function(x) {
    matrix(c(x[1], x[2], x[1], x[3], x[2], x[3]), nrow=3, byrow=T)
  }
  triad.edges <- do.call('rbind', lapply(all.triads, 'convert.nl.to.el'))
  triad.edges <- unique(paste(triad.edges[,1],triad.edges[,2],sep="-"))
  g.el <- get.edgelist(g, names=F)
  g.el <- paste(g.el[,1],g.el[,2],sep="-")
  is.triadic <- g.el %in% triad.edges
  return(is.triadic)
}


## saves output to current folder

args<-commandArgs(TRUE)

filename<-args[1]
nSD<-as.numeric(args[2])

impute<-read.table(filename)

pcMu<-colMeans(impute[,-c(1:2)])
pcSigma<-apply(impute[,-c(1:2)], 2, sd)

pdf("ScatterplotPCs.pdf", width = 12, height = 4)
par(mfrow = c(1,3))
par(mar = c(4,4,1,1))
plot(impute[,3],impute[,4], pch= 16, xlab = "PC1", ylab = "PC2")
abline(v = pcMu[1]+nSD*pcSigma[1], lty = 2)
abline(v = pcMu[1]-nSD*pcSigma[1], lty = 2)
abline(h = pcMu[2]+nSD*pcSigma[2], lty = 2)
abline(h = pcMu[2]-nSD*pcSigma[2], lty = 2)

plot(impute[,5],impute[,6], pch= 16, xlab = "PC3", ylab = "PC4")
abline(v = pcMu[3]+nSD*pcSigma[3], lty = 2)
abline(v = pcMu[3]-nSD*pcSigma[3], lty = 2)
abline(h = pcMu[4]+nSD*pcSigma[4], lty = 2)
abline(h = pcMu[4]-nSD*pcSigma[4], lty = 2)

plot(impute[,7],impute[,8], pch= 16, xlab = "PC5", ylab = "PC6")
abline(v = pcMu[5]+nSD*pcSigma[5], lty = 2)
abline(v = pcMu[5]-nSD*pcSigma[5], lty = 2)
abline(h = pcMu[6]+nSD*pcSigma[6], lty = 2)
abline(h = pcMu[6]-nSD*pcSigma[6], lty = 2)
dev.off()

## write list of outliers
outliers<-NULL
for(i in 3:22){
  index<-which(impute[,i] > pcMu[i-2]+nSD*pcSigma[i-2] | impute[,i] < pcMu[i-2]-nSD*pcSigma[i-2])
  if(length(index) > 0){
   outliers<-rbind(outliers, cbind(impute[index,1:2], paste("Outlier PC", (i-2), sep = "")))
  }
}

write.table(outliers, paste("OutliersFromPC_",nSD,"SDfromMean.txt", sep = ""), quote = FALSE, sep = " ")


#Read in data from file
dfr <- read.delim("readings.txt")
#Calculate daily means
flags <- as.matrix(dfr[,seq(3,49,2)])>0
vals <- as.matrix(dfr[,seq(2,49,2)])
daily.means <- rowSums(ifelse(flags, vals, 0))/rowSums(flags)
#Calculate time between good measurements
times <- strptime(dfr[1,1], "%Y-%m-%d", tz="GMT") + 3600*seq(1,24*nrow(dfr),1)
hours.between.good.measurements <- diff(times[t(flags)])/3600


 ZTPCON Example Program Results

 Estimate of condition number =  3.74E+01


# ----------------------------------------
#  App Title: Chaos Game -- 2 Dimensions
#     Author: Jimmy Doi
# ----------------------------------------

if (!require("shiny")) install.packages("shiny")
if (!require("shinyBS")) install.packages("shinyBS")

library(shiny)
library(shinyBS)

shinyUI(fluidPage(

   tags$head(tags$link(rel = "icon", type = "image/x-icon", href =
   "https://webresource.its.calpoly.edu/cpwebtemplate/5.0.1/common/images_html/favicon.ico")),

   tags$head(
     tags$style(HTML("hr {border-top: 1px solid #000000;}"))
   ),

     tags$title("Chaos Game -- 2 Dimensions"),
  h3("Chaos Game: Two Dimensions"),

  div("Note: Please adjust width of browser if only one column is visible.",br(),
  span(HTML("[Click here for another Shiny app on the Chaos Game]")),
    style = "font-size: 9pt;color:teal"),br(),

  p("In the two dimensional version of the ", HTML("Chaos Game"),
    "we start with a regular polygon and mark selected
    points which will typically be the vertices. These points will be called",
    tags$i("endpoints"), "and will be marked in red. The game begins by randomly choosing a
    starting point and one of the endpoints.
    Mark a new point at a fixed distance ratio from the starting point to the endpoint (e.g.,
    halfway to the endpoint). Select another endpoint at random and,
    with the most recently created point, repeat the process to generate the next point
    and continue. By applying the right distance ratio the resulting set of points can converge
    to a beautiful image known as a", HTML("fractal"),". For each polygon the required
    distance ratio to yield a fractal will be provided,
    but try different settings to see what other patterns may arise!"
    ),
  br(),

  fluidRow(
    column(4,
    wellPanel(

    selectizeInput('shape', h5(tags$b('Shape')), choices = list(
    "Two Dimensions" = c(`Triangle` = 'tri',
                     `Square` = 'sqr',
                     `Pentagon` = 'pent',
                     'Hexagon' = 'hex')
    ), selected = 'tri'),
    #hr(),

    conditionalPanel(
      condition = "input.shape=='tri'",
        sliderInput("dist.tri",
                    label = h5(tags$b("Distance ratio to endpoint:")),
                    min = 0.01, max = .99, value = .50, step=.01),
      div("For", tags$b("Triangle"), "default value is 0.50",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),

    conditionalPanel(
      condition = "input.shape=='sqr'",
        sliderInput("dist.sqr",
                    label = h5(tags$b("Distance ratio to endpoint:")),
                    min = 0.01, max = .99, value = .67, step=.01),
      div("For", tags$b("Square"), "default value is 0.67 (2/3)",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),

    conditionalPanel(
      condition = "input.shape=='pent'",
        sliderInput("dist.pent",
                    label = h5(tags$b("Distance ratio to endpoint:")),
                    min = 0.01, max = .99, value = .63, step=.01),
      div("For", tags$b("Pentagon"), "default value is 0.63 (5/8)",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),

    conditionalPanel(
      condition = "input.shape=='hex'",
        sliderInput("dist.hex",
                    label = h5(tags$b("Distance ratio to endpoint:")),
                    min = 0.01, max = .99, value = .67, step=.01),
      div("For", tags$b("Hexagon"), "default value is 0.67 (2/3)",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),

    conditionalPanel(
      condition = "input.shape=='tetra'",
        sliderInput("dist.tetra",
                    label = h5(tags$b("Distance ratio to endpoint:")),
                    min = 0.01, max = .99, value = .5, step=.01),
      div("For", tags$b("Tetrahedron"), "default value is 0.50",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),

    conditionalPanel(
      condition = "input.shape=='cube'",
        sliderInput("dist.cube",
                    label = h5(tags$b("Distance ratio to endpoint:")),
                    min = 0.01, max = .99, value = .33, step=.01),
      div("For", tags$b("Cube"), "default value is 0.33",
          style = "font-size: 9.5pt;color:teal",align="left")
      ),

    conditionalPanel(
      condition = "input.shape=='dodec'",
        sliderInput("dist.dodec",
                    label = h5(tags$b("Distance ratio to endpoint:")),
                    min = 0.01, max = .99, value = .38, step=.01),
      div("For", tags$b("Dodecahedron"), "default value is 0.38",
          style = "font-size: 9.5pt;color:teal",align="left")
      ) # NO COMMA AFTER RIGHT PARENT OF LAST CONDITIONALPANEL

    ,
    #hr(),
    br(),

    conditionalPanel(condition="input.tabselected==1",
                            div(uiOutput("my.init")),
                            div("Press the",
                                span(HTML("&#9654"),style=
                                       "font-size:10pt;color:#999999;"), "button above to animate.",br(),
                                span("Advance slider manually at anytime."),br(),
                                span("Click",tags$b("Randomize"),"to re-randomize at current n."),
                                align="center",style="font-size:8.5pt;color:teal")
    ),

    conditionalPanel(condition="input.tabselected==2",
                     div(uiOutput("my.extend")),
                     div("Press the",
                         span(HTML("&#9654"),style=
                                "font-size:10pt;color:#999999;"), "button above to animate.",br(),
                         span("Advance slider manually at anytime."),br(),
                         span("Click",tags$b("Randomize"),"to re-randomize at current n."),
                         align="center",style="font-size:8.5pt;color:teal")
    ),

    conditionalPanel(condition="input.tabselected==3",
                     div(uiOutput("my.pts")),
                     div("Press the",
                         span(HTML("&#9654"),style=
                                "font-size:10pt;color:#999999;"), "button above to animate.",br(),
                         span("Advance slider manually at anytime."),br(),
                         span("Click",tags$b("Randomize"),"to re-randomize at current n."),
                         align="center",style="font-size:8.5pt;color:teal")
    ),

    #hr(),
    br(),

#         div(bsActionButton("gen", label="Randomize"),align="right"),
        div(bsButton("gen", label="Randomize"),align="right"),
        div("Click", tags$b("Randomize")," to re-randomize outcomes based on current settings.",
            style = "font-size: 9.5pt;color:teal",align="right"),

        br(),

        div("Shiny app by",
            a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
              "Jimmy Doi"),align="right", style = "font-size: 8pt"),

        div("Base R code by",
            a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
              "Jimmy Doi"),align="right", style = "font-size: 8pt"),

        div("Shiny source files:",
            a(href="https://gist.github.com/calpolystat/d40a02fa87508ac5ac4b",
              target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

        div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
              "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")

    ) #sidebarPanel
    ), #column-4

    # Show a tabset that includes a plot, summary, and table view
    # of the generated distribution
    column(8,
      tabsetPanel(type = "tabs",id = "tabselected",
##############
# tabPanel 1 #
##############
        tabPanel("Initial Sequence",value=1,
          fluidRow(
            column(12,
                   div(
                   div(
                 plotOutput("initPlot"),style="width:500px",inline="TRUE"),align="center"),
             HTML("
")
            ), # column-12
            fluidRow(
              column(10, offset=1,
              p("
                This plot shows a step-by-step progression of the chaos game.
                At each step the randomly chosen red endpoint will be marked.
                Use the 'Number of points' slider and press the",
                span(HTML("&#9654"),style=
                         "font-size:10pt;color:#999999;"),"button to animate the plot.
                Advance the slider to n=100 before moving to the 'Extended Sequence' tab.",
                style="color:#0066CC"
                )
              ) # column-10
            ) # fluidRow
        ) # fluidRow
      ), # tabPanel

##############
# tabPanel 2 #
##############
        tabPanel("Extended Sequence",value=2,
          fluidRow(
            column(12,
                   div(
                   div(
                 plotOutput("extendPlot"),style="width:500px",inline="TRUE"),align="center"),
              HTML("
")
            ), # column-12
            fluidRow(
              column(10, offset=1,
                     p("
                Compare the plot above when n=100 to the plot when n=100 from the
                'Initial Sequence' tab",HTML("–"), "they should be identical. This shows the plot
                given above is simply a continuation of the chaos game.
                Advance the 'Number of points' slider to n=1000 before moving to the 'Complete Sequence' tab.",
                style="color:#0066CC"
                )
              ) # column-10
            ) # fluidRow
        ) # fluidRow
      ), # tabPanel

##############
# tabPanel 3 #
##############
        tabPanel("Complete Sequence",value=3,
          fluidRow(
            column(12,
                   div(
                   div(
                 plotOutput("compPlot"),style="width:500px",inline="TRUE"),align="center"),
             HTML("
")

                 ), # column-12
              fluidRow(
                column(10, offset=1,
                       p("
                Compare the plot above when n=1000 to the plot when n=1000 from the
                'Extended Sequence' tab",HTML("–"), "they should be identical.
                This again shows the plot
                given above is a continuation of the chaos game. Smaller plotting points are used
                to reveal the finer details of the completed plot.",
                style="color:#0066CC"
                )
                ) # column-10
              ) #fluidRow
          ) #fluidRow
        )  # close tabPanel-Complete
      )# tabsetPanel
    )# column-8
  ) # fluidRow
 )# fluidPage
)# shinyUI


  fecundity.allometric = function( cw, method="st.marie" ) {

    if (method == "st.marie") {
      # this is from Saint-Marie(1993, unpublished) ... look for a more recent summary
      # est = cw ^2.725 * 10^0.7311
    }
    if (method == "moncton.primiparous" ) {
      est = cw^2.94 * 10^(-0.7229)  # R^2 = 0.88
    }
    if (method == "moncton.multiparous" ) {
      est = cw^2.5811 * 10^0.0158   ## R^2 = 0.607
    }
    return( est )
  }


#---------------------------------------------------------------------
# cep  --  Cepstrally Smoothed Spectrum
#
# Calculates a cepstrally smoothed spectrum for the input signal 's'
# with at most 'b' real cepstrum coefficients retained and all others
# set to zero.
#
# This function assumes that the input is even length and returns
# N/2 + 1 points.
#--------------------------------------------------------------------
#
cep <- function(s, b=32)
{
  t <- fft(10*log10(abs(fft(s)) + 1 ))
  t[b:(length(s)-b)] = 0
  return(abs(fft(t,inverse=T))[1:(length(s)/2)]/length(s))
}


library(car)
#####Q1
# import of dataset
setwd("C:/Users/nan66/documents/msu/stt864/LAB1")
MSID<-read.table(file="MicroarraysampleIDs.txt")
SNPID<-read.table(file="SNPsampleIDs.txt")
CXM<-read.table(file="ChromoXmicroarray.txt",head=T)
CXSNP<-read.table(file="ChromoXsnp.txt",head=T)

# Q2
# CSF2RA
CSF2RA<-CXM[which(CXM$IDENTIFIER=="CSF2RA")[1],]
CSF2RAdata<-CSF2RA[,c(3:49)]
CSF2RAdata
ordered.CSF2RAdata<-CSF2RAdata[,order(colnames(CSF2RAdata))]
colnames(ordered.CSF2RAdata)<-MSID[,2]

group<-c(rep(1,27),rep(2,20))
ttests<-function(x,group)
{
x<-as.numeric(x)
pvalue<-t.test(x ~ group)$p.value;
return(pvalue)
}
pvalues_CFS2RA<-ttests(CSF2RA[,c(3:49)],group)
pvalues_CFS2RA

#Q3 Q4 Q5
# the nearest Q
nearestSNPs<-CXSNP[c(1:2),]
which(CXM$IDENTIFIER=="CSF2RA")
SNPsX<-CXSNP[1,c(1:78)]
SNPsX
colnames(SNPsX)<-SNPID[,2]
nomissingSNPs<-SNPsX[,SNPsX!="4"]
finalSNPs<-nomissingSNPs[,colnames(nomissingSNPs)%in%colnames(ordered.CSF2RAdata)]
finalMicroarray<-ordered.CSF2RAdata[,colnames(ordered.CSF2RAdata)%in%colnames(nomissingSNPs)]
finalSNPs0<-finalSNPs[,order(colnames(finalSNPs))]
finalMicroarray0<-finalMicroarray[,order(colnames(finalMicroarray))]
finaldataX<-rbind(finalMicroarray0,finalSNPs0)
#the neatest two SNPs
nearest2SNPs<-CXSNP[c(1:2),]
SNPs2X<-CXSNP[c(1:2),c(1:78)]
SNPs2X
colnames(SNPs2X)<-SNPID[,2]
nomissingSNPs2X<-SNPs2X[,(SNPs2X[1,]!="4")&(SNPs2X[2,]!="4")]
finalSNPs2X<-nomissingSNPs2X[,colnames(nomissingSNPs2X)%in%colnames(ordered.CSF2RAdata)]
finalMicroarray2X<-ordered.CSF2RAdata[,colnames(ordered.CSF2RAdata)%in%colnames(nomissingSNPs2X)]
finalSNPs02X<-finalSNPs2X[,order(colnames(finalSNPs2X))]
finalMicroarray02X<-finalMicroarray2X[,order(colnames(finalMicroarray2X))]
finaldata2X<-rbind(finalMicroarray02X,finalSNPs02X)

# summary statistics????
summary(finaldata2X)

#Q7
hist(as.matrix(CSF2RA[,c(4:49)]),main="histgram of CSF2RA")
#Q8
MA<-as.numeric(finalMicroarray02X[1,])
snp1<-as.numeric(finalSNPs02X[1,])
snp2<-as.numeric(finalSNPs02X[2,])
scatterplot(snp1~MA)
scatterplot(snp2~MA)
boxplot(MA~snp1)
boxplot(MA~snp2)

#Q9
# MIC

# Q11
# Two-way ANOVA models
snp1.factor<-as.factor(snp1)
snp2.factor<-as.factor(snp2)
y<-MA
lm2anova<-lm(y~snp1.factor*snp2.factor)
lm2anova
summary(lm2anova)
anova(lm2anova)
#QQnorm & interaction plot
qqnorm(lm2anova$res)
interaction.plot(snp1.factor,snp2.factor,y)

# Q12

x0<-as.numeric(finalSNPs0)-1
y0<-as.numeric(finalMicroarray0)

## Check residuals
predy<-Xmat%*%solve(t(Xmat)%*%Xmat)%*%t(Xmat)%*%y0
epsilonhat<-y0-predy
plot(predy, epsilonhat)

# Confidence interval for b1-b2 or hypothesis testing for
# H0: b1=b2 vs H1: b1\neq b2

xvec4AA<-c(1,1,0)
xvec4aa<-c(1,0,-1)
xvec4Aa<-c(1,1,-1)
Xmat<-matrix(0,length(finalSNPs0),3)
for (i in 1:length(finalSNPs0))
{
  Xmat[i,]<-xvec4AA*(finalSNPs0[i]=="1")+xvec4Aa*(finalSNPs0[i]=="2")+xvec4aa*(finalSNPs0[i]=="3")
}

betahat<-solve(t(Xmat)%*%Xmat)%*%t(Xmat)%*%y0
lm3<-lm(y0~Xmat[,2]+Xmat[,3])
lm3
n<-length(y0)
rankx<-qr(Xmat)$rank
SSE<-sum(epsilonhat^2)
MSE<-SSE/(n-rankx)
sigmahat<-sqrt(MSE)
cvec<-c(0,1,-1)
cbeta<-cvec%*%solve(t(Xmat)%*%Xmat)%*%t(Xmat)%*%y0
varcbeta<-t(cvec)%*%solve(t(Xmat)%*%Xmat)%*%cvec
low95cbeta<-cbeta-qt(0.975,n-rankx)*sigmahat*sqrt(varcbeta)
upp95cbeta<-cbeta+qt(0.975,n-rankx)*sigmahat*sqrt(varcbeta)
CI95cbeta<-c(low95cbeta,upp95cbeta)
Tn<-cbeta/(sigmahat*sqrt(varcbeta))
pvalue<-2*(1-pt(abs(Tn),n-rankx))
CI95cbeta
pvalue

# Q13
## Check normal distribution#Q13
qqnorm(y)

# Q14 &15
anova(lm2anova)


require(corpcor)
require(matrixcalc)

C_20 = as.matrix(read.table("tmpmat/C_20.csv"))
C_40 = as.matrix(read.table("tmpmat/C_40.csv"))
C_200 = as.matrix(read.table("tmpmat/C_200.csv"))
C_400 = as.matrix(read.table("tmpmat/C_400.csv"))

X_40x20   = as.matrix(read.table('tmpmat/X_40x20.csv'))
X_20x40   = as.matrix(read.table('tmpmat/X_20x40.csv'))
X_400x200 = as.matrix(read.table('tmpmat/X_400x200.csv'))
X_200x400 = as.matrix(read.table('tmpmat/X_200x400.csv'))

C = list(C_20, C_40, C_200, C_400)
X = list(X_40x20, X_20x40, X_400x200, X_200x400)

times = numeric(4)
res = numeric(4)

for (i in c(1, 2, 3, 4)){
  Xi = X[[i]]
  Ci = C[[i]]
  start = Sys.time()
  C_est = cov.shrink(Xi, lambda.var=0.0)
  times[i] = as.numeric(Sys.time()-start)
  res[i] = frobenius.norm(C_est - Ci)
}


 #SNOPSIS

 #commands for running correlation analyis,
 #and generating heatmap and the correlation
 #coefficients and their p-values

 #AUTHOR
 # Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(gplots)
library(RColorBrewer)
library(ltm)

allargs<-commandArgs()

phenodata<-grep("phenodata",
               allargs,
               ignore.case=TRUE,
               perl=TRUE,
               value=TRUE
               )

cortable<-grep("corre_table",
               allargs,
               ignore.case=TRUE,
               perl=TRUE,
               value=TRUE
               )

print(c("correlation table file:", cortable))

heatmap<-grep("heatmap",
               allargs,
               ignore.case=TRUE,
               perl=TRUE,
               value=TRUE
               )

print(c("heatmap file:", heatmap))

#reading phenotype data into an R object
phenodata<-read.csv(phenodata,
                    header=TRUE,
                    dec=".",
                    sep=",",
                    na.strings=c("NA", "-")
                   )

phenodata$ID=NULL

#running Pearson correlation analysis
coefpvalues<-rcor.test(phenodata,
                       method="pearson",
                       use="pairwise"
                      )

coefficients<-coefpvalues$cor.mat
allcordata<-coefpvalues$cor.mat
allcordata[lower.tri(allcordata)]<-coefpvalues$p.values[, 3]
diag(allcordata)<-1.00

pvalues<-as.matrix(allcordata)

pvalues<-round(pvalues,
               digits=2
               )

#rounding correlation coeficients into 2 decimal places
coefficients<-round(coefficients,
                    digits=2
                   )

allcordata<-round(allcordata,
                  digits=2
                  )

#remove rows and columns that are all "NA"
if ( apply(coefficients,
           1,
           function(x)any(is.na(x))
           )
    ||
    apply(coefficients,
          2,
          function(x)any(is.na(x))
          )
    )
  {

    coefficients<-coefficients[-which(apply(coefficients,
                                            1,
                                            function(x)all(is.na(x)))
                                      ),
                               -which(apply(coefficients,
                                            2,
                                            function(x)all(is.na(x)))
                                      )
                               ]
  }

print("correlation coeffients:")
print(coefficients)

pvalues[upper.tri(pvalues)]<-NA
coefficients[upper.tri(coefficients)]<-NA

png(file=heatmap,
    height=600,
    width=600,
    bg="transparent"
    )

heatmap.2(coefficients,
          Rowv=FALSE,
          Colv=FALSE,
          dendrogram="none",
          na.rm=TRUE,
          col =  rev(colorRampPalette(brewer.pal(10,"Spectral"))(128)),
          trace="none",
          ColSideColors,
          RowSideColors,
          keysize = 1,
          density.info="none",
          lmat=rbind( c(0,3), c(2,1), c(0,4)),
          lhei=c(0.25, 4, 0.75),
          lwid=c(0.25, 4),
          cexRow = 1.25,
          cexCol = 1.25,
          margins = c(10, 6)
          )

dev.off()

write.table(coefficients,
      file=cortable,
      col.names=TRUE,
      row.names=TRUE,
      quote=FALSE,
      dec="."
      )

q(save = "no", runLast = FALSE)


# 4. faza: Analiza podatkov

source("lib/libraries.r", encoding = "UTF-8")
source("uvoz/uvoz.r", encoding = "UTF-8")

nb.cols <- 6
mycolours <- colorRampPalette(brewer.pal(6, "Paired"))(nb.cols)

#Analiza po spol, izbrane drzave

podatki <- kolicina %>%
  filter(Frequency == "Every week", Country %in% c("Romania", "Cyprus", "Ireland", "Norway"), Sex %in% c("Females", "Males")) %>%
  select(Country, Sex, `From 25 to 64 years`)

graf_spol <- ggplot(data=podatki, aes(x=Country, y=`From 25 to 64 years`)) +
  geom_col(aes(fill=Sex), position = "dodge") +
  scale_fill_manual(values=c("steelblue3", "orangered2"), labels = c("Ženske", "Moški")) +
  theme_minimal() +
  labs(x="Država", y="Kolicina alkohola v procentih",
       title="Analiza kolicina alkohola po spolu\nv izbranih državah za ljudi 25-64 let",
       fill = "Spol") +
  theme(legend.position = "bottom") +
  theme(axis.text.x = element_text(angle = 90, size = 8),  plot.title = element_text(size = 20))

#Analiza za Slovenija
podatki_slovenija <- kolicina %>% filter(Country == "Slovenia") %>%
  select(-Total, -`From 15 to 24 years`) %>% gather("Years", "From 25 to 64 years", 4:5)
names(podatki_slovenija)[5] <- "Value"
oznake <- c("Females" = "Ženske", "Males" = "Moški", "Total" = "Skupaj", "From 25 to 64 years" = "25-64 let", "65 years or over" = "65+")

graf_slovenija <- ggplot(data=podatki_slovenija, mapping=aes(x=Years, y = get("Value") ,group=Frequency, fill=Frequency)) +
  geom_col(position = "dodge") +
  coord_flip() +
  scale_fill_manual(values = c("steelblue4", "steelblue3", "steelblue1", "skyblue", "lightblue1"),
                    labels = c("Vsak dan", "Vsak mesec", "Vsak teden", "Manj kot enkrat na mesec", "Nikoli ali ne v zadnjih 12 mesecih")) +
  labs(x="Let", y="Kolicina alkohola v procentih", color="Frequency", title = "Konzumacija alkohola v Sloveniji") +
  facet_grid(.~Sex, labeller = as_labeller(oznake)) +
  theme_minimal() +
  theme(legend.position = "bottom") +
  theme(axis.text.x = element_text(angle = 90, size = 8),  plot.title = element_text(size = 20))

#Regression

#Data frames
t_bulgaria1 <- table_production %>% filter(Country == "Bulgaria", Year %in% c(2008:2013)) %>% select(Country, Year, Beer)
t_bulgaria1$Beer <- t_bulgaria1$Beer / 10000
t_bulgaria2 <- table_production %>% filter(Country == "Bulgaria", Year %in% c(2008:2013)) %>% select(Country, Year, Whisky)
t_bulgaria2$Whisky <- t_bulgaria2$Whisky / 10000
t_finland1 <- table_production %>% filter(Country == "Finland", Year %in% c(2008:2013)) %>% select(Country, Year, Beer)
t_finland1$Beer <- t_finland1$Beer / 10000
t_finland2 <- table_production %>% filter(Country == "Finland", Year %in% c(2008:2013)) %>% select(Country, Year, Whisky )
t_finland2$Whisky <- t_finland2$Whisky / 10000
t_lithuania1 <- table_production %>% filter(Country == "Lithuania", Year %in% c(2008:2013)) %>% select(Country, Year, Beer)
t_lithuania1$Beer <- t_lithuania1$Beer / 10000
t_lithuania2 <- table_production %>% filter(Country == "Lithuania", Year %in% c(2008:2013)) %>% select(Country, Year, Whisky)
t_lithuania2$Whisky <- t_lithuania2$Whisky / 10000

t_all1 <- bind_rows(t_bulgaria1, t_finland1, t_lithuania1)
t_all2 <- bind_rows(t_bulgaria2, t_finland2, t_lithuania2)

test_future1 <- table_production %>%
  filter(Country %in% c("Bulgaria", "Finland", "Lithuania"), Year %in% c(2014:2018)) %>%
  select(Country, Year, Beer)
test_future1$Beer <- test_future1$Beer / 10000
test_future2 <- table_production %>%
  filter(Country %in% c("Bulgaria", "Finland", "Lithuania"), Year %in% c(2014:2018)) %>%
  select(Country, Year, Whisky)
test_future2$Whisky <- test_future2$Whisky / 10000

#Models
p_bulgaria1 <- lm(data= t_bulgaria1, Beer ~ Year)
p_bulgaria2 <- lm(data= t_bulgaria2, Whisky ~ Year)
p_finland1 <- lm(data = t_finland1, Beer ~ Year)
p_finland2 <- lm(data = t_finland2, Whisky ~ Year)
p_lithuania1 <- lm(data = t_lithuania1, Beer ~ Year)
p_lithuania2 <- lm(data = t_lithuania2, Whisky ~ Year)

#Prediction
future <- data.frame(Year=c(2014:2020))
whole_interval <- data.frame(Year=c(2007:2020))

napoved_bulgaria1 <- mutate(whole_interval, Beer=predict(p_bulgaria1, whole_interval), Country="Bulgaria")
napoved_bulgaria2 <- mutate(whole_interval, Whisky=predict(p_bulgaria2, whole_interval), Country="Bulgaria")
napoved_finland1 <- mutate(whole_interval, Beer=predict(p_finland1, whole_interval), Country="Finland")
napoved_finland2 <- mutate(whole_interval, Whisky=predict(p_finland2, whole_interval), Country="Finland")
napoved_lithuania1 <- mutate(whole_interval, Beer=predict(p_lithuania1, whole_interval), Country="Lithuania")
napoved_lithuania2 <- mutate(whole_interval, Whisky=predict(p_lithuania2, whole_interval), Country="Lithuania")

napoved1 <- bind_rows(napoved_bulgaria1, napoved_finland1, napoved_lithuania1)
napoved2 <- bind_rows(napoved_bulgaria2, napoved_finland2, napoved_lithuania2)

#Plot
graf_regresija_pivo <- ggplot() +
  geom_point(data = t_all1, mapping = aes(x=Year, y=Beer), color = "black") +
  geom_point(data = test_future1, mapping = aes(x=Year, y=Beer), color = "orangered2") +
  geom_smooth(data = napoved1 , mapping = aes(x=Year, y=Beer), method=lm, color="steelblue3") +
  labs(x="Leto", y="Kolicina poizvedenaga piva") +
  ggtitle("Napoved provizvodnja piva") +
  facet_wrap(.~Country, nrow=3, scales="free") +
  theme(axis.text.x = element_text(angle = 90, size = 8)) +
  theme_minimal() +
  theme(plot.title = element_text(size = 20))

graf_regresija_viski <- ggplot() +
  geom_point(data = t_all2, mapping = aes(x=Year, y=Whisky), color = "black") +
  geom_point(data = test_future2, mapping = aes(x=Year, y=Whisky), color = "orangered2") +
  geom_smooth(data = napoved2 , mapping = aes(x=Year, y=Whisky), method=lm, color="steelblue3") +
  labs(x="Leto", y="Kolicina poizvedenaga viskija") +
  ggtitle("Napoved provizvodnja viskija") +
  facet_wrap(.~Country, nrow=3, scales="free") +
  theme(axis.text.x = element_text(angle = 90, size = 8)) +
  theme_minimal() +
  theme(plot.title = element_text(size = 20))


[[[[[
   Occam's razor---Concentration process.
   From computer C construct C' such that
   if P_C(x) >= 1/2^k, then
   then C' has a k+1 bit program for x.
   Hence H(x) <= -log_2 P_C(x) + c
   where c depends only on C, not on x.
]]]]]

define all-together

[this is used to avoid duplicate requirements for C']
let previous-requirements nil

[test case special-purpose computer C:]
[ignores odd bits, multiplies by ten until hits a 1]
[this C has many programs that do the same job!]
[[to put U here instead, let C be 'eval read-exp]]
let C '
   let (loop n)
      let ignore-it [be] read-bit [skip bit]
      if = 1 read-bit [then return] n
         [else] (loop * 10 n)
   (loop 10)

[stage n = 0, 1, 2, ... of overall concentration process]
[look at all n-bit programs for C, run them for time n]
[merge (output,multiplicity) pairs, emit requirements for C']
let (stage n)
   let previous-requirements
      (make-requirements debug (how-many? nil debug n))
   (stage + n 1)

[produce (output,multiplicity) pairs]
[by running all n-bit programs on C for time n]
let (how-many? p n)
   if = n length p

      [run program p for time n]
      let v try n [U => 'eval read-exp] C p
      if = success car v

          [program ran to completion]
          [indicate that it produces]
          [its output with multiplicity one]
          cons cons cadr v cons 1 nil
               nil

          [otherwise program failed]
          nil
          [empty list of (output,multiplicity) pairs]

      [otherwise use recursion to combine multiplicities]
      (merge (how-many? cons 0 p n)
             (how-many? cons 1 p n)
      )

[add one (output,multiplicity) pair to a list of such pairs]
let (merge1 pair list)
   if  atom list     cons pair nil
   let first-in-list car  list
   let rest-of-list  cdr  list
   let output        car  pair
   let multiplicity  cadr pair
   let output2       car  first-in-list
   let multiplicity2 cadr first-in-list
   if = output output2
      [= -> combine multiplicities]
      cons cons output cons + multiplicity multiplicity2 nil
           rest-of-list
      [!= -> don't combine multiplicities]
      cons first-in-list
           (merge1 pair rest-of-list)

[combine two lists of (output,multiplicity) pairs]
let (merge list list2)
   if atom list list2
   (merge1 car list (merge cdr list list2))

[exponent in highest power of 2 <= n, n != 0]
let (log2 n)
   let (loop power exponent)
      let new-power    + power power [double it]
      let new-exponent + 1 exponent  [add 1 to it]
      if > new-power n [then return] exponent
         [else] (loop new-power new-exponent)
   (loop [initial power of two] 1 [initial exponent of 2] 0)

let (make-requirements list-of-pairs)
   if  atom list-of-pairs  previous-requirements
   let first-pair     car  list-of-pairs
   let list-of-pairs  cdr  list-of-pairs
   let output         car  first-pair
   let multiplicity   cadr first-pair
   let kraft-requirement
       cons output cons - + n 1 (log2 multiplicity) nil
   let previous-requirements (make-requirements list-of-pairs)
   [keep only first appearance of requirement]
   if (is-in? kraft-requirement previous-requirements)
      previous-requirements
   cons debug display kraft-requirement previous-requirements

let (is-in? x list) [is x in list?]
   if atom list     false
   if = x car list  true
   (is-in? x cdr list)

[HERE GOES!]
(stage 0)

define      all-together
value       ((' (lambda (previous-requirements) ((' (lambda (C
            ) ((' (lambda (stage) ((' (lambda (how-many?) (('
            (lambda (merge1) ((' (lambda (merge) ((' (lambda (
            log2) ((' (lambda (make-requirements) ((' (lambda
            (is-in?) (stage 0))) (' (lambda (x list) (if (atom
             list) false (if (= x (car list)) true (is-in? x (
            cdr list))))))))) (' (lambda (list-of-pairs) (if (
            atom list-of-pairs) previous-requirements ((' (lam
            bda (first-pair) ((' (lambda (list-of-pairs) ((' (
            lambda (output) ((' (lambda (multiplicity) ((' (la
            mbda (kraft-requirement) ((' (lambda (previous-req
            uirements) (if (is-in? kraft-requirement previous-
            requirements) previous-requirements (cons (debug (
            display kraft-requirement)) previous-requirements)
            ))) (make-requirements list-of-pairs)))) (cons out
            put (cons (- (+ n 1) (log2 multiplicity)) nil)))))
             (car (cdr first-pair))))) (car first-pair)))) (cd
            r list-of-pairs)))) (car list-of-pairs)))))))) ('
            (lambda (n) ((' (lambda (loop) (loop 1 0))) (' (la
            mbda (power exponent) ((' (lambda (new-power) (('
            (lambda (new-exponent) (if (> new-power n) exponen
            t (loop new-power new-exponent)))) (+ 1 exponent))
            )) (+ power power)))))))))) (' (lambda (list list2
            ) (if (atom list) list2 (merge1 (car list) (merge
            (cdr list) list2)))))))) (' (lambda (pair list) (i
            f (atom list) (cons pair nil) ((' (lambda (first-i
            n-list) ((' (lambda (rest-of-list) ((' (lambda (ou
            tput) ((' (lambda (multiplicity) ((' (lambda (outp
            ut2) ((' (lambda (multiplicity2) (if (= output out
            put2) (cons (cons output (cons (+ multiplicity mul
            tiplicity2) nil)) rest-of-list) (cons first-in-lis
            t (merge1 pair rest-of-list))))) (car (cdr first-i
            n-list))))) (car first-in-list)))) (car (cdr pair)
            )))) (car pair)))) (cdr list)))) (car list))))))))
             (' (lambda (p n) (if (= n (length p)) ((' (lambda
             (v) (if (= success (car v)) (cons (cons (car (cdr
             v)) (cons 1 nil)) nil) nil))) (try n C p)) (merge
             (how-many? (cons 0 p) n) (how-many? (cons 1 p) n)
            ))))))) (' (lambda (n) ((' (lambda (previous-requi
            rements) (stage (+ n 1)))) (make-requirements (deb
            ug (how-many? nil (debug n)))))))))) (' ((' (lambd
            a (loop) (loop 10))) (' (lambda (n) ((' (lambda (i
            gnore-it) (if (= 1 (read-bit)) n (loop (* 10 n))))
            ) (read-bit))))))))) nil)

try 60 all-together nil

expression  (try 60 all-together nil)
debug       0
debug       ()
debug       1
debug       ()
debug       2
debug       ()
debug       3
debug       ((10 4))
debug       (10 2)
debug       4
debug       ((10 8))
debug       5
debug       ((10 16) (100 8))
debug       (100 3)
debug       6
debug       ((10 32) (100 16))
debug       7
debug       ((10 64) (100 32) (1000 16))
debug       (1000 4)
debug       8
debug       ((10 128) (100 64) (1000 32))
value       (failure out-of-time ((10 2) (100 3) (1000 4)))