rm(list=ls())
library(plyr)
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(stats)
library(tibble)
library(reshape)
library(xlsx)

##################################################################################################
## Test correlation across all hypotheses
##################################################################################################
# http://www.sthda.com/english/wiki/correlation-test-between-two-variables-in-r
# https://rpubs.com/aaronsc32/spearman-rank-correlation

emptyFrame <- function(h,s){
  c.d <- data.frame("test"=c("emp.spearman","emp.pearson"),
                          "sample"=c(s,s),
                          "hypothesis"=c(h,h),
                          "Correlation"=c(NA,NA),
                          "emp"=c(NA,NA),
                          "p0.975"=c(NA,NA),
                          "p0.95"=c(NA,NA),
                          "p0.05"=c(NA,NA),
                          "p0.025"=c(NA,NA))
  return(c.d)
}

corTest <- function(d,h,s){

  # Create two datasets, one to add permutation columns to, one to pull from. because that's how I coded it?
  a <- d %>% filter(variable == h)
  perms <- d %>% filter(variable == h)
  nloci <- length(a$Locus)
  maxB <- max(a$BF)
  minB <- min(a$BF)
  maxG <- max(a$GL)
  minG <- min(a$GL)
  #print(length(a$Locus))

  # Safety check for if a subset of data has too few observations
  if(length(a$Locus) < 5){
    c.d <- emptyFrame(h,s)
    return(c.d)
  }

  # Define which column numbers to test for correlation

  b <- match('BF',names(a))
  g <- match('GL',names(a))

  # Permute BF values in 1,000 seperate columns, could permute BF or GL doesnt matter.

  for (n in 1:1000) {
    newcolname1 <- paste('BF',n,sep='')
    perms[, newcolname1] <- sample(a[[b]], replace = FALSE)
    #newcolname2 <- paste('GL',n,sep='')
    #null[, newcolname2] <- sample(a[[g]], replace = FALSE)
  }

  # Create new dataset to add null rank coefficients to

  assign('null', setNames(data.frame(1:1000), "replicate"))

  # Add bf gl

  for (n in 1:1000) {

    # Grab column names, calculate value
    colname1 <- paste('BF',n,sep='')
    cc1.s <- cor(perms[,'GL'],perms[,colname1],method="spearman")
    null[n,'null.spearman'] <- cc1.s
    cc1.p <- cor(perms[,'GL'],perms[,colname1],method="pearson")
    null[n,'null.pearson'] <- cc1.p
  }

  # Dataframe for emp scores
  emp <- data.frame(TestType=character(),
                    corr.eff=integer(),
                    p=integer(),
                    p0.975=integer(),
                    p0.95=integer(),
                    p0.05=integer(),
                    p0.025=integer(),stringsAsFactors=FALSE)

  # Designate which row is for which test

  emp[1,'TestType'] <- 'emp.spearman'
  emp[2,'TestType'] <- 'emp.pearson'

  # Calculate correlation stats from emperical data,  add to df

  e.s <- cor(a[[b]],a[[g]],method="spearman")
  e.p <- cor(a[[b]],a[[g]],method="pearson")

  emp[1,'corr.eff'] <- e.s
  emp[2,'corr.eff'] <- e.p

  # Calculate 2 sided p values

  p.s <- sum(abs(null$null.spearman) >= abs(e.s)) / length(null$null.spearman)
  p.p <- sum(abs(null$null.pearson) >= abs(e.s)) / length(null$null.pearson)

  emp[1,'p'] <- p.s
  emp[2,'p'] <- p.p

  # Add rows for quantile cut offs

  emp[1,'p0.025'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[1,'p0.975'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[1,'p0.05'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[1,'p0.95'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[2]]
  emp[2,'p0.025'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[2,'p0.975'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[2,'p0.05'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[2,'p0.95'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[2]]

  # Add significance yes/no and other data

  corr.data <- emp %>%
    mutate_if(is.numeric,round,2) %>%
    add_column(Hypothesis = h, .after = "TestType") %>%
    add_column(Sample = s, .after = "TestType") %>%
    add_column(Loci = nloci, .after = "p") %>%
    add_column(minG = minG, .after = "Loci")%>%
    add_column(maxG = maxG, .after = "Loci")%>%
    add_column(minB = minB, .after = "Loci")%>%
    add_column(maxB = maxB, .after = "Loci")

  return(corr.data)
}

setwd("/Users/ChatNoir/Projects/Squam/scripts_ch1/Graphing/DataFiles")
load("Calcs_Smoosh2021.RData")
setwd("/Users/ChatNoir/Projects/Squam/Graphs/Tables")

tvs <- corTest(all,"TvS","all")
aivsa <- corTest(all,"AIvSA","all")
aivsi <- corTest(all,"AIvSI","all")
savsi <- corTest(all,"SAvSI","all")

tvs.0x <- corTest(all.0x,"TvS","sig0x")
aivsa.0x <- corTest(all.0x,"AIvSA","sig0x")
aivsi.0x <- corTest(all.0x,"AIvSI","sig0x")
savsi.0x <- corTest(all.0x,"SAvSI","sig0x")

tvs.1x <- corTest(all.1x,"TvS","sig1x")
aivsa.1x <- corTest(all.1x,"AIvSA","sig1x")
aivsi.1x <- corTest(all.1x,"AIvSI","sig1x")
savsi.1x <- corTest(all.1x,"SAvSI","sig1x")

tvs.2x <- corTest(all.2x,"TvS","sig2x")
aivsa.2x <- corTest(all.2x,"AIvSA","sig2x")
aivsi.2x <- corTest(all.2x,"AIvSI","sig2x")
savsi.2x <- corTest(all.2x,"SAvSI","sig2x")

tvs.50m <- corTest(all.50m,"TvS","quant50m")
aivsa.50m <- corTest(all.50m,"AIvSA","quant50m")
aivsi.50m <- corTest(all.50m,"AIvSI","quant50m")
savsi.50m <- corTest(all.50m,"SAvSI","quant50m")

tvs.60m <- corTest(all.60m,"TvS","quant60m")
aivsa.60m <- corTest(all.60m,"AIvSA","quant60m")
aivsi.60m <- corTest(all.60m,"AIvSI","quant60m")
savsi.60m <- corTest(all.60m,"SAvSI","quant60m")

tvs.80m <- corTest(all.80m,"TvS","quant80m")
aivsa.80m <- corTest(all.80m,"AIvSA","quant80m")
aivsi.80m <- corTest(all.80m,"AIvSI","quant80m")
savsi.80m <- corTest(all.80m,"SAvSI","quant80m")

tvs.60mb <- corTest(all.60mb,"TvS","quant60mb")
aivsa.60mb <- corTest(all.60mb,"AIvSA","quant60mb")
aivsi.60mb <- corTest(all.60mb,"AIvSI","quant60mb")
savsi.60mb <- corTest(all.60mb,"SAvSI","quant60mb")

tvs.80mb <- corTest(all.80mb,"TvS","quant80mb")
aivsa.80mb <- corTest(all.80mb,"AIvSA","quant80mb")
aivsi.80mb <- corTest(all.80mb,"AIvSI","quant80mb")
savsi.80mb <- corTest(all.80mb,"SAvSI","quant80mb")

tvs.50l <- corTest(all.50l,"TvS","50l")
aivsa.50l <- corTest(all.50l,"AIvSA","50l")
aivsi.50l <- corTest(all.50l,"AIvSI","50l")
savsi.50l <- corTest(all.50l,"SAvSI","50l")

tvs.50h <- corTest(all.50h,"TvS","50h")
aivsa.50h <- corTest(all.50h,"AIvSA","50h")
aivsi.50h <- corTest(all.50h,"AIvSI","50h")
savsi.50h <- corTest(all.50h,"SAvSI","50h")

results <- bind_rows(tvs,aivsa,aivsi,savsi,
                     tvs.80m,aivsa.80m,aivsi.80m,savsi.80m,
                     tvs.60m,aivsa.60m,aivsi.60m,savsi.60m,
                     tvs.50m,aivsa.50m,aivsi.50m,savsi.50m,
                     tvs.50l,aivsa.50l,aivsi.50l,savsi.50l,
                     tvs.50h,aivsa.50h,aivsi.50h,savsi.50h,
                     tvs.2x,aivsa.2x,aivsi.2x,savsi.2x,
                     tvs.1x,aivsa.1x,aivsi.1x,savsi.1x,
                     tvs.0x,aivsa.0x,aivsi.0x,savsi.0x) %>% filter(TestType == "emp.spearman")

results_mb <- bind_rows(tvs,aivsa,aivsi,savsi,
                     tvs.80m,aivsa.80m,aivsi.80m,savsi.80m,
                     tvs.60m,aivsa.60m,aivsi.60m,savsi.60m,
                     tvs.80mb,aivsa.80mb,aivsi.80mb,savsi.80mb,
                     tvs.60mb,aivsa.60mb,aivsi.60mb,savsi.60mb
                     ) %>% filter(TestType == "emp.spearman")

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/Tables/AllSchmoosh.xlsx",sep='')

write.xlsx2(as.data.frame(results), file=fname, row.names=FALSE)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/Tables/AllSchmoosh_mb.xlsx",sep='')

write.xlsx2(as.data.frame(results_mb), file=fname, row.names=FALSE)

##################################################################################################
## Test correlation blind to hypotheses
##################################################################################################
# http://www.sthda.com/english/wiki/correlation-test-between-two-variables-in-r
# https://rpubs.com/aaronsc32/spearman-rank-correlation

emptyFrame <- function(s){
  c.d <- data.frame("test"=c("emp.spearman","emp.pearson"),
                    "sample"=c(s,s),
                    "hypothesis"=c('ALL','ALL'),
                    "Correlation"=c(NA,NA),
                    "emp"=c(NA,NA),
                    "p0.975"=c(NA,NA),
                    "p0.95"=c(NA,NA),
                    "p0.05"=c(NA,NA),
                    "p0.025"=c(NA,NA))
  return(c.d)
}

corTest <- function(d,s){

  # Create two datasets, one to add permutation columns to, one to pull from. because that's how I coded it?
  a <- d
  perms <- d
  nloci <- length(a$Locus)
  maxB <- max(a$BF)
  minB <- min(a$BF)
  maxG <- max(a$GL)
  minG <- min(a$GL)
  #print(length(a$Locus))

  # Safety check for if a subset of data has too few observations
  if(length(a$Locus) < 5){
    c.d <- emptyFrame(s)
    return(c.d)
  }

  # Define which column numbers to test for correlation

  b <- match('BF',names(a))
  g <- match('GL',names(a))

  # Permute BF values in 1,000 seperate columns, could permute BF or GL doesnt matter.

  for (n in 1:1000) {
    newcolname1 <- paste('BF',n,sep='')
    perms[, newcolname1] <- sample(a[[b]], replace = FALSE)
    #newcolname2 <- paste('GL',n,sep='')
    #null[, newcolname2] <- sample(a[[g]], replace = FALSE)
  }

  # Create new dataset to add null rank coefficients to

  assign('null', setNames(data.frame(1:1000), "replicate"))

  # Add bf gl

  for (n in 1:1000) {

    # Grab column names, calculate value
    colname1 <- paste('BF',n,sep='')
    cc1.s <- cor(perms[,'GL'],perms[,colname1],method="spearman")
    null[n,'null.spearman'] <- cc1.s
    cc1.p <- cor(perms[,'GL'],perms[,colname1],method="pearson")
    null[n,'null.pearson'] <- cc1.p
  }

  # Dataframe for emp scores
  emp <- data.frame(TestType=character(),
                    corr.eff=integer(),
                    p=integer(),
                    p0.975=integer(),
                    p0.95=integer(),
                    p0.05=integer(),
                    p0.025=integer(),stringsAsFactors=FALSE)

  # Designate which row is for which test

  emp[1,'TestType'] <- 'emp.spearman'
  emp[2,'TestType'] <- 'emp.pearson'

  # Calculate correlation stats from emperical data,  add to df

  e.s <- cor(a[[b]],a[[g]],method="spearman")
  e.p <- cor(a[[b]],a[[g]],method="pearson")

  emp[1,'corr.eff'] <- e.s
  emp[2,'corr.eff'] <- e.p

  # Calculate 2 sided p values

  p.s <- sum(abs(null$null.spearman) >= abs(e.s)) / length(null$null.spearman)
  p.p <- sum(abs(null$null.pearson) >= abs(e.s)) / length(null$null.pearson)

  emp[1,'p'] <- p.s
  emp[2,'p'] <- p.p

  # Add rows for quantile cut offs

  emp[1,'p0.025'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[1,'p0.975'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[1,'p0.05'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[1,'p0.95'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[2]]
  emp[2,'p0.025'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[2,'p0.975'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[2,'p0.05'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[2,'p0.95'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[2]]

  # Add significance yes/no and other data

  corr.data <- emp %>%
    mutate_if(is.numeric,round,2) %>%
    add_column(Hypothesis = "ALL", .after = "TestType") %>%
    add_column(Sample = s, .after = "TestType") %>%
    add_column(Loci = nloci, .after = "p") %>%
    add_column(minG = minG, .after = "Loci")%>%
    add_column(maxG = maxG, .after = "Loci")%>%
    add_column(minB = minB, .after = "Loci")%>%
    add_column(maxB = maxB, .after = "Loci")

  return(corr.data)
}

setwd("/Users/ChatNoir/Projects/Squam/scripts_ch1/Graphing/DataFiles")
load("Calcs_Smoosh.RData")
setwd("/Users/ChatNoir/Projects/Squam/Graphs/Tables")

bigCor <- corTest(all,"all")

bigCor.0x <- corTest(all.0x,"sig0x")
bigCor.1x <- corTest(all.1x,"sig1x")
bigCor.2x <- corTest(all.2x,"sig2x")
bigCor.50m <- corTest(all.50m,"quant50m")
bigCor.60m <- corTest(all.60m,"quant60m")
bigCor.80m <- corTest(all.80m,"quant80m")
bigCor.50l <- corTest(all.50l,"50l")
bigCor.50h <- corTest(all.50h,"50h")

results <- bind_rows(bigCor,bigCor.0x, bigCor.1x, bigCor.2x,
                     bigCor.50m, bigCor.60m, bigCor.80m,
                     bigCor.50l, bigCor.50h) %>%
  filter(TestType == "emp.spearman")

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/Tables/AllSchmooshNoHypoth.xlsx",sep='')

write.xlsx2(as.data.frame(results), file=fname, row.names=FALSE)


library(linmod2)
set.seed(1234)

cmp <- function(a, b) stopifnot(all.equal(as.matrix(a), b))
fit <- function(x, y)
{
  mdl1 <<- .lm.fit(x, y)
  mdl2 <<- .lm_fit_minimal(x, y)
}

m = 20
n = 5
x = matrix(rnorm(m*n), m, n)
y = rnorm(m)

# ---------------- Tall and skinny ----------------

# 1 RHS
fit(x, y)

cmp(mdl1$coefficients, mdl2$coefficients)
cmp(x %*% mdl1$coefficients, mdl2$fitted.values)
cmp(mdl1$residuals, mdl2$residuals)

# 3 RHS
y = matrix(rnorm(m*3), m, 3)
fit(x, y)

cmp(mdl1$coefficients, mdl2$coefficients)
cmp(x %*% mdl1$coefficients, mdl2$fitted.values)
cmp(mdl1$residuals, mdl2$residuals)

# ---------------- Short and wide ----------------

#### NOTE: the coefficients can't possibly be equal because R will fit a model
#### with only the first 'rank==m' coefficients, while we use all 'n'.

# 1 RHS
x = t(x)
y = y[1:n]
fit(x, y)

cmp(mdl1$residuals, mdl2$residuals)
cmp(x %*% mdl1$coefficients, mdl2$fitted.values)

# 3 RHS

y = matrix(rnorm(n*3), n, 3)
fit(x, y)

cmp(mdl1$residuals, mdl2$residuals)
cmp(x %*% mdl1$coefficients, mdl2$fitted.values)


#testing dic model selection in JAGS using a linear model.
#This seems to work.
rm(list=ls())
library(runjags)

#### pseudo data generation ####
set.seed(1234)
n <- 200
x1 <- rnorm(n)
x2 <- rnorm(n)
x3 <- rnorm(n)
y <- x1*1.2 + x2*-0.7 + rnorm(n)
summary(lm(y ~ x1 + x2 + x3))
x <- as.matrix(data.frame(x1,x2,x3))

#### Specify JAGS model. ####
jags.model <- "
model {
  #parameter priors
  for(i in 1:n.X){
    m[i] ~ dnorm(0, 1E-3)
  }
  #uncertain prior
    tau <- pow(sigma, -2)
  sigma  ~ dunif(0, 100)

  for(i in 1:N){
        y[i] ~ dnorm(y.hat[i], tau)
    y.hat[i] <- inprod(x[i,],m)
  }
}
"
#### Fit JAGS model. ####
jags.data <- list(N=nrow(x), n.X = ncol(x), x=x, y=y)

jags.out <- run.jags(   model = jags.model,
                         data = jags.data,
                        adapt = 100,
                       burnin = 200,
                       sample = 300,
                     n.chains = 3,
                     monitor = c('m'))
dic <- extract(jags.out, 'dic')

#### Fit models without one predictor at a time. ####
#drop each predictor.
jags.compare.data  <- list()
jags.compare.model <- list()
jags.compare.dic   <- list()
for(i in 1:ncol(x)){
  jags.x <- x[,-i]
  jags.compare.data [[i]] <- list(N=nrow(jags.x), n.X = ncol(jags.x), x=jags.x, y=y)
  jags.compare.model[[i]] <- run.jags(model=jags.model, data = jags.compare.data[[i]],adapt=100,burnin=200,sample=300,n.chains=3,monitor=c('m'))
  jags.compare.dic  [[i]] <- extract(jags.compare.model[[i]],'dic')

}
#Says to drop 3rd predictor by like 2 points.. Great. Drop and rerun.
dic
jags.compare.dic

#### modify model - inprod doesnt work with just one predictor in the predictor matrix. ####
jags.model <- "
model {
  #parameter priors
  for(i in 1:n.X){
    m[i] ~ dnorm(0, 1E-3)
  }
  #uncertain prior
    tau <- pow(sigma, -2)
  sigma  ~ dunif(0, 100)

  for(i in 1:N){
        y[i] ~ dnorm(y.hat[i], tau)
    y.hat[i] <- x[i] * m
  }
}
"
#### try dropping next two predictors which are informative ####
new.x <- x[,-3] #3 was remvoed based on last dic filtering ciriteria.
jags.data <- list(N=nrow(new.x), n.X = ncol(new.x), x=new.x, y=y)
jags.out  <- run.jags(model=jags.model, data = jags.data,adapt=100,burnin=200,sample=300,n.chains=3,monitor=c('m'))
dic <- extract(jags.out, 'dic')
jags.compare.data  <- list()
jags.compare.model <- list()
jags.compare.dic   <- list()
for(i in 1:ncol(new.x)){
  jags.x <- new.x[,-i]
  jags.compare.data [[i]] <- list(N=length(y), n.X = 1, x=jags.x, y=y)
  jags.compare.model[[i]] <- run.jags(model=jags.model, data = jags.compare.data[[i]],adapt=100,burnin=200,sample=300,n.chains=3,monitor=c('m'))
  jags.compare.dic  [[i]] <- extract(jags.compare.model[[i]],'dic')
}

#dic says keep the other predictors for sure.
dic
jags.compare.dic


# Mixed effect model with
# `sex`, `mathprep` and `mathknow` as fixed
# and `classid` and `schoolid` as random effects

lmerModel <- lmer(mathgain ~
                  sex + mathprep + mathknow +
                  (1|classid) + (1|schoolid),
                  data = studenData, na.action = "na.omit",
                  REML = TRUE)
summary(lmerModel)


mult <- function(a,b) {
  a*b
  # or:
  # return(a*b)
}


library(lme4)
library(lmerTest)
library(readr)

# read in data from 4-way ANOVA with between-subject and within-subject factors
df_full <- read_csv("compiling_results/exp_data.csv")

# get parameter estimates from a linear regression with random effects
my_model_fit <- lmer(Code_Size ~ Processors * Workloads + (Processors|Workloads), df_full)
# display results of linear regression
summary(my_model_fit)

# main and interaction effects
anova(my_model_fit)
# random effects
rand(my_model_fit)
# access underlying model for fixed effects
my_glm_fe = model.matrix(my_model_fit)
# access underlying model for random effects
my_glm_re = getME(my_model_fit, "Zt")
# inspect matrices
image(t(my_glm_fe))
image(t(my_glm_re))


fib <- function(n) {
   if (n <= 2) {
      return(1)
   } else {
      return(fib(n - 1) + fib(n - 2))
   }
}

ptm <- proc.time()

for (i in 1:40) {
   fib(i)
   print(i)
}

print(proc.time() - ptm)


## Historical data, E1673 trial
historical.data <- read.csv("../../data/e1673.jasa.dat", sep = " ")
stand_age_0 <- (historical.data$age -mean(historical.data$age))/sd(historical.data$age)
N_0 <- length(stand_age_0)
X_0 <- cbind(rep(1, N_0), # x0 - dummy for intercept
           stand_age_0, # x1 - (standardised) age
           historical.data$gender, # x2 - gender (sex)
           historical.data$PS # x3 performance status
)
Y_0_cens <- historical.data$stime
Delta_0 <- historical.data$censor

## New data, E1684 trial
full.data <- read.csv("../../data/e1684_and_e1690_data.csv", sep = "\t")
new.data <- subset(full.data,
                          study  == "1684" & survtime > 0)

stand_age <- ( new.data$age - mean(new.data$age))/sd(new.data$age)
N <- length(stand_age)
X <- cbind(rep(1, N), # x0 - dummy for intercept
             stand_age, # x1 - (standardised) age
             new.data$sex, # x2 - gender (sex)
             new.data$perform # x3 performance status
)
Y_cens <- new.data$survtime
Delta <- new.data$scens

## Hyperparameters

mu0 <- 0
s0 <- 100

d0 <- 1
tau0 <- 0.01

## \pi_A parameters
eta <- 100
nu <- 100


# Performing calculations in the Matrix

# Construct star_wars_matrix
box_office <- c(460.998, 314.4, 290.475, 247.900, 309.306, 165.8)
region <- c("US", "non-US")
titles <- c("A New Hope",
                 "The Empire Strikes Back",
                 "Return of the Jedi")

star_wars_matrix <- matrix(box_office,
                      nrow = 3, byrow = TRUE,
                      dimnames = list(titles, region))

# Calculate worldwide box office figures
worldwide_vector <- rowSums(star_wars_matrix)


## @knitr logistic-fun
x <- seq(-4,4,by=.05)
p <- 1/(1 + exp(-x))   # Figure (*\ref{fig:lrm-logistic-fun}*)
plot(x, p, xlab="X", ylab="P", type="l")

## @knitr or-vs-diff
plot(0, 0, type="n", xlab="Risk for Subject Without Risk Factor",
     ylab="Increase in Risk",
     xlim=c(0,1), ylim=c(0,.6))   # Figure (*\ref{fig:lrm-or-vs-diff}*)
i <- 0
or <- c(1.1,1.25,1.5,1.75,2,3,4,5,10)
for(h in or) {
  i <- i + 1
  p <- seq(.0001, .9999, length=200)
  logit <- log(p/(1 - p))  # same as qlogis(p)
  logit <- logit + log(h)  # modify by odds ratio
  p2 <- 1/(1 + exp(-logit))# same as plogis(logit)
  d <- p2 - p
  lines(p, d, lty=i)
  maxd <- max(d)
  smax <- p[d==maxd]
  text(smax, maxd + .02, format(h), cex=.6)
}

## @knitr lrmodel
require(rms)
getHdata(sex.age.response)
d <- sex.age.response
dd <- datadist(d); options(datadist='dd')
f <- lrm(response ~ sex + age, data=d)
fasr <- f   # Save for later
w <- function(...)
  with(d, {
    m <- sex=='male'
    f <- sex=='female'
    lpoints(age[f], response[f], pch=1)
    lpoints(age[m], response[m], pch=2)
    af <- cut2(age, c(45,55), levels.mean=TRUE)
    prop <- tapply(response, list(af, sex), mean,
                   na.rm=TRUE)
    agem <- as.numeric(row.names(prop))
    lpoints(agem, prop[,'female'],
            pch=4, cex=1.3, col='green')
    lpoints(agem, prop[,'male'],
            pch=5, cex=1.3, col='green')
    x <- rep(62, 4); y <- seq(.25, .1, length=4)
    lpoints(x, y, pch=c(1, 2, 4, 5),
            col=rep(c('blue','green'),each=2))
    ltext(x+5, y,
          c('F Observed','M Observed',
            'F Proportion','M Proportion'), cex=.8)
  } )   # Figure (*\ref{fig:lrm-lrmodel}*)

plot(Predict(f, age=seq(34, 70, length=200), sex, fun=plogis),
     ylab='Pr[response]', ylim=c(-.02, 1.02), addpanel=w)
ltx <- function(fit) latex(fit, inline=TRUE, columns=54,
                           file='', after='$.', digits=3,
        size='Ssize', before='$X\\hat{\\beta}=')
ltx(f)

## @knitr simerr
sigmas  <- c(.5, .75, 1, 1.25, 1.5, 1.75, 2, 2.5, 3, 4)
ns      <- seq(25, 300, by=25)
nsim    <- 1000
xs      <- seq(-1.5, 1.5, length=200)
pactual <- plogis(xs)

dn <- list(sigma=format(sigmas), n=format(ns))
maxerr <- N1 <- array(NA, c(length(sigmas), length(ns)), dn)
require(rms)

i <- 0
for(s in sigmas) {
  i <- i + 1
  j <- 0
  for(n in ns) {
    j <- j + 1
    n1 <- maxe <- 0
    for(k in 1:nsim) {
      x <- rnorm(n, 0, s)
      P <- plogis(x)
      y <- ifelse(runif(n) <= P, 1, 0)
      n1 <- n1 + sum(y)
      beta <- lrm.fit(x, y)$coefficients
      phat <- plogis(beta[1] + beta[2] * xs)
      maxe <- maxe + max(abs(phat - pactual))
    }
    n1 <- n1/nsim
    maxe <- maxe/nsim
    maxerr[i,j] <- maxe
    N1[i,j] <- n1
  }
}
xrange <- range(xs)
simerr <- llist(N1, maxerr, sigmas, ns, nsim, xrange)

maxe <- reShape(maxerr)
# Figure (*\ref{fig:lrm-simerr}*)
xYplot(maxerr ~ n, groups=sigma, data=maxe,
       ylab=expression(paste('Average Maximum  ',
           abs(hat(P) - P))),
       type='l', lty=rep(1:2, 5), label.curve=FALSE,
       abline=list(h=c(.15, .1, .05), col=gray(.85)))
Key(.8, .68, other=list(cex=.7,
               title=expression(~~~~~~~~~~~sigma)))

## @knitr assumptions
plot(0:1, 0:1, xlab=expression(X[2]), ylab='logit{Y=1}',
     axes=FALSE,  type='n')
axis(1, at=0:1, labels=rep('',2))
axis(2, at=0:1, labels=rep('',2))
lines(c(.05, .8), c(.05, .5))
lines(c(.05, .8), c(.30, .75))
text(.9, .5, expression(X[1]==0), adj=.5)
text(.9, .75,expression(X[1]==1), adj=.5)

## @knitr emp-age-sex
getHdata(acath)
acath$sex <- factor(acath$sex, 0:1, c('male','female'))
dd <- datadist(acath); options(datadist='dd')
f <- lrm(sigdz ~ rcs(age, 4) * sex, data=acath)

## @knitr emp-age-sex-kn
kn <- specs(f)$how.modeled['age','Parameters']
kn <- setdiff(strsplit(kn, ' ')[[1]], '')
kn[length(kn)] <- paste('and', kn[length(kn)])
kn <- paste(kn, collapse=', ')

## @knitr emp-age-sex-pl
w <- function(...)
  with(acath, {
    plsmo(age, sigdz, group=sex, fun=qlogis, lty='dotted',
          add=TRUE, grid=TRUE)
    af <- cut2(age, g=10, levels.mean=TRUE)
    prop <- qlogis(tapply(sigdz, list(af, sex), mean,
                          na.rm=TRUE))
    agem <- as.numeric(row.names(prop))
    lpoints(agem, prop[,'female'], pch=4, col='green')
    lpoints(agem, prop[,'male'],   pch=2, col='green')
  } )   # Figure (*\ref{fig:lrm-emp-age-sex-pl}*)
plot(Predict(f, age, sex), ylim=c(-2,4), addpanel=w,
     label.curve=list(offset=unit(0.5, 'cm')))

## @knitr emp-age-sex-plunused
ggplot(Predict(f, age, sex)) +
  stat_plsmo(aes(x=age, y=sigdz), data=acath, fun=qlogis)

## @knitr lrtest
lr <- function(formula)
  {
    f <- lrm(formula, data=acath)
    stats <- f$stats[c('Model L.R.', 'd.f.')]
    cat('L.R. Chi-square:', round(stats[1],1),
        '  d.f.:', stats[2],'\n')
    f
  }
a <- lr(sigdz ~ sex + age)
b <- lr(sigdz ~ sex * age)
c <- lr(sigdz ~ sex + rcs(age,4))
d <- lr(sigdz ~ sex * rcs(age,4))
lrtest(a, b)
lrtest(a, c)
lrtest(a, d)
lrtest(b, d)
lrtest(c, d)

## @knitr dur
dz <- subset(acath, sigdz==1)
dd <- datadist(dz)
f <- lrm(tvdlm ~ rcs(cad.dur, 5), data=dz)
w <- function(...)
  with(dz, {
    plsmo(cad.dur, tvdlm, fun=qlogis, add=TRUE,
          grid=TRUE, lty='dotted')
    x <- cut2(cad.dur, g=15, levels.mean=TRUE)
    prop <- qlogis(tapply(tvdlm, x, mean, na.rm=TRUE))
    xm <- as.numeric(names(prop))
    lpoints(xm, prop, pch=2, col='green')
  } )   # Figure (*\ref{fig:lrm-dur}*)
plot(Predict(f, cad.dur), addpanel=w)

## @knitr problog
f <- lrm(tvdlm ~ log10(cad.dur + 1), data=dz)
w <- function(...)
  with(dz, {
    x <- cut2(cad.dur, m=150, levels.mean=TRUE)
    prop <- tapply(tvdlm, x, mean, na.rm=TRUE)
    xm <- as.numeric(names(prop))
    lpoints(xm, prop, pch=2, col='green')
  } )
#   Figure (*\ref{fig:lrm-problog}*)
plot(Predict(f, cad.dur, fun=plogis), ylab='P',
     ylim=c(.2, .8), addpanel=w)

## @knitr acath
acath <- transform(acath,
                   cholesterol = choleste,
                   age.tertile = cut2(age,g=3),
                   sx = as.integer(acath$sex) - 1)
# sx for loess, need to code as numeric
dd <- datadist(acath); options(datadist='dd')

# First model stratifies age into tertiles to get more
# empirical estimates of age x cholesterol interaction

f <- lrm(sigdz ~ age.tertile*(sex + rcs(cholesterol,4)),
         data=acath)
f
ltx(f)

## @knitr cholxage
print(anova(f), caption='Crudely categorizing age into tertiles',
      size='smaller')
yl <- c(-1,5)
plot(Predict(f, cholesterol, age.tertile),
     adj.subtitle=FALSE, ylim=yl)   # Figure (*\ref{fig:lrm-cholxage}*)

## @knitr iacholxage-loess
# Re-do model with continuous age
f <- loess(sigdz ~ age * (sx + cholesterol), data=acath,
           parametric="sx", drop.square="sx")
ages  <- seq(25,   75, length=40)
chols <- seq(100, 400, length=40)
g <- expand.grid(cholesterol=chols, age=ages, sx=0)
# drop sex dimension of grid since held to 1 value
p <- drop(predict(f, g))
p[p < 0.001] <- 0.001
p[p > 0.999] <- 0.999
zl <- c(-3, 6)   # Figure (*\ref{fig:lrm-iacholxage-loess}*)
wireframe(qlogis(p) ~ cholesterol*age,
          xlab=list(rot=30), ylab=list(rot=-40),
          zlab=list(label='log odds', rot=90), zlim=zl,
          scales = list(arrows = FALSE), data=g)

## @knitr iacholxage-lsp
f <- lrm(sigdz ~ lsp(age,c(46,52,59)) *
         (sex + lsp(cholesterol,c(196,224,259))),
         data=acath)
ltx(f)
print(anova(f), caption='Linear spline surface',
      size='smaller')
perim <- with(acath,
              perimeter(cholesterol, age, xinc=20, n=5))
zl <- c(-2, 4)   # Figure (*\ref{fig:lrm-iacholxage-lsp}*)
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)

## @knitr iacholxage-1
f <- lrm(sigdz ~ rcs(age,4)*(sex + rcs(cholesterol,4)),
         data=acath, tol=1e-11)
ltx(f)
print(anova(f), caption='Cubic spline surface',
      size='smaller')
# Figure (*\ref{fig:lrm-iacholxage-1}*):
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)

## @knitr iacholxage-2
f <- lrm(sigdz ~ sex*rcs(age,4) + rcs(cholesterol,4) +
         rcs(age,4) %ia% rcs(cholesterol,4), data=acath)
print(anova(f), size='smaller',
      caption='Singly nonlinear cubic spline surface')
# Figure (*\ref{fig:lrm-iacholxage-2}*):
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)
ltx(f)

## @knitr iacholxage-3
f <- lrm(sigdz ~ rcs(age,4)*sex + rcs(cholesterol,4) +
         age %ia% cholesterol, data=acath)
print(anova(f), caption='Linear interaction surface',
      size='smaller')
# Figure (*\ref{fig:lrm-iacholxage-3}*):
bplot(Predict(f, cholesterol, age, np=40), perim=perim,
      lfun=wireframe, zlim=zl, adj.subtitle=FALSE)
f.linia <- f  # save linear interaction fit for later
ltx(f)

## @knitr cholxage-model
# Make estimates of cholesterol effects for mean age in
# tertiles corresponding to initial analysis
mean.age <-
  with(acath,
       as.vector(tapply(age, age.tertile, mean, na.rm=TRUE)))
plot(Predict(f, cholesterol, age=round(mean.age,2),
             sex="male"),
     adj.subtitle=FALSE, ylim=yl) #3 curves, Figure (*\ref{fig:lrm-cholxage-model}*)

## @knitr dur-partial-resid
f <- lrm(tvdlm ~ cad.dur, data=dz, x=TRUE, y=TRUE)
resid(f, "partial", pl="loess", xlim=c(0,250), ylim=c(-3,3))
scat1d(dz$cad.dur)
log.cad.dur <- log10(dz$cad.dur + 1)
f <- lrm(tvdlm ~ log.cad.dur, data=dz, x=TRUE, y=TRUE)
resid(f, "partial", pl="loess", ylim=c(-3,3))
scat1d(log.cad.dur)   # Figure (*\ref{fig:lrm-dur-partial-resid}*)

## @knitr asr-influence
f <- update(fasr, x=TRUE, y=TRUE, data=sex.age.response)
## Also try which.influence(f, .4)
round(resid(f, 'dfbetas'), 1)   # Table (*\ref{table:dfbetas}*)

## @knitr sex-age-response-boot
d <- sex.age.response
dd <- datadist(d); options(datadist='dd')
f <- lrm(response ~ sex + age, data=d, x=TRUE, y=TRUE)
set.seed(3)  # for reproducibility
v1  <- validate(f, B=150)

## @knitr sex-age-response-booth
ap1 <- round(v1[,'index.orig'], 2)
bc1 <- round(v1[,'index.corrected'], 2)

## @knitr sex-age-response-bootp
latex(v1,
      caption='Bootstrap Validation, 2 Predictors Without Stepdown',
      insert.bottom='\\label{pg:lrm-sex-age-response-boot}',
      digits=2, size='Ssize', file='')

## @knitr sex-age-response-bootsw
v2 <- validate(f, B=150, bw=TRUE,
               rule='p', sls=.1, type='individual')

## @knitr sex-age-response-bootswh
ap2 <- round(v2[,'index.orig'], 2)
bc2 <- round(v2[,'index.corrected'], 2)

## @knitr sex-age-response-bootswp
latex(v2,
      caption='Bootstrap Validation, 2 Predictors with Stepdown',
      digits=2, B=15, file='', size='Ssize')

## @knitr sex-age-response-bootsw5
set.seed(133)
n  <- nrow(d)
x1 <- runif(n)
x2 <- runif(n)
x3 <- runif(n)
x4 <- runif(n)
x5 <- runif(n)
f  <- lrm(response ~ age + sex + x1 + x2 + x3 + x4 + x5,
          data=d, x=TRUE, y=TRUE)
v3 <- validate(f, B=150, bw=TRUE,
               rule='p', sls=.1, type='individual')

## @knitr sex-age-response-bootsw5v
k <- attr(v3, 'kept')
# Compute number of x1-x5 selected
nx <- apply(k[,3:7], 1, sum)
# Get selections of age and sex
v <- colnames(k)
as <- apply(k[,1:2], 1,
            function(x) paste(v[1:2][x], collapse=', '))
table(paste(as, ' ', nx, 'Xs'))

## @knitr sex-age-response-bootsw5ph
ap3 <- round(v3[,'index.orig'], 2)
bc3 <- round(v3[,'index.corrected'], 2)

## @knitr sex-age-response-bootsw5p
latex(v3,   # (*\label{pg:lrm-sw5p}*)
 caption='Bootstrap Validation with 5 Noise Variables and Stepdown',
 digits=2, B=15, size='Ssize', file='')

## @knitr sex-age-response-bootsw52
v4 <- validate(f, B=150, bw=TRUE, rule='p', sls=.1,
               type='individual', force=1:2)
ap4 <- round(v4[,'index.orig'], 2)
bc4 <- round(v4[,'index.corrected'], 2)

## @knitr sex-age-response-bootsw52p
latex(v4,
      caption='Bootstrap Validation with 5 Noise Variables and Stepdown, Forced Inclusion of age and sex',
      digits=2, B=15, size='Ssize')

## @knitr calibrations
g <- function(v) v[c('Intercept','Slope'),'index.corrected']
k <- rbind(g(v1), g(v2), g(v3))
co <- c(2,5,4,1)
plot(0, 0, ylim=c(0,1), xlim=c(0,1),
     xlab="Predicted Probability",
     ylab="Estimated Actual Probability", type="n")
legend(.45,.35,c("age, sex", "age, sex stepdown",
                 "age, sex, x1-x5", "ideal"),
       lty=1, col=co, cex=.8, bty="n")
probs <- seq(0, 1, length=200); L <- qlogis(probs)
for(i in 1:3) {
  P <- plogis(k[i,'Intercept'] + k[i,'Slope'] * L)
  lines(probs, P, col=co[i], lwd=1)
}
abline(a=0, b=1, col=co[4], lwd=1)   # Figure (*\ref{fig:lrm-calibrations}*)

## @knitr cholxage-confbar
s <- summary(f.linia)
print(s, size='Ssize')
plot(s)   # Figure (*\ref{fig:lrm-cholxage-confbar}*)

## @knitr iacholxage-3-nomogram
# Draw a nomogram that shows examples of confidence intervals
nom <- nomogram(f.linia, cholesterol=seq(150, 400, by=50),
                interact=list(age=seq(30, 70, by=10)),
                lp.at=seq(-2, 3.5, by=.5),
                conf.int=TRUE, conf.lp="all",
                fun=function(x)1/(1+exp(-x)),  # or plogis
                funlabel="Probability of CAD",
                fun.at=c(seq(.1, .9, by=.1), .95, .99)
                )   # Figure (*\ref{fig:lrm-iacholxage-3-nomogram}*)
plot(nom, col.grid = gray(c(0.8, 0.95)),
     varname.label=FALSE, ia.space=1, xfrac=.46, lmgp=.2)

## @knitr val-prob
set.seed(13)
n <- 200
x1 <- runif(n)
x2 <- runif(n)
x3 <- runif(n)
logit <- 2*(x1-.5)
P <- 1/(1+exp(-logit))
y <- ifelse(runif(n) <= P, 1, 0)
d <- data.frame(x1, x2, x3, y)
f <- lrm(y ~ x1 + x2 + x3, subset=1:100)
phat <- predict(f, d[101:200,], type='fitted')
# Figure (*\ref{fig:lrm-val-prob}*)
v <- val.prob(phat, y[101:200], m=20, cex=.5)

## Bayesian analysis

## @knitr bayes-bin_mods
dd <- datadist(sex.age.response)
options(datadist = 'dd')
require(brms)

# Frequentist model
fit_lrm <- lrm(response ~ sex + age, data=sex.age.response)

# Bayesian model
# Distribute chains across cpu cores:
options(mc.cores=parallel::detectCores())

# Set priors
# Solve for SD such that sex effect has only a 0.025 chance of
# being above 5 (or being below -5)

s1 <- 5 / qnorm(0.975)

# Solve for SD such that 10-year age effect has only 0.025 chance
# of being above 20

s2 <- (20 / qnorm(0.975)) / 10   # divide by 10 since ratio on 10b scale

stanvars <- stanvar(s1, name='s1') + stanvar(s2, name='s2')

prs <- c(prior(student_t(3,0,10), class='Intercept'),
         prior(normal(0, s1), class='b', coef='sexmale'),
         prior(normal(0, s2), class='b', coef='age'))

# Full model
fit_brms <- brm(response ~ sex + age, data=sex.age.response,
                family=bernoulli("logit"), prior=prs, iter=5000,
                stanvars=stanvars)

## @knitr bayes-bin_fits
# Frequentist model output
fit_lrm

summary(fit_lrm, age=20:21)

## @knitr bayes-bin_fits2
# Bayesian model output
post_samps <- posterior_samples(fit_brms, c("age","sex"))

fit_brms
posterior_interval(fit_brms, c("age","sex"))
prior_summary(fit_brms)

## @knitr bayes-post_plt
# display posterior densities for age and sex parameters
plot(fit_brms, c("age","sex"), combo=c("dens","trace","hex"))

## @knitr bayes-margeff
# Marginal effects plot
plot(conditional_effects(fit_brms, "age:sex"))

## @knitr bayes-biv
# Frequentist
# variance-covariance for sex and age parameters
sex_age_vcov <- vcov(fit_lrm)[2:3,2:3]

# Sampling based parameter estimate correlation coefficient
f_cc <- sex_age_vcov[1,2] / (sqrt(sex_age_vcov[1,1]) * sqrt(sex_age_vcov[2,2]))

# Bayesian
# Linear correlation between params from posterior
b_cc <- cor(post_samps)[1,2]

## @knitr bayes-postprobs
# Define P() as mean() just to provide a nice notation for
# computing posterior probabilities
P <- function(x) mean(x)
b1 <- post_samps[, 'b_sexmale']
b2 <- post_samps[, 'b_age']
(p1 <- P(b1 > 0))   # post prob(sex has positive association with Y)
(p2 <- P(b2 > 0))
(p3 <- P(b1 > 0 & b2 > 0))
(p4 <- P(b1 > 0 | b2 > 0))

## @knitr bayes-bidens
ggplot(post_samps, aes(x=b_sexmale, y = b_age)) +
  geom_hex() +
  theme(legend.position="none")

## @knitr bayes-MAP
# Calculate MAP interval
# Code from http://www.sumsar.net/blog/2014/11/how-to-summarize-a-2d-posterior-using-a-highest-density-ellipse/
samples <- as.matrix(post_samps)
coverage = 0.95
fit <- MASS::cov.mve(samples, quantile.used = round(nrow(samples) * coverage))
points_in_ellipse <- samples[fit$best,]
ellipse_boundary <- predict(cluster::ellipsoidhull(points_in_ellipse))
map <- data.frame(ellipse_boundary)
names(map) <- c("y","x")

ggplot(post_samps, aes(x=b_sexmale, y = b_age)) +
  geom_hex() +
  geom_polygon(data = map, aes(x=x,y=y), color = "grey", alpha = 0) +
  geom_point(aes(x = fixef(fit_brms)[,1][2], y = fixef(fit_brms)[,1][3]), color = "grey") +
  theme(legend.position="none")

## @knitr bayes-ellipse
# Function takes in variance-covariance matrix (D), point estimates (d),
# and a level of significance (alpha)
EllipseDF <- function(D, d, alpha = 0.05) {
  delta = sqrt(eigen(D)$values)
  # Root eigenvalues correspond to the half-lengths of the ellipse
  V = eigen(D)$vectors
  # Eigenvectors give the axes of the confidence ellipse
  R = sqrt(qchisq(1-alpha, df = length(delta)))
  # Scaling factor to get to 0.95 confidence
  a = R*delta[1] # scale the ellipse axes
  b = R*delta[2]
  t <- seq(0, 2*pi, length.out=200)
  # Generate radian measures from 0 to 2pi
  points.proj = V %*% t(cbind(a * cos(t), b * sin(t)))
  # Transform circle into ellipse
  return(data.frame(x = (points.proj)[1, ] + d[1],
                    y = (points.proj)[2, ] + d[2]))
}

D <- vcov(fit_lrm)[-1,-1]
beta <- coef(fit_lrm)[-1]
ci_ellipse <- EllipseDF(D, beta, alpha = 0.05)

ggplot(post_samps, aes(x=b_sexmale, y = b_age)) +
  geom_hex() +
  geom_polygon(data = map, aes(x=x,y=y), color = "grey", alpha = 0) +
  geom_polygon(data = ci_ellipse, aes(x = x,y = y), color = "red", alpha = 0) +
  geom_point(aes(x = fixef(fit_brms)[,1][2], y = fixef(fit_brms)[,1][3]), color = "grey") +
  geom_point(aes(x = coef(fit_lrm)[2], y = coef(fit_lrm)[3]), color = "red") +
  theme(legend.position="none")


# ejemplo replicable del problema de smallworldness

library(igraph)
library(igraphdata)
# library(sand)
library(qgraph)
library(dplyr)

# dado un grafo no conectado , me caga el " smallworldness",
# porque por default le pone conectedness FALSE. lo que hace que pondere muy pesadamente los desconectados.

# paso 1: levantar grafo no conectado

data(package="igraphdata")

# carga data
data(kite)
# verificar conectado
igraph::is_connected(kite)
# ver data
plot(kite)

# ver los edges
E(kite)
# seleccinar el que voy a borrar
edge_delete <- E(kite)[17]

# borrar el deseado
kite_unconected <- kite %>% delete_edges(edge_delete)
# verificar desconectado
igraph::is_connected(kite_unconected)
# ver data
plot(kite_unconected)

# paso 2: verificar smallworldness

# paso 2-a: verificar smallworldness grafo conectado
smallworldness_res_kite <- qgraph::smallworldness(kite)
smallworldness_res_kite_df <- data.frame(nombres=names(smallworldness_res_kite),
                                         valores=smallworldness_res_kite,
                                         row.names = 1:length(smallworldness_res_kite))

igraph::transitivity(kite)
igraph::mean_distance(kite) # average path lenght
igraph::mean_distance(kite,directed = FALSE,unconnected = FALSE)

# paso 2-b: verificar smallworldness grafo no conectado
smallworldness_res_unc_kite <- qgraph::smallworldness(kite_unconected)
smallworldness_res_unc_kite_df <- data.frame(nombres=names(smallworldness_res_unc_kite),
                                         valores=smallworldness_res_unc_kite,
                                         row.names = 1:length(smallworldness_res_unc_kite))

igraph::transitivity(kite_unconected)
igraph::mean_distance(kite_unconected) # average path lenght
igraph::mean_distance(kite_unconected,directed = FALSE,unconnected = FALSE)

# paso 3: observar diferencias


# Load packages
library(tidyverse)
library(fBasics)
library(plotly)
library(sf)
library(urbnmapr)
library(reshape2)
# Read data
inc <- read_csv("incarceration_trends.csv")

# Select variables of interest
my_dat <- inc %>%
  select(
    state, year, total_jail_pop, land_area, black_jail_pop_rate,
    white_jail_pop_rate, latinx_jail_pop_rate, native_jail_pop_rate,
    urbanicity
  )

## Summary statistics
summ <- basicStats(my_dat[, -c(1, 2, 9)])[c(3, 4, 7, 8, 13:16), ]
t_summ <- as.data.frame(t(round(summ, 3)))
names(t_summ) <- c("Min", "Max", "Mean", "Med", "Var", "St.dev", "Skew", "Kurt")

t_summ

# Generate dataframe for average population by year. Select top 10 yrs
dat1 <- my_dat %>%
  group_by(year) %>%
  summarise(Avg.Pop = mean(total_jail_pop, na.rm = T)) %>%
  arrange(desc(Avg.Pop)) %>%
  head(10)
dat1

# Generate dataframe for average population by state. Select top 10 states
dat2 <- my_dat %>%
  group_by(state) %>%
  summarise(Avg.Pop = mean(total_jail_pop, na.rm = T)) %>%
  arrange(desc(Avg.Pop)) %>%
  head(10)
dat2

# Generate dataframe for average population by year
df1 <- inc %>%
  dplyr::select(
    white_jail_pop, black_jail_pop, native_jail_pop, latinx_jail_pop,
    other_race_jail_pop, year
  ) %>%
  dplyr::rename(
    White = "white_jail_pop", Black = "black_jail_pop",
    Native = "native_jail_pop", Latin = "latinx_jail_pop",
    Other = "other_race_jail_pop"
  ) %>%
  reshape2::melt(id = "year") %>%
  dplyr::group_by(year, variable) %>%
  summarise(Avg.Pop = mean(value, na.rm = T))

# Make plot
ggplot(df1, aes(x = year, y = Avg.Pop, color = variable)) +
  geom_line() +
  labs(
    x = "Year", y = "Average population", color = "Race",
    title = "Evolution of average incacerations over the years"
  ) +
  theme(plot.title = element_text(hjust = 0.5))

# Box plot
ggplot(my_dat, aes(
  x = urbanicity, y = log(total_jail_pop),
  fill = urbanicity
)) +
  geom_boxplot() +
  labs(
    x = "Region", y = "Log Total population",
    title = "Relationsip between region and total jail population"
  ) +
  theme(plot.title = element_text(hjust = 0.5))

# Geographic representation
df2 <- my_dat %>%
  group_by(state) %>%
  summarise(Avg.Pop = mean(total_jail_pop, na.rm = T)) %>%
  dplyr::rename(state_abbv = state)

spatial_data <- left_join(df2,
  get_urbn_map(map = "states", sf = TRUE),
  by = "state_abbv"
) %>%
  st_as_sf()

m <- ggplot() +
  geom_sf(spatial_data, mapping = aes(fill = log(Avg.Pop))) +
  geom_sf_text(
    data = get_urbn_labels(map = "states", sf = TRUE),
    aes(label = state_abbv), size = 2
  ) +
  scale_fill_distiller("Log Average Population", palette = "Spectral") +
  labs(title = "Average population by State", x = "Longitude", y = "Latitude") +
  theme(plot.title = element_text(hjust = 0.5))
ggplotly(m)


pt.color<- function(x,low=min(x,na.rm=T),high=max(x,na.rm=T),nvals=10) {
#+
# PURPOSE
# To provide color numbers for each point in x in the
# data-interval from low to high
# along a palette of colors (specified externally),
# one of nvals color numbers provided for length(x) points
# revised 2012.03.07
# -
npts = length(x)
ptcolor = vector(length=npts,mode="numeric")
hlrange = high-low
x = pmin(x,high)
x = pmax(x,low)
for (i in 1:npts) {
    ptcolor[i] = ((nvals-1)/hlrange)*(x[i] - low)+ 1
}
return(ptcolor)
}


##### 医学統計勉強会18第6回ロジスティック回帰分析　R code #####

### Low Infant Birth Weightデータの準備 ###

library(MASS)
data(birthwt)
head(birthwt, n=2)

birthwt2 <- birthwt[, -10]		# bwt: 出生体重を除く
birthwt2$race <- factor(birthwt2$race, label=c("white", "black", "other"))	# 因子型に変換し、水準のラベルを1, 2, 3から、white, black, otherに変更する。
birthwt2$ptl[birthwt2$ptl >= 1] <- "1+"		# ptl: 1以上の値を "1+" とする。
birthwt2$ftv[birthwt2$ftv >= 1] <- "1+"		# ftv: 1以上の値を "1+" とする。
head(birthwt2, n=2)

attach(birthwt2)	# birthwt2に含まれる変数を、個別に扱えるようにする。

### 連続説明変数の要約 ###
summary(age)
summary(lwt)

sd(age); IQR(age)
sd(lwt); IQR(lwt)

## boxplot ##
boxplot(age ~ low)
p <- t.test(age ~ low)$p.value	# Welch's t-test p-value
p <- round(p, 3)				# 小数点以下第3位まで四捨五入
boxplot(age ~ low, main="age", sub=paste("Welch's t-test p =", p))

boxplot(lwt ~ low)
p <- t.test(lwt ~ low)$p.value	# Welch's t-test p-value
p <- round(p, 3)				# 小数点以下第3位まで四捨五入
boxplot(lwt ~ low, main="lwt", sub=paste("Welch's t-test p =", p))

## scatter plot ##
plot(age, lwt)
x1 <- cov(age, lwt); x1 <- round(x1, 3)		# 共分散
x2 <- cor(age, lwt); x2 <- round(x2, 3)		# 相関係数
plot(age, lwt, pch = 16, sub=paste("cov =", x1, ": cor =", x2))

### 離散説明変数の要約 ###
tbl <- table(low, race)
print(tbl)
fisher.test(tbl)

tbl <- table(low, smoke)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ptl)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ht)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ui)
print(tbl)
fisher.test(tbl)

tbl <- table(low, ftv)
print(tbl)
fisher.test(tbl)

### logistic regression ###

fit <- glm(low ~ age + lwt + race + smoke + ptl + ht + ui + ftv, family=binomial, data=birthwt2)
summary(fit)

## 係数の信頼区間 ##
confint(fit)

## オッズ比の信頼区間 ##
exp(confint(fit))

## イベントの予測確率 ##
fit$fitted

### goodness of fit test for logistic regression ###

## Hosmer-Lemeshow検定 ##
install.packages("ResourceSelection")	# 初回のみ
library(ResourceSelection)
hl <- hoslem.test(low, fit$fitted, g=10)

## ROC曲線とAUC ##
library(pROC)
tbl.roc <- roc(low, fit$fitted)
plot(tbl.roc, print.auc=TRUE, print.thres=TRUE)				# ROC曲線の描画
opt.sp <- tbl.roc$sp[which.max(tbl.roc$se+tbl.roc$sp)]		# 最適な特異度
opt.se <- tbl.roc$se[which.max(tbl.roc$se+tbl.roc$sp)]		# 最適な感度
abline((opt.sp+opt.se), -1)		# 最適なカットポイントを通る45度線

## 変数選択 ##
library(MASS)
fit.aic1 <- stepAIC(fit, direction="backward")			# backward elimination #
summary(fit.aic1)

fit0 <- glm(low ~ 1, family=binomial, data=birthwt2)	# forward selection #
fit.aic2 <- stepAIC(fit0, direction="forward", scope=list(upper=fit, lower=fit0))
summary(fit.aic2)

fit.aic3 <- stepAIC(fit0, direction="both", scope=list(upper=fit, lower=fit0))	# both #
summary(fit.aic3)

### Generalized Additive Model ###
install.packages("mgcv")	# 初回のみ
library(mgcv)
fit.gam <- gam(low ~ s(age) + s(lwt) + race + smoke + ptl + ht + ui, family=binomial, data=birthwt2)
summary(fit.gam)

par(mfrow=c(1,2))
plot(fit.gam)

## additive model ##
fit.gam2 <- gam(lwt ~ s(age), family=gaussian, data=birthwt2)

summary(fit.gam2)

plot(age, lwt)

ord <- order(age)

lines(age[ord], fit.gam2$fitted[ord], col="red", lwd=2)

fit.lm <- lm(lwt ~ age, data=birthwt2)

summary(fit.lm)

lines(age[ord], fit.lm$fitted[ord], col="green", lwd=2)


insertionsort <- function(x)
{
   for(i in 2:(length(x)))
   {
      value <- x[i]
      j <- i - 1
      while(j >= 1 && x[j] > value)
      {
         x[j+1] <- x[j]
         j <- j-1
      }
      x[j+1] <- value
   }
   x
}
insertionsort(c(4, 65, 2, -31, 0, 99, 83, 782, 1)) # -31   0   1   2   4  65  83  99 782


 ZGERQF Example Program Results

 Minimum-norm solution
 ( -2.8501,  6.4683) (  1.6264, -0.7799) (  6.9290,  4.6481) (  1.4048,  3.2400)


### Make climate data

## Specify randomness parameter
set.seed(11)

## Create fake climate variables
MAT <- c(rnorm(1000, mean = 18, sd=3),rnorm(1000, mean = 22, sd=3))
MAP <- c(rbinom(1000, size = 20, prob=0.05)*rnorm(1000,mean=5, sd=3), rbinom(1000, size = 20, prob=0.05)*rnorm(1000,mean=20, sd=4))
TMN <- c(rnorm(1000, mean = -8, sd=2),rnorm(1000, mean = -5, sd=4))
TMX <- c(rnorm(1000, mean = 38, sd=3),rnorm(1000, mean = 34, sd=2))

## create population change
pop1Rt <- c(rnorm(1000, mean=-0.2, sd=0.5),rnorm(1000, mean=0.2, sd=0.5))
pop2Rt <- c(rnorm(1000, mean=-0.4, sd=0.5),rnorm(1000, mean=0.4, sd=0.5))
pop3Rt <- c(rnorm(1000, mean=-0.2, sd=1),rnorm(1000, mean=0.2, sd=1))
pop4Rt <- c(rnorm(1000, mean=-0, sd=0.5),rnorm(1000, mean=0, sd=0.5))

## Make dataframe
climate <- data.frame(MAT, MAP, TMN, TMX)
population <- data.frame(Pop1 = pop1Rt, Pop2 = pop2Rt,Pop3 = pop3Rt,Pop4 = pop4Rt)

futureClimate <- data.frame(MAT = rnorm(10000, mean = 16, sd=3),
           MAP = rbinom(10000, size = 20, prob=0.05)*rnorm(2000,mean=12, sd=3),
           TMN = rnorm(10000, mean = -4, sd=3),
           TMX = rnorm(10000, mean = 35, sd=3))

MAP <- c(rbinom(1000, size = 20, prob=0.05)*rnorm(1000,mean=5, sd=3), rbinom(1000, size = 20, prob=0.05)*rnorm(1000,mean=20, sd=4))
TMN <- c(rnorm(1000, mean = -8, sd=2),rnorm(1000, mean = -5, sd=4))
TMX <- c(rnorm(1000, mean = 38, sd=3),rnorm(1000, mean = 34, sd=2))


height <- c(172,190,180,167,165,150,187,192,189,155)
weight <- c(68,76,70,65,65,57,75,78,77,59)

model <- lm(formula = weight ~ height)

newdata <- data.frame(
  height = c(168, 162, 177), stringsAsFactors = FALSE)

predictedWeights = predict(model, newdata)

print(predictedWeights)


rm(list=ls())
####################################################
### Functions
####################################################
installIfAbsentAndLoad <- function(neededVector) {
  for(thispackage in neededVector) {
    if( ! require(thispackage, character.only = T) )
    { install.packages(thispackage)}
    require(thispackage, character.only = T)
  }
}
##############################
### Load required packages ###
##############################

needed <- c('tree','randomForest', "gbm", "glmnet")
installIfAbsentAndLoad(needed)
time_start <- Sys.time()
##############################
######### Load Data ##########
##############################
set.seed(1)
data <- read.csv('data/train_enhanced.csv', header =T, stringsAsFactors = FALSE)
data <- data[,2:8]
data$feature_1  <- factor(data$feature_1)
data$feature_2 <- factor(data$feature_2)
data$feature_3 <- factor(data$feature_3)
n <- nrow(data)
train.indices <- sample(n, .8 * n)
data2 <- data
train_data2 <- data2[train.indices,]
test_data2 <- data2[-train.indices,]
data$first_active_month <- as.factor(data$first_active_month)
y <- data$target

data <- model.matrix(target~., data)[,-4]
data <- scale(data)
data <- data[,-1]

train_data <- as.data.frame(data[train.indices,])

train.y <- y[train.indices]
train_data <- data.frame(train_data, target = train.y)
test_data <- as.data.frame(data[-train.indices,])
test.y <- y[-train.indices]
test_data <- data.frame(test_data, target=test.y)
train_n <- nrow(train_data)

#######################################
####            Lasso              ####
#######################################
set.seed(5082)

grid = 10 ^ seq(10, -3, length=100)
mod.lasso <- glmnet(train.x, train.y, alpha=1, lambda=grid)
cv.out.class <- cv.glmnet(train.x, train.y, alpha=1, lambda=grid) # evaluate performance
bestlam <- cv.out.class$lambda.min # find best lambda
lasso.pred.class <- predict(mod.lasso,
                            s=bestlam,
                            newx=test.x,
                            type="class")

# RMSE
table(test.y, lasso.pred.class)
rmse.lasso <- sqrt(mean((test.y - lasso.pred.class)^2))
rmse.lasso
# rmse: 3.847178
lasso.coefficients <- predict(mod.lasso,
                              s=bestlam,
                              type="coefficients")[1:83,]
lasso.coefficients

#######################################
####            Ridge              ####
#######################################
set.seed(5082)

grid = 10 ^ seq(10, -3, length=100)
mod.ridge <- glmnet(train.x, train.y, alpha=0, lambda=grid)
cv.out.class <- cv.glmnet(train.x, train.y, alpha=0, lambda=grid) # evaluate performance
bestlam <- cv.out.class$lambda.min
ridge.pred.class <- predict(mod.ridge,
                            s=bestlam,
                            newx=test.x,
                            type="class")

# RMSE
table(test.y, ridge.pred.class)
rmse.ridge <- sqrt(mean((test.y - ridge.pred.class)^2))
rmse.ridge
#rmse: 3.847511
ridge.coefficients <- predict(mod.ridge,
                              s=bestlam,
                              type="coefficients")[1:83,]
ridge.coefficients

####################################################################
# Multiple Linear Regression
set.seed(1)
RMSE = function(m, o){
  sqrt(mean((m - o)^2))
}
test_data2 <- test_data2[test_data2$first_active_month != "2018-02",]
# Linear regression fit using features 1, 2, 3, Avg_purchase_amount, count_merchants, and first_active_month
lm.fit=lm(target~feature_1+feature_2+feature_3+Avg_purchase_amount+count_merchants+first_active_month,data=train_data2)

# Polynomial terms for the Avg_purchase amount and count_merchants
'''
poly_degrees <- c(1,2,3,4)
for (i in poly_degrees){
  for (j in poly_degrees){
      lm.poly=lm(target~feature_1+feature_2+feature_3+poly(Avg_purchase_amount,i)+poly(count_merchants,j)+first_active_month,data=train_data2)
      y_preds=predict(lm.poly, newdata=test_data2)
      print(paste("Average Purchase Degree: ",i))
      print(paste("Count Merchant Degree: ", j))
      print(RMSE(y_preds, test_data2$target))
  }
}'''
# lowest RMSE: 3.846742 with Avg_Purchase_amount degree 1 and count_merchants degree 4

# Interaction terms between the three features
lm.fit.12=lm(target~feature_1*feature_2+feature_3+Avg_purchase_amount+count_merchants+first_active_month,data=train_data2)
lm.fit.13=lm(target~feature_1*feature_3+feature_2+Avg_purchase_amount+count_merchants+first_active_month,data=train_data2)
lm.fit.23=lm(target~feature_2*feature_3+feature_1+Avg_purchase_amount+count_merchants+first_active_month,data=train_data2)

# Predict

y_preds <- predict(lm.fit, newdata=test_data2)
y_preds.12 <- predict(lm.fit.12, newdata=test_data2)
y_preds.13 <- predict(lm.fit.13, newdata=test_data2)
y_preds.23 <- predict(lm.fit.23, newdata=test_data2)

# Calculate RMSE

RMSE(y_preds, test_data2$target)
RMSE(y_preds.12, test_data2$target)
RMSE(y_preds.13, test_data2$target)
RMSE(y_preds.23, test_data2$target)

# interaction term between feature_2 and feature_3 did the best at 3.847453

# Combination of best polynomial and best interaction features
lm.fit.combo=lm(target~feature_2*feature_3+feature_1+Avg_purchase_amount+poly(count_merchants,4)+first_active_month,data=train_data2)
y_preds.combo=predict(lm.fit.combo, newdata=test_data2)
RMSE(y_preds.combo, test_data$target) # RMSE of 3.846591

# Best Model:
time_start <- Sys.time()
lm.fit.combo=lm(target~feature_2*feature_3+feature_1+Avg_purchase_amount+poly(count_merchants,4)+first_active_month,data=train_data2)
y_preds.combo=predict(lm.fit.combo, newdata=test_data2)
RMSE(y_preds.combo, test_data2$target) # RMSE of 3.846591
time_out <- Sys.time()
print(time_out - time_start)

############################
###### Random Forests ######
############################

# create a triple nested for loop to evaluate different parameters
num_trees <- c(5000, 10000, 15000)
shrinkage <- c(.1, .01, .001)
depth <- c(2, 4, 6)
matrix <- data.frame()
counter <- 0
'''
for ( n in num_trees){
  for (s in shrinkage){
    for(i in depth){
      boosted_rf <- gbm(target~., data = train_data, distribution="gaussian", n.trees=n, interaction.depth=i, shrinkage = s)
      y_preds <-predict(boosted_rf,newdata=test_data,n.trees=n)
      error <- mean((y_preds-test_data$target)^2)
      matrix <- rbind(matrix, c(error, n, s, i))
      counter <- counter + 1
      print(counter)
    }
  }
}
'''
# lines 66- 70 is to save the RMSE's of the models above in a csv file
#matrix[which.min(matrix[,1]),]
#RMSEs <- sqrt(matrix[,1])
#matrix$RMSEs <- RMSEs
#colnames(matrix) <- c("MeanSquaredError","Num_Trees","Learning_Rate",'Depth','RMSEs')
#write.csv(matrix, "data/Boosted_RF_errors.csv")

# bring in the file we wrote out to earlier
forest_data <- read.csv("data/Boosted_RF_errors.csv")
# then get the best model
best_forest <- forest_data[which.min(forest_data$RMSEs),]
# run it again
best_rf <- gbm(target~., data = train_data, distribution="gaussian",
               n.trees=best_forest$Num_Trees,
               interaction.depth=best_forest$Depth,
               shrinkage = best_forest$Learning_Rate)
y_preds <-predict(best_rf,newdata=test_data,n.trees=best_forest$Num_Trees)
error <- sqrt(mean((y_preds-test_data$target)^2))
error
summary(best_rf)


# Definir o diretório
setwd('C:/Users/Nina/Desktop/Data-Science-R/files')
getwd()

# libs necessárias

library(tseries) #Manipular ST (Trapletti and Hornik, 2017)
library(tidyverse)
library(dplyr)
library(readxl)
library("TTR")
library(forecast)
library(lmtest)
library(FitAR)
library(randtests)
library(seasonalview)

#Leitura da base de dados

df <-
  read.csv(
    'base.csv',
    sep = "," ,
    dec = ',',
    header = T,
    stringsAsFactors = FALSE
  )

# Análise explorátoria
summary(df$volume)

# Realizar a transformaÃ§Ã£o dos dados

df$data <- as.Date(df$data, format = "%d/%m/%Y")
df$volume <- as.numeric(df$volume)

# Converter em uma série, importante especificar quando começa e a frequência
tsData = ts(df, start = c(2018,1), frequency = 12)
plot(tsData)

tsData

# # Teste de Cox-Stuart - Verifica-se hÃ¡ tendencia
cox.stuart.test(tsData)
runs.test(tsData)

timeseriescomponents <- decompose(tsData)
plot(timeseriescomponents)

#Gráfico de Autocorrelação e Autocorrelação Parcial da série
par(mfrow=c(1,2))
print(acf(df))
print(pacf(df))
Modelo

fitARIMA <- arima(tsData, order=c(1,0,0),seasonal = list(order = c(1,0,0), period = 12),method="ML")
library(lmtest)
coeftest(fitARIMA)

confint(fitARIMA)

# Plotar os residuos
tsdiag(fitARIMA)
plot(fitARIMA$residuals)

#Teste de hipótese dos parâmetros
library(lmtest)
coeftest(modelo)
par(mfrow=c(1,2))

coeftest(modelo)
par(mfrow=c(1,2))
#Gráfico de Autocorrelação e Autocorrelação Parcial dos resíduos
acf(residuals(modelo))
pacf(residuals(modelo))

#Projeção N passos para frente
library(forecast)
(projecao <- forecast(modelo, h=5))


# Reading in Data
ds = read.csv('Social_Network_Ads.csv')
ds = ds[, 3:5]

# Scaling and splitting
library(caTools)
ds[,1:2] = scale(ds[,1:2])
ds$Purchased = factor(ds$Purchased, levels = c(0,1))

split = sample.split(ds$Purchased, SplitRatio = 0.75)
train = subset(ds, split == TRUE)
test = subset(ds, split == FALSE)

# Classifier
library(randomForest)
clf = randomForest(x = train[-3], y = train$Purchased, ntree = 500)
y_pred = predict(clf, newdata=test[-3])

# Confusion matrix
cm = table(test[, 3], y_pred)

# Plot
library('ElemStatLearn')
set = train
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')

y_grid = predict(clf, newdata=grid_set)

plot(set[, -3],
     main = 'Random forest classifier',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))


#
# # modified to get quantile function
# # this code is not efficient but should be OK for case of
# #  pair-copulas all permutation symmetric
#
# # Different copula family for each edge
# # nsim = #replications or sample size
# # parvec = vector of parameters to be optimized in nllk
# # A = dxd vine array with 1:d on diagonal
# # ntrunc = truncated level, assume >=1
# # pcondmat = matrix of names of conditional cdfs for trees 1,...,ntrunc
# #  (assuming only one needed for permutation symmetric pair-copulas)
# # qcondmat = matrix of names of conditional quantile functions for
# #        trees 1,...,ntrunc
# #   pcondmat and qcondmat are empty for diagonal and lower triangle,
# #    and could have ntrunc rows or be empty for rows ntrunc+1 to d-1
# # np = dxd where np[ell,j] is #parameters for parameter th[ell,j]
# #   for pair-copula in tree ell, variables j and A[ell,j]
# #   np=0 on and below diagonal
# # iinv=T to check that this is inverse of rvinepcond()
# #    in this case, columns of pmat come from rvinepcond()
# # iinv=F, get quantiles C_{d|1:(d-1)}(p|u[1:(d-1)]) based on last column of
# #       pmat[,d] where u[1],..,u[d-1] have been previously converted to
# #       u[1], C_{2|1}(u[2]|u[1]), ... C_{d-1|1:(d-2)}(u[d-1]|u[1:(d-2)])
# #       via rvinepcond()
# ## Output: nsim x d matrix with values in (0,1) or
# #        quantile C_{d|1...d-1}(p| u1,...,u[d-1])
# #rvinesimvec2=function(nsim,A,ntrunc,parvec,np,qcondmat,pcondmat,iprint=F)
# temrvineqcond=function(pmat,A,ntrunc,parvec,np,qcondmat,pcondmat,iinv=F)
# { d=ncol(A)
#   # get matrix ip1,ip2 of indices
#   ii=0
#   ip1=matrix(0,d,d); ip2=matrix(0,d,d)
#   for(ell in 1:ntrunc)
#   { for(j in (ell+1):d)
#     { ip1[ell,j]=ii+1; ip2[ell,j]=ii+np[ell,j]
#       ii=ii+np[ell,j]
#     }
#   }
#   #if(iprint) { print(ip1); print(ip2) }
#   out=varray2M(A)
#   M=out$mxarray
#   icomp=out$icomp
#   #p=matrix(runif(nsim*d),nsim,d)
#   p=pmat
#   nsim=nrow(p)
#   qq=array(0,c(nsim,d,d)); v=array(0,c(nsim,d,d))
#   u=matrix(0,nsim,d)
#   u[,1]=p[,1]; qq[,1,1]=p[,1]; qq[,2,2]=p[,2];
#   qcond=match.fun(qcondmat[1,2])
#   u[,2]=qcond(p[,2],p[,1],parvec[ip1[1,2]:ip2[1,2]])
#   qq[,1,2]=u[,2]
#   if(icomp[1,2]==1)
#   { #pcond=match.fun(pcondnames[1])
#     pcond=match.fun(pcondmat[1,2])
#     v[,1,2]=pcond(u[,1],u[,2],parvec[ip1[1,2]:ip2[1,2]])
#   }
#   # the main loop
#   for(j in 3:d)  # variable
#   { tt=min(ntrunc,j-1)
#     qq[,tt+1,j]=p[,j]
#     if(tt>1)
#     { for(ell in seq(tt,2)) # tree
#       { if(A[ell,j]==M[ell,j]) { s= qq[,ell,A[ell,j]] }
#         else { s=v[,ell-1,M[ell,j]] }
#         #qcond=match.fun(qcondnames[ell])
#         qcond=match.fun(qcondmat[ell,j])
#         qq[,ell,j]=qcond(qq[,ell+1,j], s, parvec[ip1[ell,j]:ip2[ell,j]]);
#       }
#     }
#     #qcond=match.fun(qcondnames[1])
#     qcond=match.fun(qcondmat[1,j])
#     qq[,1,j]=qcond(qq[,2,j],u[,A[1,j]], parvec[ip1[1,j]:ip2[1,j]])
#     u[,j]=qq[,1,j]
#     # set up for next iteration (not needed for last j=d)
#     #pcond=match.fun(pcondnames[1])
#     pcond=match.fun(pcondmat[1,j])
#     v[,1,j]=pcond(u[,A[1,j]],u[,j],parvec[ip1[1,j]:ip2[1,j]])
#     if(tt>1)
#     { for(ell in 2:tt)
#       { if(A[ell,j]==M[ell,j]) { s=qq[,ell,A[ell,j]] }
#         else { s=v[,ell-1,M[ell,j]] }
#         if(icomp[ell,j]==1)
#         { #pcond=match.fun(pcondnames[ell])
#           pcond=match.fun(pcondmat[ell,j])
#           v[,ell,j]=pcond(s, qq[,ell,j], parvec[ip1[ell,j]:ip2[ell,j]]);
#         }
#       }
#     }
#   }
#   if(iinv) u=u[,d]
#   u
# }
#
# #============================================================
#
# library(CopulaModel)
# source("hjcondvine.R")
# d=5
# np=matrix(1,d,d)
# ntrunc=4
# udat=matrix(c(.1,.2,.3,.4,.5, .6,.7,.8,.9,.5),2,5,byrow=T)
# parvec=c(2,2,2,2,1.5,1.5,1.5,1.2,1.2,1.1)
# D5=Dvinearray(d)
# pcondmat=matrix("pcondgum",d,d)
# qcondmat=matrix("qcondgum",d,d)
#
# pmatd=rvinepcond(parvec,udat,D5,ntrunc,pcondmat,np)
# print(pmatd)
#
# #rvineqcond=function(pmat,A,ntrunc,parvec,np,qcondmat,pcondmat,iprint=F)
#
# qmatd=temrvineqcond(pmatd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd) # same as udat
#
# q5=temrvineqcond(pmatd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5)
# # [1] 0.5 0.5
# pnewd=pmatd; pnewd[,d]=0.9
# q5b=temrvineqcond(pnewd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5b)
# # [1] 0.5227173 0.8994989
#
# # direct approach
# ntrunc=4
# pcond=pcondgum
# qcond=qcondgum
# parm=matrix(0,d,d) # format of parameter for vine
# ii=0;
# for(ell in 1:ntrunc)
# { for(j in (ell+1):d)
#   { parm[ell,j]=parvec[ii+1]
#     ii=ii+1
#   }
# }
#
# # compared with specific case for dvine
# pdchk=udat
# pdchk[,2]=pcond(udat[,2],udat[,1],parm[1,2])
# tem12=pcond(udat[,1],udat[,2],parm[1,2])
# tem32=pcond(udat[,3],udat[,2],parm[1,3])
# pdchk[,3]=pcond(tem32,tem12,parm[2,3])
# tem1g23=pcond(tem12,tem32,parm[2,3])
# tem23=pcond(udat[,2],udat[,3],parm[1,3])
# tem43=pcond(udat[,4],udat[,3],parm[1,4])
# tem4g23=pcond(tem43,tem23,parm[2,4])
# pdchk[,4]=pcond(tem4g23,tem1g23,parm[3,4])
# tem1g234=pcond(tem1g23,tem4g23,parm[3,4])
# tem34=pcond(udat[,3],udat[,4],parm[1,4])
# tem54=pcond(udat[,5],udat[,4],parm[1,5])
# tem5g34=pcond(tem54,tem34,parm[2,5])
# tem2g34=pcond(tem23,tem43,parm[2,4])
# tem5g234=pcond(tem5g34,tem2g34,parm[3,5])
# pdchk[,5]=pcond(tem5g234,tem1g234,parm[4,5])
# # quantiles at .9
# p=rep(.9,2)
# s2=qcond(p,tem1g234,parm[4,5])
# s3=qcond(s2,tem2g34,parm[3,5])
# s4=qcond(s3,tem34,parm[2,5])
# s5=qcond(s4,udat[,4],parm[1,5])
# print(s5)
# # 1] 0.5227173 0.8994989
#
# #============================================================
#
# # truncated vines
#
# # ntrunc=2
# pmatd2=rvinepcond(parvec,udat,D5,2,pcondmat,np)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.7430672 0.76377507
# #[2,]  0.6 0.7328919 0.8830648 0.9508236 0.08757126
# qmatd2=temrvineqcond(pmatd2,D5,2,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd2) # same as udat
# q52=temrvineqcond(pmatd2,D5,2,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q52)
# # [1] 0.5 0.5
# pnewd=pmatd2; pnewd[,d]=0.9
# q52b=temrvineqcond(pnewd,D5,2,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q52b)
# # [1] 0.6190225 0.9281953
#
# # ntrunc=1
# pmatd1=rvinepcond(parvec,udat,D5,1,pcondmat,np)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.5364857 0.5842195 0.63198274
# #[2,]  0.6 0.7328919 0.7951641 0.8831572 0.08282512
# qmatd1=temrvineqcond(pmatd1,D5,1,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd1) # same as udat
# q51=temrvineqcond(pmatd1,D5,1,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q51)
# # [1] 0.5 0.5
# pnewd=pmatd1; pnewd[,d]=0.9
# q51b=temrvineqcond(pnewd,D5,1,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q51b)
# # [1] 0.7332716 0.9529803
#


# ==============================================================================
# ==============================================================================
#		 SCRIPTS TO GENERATE SOME OF MY \new GRAPHICS IN R
# ==============================================================================
# ==============================================================================

# DATASETS
# 	TIME (EFFORT)
	NormalityT<-c(-69,-64,-43,-35,-30,-25,-22,-12,-9,-9,-9,-7,-3,-2,1,5,9,17,18,19,20,25,3,40,46)
	GraphicT<-c(24,24,28,28,29,30,30,30,31,33,35,38,38,44,45,46,46,46,53,58,61,70,74,90,102)
	TextualT<-c(21,23,25,29,30,30,31,32,35,36,40,40,43,44,47,50,50,55,55,55,67,74,93,93,171)
# 	FSCORE (EFFECTIVENESS)
	NormalityFS<-c(-6.95,-6.37,-5.29,-3.80,-2.53,-2.52,-2.51,-1.49,-1.41,0.82,1.39,1.46,1.71,1.73,1.80,2.51,3.91,3.92,3.94,4.42,4.95,5.10,6.62,6.96,8.43)
	GraphicFS<-c(68.66,73.17,73.81,76.92,78.65,78.65,79.12,79.49,80.41,80.43,80.46,81.08,81.32,81.58,82.98,83.33,83.78,83.87,86.02,86.60,87.23,87.23,87.80,89.16,91.67)
	TextualFS<-c(69.47,71.29,71.70,73.12,77.11,77.78,78.72,81.25,82.47,82.57,83.87,84.62,84.71,85.33,85.37,86.08,86.32,86.42,87.06,87.76,88.31,88.89,89.16,89.74,91.14)

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

# DISTRIBUTION
#	TIME (EFFORT)
	qqnorm(NormalityT,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityT, col=4, lwd=2,lty=1)
#	FSCORE (EFFECTIVENESS)
	qqnorm(NormalityFS,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityFS, col=4, lwd=2,lty=1,)

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

# BOXPLOT
#	TIME (EFFORT)
	boxplot(GraphicT, TextualT, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Time (minutes)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)
#	FSCORE (EFFECTIVENESS)
	boxplot(GraphicFS, TextualFS, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Percentage (%)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)

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

# 	+ PLOTS
	qqnorm(NormalityT,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityT, col=4, lwd=2,lty=1)
	qqnorm(NormalityFS,main=NULL, xlab = "",ylab = "",cex = 2, pch = 1,cex.lab= 1.5, cex.axis= 1.5)
	qqline(NormalityFS, col=4, lwd=2,lty=1,)
	boxplot(GraphicT, TextualT, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Time (minutes)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)
	boxplot(GraphicFS, TextualFS, col=(c("darkgreen","darkorange")), names=c("Graphical Treatment","Textual Treatment"), ylab="Percentage (%)", cex=1.5, cex.lab= 1.5, cex.axis= 1.5, outline=FALSE)


set.seed(1234)
ind <- sample(2, nrow(iris),replace=TRUE, prob=c(0.7,0.3))
trainData <- iris[ind==1,]
testData <- iris[ind==2,]
library(party)
myFormula <- iris$Species ~ iris$Sepal.Length + iris$Sepal.Width + iris$Petal.Length + iris$Petal.Width
iris_ctree <- ctree(myFormula, data=trainData)
testPred <- predict(iris_ctree, newdata = testData)

print(iris_ctree)
plot(iris_ctree,type="simple")


# Installing the important packages:

#install.packages("missForest")
#install.packages("caret")
#install.packages("caret")
#install.packages("e1071")

library(missForest)     # Imputing the missing values from dataset
library(caret)          # Using Caret package (for models)
library(randomForest)   # Dependeny for random forest regression
library(e1071)          # to support the other packages

# Importing the data:

train <- read.csv("housing_data.csv")

#Store sales_price as another variable:
SalePrice = train$SalePrice
train$SalePrice = NULL

#***************************************
#****** Missing Value Imputation *******
#***************************************

missing <- sort(sapply(train ,function(x) sum(is.na(x))  ) , decreasing = T)
missing[missing>0]

?missForest # See the help to know more about the imputation:
imputed_data <- missForest(xmis = train, maxiter = 10, ntree = 100,mtry = floor(sqrt(ncol(train))))

train_no_missing <- imputed_data$ximp
head(train_no_missing)
dim(train_no_missing)

# Let's check the presence of missing value again:

missing <- sort(sapply(train_no_missing ,function(x) sum(is.na(x))  ) , decreasing = T)
missing[missing>0]

# Create dummy variables:
dummies <- dummyVars(~., data = train_no_missing)

train_no_missing_2 <- data.frame(predict(dummies, newdata = train_no_missing))
train_no_missing_3 <- cbind(train_no_missing_2, SalePrice)

#***************************************
#***********1. Linear Model  ***********
#***************************************

lm_model <- train(SalePrice~., data=train_no_missing_3, method="lm",metric="RMSE",
                  maximize=FALSE,trControl=trainControl(method = "repeatedcv",number = 10))

lm_model
### Verify accuracy
lm_model$results

#***************************************
#************ 3.Random Forest **********
#***************************************

rf_model <- train(SalePrice~., data=train_no_missing_3,method="rf",metric="RMSE",
                  maximize=FALSE,trControl=trainControl(method="repeatedcv",number=5),
                  tuneGrid=expand.grid(mtry = c(5)), importance = T, allowParallel = T, prox = T)

#  Verify accuracy
rf_model$results

#Take a look at contribution of each variable to make prediction
varImp(rf_model)

#**********************************************
#******** 3.Comparing the two models **********
#**********************************************

rf_model$results
lm_model$results


library(ggplot2)
library(caret)
library(rpart)
library(randomForest)
library(e1071)

setwd("/media/sanjeed/Mine/OSDSM/Introduction to data science/datasci_course_materials/assignment5")

#Step 1:  Read and summarize the data
heisenberg <- read.csv("seaflow_21min.csv")
summary(heisenberg)

#Step2: Split the data into test and training sets
splitHeisenberg <- function(dataFrame) {
  dataIndex = createDataPartition(dataFrame$cell_id+dataFrame$file_id, p = 0.7, list = FALSE, times=1)
  train <- heisenberg[dataIndex,]
  test <- heisenberg[-dataIndex,]
  list(trainingSet=train, testSet=test)
}

dataSplit = splitHeisenberg(heisenberg)
training = dataSplit$trainingSet
test = dataSplit$testSet

# Question 3: mean time of training set
mean(training$time)

#Step3:Plot the data
plot = ggplot(training, aes(pe, chl_small))
plot + geom_point() + geom_point(aes(color = pop))

testPlot = ggplot(heisenberg, aes(pe, chl_small))
testPlot + geom_point() + geom_point(aes(color = pop))

#Step 4: Train a decision tree.
# Question 5: what populations, if any, is the tree *incapable* of measuring?
# (Hint: look for the one that's not listed.)
# Question 6: Verify there's a threshold on PE learned in the model.
# Question 7: Based on the tree, which variables appear most important
fol <- formula(pop ~ fsc_small + fsc_perp + fsc_big + pe + chl_big + chl_small)
decision_tree <- rpart(fol, method = 'class', data = training)
print(decision_tree)

# Question 8: Decision tree prediction.
decision_pd <- predict(decision_tree, newdata = test, type ='class')
decision_result <- decision_pd == test$pop
summary(decision_result)

#Step 6: Build and evaluate a random forest.
rf_model <- randomForest(fol, data = training)
rf_pd <- predict(rf_model, newdata = test, type ='class')
decision_result <- rf_pd == test$pop
summary(decision_result)

# Question 10: which varibles appear most important in terms of gini
# impurity measure
importance(rf_model)

#Step 7: Train a support vector machine model and compare results.
svm_model <- svm(fol, data = training)
svm_pd <- predict(svm_model, newdata = test)
decision_result <- svm_pd == test$pop
summary(decision_result)

#Step 8: Construct confusion matrices
table(pred=decision_pd, true=test$pop)
table(pred=rf_pd, true=test$pop)
table(pred=svm_pd, true=test$pop)

#Step 9: Sanity check the data
# Question 13: We assumed variables were continuous.  One of them has a
# lot of clustering.
plot(heisenberg$chl_big, heisenberg$chl_small)
plot(heisenberg$fsc_big, heisenberg$fsc_small)
plot(heisenberg$fsc_perp, heisenberg$pe)

# Question 14: Remove File 208 from the mix and run the SVM again.
# What's the change in accuracy
plot(heisenberg$chl_big, heisenberg$time)
dataset2 = subset(heisenberg, heisenberg$file_id != 208)
resample = splitHeisenberg(dataset2)
training_set = resample$training
test_set = resample$test

svm_model <- svm(fol, data = training_set)
svm_pd <- predict(svm_model, newdata=test_set)
svm_result <- svm_pd == test_set$pop
summary(svm_result)
table(pred=svm_pd, true= test_set$pop)

Intro to Data Science /Assignment-5/assignment5.r


# Spiral 2-dimensional data set
# Ref: http://cs231n.github.io/neural-networks-case-study/

args <- commandArgs(trailingOnly = TRUE)

n = as.numeric(args[1])
n = if(is.na(n)){100}else{n}

th = function(k){ seq(k*4,(k+1)*4,length=n) + rnorm(n)*0.2}
r = seq(0,1,length=n)
z = function(k) { cbind(r*sin(th(k)),r*cos(th(k))) }
z0 = z(0)
z1 = z(1)
z2 = z(2)
plot(z0,col="red",xlim=c(-1,1),ylim=c(-1,1))
points(z1,col="green")
points(z2,col="blue")
s = c(rep(1,n),rep(2,n),rep(3,n))
z_all = rbind(z0,z1,z2)
m = cbind(s==1,s==2,s==3,z_all)
write.table(m, 'spiral.csv',row.names=F, col.names=F,sep=',')


source("examples/example.r")

# Compare true density to samples collected from an MCMC chain.
# Also show the samples by iteration and the autocorrelation function.
#
# g: true density function
# samples: vector of samples from a density g
plot.chain <- function(g,samples) {
  par(mfrow=c(1,3))#,mar=c(2,1,1,1))
  window <- .01
  xs <- seq(min(samples),max(samples),window)
  hist(samples, breaks=20, probability=TRUE,main="")
  lines(xs,g(xs)/sum(g(xs))/window,lwd=2)
  plot(samples, type="l")
  acf(samples)
}

# Plot of the samples from the R code and the julia code.
fns <- list(g,h)
for (i in c("g","h")) {   # target densities
  chains <- c(paste("examples/results/r.slice.",i,".dat",sep=""),
              paste("examples/results/slice.",i,".dat",sep=""),
              paste("examples/results/mh.",i,".dat",sep=""))
  f <- get(i)
  for (chain in chains) { # methods
    samples <- read.csv(chain)[,1]
    png(paste(chain,".png",sep=""),width=1000,height=300)
    plot.chain(f,samples)
    dev.off()
  }
}

# Plots for multivariate example.
f <- function(x,y) x^2 * exp(-x*y^2 - y^2 + 2*y - 4*x)
xs <- seq(0,3,by=.01)
ys <- seq(-1,2,by=.01)
truth <- matrix(0,length(xs),length(ys))
for (i in 1:length(xs)) {
  for (j in 1:length(ys)) {
    truth[i,j] <- f(xs[i],ys[j])
  }
}

samples_gibbs <- read.csv("examples/multivariate/gibbs.dat",header=FALSE)
samples_hmc <- read.csv("examples/multivariate/hmc.dat",header=FALSE)
samples_slice <- read.csv("examples/multivariate/slice.dat",header=FALSE)
png("examples/multivariate/compare.png",width=1000,height=300)
xlims <- c(0,3)
ylims <- c(-1,2)
par(mfrow=c(1,3))
image(xs,ys,truth)
plot(samples_gibbs[1:1000,],xlim=xlims,ylim=ylims,xlab="Gibbs",ylab="")
plot(samples_slice[1:1000,],xlim=xlims,ylim=ylims,xlab="Slice",ylab="")
#plot(samples_hmc[1:1000,],xlim=xlims,ylim=ylims,xlab="HMC",ylab="")
#acf(samples_slice)
dev.off()

png("examples/multivariate/trace.png",width=500,height=500)
par(mfrow=c(2,2))
plot(samples_gibbs[1:1000,1],type="l",xlab="Iteration",ylab="Gibbs sampling x",ylim=xlims)
plot(samples_slice[1:1000,1],type="l",xlab="Iteration",ylab="Slice sampling x",ylim=xlims)
plot(samples_gibbs[1:1000,2],type="l",xlab="Iteration",ylab="Gibbs sampling y",ylim=ylims)
plot(samples_slice[1:1000,2],type="l",xlab="Iteration",ylab="Slice sampling y",ylim=ylims)
dev.off()


#Teste Shapiro é importante para verificar se os dados segue a distribuição normal, ou seja, Gaussiana.
# Se os dados segue essa distribuição, portanto os dados serão simétricos e a média = mediana = moda

# Pasta do Trabalho

setwd("C:/Users/Nina/Desktop/Machine Learning- R")

# Instalar e ler a biblioteca
#install.packages("dplyr")
#install.packages("readxl")
library(dplyr)
library(readxl)

# Leitura do dataset

dados<- read_excel("dataset/consulta.xlsx", sheet = 1)

# Visualização dos dados em uma janela separada

View(dados)

# Função que resume as variáveis se são inteiras, float e etc..

glimpse(dados)

# Uma das Variáveis é fator , no entanto no teste de shapiro, as variáveis precisa ser númericas.
# Para confirmar utilizo a função "Sapply"

i<- sapply(dados, is.factor)

# Nesta expressão transforma as listas em dados númericos com o uso da função "lapply"

dados[i]<-lapply(dados[i], as.numeric)

# Realizo o Teste Shapiro

# É importante entender que no Teste Shapiro
# A Hipótese Nula (H0) = Se o p-value > nível de significância , então a distribuição é normal
# A Hipótese Alternativa (H1) = Se o p value < nível de significância , então a distribuição não é normal

# Nível de significância = 0.05

shapiro.test(dados$Idade)
shapiro.test(dados$Attend)

# Gráfico de Histograma
# É importante a visualização deste gráfico, pois podemos analisar grandes assimetrias, descontinuidade de dados
# e também picos multimodais. Assim identificando que não é um padrão de distribuição normal.

hist(dados$Idade,  main = "Histograma Idade", xlab = "Idade", ylab = "Frequência absoluta",
                   col  = c("blue"), lables = TRUE)
hist(dados$Attend, main = "Histograma Attend", xlab = "Attend", ylab = "Frequência absoluta",
                   col  = c("violet"), labels = TRUE)


## ----load packages, echo = FALSE-----------------------------------------
library(tidyverse)
library(lubridate)
library(gapminder)

## ----select a subset of the observations---------------------------------
load(here::here("data/french_fries.rda"))
french_fries %>%
    filter(subject == 3, time == 1)

## ----order the observations----------------------------------------------
french_fries %>%
    arrange(desc(rancid)) %>%
    head

## ----select a subset of the variables------------------------------------
french_fries %>%
    select(time, treatment, subject, rep, potato) %>%
    head

## ----summarize observations into one-number statistic--------------------
french_fries %>%
    summarise(mean_rancid = mean(rancid, na.rm=TRUE),
              sd_rancid = sd(rancid, na.rm = TRUE))

## ----summarise and group_by----------------------------------------------
french_fries %>%
    group_by(time, treatment) %>%
    summarise(mean_rancid = mean(rancid), sd_rancid = sd(rancid))

## ----checking design completeness----------------------------------------
french_fries %>%
  group_by(subject) %>%
  summarize(n = n())

## ----counts for subject by time------------------------------------------
french_fries %>%
  na.omit() %>%
  count(subject, time) %>%
  spread(time, n)

## ----do scores change over time, fig.show='hide'-------------------------
ff.m <- french_fries %>%
  gather(type, rating, -subject, -time, -treatment, -rep)
ggplot(data=ff.m, aes(x=time, y=rating, colour=treatment)) +
  geom_point() +
  facet_grid(subject~type)

## ----get means over reps, and connect the dots, fig.show='hide'----------
ff.m.av <- ff.m %>%
  group_by(subject, time, type, treatment) %>%
  summarise(rating=mean(rating))

ggplot(data=ff.m, aes(x=time, y=rating, colour=treatment)) +
  facet_grid(subject~type) +
  geom_line(data=ff.m.av, aes(group=treatment))

## ----first look at gapminder data----------------------------------------
library(gapminder)
ggplot(data=gapminder,
       aes(x=year, y=lifeExp, group=country)) +
  geom_line()

## ----using models as exploratory tools, echo=FALSE, fig.width=6.5, fig.height=5----
library(dplyr)
library(tidyr)
library(purrr)

gapminder2 <- gapminder %>% mutate(year = year-1950)
by_country <- gapminder2 %>%
  group_by(continent, country) %>%
  nest()

by_country <- by_country %>% mutate(
    model = purrr::map(data, ~ lm(lifeExp ~ year, data = .))
)

by_country <- by_country %>% unnest(model %>% purrr::map(broom::tidy))
country_coefs <- by_country %>% select(continent, country, term, estimate) %>% spread(term, estimate)

p <- ggplot(data=country_coefs, aes(x=`(Intercept)`, y=year, colour=continent, label=country)) +
  geom_point() +
  scale_colour_brewer(palette="Dark2") +
  xlab("Average Life Expectancy in 1950") +
  ylab("Average Gain in Life Expectancy per Year")
plotly::ggplotly(p)

## ----start with a single country-----------------------------------------
usa <- gapminder %>% filter(country=="United States")
head(usa)

## ----life expectancy in the U.S. since 1950------------------------------
ggplot(data=usa, aes(x=year, y=lifeExp)) +
  geom_point() +
  geom_smooth(method="lm")

## ------------------------------------------------------------------------
usa.lm <- lm(lifeExp~year, data=usa)
usa.lm

## ------------------------------------------------------------------------
gapminder <- gapminder %>% mutate(year = year-1950)

## ----nesting data--------------------------------------------------------
by_country <- gapminder %>% group_by(continent, country) %>% nest()
head(by_country)

## ----fitting multiple models---------------------------------------------
by_country$model <- by_country$data %>% purrr::map(~lm(lifeExp~year, data=.))
head(by_country)

## ----broom again---------------------------------------------------------
broom::tidy(by_country$model[[1]])

## ----extract all countries automatically---------------------------------
by_country$coefs <- by_country$model %>% purrr::map(broom::tidy)
by_country

## ----get the coefficients into one data set------------------------------
by_country_coefs <- by_country %>% unnest(coefs)
by_country_coefs

## ----and finally a visualization-----------------------------------------
coefs <- by_country_coefs %>%
  select(country, continent, term, estimate) %>%
  spread(term, estimate)
ggplot(data=coefs, aes(x=`(Intercept)`, y=year, colour=continent)) +
  geom_point()


library(tidyverse)
library(FactoMineR)
library(factoextra)
library(ggplot2)

names <- read.csv("/Users/glmarschmann/.julia/dev/DEBmicroTrait/files/isolates_name.csv")
dat <- read.csv("/Users/glmarschmann/.julia/dev/DEBmicroTrait/files/isolates_pca.csv")
rownames(dat) <- names[,1]
colnames(dat) <- c("Genome size", "Minimum generation time", "RRN", "Total transporters", "Sugars", "Auxins", "Fatty acids", "Nucleotides", "Amino acids", "Organic acids", "GHs", "SAV", "Response")
pca.res <- PCA(dat, quali.sup = c(13), scale.unit = TRUE, graph = FALSE)
summary(pca.res)

p <- fviz_pca_biplot(pca.res,
             geom.ind = c("text"), labelsize=3, # show points only (nbut not "text")
             col.ind = dat$Response, # color by groups
             palette = c("#bd5e8b", "#007100", '#525252'),
             addEllipses = FALSE, # Concentration ellipses
             pointshape = 15, pointsize = 3,
             geom.var = c("arrow", "point", "text"), col.var="black", alpha.var=0.3, repel=TRUE,
             title="", show.legend=FALSE, xlab="PC1 (31% contribution to total variance)", ylab="PC2 (17.7% contribution to total variance)")

p <- fviz_add(p, pca.res$quali.sup$coord, color = c("#bd5e8b", "#007100", '#525252'), labelsize=5, pointsize=1, repel=FALSE)
ggsave("/Users/glmarschmann/.julia/dev/DEBmicroTrait/plots/IsolatesPCA.png", width=5.5, height=5.5)
#ggsave("/Users/glmarschmann/.julia/dev/DEBmicroTrait/first_manuscript/plots/IsolatesPCA.eps", width=5.5, height=5.5)


univariate_analysis = function(data, output, adjusted_method = 'BH')
{
  #=== Installing missing packages ===
  package_list = c('pROC')
  for (package in package_list)
  {
    if (!require(package, character.only = TRUE)){install.packages(package, repos = 'https://cloud.r-project.org/')}
    library(package, character.only = TRUE)
  }
  #=== Preprocess data ===
  data <- as.data.frame(sapply(data[, !colnames(data) == 'Output'], as.numeric))
  output <- as.factor(output)
  #=== Statistical analysis ===
  pvalue_list = list()
  diag_perf = data.frame()
  rets <- c("specificity", "sensitivity", "accuracy")
  for (n_feature in 1:dim(data)[2])
  {
    if (length(unique(output))==2)
    {
      test_results <- wilcox.test(data[[n_feature]] ~ output)
    }else{test_results <- kruskal.test(data[[n_feature]] ~ output)}
    pvalue_list[[n_feature]] = test_results$p.value
    rocc <- roc(output, data[[n_feature]], quiet = TRUE)
    ROC_results <- coords(rocc, x="best", input = "threshold", ret=rets, best.method = "closest.topleft", transpose = TRUE)
    diag_perf[n_feature, 1] = as.numeric(rocc$auc)
    if (is.null(dim(ROC_results)) != TRUE)
    {
      diag_perf[n_feature, 2] = ROC_results['sensitivity', ][ROC_results['accuracy', ] == max(ROC_results['accuracy', ])]
      diag_perf[n_feature, 3] = ROC_results['specificity', ][ROC_results['accuracy', ] == max(ROC_results['accuracy', ])]
      diag_perf[n_feature, 4] = ROC_results['accuracy', ][ROC_results['accuracy', ] == max(ROC_results['accuracy', ])]
    }
    else
    {
      diag_perf[n_feature, 2] = ROC_results[['sensitivity']]
      diag_perf[n_feature, 3] = ROC_results[['specificity']]
      diag_perf[n_feature, 4] = ROC_results[['accuracy']]
    }
  }
  adjusted_pvalue_list <- p.adjust(pvalue_list, method = adjusted_method)
  colnames(diag_perf) <- c("AUC", "Specificity", "Sensitivity", "Accuracy")
  final_df = data.frame("pvalue" = unlist(pvalue_list), "adjusted p_value"=unlist(adjusted_pvalue_list),"AUC"=diag_perf$AUC,
                        "Sensitivity"=diag_perf$Sensitivity, "Specificity"=diag_perf$Specificity, "Accuracy"=diag_perf$Accuracy,
                        row.names = colnames(data))
  return(final_df)
}


source('ifm_func.r')

# Strategy B - countertrend trading:
# Long-term moving average is 17-day zero lag exponential moving average (ZLEMA)
# of closing price of the given stock, while short-term moving average is 9-day.
# When short-term moving average crosses below long-term moving average (death
# cross), we buy in at opening price on the next day, and then hold to sell out
# at opening price on the following day when short-term moving average crosses
# above long-term moving average (golden cross).
strategy <- function(stock) {
    # Strategy.
    LMA_DAYS_N <- 17
    SMA_DAYS_N <- 9
    M_START <- LMA_DAYS_N + 1

    # Prepare data.
    opp <- Op(stock) # [op]en [p]rices
    clp <- Cl(stock) # [cl]ose [p]rices
    lmap <- ZLEMA(clp, n=LMA_DAYS_N) # [l]ong-term [m]oving [a]verage [p]rices
    smap <- ZLEMA(clp, n=SMA_DAYS_N) # [s]hort-term [m]oving [a]verage [p]rices
    yesterday <- nrow(stock) - 1

    # Execute the strategy.
    pl <- setNames( rep( 0, length(clp) ), time(stock) )
    is_bought <- FALSE
    for (m in M_START:yesterday) {
        if ( !is_bought
          && as.numeric( smap[m-1] ) >  as.numeric( lmap[m-1] )
          && as.numeric( smap[m]   ) <= as.numeric( lmap[m]   ) ) {
            bought <- long( as.numeric( opp[m+1] ) )
            is_bought <- TRUE
        }
        else if ( is_bought
               && as.numeric( smap[m-1] ) <  as.numeric( lmap[m-1] )
               && as.numeric( smap[m]   ) >= as.numeric( lmap[m]   ) ) {
            pl[m] <- -bought + short( as.numeric( opp[m+1] ) )
            is_bought <- FALSE
        }
    }

    # Return [p]rofit-[l]oss.
    return(pl)
}


=begin
[((<index-ja|URL:index-ja.html>))]

= AlgebraicExtensionField
((*(代数拡大体)*))

代数拡大体を表現するクラス

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

== スーパークラス:

* ((|ResidueClassRing|))

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

なし。

== 関連するメソッド:

--- Algebra.AlgebraicExtensionField(field, obj){|x| ... }
    ((<::create>)) と同じ。

== クラスメソッド:

--- ::create(k, obj){|x| p(x) }
    体 ((|k|)) を、((|obj|)) で表される変数 ((|x|)) の多項式
    ((|p(x)|)) で拡大した環 ((|k[x]/(p(x))|))を返します。
    この環には、クラスメソッド ((<::var>))、((<::def_polys>))、
    ((<::env_ring>)) が定義されます。

    例: 有理数を方程式 (({x**2 + x + 1 == 0})) で拡大した体 F を作る。
      require "rational"
      require "algebraic-extension-field"
      F = Algebra::AlgebraicExtensionField.create(Rational, "x") {|x| x**2 + x + 1}
      x = F.var
      p( (x-1)** 3 / (x**2 - 1) ) #=> -3x - 3

--- ::to_ary
    (({[self, var]})) を返します。

    例: 代数拡大体と添加元を同時に定義する
      require "rational"
      require "algebraic-extension-field"
      F, a = Algebra.AlgebraicExtensionField(Rational, "a") {|a| a**2 + a + 1}

--- ::var
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、
    この剰余環における ((|x|)) で
    代表される剰余類を返します。

--- ::modulus
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、((|k[x]|))
    の要素 ((|p(x)|))  を返します。

--- ::def_polys
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、
    長さ ((|n|)) の各 ((<::modulus>)) の配列を返します。
    ここで、自身は、基礎体 ((|k0|)) 上高さ ((|n|)) の
    再帰的な ((|AlgebraicExtensionField|)) であるとします。

    例: 基礎体を有理数とし、2, 3, 5 の立方根による拡大体を作る
      require "algebra"
      # K0 == Rational
      K1 = AlgebraicExtensionField(Rational, "x1") { |x|
        x ** 3 - 2
      }
      K2 = AlgebraicExtensionField(K1, "x2") { |y|
        y ** 3 - 3
      }
      K3 = AlgebraicExtensionField(K2, "x3") { |z|
        z ** 3 - 5
      }

      p K3.def_polys #=> [x1^3 - 2, x2^3 - 3, x3^3 - 5]

      x1, x2, x3 = K1.var, K2.var, K3.var
      f = x1**2 + 2*x2**2 + 3*x3**2
      f0 = f.abs_lift

      p f0.type     #=> (Polynomial/(Polynomial/(Polynomial/Rational)))
      p f0.type == K3.env_ring #=> true

      p f #=> 3x3^2 + 2x2^2 + x1^2
      p f0.evaluate(x3.abs_lift, x2.abs_lift, x1.abs_lift)
          #=> x3^2 + 2x2^2 + 3x3^2

--- ::env_ring
    ((<::create>)) の返り値 ((|k[x]/(p(x))|)) に定義され、
    多変数多項式環 ((|k0[x1, x2,.., xn]|)) を返します。
    ここで、自身は、基礎体 ((|k0|)) 上高さ ((|n|)) の
    再帰的な ((|AlgebraicExtensionField|)) であるとします。

--- ::ground
    剰余環のもとになる多項式環 ((|k[x]|)) を返します。

== メソッド
--- abs_lift
    ((<::env_ring>)) すなわち基礎体 ((|k0|)) 上
    の多変数多項式環 ((|k0[x1, x2,.., xn]|))
    へのリフトを返します。

--- [](n)
    ((<n>)) 次の係数を返します。(({lift[n]})) と同じです。

    例: Fibonacci 数列
      require "algebra"
      t = AlgebraicExtensionField(Integral, "t"){|x| x**2-x-1}.var
      (0..10).each do |n|
        p( (t**n)[1] ) #=> 0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55
      end

=end


# Pvec if the vector of probabilities predicted by your model
# Cvec is the vector of 0's and 1's indicating the realized
# classifications of each observation.

ROCPlot <- function(Pvec,Cvec,Plot=T,Add=F) {
  NHam <- sum(Cvec==0)
  NSpam <- sum(Cvec==1)
  PvecS <- unique(sort(Pvec))
  x <- rep(NA,length(PvecS))
  y <- rep(NA,length(PvecS))
  for(i in 1:length(PvecS)) {
    x[i] <- sum(Pvec>=PvecS[i]&Cvec==0)/NHam
    y[i] <- sum(Pvec>=PvecS[i]&Cvec==1)/NSpam
  }
  x <- c(0,x,1)
  y <- c(0,y,1)
  ord <- order(x)
  x <- x[ord]
  y <- y[ord]

  AUC <- sum((x[2:length(x)]-x[1:(length(x)-1)])*(y[2:length(y)]+y[1:(length(y)-1)])/2)

  if(Add) {
    plot(x,y,type="l",xlim=c(0,1),ylim=c(0,1),xlab="P( classified + | Is - )",ylab="P( classified + | Is + )")
    title("ROC Curve")
    mtext(paste("AUC =",round(AUC,3)),side=3,line=0.5)
    abline(0,1)
    par(pty="m")
  } else {
    if(Plot) {
      par(pty="s")
      plot(x,y,type="l",xlim=c(0,1),ylim=c(0,1),xlab="P( classified + | Is - )",ylab="P( classified + | Is + )")
      title("ROC Curve")
      mtext(paste("AUC =",round(AUC,3)),side=3,line=0.5)
      abline(0,1)
      par(pty="m")
    }
  }

  invisible(list(x=c(0,x,1),y=c(0,y,1),AUC=AUC))
}


john_z <- function(x, parms) {
    ## transform x values to z which is normally distributed if Johnson distribution
    ## x can be one value or a set of values
    ## parms is the set of parameters from SuppDists::JohnsonFit on the entire dataset
    u <- (x - parms$xi) / parms$lambda
    type <- parms$type
    if (type == 'SU') {
        ## unbounded distribution
        fu <- u + (1 + u^2)^0.5
    } else if (type == 'SL') {
        ## log normal
        fu <- u
    } else if (type == 'SB') {
        ## bounded distribution
        fu <- u / (1-u)
    } else if (type == 'SN') {
        ## normal distribution
        fu <- exp(u)
    } else {
        cat('\n')
        cat('#####################################\n')
        cat('  ERROR IN JOHNSON_TOL         \n')
        cat('  no type returned from fit attempt  \n')
        cat('#####################################\n')
        print(jparms)
        ## stop()
    }
    ## z is normally distributed
    z    <- parms$gamma + parms$delta * log(fu)
    return(z)
}


library(survival)
options(warn=-1)

Args<-commandArgs()
in_file<-Args[6]
out_textfile<-Args[7]
out_summary<-Args[8]

data<-read.table(in_file, header=T, com='', sep="\t")
data$Time <- as.numeric(as.character(data$Time))
s<-Surv(data$Time, data$Status == 1)
km <- survfit(s~(data$Value), conf.type = "log-log")
sm = summary(km, censored=T)
m <- cbind(sm$time, sm$surv, gsub("data\\$Value=", "", as.character(sm$strata)), sm$n.event, sm$n.censor)
values = unique(data$Value)
if (length(values) == 1)
	m[,3] <- as.character(values[1])
#summary(km)$n.censor
write.table(m, out_textfile, sep="\t", row.names=FALSE, col.names=FALSE, quote=F)

sink(out_summary)
res <- tryCatch({
			diff <- survdiff(s~(data$Value))
			pvalue <- 1 - pchisq(diff$chisq, length(diff$n) - 1)
			cat(paste("pvalue", pvalue, sep="\t"))
			cat("\n")
		}, error= function(e){
			cat(paste("pvalue", "NA", sep="\t"))
			cat("\n")
		})

for (i in values) {
	cat(paste(i,length(which(data$Value==i)), sep="\t"))
	cat("\n")
}
sink()
#svg(out_file)
#plot(km, xlab="Time ( Days )",ylab="Probability of survival",lty = 1:1,lwd=3:3, col=c("red","blue"))
#group = c(paste("High (", hight_num, ")"), paste("Low (", low_num, ")"))
#legend("topright", legend=unique(group), col=c("red","blue"), lty = 1:1,lwd=3:3, horiz=FALSE, bty='n')
#title(main=paste("Exp-cutoff =  ", cutoff, " ; p-value = ",  pvalue))
#dev.off()


### Illustrates the piece-wise linear approximation of the cumulative distribution using constant size bins
fade = rgb(0,0,0,alpha=0.5)
dot.size = 0.7
n = 10000
set.seed(5)

pdf("linear-interpolation.pdf", width=6, height=2.7, pointsize=10)
layout(matrix(c(1,2),byrow=T, ncol=2), widths=c(1.1,1))
u = sort(runif(n))
x = log(1-u)
x = sort(x)
F = ((0:(n-1))+0.5)/n
par(mar=c(2.5,3,0.5,1))
plot(x, F, cex=dot.size, pch=21, bg=fade, col=NA, type='b', xlim=c(-9,-4.5), ylim=c(0,0.01), xaxt='n', ylab=NA, mgp=c(1,0.5,0), xlab=NA)

axis(side=1, at=-10:-1, labels=NA)
title(xlab='x', line=0.8, cex.lab=1.5)
title(ylab='q', line=1.5, cex.lab=1.5)

left.end = x[1] - (x[2]-x[1])

lines(c(left.end, x[100]), c(0, 0.01), lwd=2)
lines(c(left.end, left.end), c(-0.0005, 0.0005), lt=1, col='black', lwd=0.5)
lines(c(x[100], x[100]), c(0.0085, 0.015), lt=1, col='black', lwd=0.5)
text(-7, 0.006, "100")

###text(-5, 0.4, adj=0, "Constant size bins result in large")
###text(-5, 0.35, adj=0, "errors at extreme quantiles")

par(mar=c(2.5,1.5,0.5,1))

plot(x, F, cex=dot.size, pch=21, bg=fade, col=NA, type='b', xlim=c(-9,-4.5), ylim=c(0,0.01), yaxt='n', xaxt='n')
axis(side=1, at=-10:-1, labels=NA)
axis(side=2, at=(0:6)/10, labels=NA)
title(xlab='x', line=0.8, cex.lab=1.5)
title(ylab='q', line=2, cex.lab=1.5)

q.to.k = function(q) {
    (asin(2*q-1)/pi + 1/2)
}

k.to.q = function(k,compression) {
    sin(k/compression*pi - pi/2)/2 + 0.5
}

weights = c(2, 8, 19, 35, 56, 81, 111)
q.bin = cumsum(c(0, weights)/n)

i.bin = c(1, cumsum(weights)+1)
i.right = i.bin-1
i.right = i.right[i.right > 0]
m = length(i.right)
i.bin = i.bin[1:m]

x.bin = c(left.end, (x[i.right[1:(m-1)]] + x[i.bin[2:m]])/2)
F.bin = (i.bin-1) / n
lines(x.bin, F.bin, lwd=2)
dy = 0.0005
for (i in 1:m) {
    x.text = (x[i.bin[i]] + x[i.right[i]])/2
    y.text = (F.bin[i] + F.bin[i+1])/2
    x.offset = 0.3 * y.text
    y.offset = dy * (1 + 500*y.text)
    x.pos = x.text - x.offset
    y.pos = y.text + y.offset
    lines(c(x.bin[i],x.bin[i]), c(F.bin[i]-dy+0.000, F.bin[i]+dy+y.offset*0.6-0.0005), lt=1, lwd=0.5, col='black')
    text(x.text - x.offset, y.text + y.offset, i.right[i]-i.bin[i]+1)
}
###text(-5, 0.35, adj=0, "Variable size bins keep errors")
###text(-5, 0.3, adj=0, "small at extreme quantiles")

dev.off()


# diagnoses-per-patients-frequency

### summarise the frequency of unique diagnoses across patients

library(tidyverse) #for packages dplyr

# create a small example dataframe with just one column
df1 <- data_frame( patient = c(1,1,1,2,2,2,3,3,3,4,5,5),
                   diagnosis = c('a','b','c','d','d','e','f','f','f','g','h','i'))

# count diagnoses per patient using dplyr
# key part is 'group_by()'
df2 <- df1 %>%
  group_by(patient) %>%
  summarize(n_diagnoses = length(unique(diagnosis)))

# proportion of patients with each number of diagnoses
# count counts the number of patients with each number of diagnoses (& names it n_patients)
# mutate & prop.table create a new column containing the proportions
df3 <- df2 %>%
  count(n_diagnoses, name='n_patients') %>%
  mutate(propn=prop.table(n_patients))

df3

# n_diagnoses n_patients propn
# 1           2          0.4
# 2           2          0.4
# 3           1          0.2


iris2 <- iris
iris2$Species <- NULL
kmeans.result <- kmeans(iris2,3)
plot(iris2[c("Sepal.Length","Sepal.Width")], col = kmeans.result$cluster)
points(kmeans.result$centers[,c("Sepal.Length","Sepal.Width")],col=1:3,pch=8,cex=2)