###########################################################################
## RDROBUST R Package
## Do-file for Empirical Illustration
## Authors: Sebastian Calonico, Matias D. Cattaneo, Max H. Farrell and Rocio Titiunik
###########################################################################
### Clear R environment
rm(list=ls(all=TRUE))
setwd("C:/Users/scalonico/Dropbox/2018/rdrobust/R")

### Install R library
### NOTE: depending on your system, you may need to do it as root
#install.packages('rdrobust')

### Load RDROBUST package
library(rdrobust)

### Load data base
rdrobust_senate <- read.csv("rdrobust_senate.csv")
attach(rdrobust_senate)

### Summary stats
summary(rdrobust_senate)

### rdplot with 95% confidence intervals
rdplot(y=vote, x=margin, binselect="es", ci=95,
         title="RD Plot: U.S. Senate Election Data",
         y.label="Vote Share in Election at time t+2",
         x.label="Vote Share in Election at time t")

### rdplot with MSE-optimal choice
rdplot(y=vote, x=margin, binselect="es",
       title="RD Plot: U.S. Senate Election Data",
       y.label="Vote Share in Election at time t+2",
       x.label="Vote Share in Election at time t")

### rdplot with QS partitioning and mimicking variance choice
rdplot(y=vote, x=margin, binselect="qsmv",
       title="RD Plot: U.S. Senate Election Data",
       y.label="Vote Share in Election at time t+2",
       x.label="Vote Share in Election at time t")

### rdrobust
summary(rdrobust(y=vote, x=margin))

### rdrobust with all estimates
summary(rdrobust(y=vote, x=margin, all=TRUE))

## rdrobust backward compatibility
summary(rdrobust(y=vote, x=margin, h=16.79369, b=27.43745))

## rdplot to show rdrobust estimate
est <- rdrobust(y=vote, x=margin)
rdplot(y=vote, x=margin, subset=-est$h_l<= margin & margin <= est$h_r,
       binselect="esmv", kernel="triangular", h=c(est$h_l, est$h_r), p=1,
       title="RD Plot: U.S. Senate Election Data",
       y.label="Vote Share in Election at time t+2",
       x.label="Vote Share in Election at time t")

## rdrobust with covariates within the same window (i.e., using same bandwidths)
est1 <- rdrobust(y=vote, x=margin)
len1 <- est1$ci[3,2] - est1$ci[3,1]
est2 <- rdrobust(y=vote, x=margin, covs=cbind(class,termshouse,termssenate), h=c(est$h_l,est$h_r), b=c(est$b_l, est$b_r))
len2 <- est2$ci[3,2] - est2$ci[3,1]
paste("CI length change: ", round((len2/len1-1)*100,2), "%")

## rdrobust with covariates with data-driven optimal bandwidths
est1 <- rdrobust(y=vote, x=margin)
len1 <- est1$ci[3,2] - est1$ci[3,1]
est2 <- rdrobust(y=vote, x=margin, covs=cbind(class,termshouse,termssenate))
len2 <- est2$ci[3,2] - est2$ci[3,1]
paste("CI length change: ", round((len2/len1-1)*100,2), "%")

## rdrobust with useless covariate
est1 <- rdrobust(y=vote, x=margin)
len1 <- est1$ci[3,2] - est1$ci[3,1]
est2 <- rdrobust(y=vote, x=margin, covs=cbind(population))
len2 <- est2$ci[3,2] - est2$ci[3,1]
paste("CI length change: ", round((len2/len1-1)*100,2), "%")

## rdrobust check covariate "balanced"
covs <- cbind(class, termshouse, termssenate, population)
balance <- matrix(NA,4,2)
for (z in 1:ncol(covs)) {
  est <- rdrobust(y=covs[,z], x=margin)
  balance[z,1] = est$Estimate[,"tau.us"]
  balance[z,2] = est$pv[3]
}
rownames(balance) = c("class", "termshouse", "termssenate", "population")
colnames(balance) = c("RD Effect", "Robust p-val")
print(balance)

## rdrobust with clustering
summary(rdrobust(y=vote, x=margin, vce="nn", cluster=state))

## rdrobust with clustering and covariates, and different bandwidth
summary(rdrobust(y=vote, x=margin, vce="nn", bwselect="msetwo", covs=cbind(class,termshouse,termssenate), cluster=state))

## rdbwselect with all estimates
summary(rdbwselect(y=vote, x=margin, all=TRUE))

## Other examples
summary(rdrobust(y=vote, x=margin, kernel="uniform", vce="hc1", cluster=state))
summary(rdrobust(y=vote, x=margin, bwselect="certwo", vce="hc3"))
summary(rdrobust(y=vote, x=margin, h=c(12,15), b=c(18,20)))
summary(rdrobust(y=vote, x=margin, covs=cbind(class), bwselect="cerrd", scaleregul=0, rho=1))
summary(rdbwselect(y=vote, x=margin, kernel="uniform", vce="hc1", cluster=state, all=TRUE))
summary(rdbwselect(y=vote, x=margin, covs=cbind(class), bwselect="msetwo", vce="hc2", all=TRUE))


library(igraph)
#gg = graph.data.frame(d = Cit.HepPh, directed = T)
gg = graph.data.frame(d = smallsize, directed = T)
is.simple(gg)
gg = simplify(gg)
is.simple(gg)
dg = degree(gg)

dg_in = degree(gg,mode="in")
dg_out = degree(gg,mode="out")
plot(degree.distribution(gg,mode="in"), xlab="node degree")

par(mar = c(0, 0, 0, 0))
set.seed(23)

plot(gg, layout = layout.fruchterman.reingold,
     vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
     edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)


scrapedData <- read.table("scrape22.csv")

repCount <- scrapedData[1L,1L]
demCount <- scrapedData[2L,1L]
othCount <- scrapedData[3L,1L]
totCount <- repCount + demCount + othCount

repPercent <- as.integer((repCount/totCount*100) + 0.5)
demPercent <- as.integer((demCount/totCount*100) + 0.5)
othPercent <- as.integer((othCount/totCount*100) + 0.5)

if(repPercent + demPercent + othPercent != 100) {
    #fix it
}

pieLabels <- c(paste("Republicans: ", toString(repPercent), "%", sep = ""), paste("Democrats: ", toString(demPercent), "%", sep = ""), paste("Other: ", toString(othPercent), "%", sep = ""))

png("scrapedPie22.png", width = 2240L, height = 1920L)

pie(c(repCount, demCount, othCount), labels = pieLabels, col = c("red", "blue", "grey"), main = "Candidate Party Data by Percent", radius = 0.9, cex = 5L, cex.main = 5L)

dev.off()


# Get time with millisecond accuracy
options(digits.secs=6)

shinyServer(function(input, output, session) {

  all_values <- 100  # Start with an initial value 100
  max_length <- 80   # Keep a maximum of 80 values

  # Collect new values at timed intervals and adds them to all_values
  # Returns all_values (reactively)
  values <- reactive({
    # Set the delay to re-run this reactive expression
    invalidateLater(input$delay, session)

    # Generate a new number
    new_value <- isolate(last(all_values) *
      (1 + input$rate + runif(1, min = -input$volatility, max = input$volatility)))

    # Append to all_values
    all_values <<- c(all_values, new_value)

    # Trim all_values to max_length (dropping values from beginning)
    all_values <<- last(all_values, n = max_length)

    all_values
  })

  # Generate histogram
  output$plotout <- renderPlot({
    hist(values(), col = "#cccccc",
      main = paste("Last", length(values()), "values"),
      xlab = paste("Mean =", round(mean(values()), 1))
    )

    abline(v = mean(values()), col = "red", lwd = 2, lt = 2)
  })

  # Set the value for the gauge
  # When this reactive expression is assigned to an output object, it is
  # automatically wrapped into an observer (i.e., a reactive endpoint)
  output$live_gauge <- reactive({
    running_mean <- mean(last(values(), n = 10))
    round(running_mean, 1)
  })

  # Output the status text ("OK" vs "Past limit")
  # When this reactive expression is assigned to an output object, it is
  # automatically wrapped into an observer (i.e., a reactive endpoint)
  output$status <- reactive({
    running_mean <- mean(last(values(), n = 10))
    if (running_mean > 200)
      list(text="Past limit", gridClass="alert")
    else if (running_mean > 150)
      list(text="Warn", subtext = "Mean of last 10 approaching threshold (200)",
           gridClass="warning")
    else
      list(text="OK", subtext="Mean of last 10 below threshold (200)")
  })

  # Update the latest value on the graph
  # Send custom message (as JSON) to a handler on the client
  observe({
    session$sendCustomMessage(
      type = "updateHighchart",
      message = list(
        # Name of chart to update
        name = "live_highchart",
        # Send UTC timestamp as a string so we can specify arbitrary precision
        # (large numbers get converted to scientific notation and lose precision)
        x = sprintf("%15.3f", as.numeric(Sys.time()) * 1000),
        # Most recent value
        y0 = last(values()),
        # Smoothed value (average of last 10)
        y1 = mean(last(values(), n = 10))
      )
    )
  })

})

# Return the last n elements in vector x
last <- function(x, n = 1) {
  start <- length(x) - n + 1
  if (start < 1)
    start <- 1

  x[start:length(x)]
}


# from: http://www.psych.ualberta.ca/~phurd/cruft/g.test.r
#
# Log-likelihood tests of independence & goodness of fit
# Does Williams' and Yates' correction
# does Monte Carlo simulation of p-values, via gtestsim.c
#
# G & q calculation from Sokal & Rohlf (1995) Biometry 3rd ed.
# TOI Yates' correction taken from Mike Camann's 2x2 G-test fn.
# GOF Yates' correction as described in Zar (2000)
# more stuff taken from ctest's chisq.test()
#
# ToDo:
# 1) Beautify
# 2) Add warnings for violations
# 3) Make appropriate corrections happen by default
#
# V3.3 Pete Hurd Sept 29 2001. phurd@ualberta.ca

g.test <- function(x, y = NULL, correct="none",
  p = rep(1/length(x), length(x)), simulate.p.value = FALSE, B = 2000)
{
  DNAME <- deparse(substitute(x))
  if (is.data.frame(x)) x <- as.matrix(x)
  if (is.matrix(x)) {
    if (min(dim(x)) == 1)
      x <- as.vector(x)
  }
  if (!is.matrix(x) && !is.null(y)) {
    if (length(x) != length(y))
      stop("x and y must have the same length")
    DNAME <- paste(DNAME, "and", deparse(substitute(y)))
    OK <- complete.cases(x, y)
    x <- as.factor(x[OK])
    y <- as.factor(y[OK])
    if ((nlevels(x) < 2) || (nlevels(y) < 2))
      stop("x and y must have at least 2 levels")
    x <- table(x, y)
  }
  if (any(x < 0) || any(is.na(x)))
    stop("all entries of x must be nonnegative and finite")
  if ((n <- sum(x)) == 0)
    stop("at least one entry of x must be positive")
  #If x is matrix, do test of independence
  if (is.matrix(x)) {
    #Test of Independence
    nrows<-nrow(x)
    ncols<-ncol(x)
    if (correct=="yates"){ # Do Yates' correction?
      if(dim(x)[1]!=2 || dim(x)[2]!=2) # check for 2x2 matrix
        stop("Yates' correction requires a 2 x 2 matrix")
      if((x[1,1]*x[2,2])-(x[1,2]*x[2,1]) > 0)
        {
          x[1,1] <- x[1,1] - 0.5
          x[2,2] <- x[2,2] - 0.5
          x[1,2] <- x[1,2] + 0.5
          x[2,1] <- x[2,1] + 0.5
        }
      else
        {
          x[1,1] <- x[1,1] + 0.5
          x[2,2] <- x[2,2] + 0.5
          x[1,2] <- x[1,2] - 0.5
          x[2,1] <- x[2,1] - 0.5
        }
    }

    sr <- apply(x,1,sum)
    sc <- apply(x,2,sum)
    E <- outer(sr,sc, "*")/n
    # are we doing a monte-carlo?
    # no monte carlo GOF?
    if (simulate.p.value){
      METHOD <- paste("Log likelihood ratio (G-test) test of independence\n\t with simulated p-value based on", B, "replicates")
      tmp <- .C("gtestsim", as.integer(nrows), as.integer(ncols),
                as.integer(sr), as.integer(sc), as.integer(n), as.integer(B),
                as.double(E), integer(nrows * ncols), double(n+1),
                integer(ncols), results=double(B), PACKAGE= "ctest")
      g <- 0
      for (i in 1:nrows){
        for (j in 1:ncols){
          if (x[i,j] != 0) g <- g + x[i,j] * log(x[i,j]/E[i,j])
        }
      }
      STATISTIC <- G <- 2 * g
      PARAMETER <- NA
      PVAL <- sum(tmp$results >= STATISTIC)/B
    }
    else {
      # no monte-carlo
      # calculate G
      g <- 0
      for (i in 1:nrows){
        for (j in 1:ncols){
          if (x[i,j] != 0) g <- g + x[i,j] * log(x[i,j]/E[i,j])
        }
      }
      q <- 1
      if (correct=="williams"){ # Do Williams' correction
        row.tot <- col.tot <- 0
        for (i in 1:nrows){ row.tot <- row.tot + 1/(sum(x[i,])) }
        for (j in 1:ncols){ col.tot <- col.tot + 1/(sum(x[,j])) }
        q <- 1+ ((n*row.tot-1)*(n*col.tot-1))/(6*n*(ncols-1)*(nrows-1))
      }
      STATISTIC <- G <- 2 * g / q
      PARAMETER <- (nrow(x)-1)*(ncol(x)-1)
      PVAL <- 1-pchisq(STATISTIC,df=PARAMETER)
      if(correct=="none")
        METHOD <- "Log likelihood ratio (G-test) test of independence without correction"
      if(correct=="williams")
        METHOD <- "Log likelihood ratio (G-test) test of independence with Williams' correction"
      if(correct=="yates")
        METHOD <- "Log likelihood ratio (G-test) test of independence with Yates' correction"
    }
  }
  else {
    # x is not a matrix, so we do Goodness of Fit
    METHOD <- "Log likelihood ratio (G-test) goodness of fit test"
    if (length(x) == 1)
      stop("x must at least have 2 elements")
    if (length(x) != length(p))
      stop("x and p must have the same number of elements")
    E <- n * p

    if (correct=="yates"){ # Do Yates' correction
      if(length(x)!=2)
        stop("Yates' correction requires 2 data values")
      if ( (x[1]-E[1]) > 0.25) {
        x[1] <- x[1]-0.5
        x[2] <- x[2]+0.5
      }
      else if ( (E[1]-x[1]) > 0.25){
        x[1] <- x[1]+0.5
        x[2] <- x[2]-0.5
      }
    }
    names(E) <- names(x)
    g <- 0
    for (i in 1:length(x)){
      if (x[i] != 0) g <- g + x[i] * log(x[i]/E[i])
    }
    q <- 1
    if (correct=="williams"){ # Do Williams' correction
      q <- 1+(length(x)+1)/(6*n)
    }
    STATISTIC <- G <- 2*g/q
    PARAMETER <- length(x) - 1
    PVAL <- pchisq(STATISTIC, PARAMETER, lower = FALSE)
  }
  names(STATISTIC) <- "Log likelihood ratio statistic (G)"
  names(PARAMETER) <- "X-squared df"
  names(PVAL) <- "p.value"
  structure(list(statistic=STATISTIC,parameter=PARAMETER,p.value=PVAL,
            method=METHOD,data.name=DNAME, observed=x, expected=E),
            class="htest")
}


#getting site level means of NEON functional groups for forecast validation.
rm(list=ls())
library(runjags)
source('paths.r')

#set output.path----
plot.output.path <- NEON_plot.level_fg_obs.path
site.output.path <- NEON_site.level_fg_obs.path

#load data and format.----
d <- readRDS(NEON_taxa_fg.path)
fg.c <- d$abundances
fg.c <- fg.c[,!colnames(fg.c) %in% c('deprecatedVialID','other')]

#get y dependent matrix.----
y <- fg.c
y$geneticSampleID <- NULL
y <- as.matrix(y)
y <- y+1 #dirichlet doesn't like hard zeros because log-link.
y <- y/d$seq_total
other <- 1- rowSums(y)
y <- cbind(other,y)

#get core_plot, core_site, plot_site
core_plot <- substr(fg.c$geneticSampleID,1,8)
core_site <- substr(fg.c$geneticSampleID,1,4)
plot_site <- unique(core_plot)
plot_site <- substr(plot_site,1,4)

#jags data object.----
jd <- list(y=as.matrix(y), N.site = length(unique(plot_site)), N.plot =  length(plot_site), N.core = nrow(y), N.spp = ncol(y),
            core_plot = as.factor(core_plot), plot_site=as.factor(plot_site))

#jags model.----
jags.model = "
model {
  # Observations (single set per core):
  for(i in 1:N.core){
    y[i,1:N.spp] ~ ddirch(plot_mu[core_plot[i],1:N.spp] * core_alpha)
  }
  # Plot means:
  for(i in 1:N.plot){
    plot_mu[i,1:N.spp] ~ ddirch(site_mu[plot_site[i],1:N.spp] * plot_alpha)
  }

  # Site means:
  for(i in 1:N.site){
    site_mu[i,1:N.spp] ~ ddirch(priors[1:N.spp] * site_alpha)
  }

  # Priors:
  priors[1] <- 1
  for(s in 2:N.spp){
    priors[s] ~ dnorm(1,1E-3) I(0,)
  }
  site_alpha ~ dgamma(0.01, 0.01)
  plot_alpha ~ dgamma(0.01, 0.01)
  core_alpha ~ dgamma(0.01, 0.01)

}" #end jags model.

#run JAGS model in runjags.----
test <- run.jags(model = jags.model,
                 data = jd,
                 n.chains = 3,
                 monitor = c('core_alpha','plot_alpha','site_alpha','plot_mu','site_mu','priors'),
                 adapt = 1000,
                 burnin = 3500,
                 sample = 5000)

#get matrices of mean, upper and lower confidence intervals at plot and site level.----
#site level
site.out <- summary(test, var='site_mu')
mean.matrix <- matrix(site.out[,4], nrow = length(unique(plot_site)), ncol = ncol(y))
lo95.matrix <- matrix(site.out[,1], nrow = length(unique(plot_site)), ncol = ncol(y))
hi95.matrix <- matrix(site.out[,3], nrow = length(unique(plot_site)), ncol = ncol(y))

site.output.list <- list(mean.matrix, lo95.matrix, hi95.matrix)
names(site.output.list) <- c('mean','lo95','hi95')
#add row and column names
for(i in 1:length(site.output.list)){
  rownames(site.output.list[[i]]) <- unique(plot_site)
  colnames(site.output.list[[i]]) <- colnames(y)
}

#plot level
plot.out <- summary(test, var = 'plot_mu')
mean.matrix <- matrix(plot.out[,4], nrow = length(plot_site), ncol = ncol(y))
lo95.matrix <- matrix(plot.out[,1], nrow = length(plot_site), ncol = ncol(y))
hi95.matrix <- matrix(plot.out[,3], nrow = length(plot_site), ncol = ncol(y))

plot.output.list <- list(mean.matrix, lo95.matrix, hi95.matrix)
names(plot.output.list) <- c('mean','lo95','hi95')
#add row and column names
for(i in 1:length(plot.output.list)){
  rownames(plot.output.list[[i]]) <- unique(core_plot)
  colnames(plot.output.list[[i]]) <- colnames(y)
}

#DO THESE MODELS BALL-PARK FIT STRAIGHTFORWARD HIERARHCICAL MEANS?
#Fit doesn't need to be perfect and can be biased, just need to be ~linear.
#check if this is similar to just aggregating by site.
test.mu <- data.frame(core_plot,core_site, y)
k <- aggregate(. ~ core_site, FUN=mean, data = test.mu[,colnames(y)])
par(mfrow = c(2,ncol(site.output.list$mean)))
for(i in 1:ncol(site.output.list$mean)){
  plot(k[,i+1]/rowSums(k[,2:ncol(k)]) ~ site.output.list$mean[,i]);abline(0,1,lwd=2, col = 'purple')
  mtext(colnames(k)[i+1], side = 3)
}

#check if this is similar to just aggregating by plot.
k <- aggregate(. ~ core_plot, FUN=mean, data = test.mu[,colnames(y)])
for(i in 1:ncol(plot.output.list$mean)){
  plot(k[,i+1]/rowSums(k[,2:ncol(k)]) ~ plot.output.list$mean[,i]);abline(0,1,lwd=2, col = 'purple')
  mtext(colnames(k)[i+1], side = 3)
}

#save matrix list.----
saveRDS(site.output.list, site.output.path)
saveRDS(plot.output.list, plot.output.path)


# From Andy Bush <andy@kb4lsn.net>
require(rms)
set.seed(20)
x1<-10*runif(20,0,1)
y1<-c(rep(0,10),rep(1,10))
y2<-5*rnorm(20,0,1)

d<-data.frame(cbind(y1,y2,x1))
dd<-datadist(d)
options(datadist='dd')
flrm<-lrm(y1~x1,x=T,y=T,model=T)
nomlrm<-nomogram(flrm)
plot(nomlrm,xfac=.45)
fols<-ols(y2~x1,x=T,y=T,model=T)
nomols<-nomogram(fols)
plot(nomols,xfac=.45)

## From Zongheng Zhang zh_zhang1984@hotmail.com

n <- 1000    # sample size
set.seed(88) # set seed for replication
age<- rnorm(n, 65, 11)
lac<- round(abs(rnorm(n, 3, 1)),1)
sex<- factor(sample(1:2,n,prob=c(0.6,0.4),TRUE),
                      labels=c('male','female'))
shock<-factor(sample(1:4,n,prob=c(0.3,0.3,0.25,0.15),TRUE),
                labels=c('no','mild','moderate','severe'))
z<- 0.2*age + 3*lac* as.numeric(sex)+ 5*as.numeric(shock) -rnorm(n,36,15)
## linear combination with a bias

y <- ifelse(runif(n) <= plogis(z), 1, 0)
library(rms)
ddist <- datadist(age, lac, shock, sex)
options(datadist='ddist')
mod <- lrm(y ~ shock+lac*sex+age)
nom <- nomogram(mod,
        lp.at=seq(-3,4,by=0.5),
        fun=plogis,
        fun.at=c(.001,.01,.05,seq(.1,.9,by=.1),.95,.99,.999),
        funlabel="Risk of Death",
        conf.int=c(0.1, 0.7),
        abbrev=TRUE, #had not been working for shock
        minlength=1)

plot(nom, lplabel="Linear Predictor",
          fun.side=c(3,3,1,1,3,1,3,1,1,1,1,1,3),
          col.conf=c('red','green'),
          conf.space=c(0.1,0.5),
          label.every=3,
          col.grid = gray(c(0.8, 0.95)),
          which="shock")
legend.nomabbrev(nom, which='shock', x=.5, y=.5)


library(ape)

coalescent_rate <- function(k, pop_size) {
    0.25 * k * (k - 1) / pop_size
}

leaf_node <- function(name, time) {
    list(type = "leaf", name = name, time = time)
}

branch_node <- function(name, children, time) {
    list(type = "branch",
         name = name,
         children = children,
         time = time,
         lengths = c(time - children[[1]]$time,
                     time - children[[2]]$time))
}

binary_parent <- function(child1, child2, time) {
    parent_name <- paste(child1$name, child2$name, sep = "-")
    branch_node(parent_name, list(child1, child2), time)
}

current_time <- 0
sampled_population <- list(leaf_node("beth", current_time),
                           leaf_node("gerry", current_time),
                           leaf_node("morty", current_time),
                           leaf_node("summer", current_time))
population_size <- 100

k <- +Inf

while (k > 2) {
    k <- length(sampled_population)
    coalescent_time <- rexp(1, coalescent_rate(k, population_size))
    current_time <- current_time + coalescent_time
    ixs <- sample.int(k, size = 2)
    parent_node <- binary_parent(sampled_population[[ixs[1]]], sampled_population[[ixs[2]]], current_time)
    if (k > 2) {
        sampled_population <- c(list(parent_node), sampled_population[-ixs])
    } else {
        sampled_population <- parent_node
    }
}

newick_helper <- function(node) {
    if (node$type == "leaf") {
        node$name
    } else if (node$type == "branch") {
        sprintf("(%s:%f,%s:%f)%s",
                newick_helper(node$children[[1]]),
                node$lengths[1],
                newick_helper(node$children[[2]]),
                node$lengths[2],
                node$name)
    }
}

newick <- function(node) {
    sprintf("%s;", newick_helper(node))
}

demo_tree <- read.tree(text = newick(sampled_population))

plot(demo_tree)


# ---Library---

library(dplyr)
library(rpart) # Decision Tree
install.packages("rpart.plot")
library(rpart.plot) # Decision Tree

# ---Import Data---
data.df <- read.csv(file="../data/train.csv", header = T)

# ---Data Pre-processing---
data.df <- data.df %>% select("Survived", "Pclass", "Sex",
                                "Age","Fare") %>%
                       mutate(Survived = factor(Survived, levels = c(0,1), labels = c('No','Yes'))) %>%
                       mutate(Pclass = factor(Pclass, levels = c(1,2,3),labels = c('Upper','Middle','Lower'))) %>%
                       mutate(Sex = factor(Sex, levels = c('male','female'),labels = c('Male','Female')))

train.index <- sample(x=1:nrow(data.df), size=ceiling(0.8*nrow(data.df) ))
train.df <- data.df[train.index, ]
test.df <- data.df[-train.index, ]

# ---Build Decision Tree Model---

## Build Decision Tree Model
set.seed(5)
cart.model<- rpart(Survived ~. ,
                   data=train.df)
cart.model

## Plot the Decision Tree and Save the image
png("../results/decision_tree.png")
prp(cart.model,         # 模型
    faclen=0,           # 呈現的變數不要縮寫
    fallen.leaves=TRUE, # 讓樹枝以垂直方式呈現
    shadow.col="gray", extra =4,main="Decision Tree")
dev.off()

## Predict on Test Dataset
set.seed(5)
pred <- predict(cart.model, newdata=test.df, type ="class")
confusion_matrix <- table(real=test.df$Survived, predict=pred)
print(confusion_matrix)
accuracy <- (confusion_matrix[1,1]+confusion_matrix[2,2])/nrow(test.df)
print(accuracy)


Reduce(function(x,acc){if (0==x%%3) c(x*x,acc) else acc}, 0:22,
       init=c(), right=T)
   0   9  36  81 144 225 324 441


### Functions for data process
#' Generate initialization from specific space
#'
#' @param p p*p orthodox matrix
#' @param d p*d orthodox matrix
#' @param runs the number of orthodox matrix
#' @param orth.method orthodox method
#'
#' @return w.list
#' @export
#'
#' @examples gen.inits(2,3,3,'svd')
gen.inits <- function(p,d,runs,orth.method=c('svd','givens')) {
  orth.method=match.arg(orth.method) # the first value in orth.metod #
  W.list = list()
  for(i in 1:runs) {
    if(orth.method=='givens') {
      W.list[[i]] <- as.matrix(theta2W(runif(n=choose(p,2),min=0,max=2*pi)))[,1:d]  # convert vector into orthodox matirx and get p*d #
    } else {
      temp = matrix(rnorm(p*d),p,d)
      W.list[[i]] <- svd(temp)$u     # svd left matrix p*d #
    }
  }
  W.list
}

#' Convert angle vector into  orthodox matrix
#'
#' @param theta vector of angles theta
#'
#' @return an orthodox matrix
#' @export
#'
#'
theta2W = function(theta)
{
  #<author hidden>
  # For a vector of angles theta, returns W, a d x d Givens rotation matrix:
  # W = Q.1,d %*% ... %*% Q.d-1,d %*% Q.1,d-1 %*% ... %*% Q.1,3 %*% Q.2,3 %*% Q.1,2
  ##  if(theta < 0  || pi < theta){stop("theta must be in the interval [0,pi]")}
  d = (sqrt(8*length(theta)+1)+1)/2
  if(d - floor(d) != 0){stop("theta must have length: d(d-1)/2")}
  W = diag(d)
  index = 1
  for(j in 1:(d-1)){
    for(i in (j+1):d){
      Q.ij = givens.rotation(theta[index], d, c(i,j))
      W = Q.ij %*% W
      index = index + 1
    }
  }
  W
}

#-----------------------
#' Orthogonalization of matrix
#'
#' @param W arbitrary matrix
#'
#' @return orthogonalized matrix
#' @export
#'
orthogonalize = function (W) {
  ##For arbitrary W, this is equivalent to (WW^T)^{-1/2} W
  temp <- svd(W)
  tcrossprod(temp$u,temp$v)
}

#' Whitening Function
#'
#' @param X dataset
#' @param n.comp the number of components
#' @param center.row whether center the row of data
#'
#' @return a whitener matrix
#' @export
#'
#' @import MASS
whitener <- function(X,n.comp=ncol(X),center.row=FALSE) {

  #X must be n x d
  if(ncol(X)>nrow(X)) warning('X is whitened with respect to columns')
  #Corresponds to model of the form X.center = S A, where S are orthogonal with covariance = identity.
  x.center=scale(X,center=TRUE,scale=FALSE)
  if(center.row==TRUE) x.center = x.center - rowMeans(x.center)
  n.rep=dim(x.center)[1]
  svd.x=svd(x.center,nu=n.comp,nv=n.comp)

  #RETURNS PARAMETERIZATION AS IN fastICA (i.e., X is n x d)
  #NOTE: For whitened X, re-whitening leads to different X
  #The output for square A is equivalent to solve(K)
  return(list(whitener=t(ginv(svd.x$v%*%diag(svd.x$d[1:n.comp])/sqrt(n.rep-1))),Z=sqrt(n.rep-1)*svd.x$u,mean=apply(X,2,mean)))
}

###############################################################
# Auxillary functions taken from other people
##############################################################

# Original function by Yunfeng Zhang - calculate the power of a matrix
#' Calculate the power of a square matrix
#'
#' returns a matrix composed of eigenvector x diag(eigenvalue ^ power) x eigenvector'
#' @param S a square matrix
#' @param power the times of power
#'
#' @return a matrix after power calculation that eigenvector x diag(eigenvalue ^ power) x eigenvector'
#' @export
#'
#' @examples a <- matrix(1:9,3,3)
#' a %^% 2
#'
"%^%" <- function(S, power){
  out = eigen(S)
  nonzero = which(out$values > 1e-8)
  out$vectors[,nonzero] %*% (out$values[nonzero]^power * t(out$vectors[,nonzero]))  # which equals to out$vectors[,nonzero] %*% (diag(out$values[nonzero]^power) %*% t(out$vectors[,nonzero]))
}

#######################################################
# Objective functions - to monitor the convergence
####################################################
# Function that calculates JB
#' JB score calculate
#'
#' @param U U matrix for matched columns rj x n
#' @param X whitened data matrix n x px, data = whitenerXA \%*\% dXcentered
#' @param alpha default = 0.8
#'
#' @return the sum of JB score for each component, the row of Sj.
#' @export
#'
calculateJB <- function(U, X, alpha = 0.8){
  # Calculate u^{top}X for each u_l and Xj, this is UX
  UX = U %*% X # Sx matrix with rx x p, Sx = Ux * Lx * Xc, in which X = Lx * Xc.
  p = ncol(X)
  # Calculate all individual components
  gamma = rowMeans(UX^3) # length r
  kappa = rowMeans(UX^4 - 3) # length r

  # TU must be r by n
  JB = sum(alpha*gamma^2 + (1-alpha)*kappa^2)

  return(JB)
}

# Separate function for chordal distance of two vectors
chordal <- function(x, y){
  sum((tcrossprod(x)/sum(x^2) - tcrossprod(y)/sum(y^2))^2)
}

############
# BRisk: returns 4/5 of Jin's function
calculateJBofS <- function(S, alpha = 0.8){
  p = ncol(S)
  if (p < nrow(S)) warning("S should be r x p")
  # Calculate all individual components
  gamma = rowMeans(S^3) # length r
  kappa = rowMeans(S^4 - 3) # length r

  JB = sum(alpha*gamma^2 + (1-alpha)*kappa^2)

  return(JB)
}

#' Sign change for S matrix to image
#'
#' @param S t(S) px x r.
#' @param M another matrix.
#'
#' @return newS the original S * signskew, which is mean(S.column^3)
#' @export
#'
signchange = function(S,M=NULL) {
  # S: 59,412 x r_J
  signskew = sign(apply(S,2,function(x) mean(x^3)))
  newS = signskew*S          # t(signskew*t(S))
  if(!is.null(M)) newM = t(signskew*t(M))
  ifelse(is.null(M),return(newS),return(list(S=newS,M=newM)))
}

###############
# logistic <- function(xData, scale=sqrt(3)/pi, df=0) {
#   #maximizes likelihood given s then calculates gradient w.r.t. w.hat
#   #df is not used
#   xData = as.vector(xData)
#   list(Gs = -xData/scale - log(scale) - 2*log(1+exp(-xData/scale)), gs = -1/scale + 2*exp(-xData/scale)/(scale*(1+exp(-xData/scale))), gps = (2*exp(-2*xData/scale) - 2*exp(-xData/scale)*(1+exp(-xData/scale))) / (scale^2*(1+exp(-xData/scale))^2))
# }

logistic <- function(xData, scale=sqrt(3)/pi, df=0) {
  #maximizes likelihood given s then calculates gradient w.r.t. w.hat
  #df is not used
  xData = as.vector(xData)
  list(Gs = -xData/scale - log(scale) - 2*log(1+exp(-xData/scale)), gs = -1/scale + 2*exp(-xData/scale)/(scale*(1+exp(-xData/scale))), gps = - 2*exp(-xData/scale) / (scale^2*(1+exp(-xData/scale))^2))
}

jb.stat <- function(x, df=0) {
  n <- length(x)
  s <- sum(x^3)
  k <- sum(x^4)
  Gs <- x^3 * s / n^2 + (x^4 * k / n^2 + 9 / n - 6 * x^4 / n) / 4
  gs <- 6 * x^2 * s / n^2 + (8 * x^3 * (k / n - 3) / n) / 4
  gps <- 6 * (3 * x^4 + 2 * x * s) / n^2 + (24 * x^2 * (k / n - 3) / n + 32 * x^6 / n^2) / 4
  list(Gs = Gs, gs = gs, gps = gps)
}

tiltedgaussian = function (xData, df = 8, B = 100, ...) {
  #This function is based on ProDenICA::GPois by Trevor Hastie
  #NOTE: Assumes data are zero mean.

  n <- length(xData)
  sd.x = sd(xData)
  rx <- c(min(xData)-0.1*sd.x, max(xData)+0.1*sd.x)
  xg <- seq(from = rx[1], to = rx[2], length = B)
  gaps <- diff(rx)/(B - 1)
  xcuts <- c(rx[1] - gaps/2, xg[-B] + gaps/2, rx[2] + gaps/2)
  #NOTE: I use the response variable that corresponds to the LCA paper.
  #This differs from the GPois algorithm in ProDenICA
  ys <- as.vector(table(cut(xData, xcuts)))/(gaps*n)
  pois.fit <- suppressWarnings(gam(ys ~ s(xg, df)+offset(dnorm(xg,log=TRUE)), family = poisson, ...))
  Gs <- predict(pois.fit) #log tilt function predicted at grid locations (note: predict on gam object can not be used to obtain derivatives)
  # the gam object with the predict function can not be used directly to obtain the derivatives
  # of the smoothing spline.
  # Here, we refit another iteration of the IRWLS algorithm used in gam:
  # Note: working residuals = (y - mu0)/mu0
  # weights = mu0
  # fitted(pois.fit) = mu0
  # predict(pois.fit) = eta0 = log(mu0)
  sGs = Gs #+ log(sum(dnorm(xg))/sum(fitted(pois.fit)))
  z0 <- sGs + residuals(pois.fit, type='working')
  pois.refit <- smooth.spline(x=xg, y=z0, w=fitted(pois.fit),df=df) #obtain the log tilt function in an object that can be used to obtain derivatives
  Gs <- predict(pois.refit, xData, deriv = 0)$y
  gs <- predict(pois.refit, xData, deriv = 1)$y
  gps <- predict(pois.refit, xData, deriv = 2)$y
  fGs <- function(x) predict(pois.refit,x,deriv=0)$y
  fgs <- function(x) predict(pois.refit,x,deriv=1)$y
  fgps <- function(x) predict(pois.refit,x,deriv=2)$y
  list(Gs = Gs, gs = gs, gps = gps, fGs = fGs, fgs=fgs, fgps=fgps)
}
#---------------------------------------------


lambda_dgvm <- function(c_start1, c_start0, c_1, c_0, BA_1, return_r) {

    delta = (c_start1 - c_start0)

    test = c_start1 > c_start0
    delta[test] = delta[test] * (1 - c_0[test])/(1 - c_start0[test])

    test = !test
    delta[test] = delta[test] * (c_0[test]/c_start0[test])

    gamma_burn = BA_1 * c_1

    rt = c_1 - c_0 - delta + gamma_burn

    if (return_r) return(rt)
    l = rt / (c_start0 - c_0)
    lambda = 1 - log(1 - l)

    #num = c_start1 - c_0

    #den = c_start1 - c_1 - gamma_burn + delta

    #lambda = log(num/den)

    return(lambda)
}


# load agreement statistics functions
source('./agree.coeff2.r')
source('./agree.coeff3.raw.r')
source('./sem_distance.r')

#
# Random data, difference between percentage agreement and agreement measures
#

# generate random data
data <- matrix(sample(1:2, 20000, replace=T), nrow = 2)

# convert to contingency table
cont_table <- table(data[1,], data[2,])

# calculate agreement measures
kappa2.table(cont_table)

# read ASSESS CT data
data_assessment <- read.table('./agree_data_assess_ct.csv', header = TRUE, sep = ',')
# select SNOMED CT coded cases
sct <- matrix(as.vector(data_assessment[,2]), nrow = 101, ncol = 6)

# calculate semantic distance weights based on Lin
weight <- lin_sem_distance(sct)

# calculate Krippendorff's alpha w/o weights
krippen.alpha.raw(sct)

# calculate weighted Krippendorff's alpha
krippen.alpha.raw(sct, weight)


library(grDevices)

readRawTable = function(tablePath) {
    rawTable = read.csv2(tablePath, sep = ",", header = T, stringsAsFactors = F, check.names = FALSE)
    rownames(rawTable) = rawTable[,1] # first column is the classification vector
    rawTable = rawTable[,2:ncol(rawTable)] # remove first column
    return(rawTable)
}

groupSources = function(rawTable, clusteringThreshold) {
    # normalize by columns, since key counts are different
    rawTable = as.matrix(rawTable)
    rawTable = rawTable/colSums(rawTable)[col(rawTable)]

    # cluster using hclust and Euclidean distances
    clustered = hclust(dist(t(rawTable)))
    # group according to empirically found clustering threshold
    grouped = cutree(clustered, h = clusteringThreshold)

    groups = unique(grouped)
    groupedTable = matrix(0, ncol = length(groups), nrow = nrow(rawTable))
    colnames(groupedTable) = paste0("Group ", groups)
    rownames(groupedTable) = rownames(rawTable)

    for (group in groups) {
        sourcesInGroup = names(grouped[which(grouped == group)])
        for (source in sourcesInGroup) {
            # add together distributions of all sources in the group
            groupedTable[,group] = groupedTable[,group] + rawTable[,source]
        }
        # normalize, possibly more sources in a group
        groupedTable[,group] = groupedTable[,group]/sum(groupedTable[,group])
    }
    return(list("table" = groupedTable, "grouping" = grouped, "clustering" = clustered))
}

colorAssignment = function(x, colors, grouped, useFixedColors) {
    if (is.leaf(x)) {
        a = attributes(x)
        groupID = a$label
        groupLabel = grouped[a$label]
        if (useFixedColors) {
            groupIDs = c(13, 12, 7, 5, 10, 4, 9, 3, 11, 1, 2, 6, 8)
            groupLabel = groupIDs[grouped[a$label]]
            labCol = colors[groupLabel]
        } else {
            labCol = colors[grouped[which(names(grouped) == a$label)]]
        }

        attr(x, "nodePar") = list(lab.cex = 1.65, lab.col = labCol, label = "test", lab.font=2, pch="o")
        attr(x, "label") = paste0("[", groupLabel, "] ", groupID)
    }
    return(x)
}

drawGeneral = function(groupedTable, clustered, grouped, clusteringThreshold) {
    groupCount = ncol(groupedTable)
    par = par(mfrow = c(1, 1), mar = c(5, 1, 5, 40), cex = 0.7,
              cex.axis = 2, cex.lab = 2, cex.main = 3)
    useFixedColors = groupCount == 13
    if (useFixedColors) {
        colors = c("#AEC7E8", "#FFBB78", "#98DF8A", "#FF9896", "#C5B0D5",
                   "#C49C94", "#2CA02C", "#DBDB8D", "#E377C2", "#C7C7C7",
                   "#17BECF", "#D62728", "#FF7F0E")
    } else {
        colors = sort(rainbow(groupCount, s = 1, v = 0.8))
    }

    dendrogram = dendrapply(as.dendrogram(clustered),
                            function(x) {return(colorAssignment(x, colors, grouped, useFixedColors))})
    plot(dendrogram, main = "                                                  Clustering of sources", horiz = T,
         xlab = "Euclidean distance") #clustered$dist.method

    abline(v = clusteringThreshold, untf = FALSE, col = "blue", lty = 2, lwd = 3)
    mtext("Clustering threshold = 0.02", side = 3, line = -2, outer = FALSE, col = "blue", at = 0.19)
}

processDirectory = function(rawTablePath,
                            clusteringThreshold = 0.02) {
    # table where all sources (libraries) have their own column
    rawTable = readRawTable(rawTablePath)

    grouping = groupSources(rawTable, clusteringThreshold)
    # table where each group has one column (1 group ay be more sources)
    groupedTable = data.frame(grouping$table)
    clustered = grouping$clustering # result of hclust
    grouped = grouping$grouping # result of cutree

    # draw dendrogram
    drawGeneral(groupedTable, clustered, grouped, clusteringThreshold)

}

args = commandArgs(TRUE)
if (length(args) != 1) {
    print("Usage: 1 argument - raw classification table (-er)")
} else {
    rawTablePath = args[1]

    pdf("dendrogram.pdf", width = 8, height = 12)
    processDirectory(rawTablePath)
    dev.off()
    embedFonts("dendrogram.pdf")
}


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Discriminant Analysis
#==============================================================================
# Title          : DiscriminantAnalysis.r
# Description    : Discriminant Analysis including linear and quadratic
#                  functions.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20180412
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : based on
# https://www.statmethods.net/advstats/discriminant.html
# https://www.r-bloggers.com/linear-discriminant-analysis-in-r-an-introduction/
# https://ggobi.github.io/ggally
# https://rstudio-pubs-static.s3.amazonaws.com/35817_2552e05f1d4e4db8ba87b334101a43da.html
# R version      : 3.4
#==============================================================================

#==============================================================================
# PACKAGE INSTALATION
#==============================================================================
install.packages("MASS")
install.packages("car")
install.packages("klaR")
install.packages("ggplot2")
install.packages("mvoutlier")
install.packages("mvnormtest")
install.packages("GGally")
install.packages("RColorBrewer")
install.packages("dplyr")

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(MASS)
library(car)
library(klaR)
library(ggplot2)
library(mvoutlier)
library(mvnormtest)
library(GGally)
library(RColorBrewer)
library(dplyr)

#------------------------------------------------------------------------------
# Data generation/preparation and pattern
#------------------------------------------------------------------------------
# mydata <- mtcars
# http://archive.ics.uci.edu/ml/machine-learning-databases/car/car.data
mydata <-
read.table("http://archive.ics.uci.edu/ml/machine-learning-databases/wine/wine.data",
sep=",")

# Variables names
# (http://archive.ics.uci.edu/ml/machine-learning-databases/wine/wine.names)
# 1) Alcohol
# 2) Malic acid
# 3) Ash
# 4) Alcalinity of ash
# 5) Magnesium
# 6) Total phenols
# 7) Flavanoids
# 8) Nonflavanoid phenols
# 9) Proanthocyanins
# 10)Color intensity
# 11)Hue
# 12)OD280/OD315 of diluted wines
# 13)Proline
names(mydata) <- c("Class", "Alcohol", "MalicAcid", "Ash", "AlcalinityAsh",
"Magnesium", "TotalPhenols", "Flavanoids", "NonflavanoidPhenols",
"Proanthocyanins", "Color", "Hue", "OD280_OD315", "Proline")
# Visualizing data
scatterplotMatrix(mydata)

ggpairs(mydata)

plot(mydata$Flavanoids, mydata$NonflavanoidPhenols)
text(mydata$Flavanoids, mydata$NonflavanoidPhenols, mydata$Alcohol, cex=0.7, pos=4, col="red")

# Profile Plot - how is the variation in each of the variables
makeProfilePlot <- function(mylist,names)
  {
     require(RColorBrewer)
     # find out how many variables we want to include
     numvariables <- length(mylist)
     # choose 'numvariables' random colours
     colours <- brewer.pal(numvariables,"Set1")
     # find out the minimum and maximum values of the variables:
     mymin <- 1e+20
     mymax <- 1e-20
     for (i in 1:numvariables)
     {
        vectori <- mylist[[i]]
        mini <- min(vectori)
        maxi <- max(vectori)
        if (mini < mymin) { mymin <- mini }
        if (maxi > mymax) { mymax <- maxi }
     }
     # plot the variables
     for (i in 1:numvariables)
     {
        vectori <- mylist[[i]]
        namei <- names[i]
        colouri <- colours[i]
        if (i == 1) { plot(vectori,col=colouri,type="l",ylim=c(mymin,mymax)) }
        else         { points(vectori, col=colouri,type="l")                                     }
        lastxval <- length(vectori)
        lastyval <- vectori[length(vectori)]
        text((lastxval-10),(lastyval),namei,col="black",cex=0.6)
     }
  }

lnames <- names(mydata)[c(6,2,3)]
mylist <- list(mydata$Magnesium, mydata$Alcohol, mydata$MalicAcid)
makeProfilePlot(mylist,lnames)

# Descriptive statistics
summary(mydata , digits = 2)
tapply(mydata$Alcohol, mydata$Class, summary)
mydata %>% group_by(mydata$Class) %>% summarize(mean=mean(mydata$Alcohol), sum=sum(mydata$Magnesium))

#------------------------------------------------------------------------------
# Assumptions
#------------------------------------------------------------------------------
#
# 1) Multivariate normality and homogeneity of covariance matrices.
# 2) Assumes that the independent variables are normally distributed.
# 3) The analysis is quite sensitive to outliers and the size of the smallest group must be larger than the number of predictor variables.[7]
# 4) LDA assumes linearly separable latent representations.
#
# Multivariate normality: Independent variables are normal for each level of the grouping variable.
# Homogeneity of variance/covariance (homoscedasticity): Variances among group variables are the same across levels of predictors. Can be tested with Box's M statistic.It has been suggested, however, that linear discriminant analysis be used when covariances are equal, and that quadratic discriminant analysis may be used when covariances are not equal.
# Multicollinearity: Predictive power can decrease with an increased correlation between predictor variables.
# Independence: Participants are assumed to be randomly sampled, and a participant’s score on one variable is assumed to be independent of scores on that variable for all other participants.
# It has been suggested that discriminant analysis is relatively robust to slight violations of these assumptions, and it has also been shown that discriminant analysis may still be reliable when using dichotomous variables (where multivariate normality is often violated).
#==============================================================================
# Testing assumptions
#==============================================================================

# Outliers --------------------------------------------------------------------
# Detect Outliers in the MTCARS Data
outliers <- aq.plot(mydata[c("Alcohol", "MalicAcid", "Ash", "AlcalinityAsh",
"Color")])
outliers

# Multivariate Normality ------------------------------------------------------
Gm <- as.matrix(mydata[,c("Alcohol", "MalicAcid", "Ash", "AlcalinityAsh",
"Color")])
mshapiro.test(Gm)

# Graphical Assessment of Multivariate Normality
x <- as.matrix(Gm) # n x p numeric matrix
center <- colMeans(x) # centroid
n <- nrow(x); p <- ncol(x); cov <- cov(x);
d <- mahalanobis(x,center,cov) # distances
qqplot(qchisq(ppoints(n),df=p),d,
  main="QQ Plot Assessing Multivariate Normality",
  ylab="Mahalanobis D2")
abline(a=0,b=1)

# In case no multinormality, preceed an inspection for problems univariately
# Univariate Normality

# Q-Q Plot for variable
qqnorm(mydata$Alcohol) ; qqline(mydata$Alcohol)

# Homogeneity of Variances ----------------------------------------------------

# Bartlett Test of Homogeneity of Variances
mylist4 <- list(mydata$Alcohol, mydata$MalicAcid, mydata$Ash,
				mydata$AlcalinityAsh, mydata$Color)

bartlett.test(mylist, data=mydata)

# Figner-Killeen Test of Homogeneity of Variances
fligner.test(mylist, data=mydata)

# HH package provides a graphic test of homogeneity of variances based on
# Brown-Forsyth. In the following example, y is numeric and G is a grouping
# factor. Note that G must be of type factor.

#==============================================================================
# Linear Discriminant Analysis with Jacknifed Prediction (LDA)
#==============================================================================

# LDA, using listwise deletion of missing data. CV=TRUE generates jacknifed
# (i.e., leave one out) predictions.
G <- mydata[,c("Class", "Alcohol", "MalicAcid", "Ash", "AlcalinityAsh", "Color")]

model.lda <- lda(Class ~ ., data = G, na.action="na.omit", CV=TRUE)
model.lda

model.lda <- lda(Class ~ ., data = G, na.action="na.omit") # no validation
model.lda

# Assess the accuracy of the prediction
# percent correct for each category of G
ct <- table(mydata$G, model.lda$class)
diag(prop.table(ct, 1))
# total percent correct
sum(diag(prop.table(ct)))

# lda() prints discriminant functions based on centered (not standardized) variables. The "proportion of trace" that is printed is the proportion of between-class variance that is explained by successive discriminant functions.

#==============================================================================
# Plots
#==============================================================================

# Scatter plot using the 1st two discriminant dimensions
plot(fit) # fit from lda

# Panels of histograms and overlayed density plots
# for 1st discriminant function
plot(fit, dimen=1, type="both") # fit from lda

# The partimat( ) function in the klaR package can display the results of a linear or quadratic classifications 2 variables at a time.

# Exploratory Graph for LDA or QDA
partimat(G~x1+x2+x3,data=mydata,method="lda")

# Scatterplot for 3 Group Problem
pairs(mydata[c("x1","x2","x3")], main="My Title ", pch=22,
   bg=c("red", "yellow", "blue")[unclass(mydata$G)])

#==============================================================================
# Quadratic Discriminant Analysis (QDA)
#==============================================================================

# Quadratic Discriminant Analysis with resubstitution prediction and equal prior probabilities.
library(MASS)
fit <- qda(G ~ x1 + x2 + x3 + x4, data=na.omit(mydata),
  prior=c(1,1,1)/3))

# EOF


#' Cartesian coordinates with fixed "aspect ratio"
#'
#' A fixed scale coordinate system forces a specified ratio between the
#' physical representation of data units on the axes. The ratio represents the
#' number of units on the y-axis equivalent to one unit on the x-axis. The
#' default, `ratio = 1`, ensures that one unit on the x-axis is the same
#' length as one unit on the y-axis. Ratios higher than one make units on the
#' y axis longer than units on the x-axis, and vice versa. This is similar to
#' [MASS::eqscplot()], but it works for all types of graphics.
#'
#' @export
#' @inheritParams coord_cartesian
#' @param ratio aspect ratio, expressed as `y / x`
#' @examples
#' # ensures that the ranges of axes are equal to the specified ratio by
#' # adjusting the plot aspect ratio
#'
#' p <- ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' p + coord_fixed(ratio = 1)
#' p + coord_fixed(ratio = 5)
#' p + coord_fixed(ratio = 1/5)
#' p + coord_fixed(xlim = c(15, 30))
#'
#' # Resize the plot to see that the specified aspect ratio is maintained
coord_fixed <- function(ratio = 1, xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") {
  ggproto(NULL, CoordFixed,
    limits = list(x = xlim, y = ylim),
    ratio = ratio,
    expand = expand,
    clip = clip
  )
}

#' @export
#' @rdname coord_fixed
#' @usage NULL
coord_equal <- coord_fixed

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
CoordFixed <- ggproto("CoordFixed", CoordCartesian,
  is_free = function() FALSE,

  aspect = function(self, ranges) {
    diff(ranges$y.range) / diff(ranges$x.range) * self$ratio
  }
)


two_class_sample_data <- read.csv("../extdata/two-class-sample-data.csv")
act <- two_class_sample_data$act
pred <- two_class_sample_data$pred

## Test correctness ------------------------------------------------------------

## test confusion matrix
expect_equivalent(
    mtr_confusion_matrix(act, pred),
    matrix(c(410, 84, 78, 428), ncol = 2)
)

## test accuracy / correctly classified rate
expect_equal(
    mtr_accuracy(act, pred),
    target = (410 + 428) / length(act)
)

## test true posotive rate / sensitivity / hit rate / detection rate / recall
expect_equal(
    mtr_sensitivity(act, pred),
    target = 410 / (410 + 84)
)

## test true negative rate / specificity/ selectivity
expect_equal(
    mtr_specificity(act, pred),
    target = 428 / (428 + 78)
)

## test false negative rate / miss rate
expect_equal(
    mtr_false_negative_rate(act, pred),
    target = 78 / (78 + 428)
)

## test positive predicted value / precision
expect_equal(
    mtr_positive_predicted_value(act, pred),
    target = 410 / (410 + 78)
)

## test false discovery rate
expect_equal(
    mtr_false_discovery_rate(act, pred),
    target = 78 / (410 + 78)
)

## test negative predicted value
expect_equal(
    mtr_negative_predicted_value(act, pred),
    target = 428 / (428 + 84)
)

## test prevalence
expect_equal(
    mtr_prevalence(act, pred),
    target = (410 + 84) / length(act)
)

## test detection prevalence
expect_equal(
    mtr_detection_prevalence(act, pred),
    target = (410 + 78) / length(act)
)

## test balanced accuracy
expect_equal(
    mtr_balanced_accuracy(act, pred),
    target = ((410 / (410 + 84)) + (428 / (428 + 78))) / 2
)

## test Matthews correlation coefficient
expect_equal(
    mtr_matthews_corr_coef(act, pred),
    target = ((410 * 428) - (84 * 78)) / sqrt(prod(410 + 84, 410 + 78, 428 + 84, 428 + 78))
)

## test markedness
expect_equal(
    mtr_markedness(act, pred),
    target = mtr_ppv(act, pred) + mtr_npv(act, pred) - 1
)

## test informedness
expect_equal(
    mtr_informedness(act, pred),
    target = mtr_sensitivity(act, pred) + mtr_specificity(act, pred) - 1
)

## Test edge cases -------------------------------------------------------------

expect_equal(
    mtr_hit_rate(c(0, 0, 0, 0, 0), c(0.1, 0.3, 0.5, 1, 0), 0.5),
    target = 0
)

expect_equal(
    mtr_hit_rate(c(0, 0, 0, 0, 0), c(0.1, 0.3, 0.5, 1, 0), 1),
    target = 1
)

expect_equal(
    mtr_hit_rate(c(0, 0, 0, 0, 0), c(0.1, 0.3, 0.5, 1, 0), 0),
    target = 0
)

## Test error handling ---------------------------------------------------------

## raise error if length of input vectors is inconsistent
expect_error(
    confusion_list(c(0, 1, 0, 0), c(0.1, 0.3, 0.4))
)

## raise error if value of `cutoff` is out of range [0,1]
expect_error(
    confusion_list(c(0, 1, 1), c(0.1, 0.4, 0.8), 1.1)
)

## raise error if `actual` is multi-class
expect_error(
    confusion_list(c(0, 1, -1), c(0.3, 0.2, 0.9))
)


#'multipy together two numbers
#'
#'@param x A number
#'@param y Another number
#'@param product The product of multiplying x and y
#'@usage
#'mult(4,5)

mult <- function(x,y){
  product <- x*y
  return(product)
}


sessionInfo()

options(repos = c(CRAN = "https://mran.revolutionanalytics.com/snapshot/2018-09-14"))

getOption("repos")

#install.packages("dplyr")
library(dplyr)
packageVersion("dplyr")

#install.packages("prettyR")
library(prettyR)
packageVersion("prettyR")

nhanes_extracted <- read.csv("NHANES_extracted.csv")

head(nhanes_extracted)

nhanes_extracted <- nhanes_extracted[-1]

glimpse(nhanes_extracted)

variables <- c('index', 'female', 'male', 'age', 'body_mass_index', 'waist_circumference', 'sugarfree_diet' )

names(nhanes_extracted) <- variables

head(nhanes_extracted)

nhanes_extracted$sugarfree_diet <- factor(nhanes_extracted$sugarfree_diet, levels=c('0','1'), labels=c('No','Yes'))

table(nhanes_extracted$female, nhanes_extracted$male, deparse.level = 2, useNA = 'always')

nhanes_extracted <- nhanes_extracted %>% mutate(sex = ifelse(female == 1, "female", "male")) %>% select(-c('female', 'male'))

nhanes_extracted$sex <- as.factor(nhanes_extracted$sex)

head(nhanes_extracted)

describe(nhanes_extracted[, -1], num.desc = c("mean", "sd", "median", "min", "max", "valid.n"))

gender_distribution <- table(nhanes_extracted$sex)

gender_distribution

gender_proportion<- round(100*gender_distribution/sum(gender_distribution), 1)

gender_proportion

gender_percent <- paste(gender_proportion,"%",sep="")

pie(gender_distribution, labels = gender_percent, main = "Gender distribution", col = c("pink", "blue"))
legend("topright", c("female", "male"), fill = c("pink", "blue"))

nhanes_extracted %>% group_by(sex)%>% summarise(first_quantile_age = quantile(age, probs = 0.25, na.rm = TRUE), median_age = median(age, na.rm = TRUE), third_quantile_age = quantile(age, probs = 0.75, na.rm = TRUE))

boxplot(age~sex, data = nhanes_extracted, main = "Boxplot of age distribution by gender", xlab = "Gender", ylab = "Age in years", col = c("pink", "blue"))

nhanes_extracted %>% group_by(sex)%>% summarise(first_quantile_bmi = quantile(body_mass_index, probs = 0.25, na.rm = TRUE), median_bmi = median(body_mass_index, na.rm = TRUE), third_quantile_bmi = quantile(body_mass_index, probs = 0.75, na.rm = TRUE))

boxplot(body_mass_index~sex, data = nhanes_extracted, main = "Boxplot of BMI distibution by gender", xlab = "Gender", ylab = "BMI in kg/m^2", col = c("pink", "blue"))

nhanes_over_two <- nhanes_extracted  %>% filter(age >=2)

#quick check of the number of observations and variables
dim(nhanes_over_two)

describe(nhanes_over_two[, -1], num.desc = c("mean", "sd", "median", "min", "max", "valid.n"))

nhanes_over_two %>% group_by(sugarfree_diet)%>% summarise(count = n(), mean = mean(waist_circumference, na.rm = TRUE))

nhanes_over_two %>% filter(is.na(nhanes_over_two$waist_circumference))%>% nrow()

wilcox.test(waist_circumference~sugarfree_diet, conf.int=TRUE, data = nhanes_over_two)


# Generate and plot Brownian tree. Version #3.
# 7/27/16 aev
# gpBrownianTree3(m, n, clr, fn, ttl, dflg, seed, psz):
# Where: m - defines matrix m x m; n - limit of the number of moves;
#   fn - file name (.ext will be added); ttl - plot title; dflg - 0-no dump,
#   1-dump; seed - 0-center, 1-random: psz - picture size.
gpBrownianTree3 <- function(m, n, clr, fn, ttl, dflg=0, seed=0, psz=600)
{
  cat(" *** START:", date(),"m=",m,"n=",n,"clr=",clr, "psz=",psz, "\n");
  M <- matrix(c(0), ncol=m, nrow=m, byrow=TRUE);
  # Random seed
  if(seed==1)
    {x <- sample(1:m, 1, replace=FALSE);y <- sample(1:m, 1, replace=FALSE)}
  # Seed in center
  else {x <- m%/%2; y <- m%/%2}
  M[x,y]=1;
  pf=paste0(fn,". png");
  cat(" *** Plot file -", pf, "Seed:",x,"/",y, "\n");
  # Main loops
  for (i in 1:n) {
    if(i>1) {
      x <- sample(1:m, 1, replace=FALSE)
      y <- sample(1:m, 1, replace=FALSE)}
    b <- 0;
    while(b==0) {
      dx <- sample(-1:1, 1, replace=FALSE)
      dy <- sample(-1:1, 1, replace=FALSE)
      if(!(x+dx<=m && y+dy<=m && x+dx>0 && y+dy>0))
        { x <- sample(1:m, 1, replace=FALSE)
          y <- sample(1:m, 1, replace=FALSE)
        }
      else{if(M[x+dx,y+dy]==1) {M[x,y]=1; b=1}
        else {x=x+dx; y=y+dy;} }
    }
  }
  plotmat(M, fn, clr, ttl, dflg, psz);
  cat(" *** END:", date(), "\n");
}
gpBrownianTree3(400,5000,"dark green", "BT3R", "Brownian Tree v.3", 1);


##
## Compare social relations models
##
## The 'amen' package doesn't do model selection, as such, so we take two appoaches here:
##
## 1. Use 'amen's goodness of fit function to calculate root mean square errors (RMSE) between each model
##    and the observed networks. Smallest RMSE overall = best model
##
## 2. Calculate F_1 scores and Accuracy metrics for each of the models' predictions compared to observed data
##
## Make sure you run 'social relations model - fit.r' first
##
library(ggplot2)

source("init if necessary.r")

flog.info("Comparing social relations models")

load(file.path(models.dir, "social relations models.rdata"))

model_names = c("Intercept-only", "r + siida + gift", "r x siida + gift", "r x siida x gift")

#######################################################################
## Goodness of fit
## which model had the smallest discrepancies between the posterior predictive distributions and the observed statistics?
##
flog.info("... goodness of fit")

#' Function to calculate the root mean square errors, mean absolute errors and median absolute errors
#' for each of the four goodness of fit stats generated by 'amen'
#' (though we only use RMSE here)
#'
#' @param Y, adjacency matrix for observed network ties
#' @param srrm, the SRM
#' @return A named list containing RMSEs, MAEs and MedianAEs for each of the four goodness of fit stats
#'
gof_diffs = function(Y, srrm)
{
  ## debug ###
  # Y = adj.coop
  # srrm = fit_srrm3
  ###

  GOF = gofstats(Y)  # empirical standard deviations

  n = length(srrm$GOF[-1, 1])  # no. sims in posterior distribution

  # calculate the root mean square error between the posterior predictive distribution and the observed stats
  # for the SD of ego means, SD of alter means and the within-dyad correlation
  rmse = c()
  mdae = c()  # median absolute error
  mae = c()   # mean absolute error
  for (k in 1:4)
  {
    rmse[k]  = sqrt( sum( (srrm$GOF[-1, k] - GOF[k])^2 ) / n )
    mae[k] = mean(abs(srrm$GOF[-1, k] - GOF[k]))
    mdae[k] = median(abs(srrm$GOF[-1, k] - GOF[k]))
  }
  # return(rmse)
  return(list(
    rmse=rmse,
    mae=mae,
    median_ae=mdae
  ))
}

# calculate goodness of fit discrepancies for each of our models
gof_null  = gof_diffs(adj.coop, fit_null_ind)
gof_srrm2 = gof_diffs(adj.coop, fit_srrm2)
gof_srrm3 = gof_diffs(adj.coop, fit_srrm3)
gof_srrm4 = gof_diffs(adj.coop, fit_srrm4)

# find which models had lowest RMSEs for each of the four goodness of fit stats
for (i in 1:4)
{
  # print("RMSE:")
  print( model_names[
    which.min( c(gof_null$rmse[i], gof_srrm2$rmse[i], gof_srrm3$rmse[i], gof_srrm4$rmse[i]) )
    ] )

  # print("\nMAE")
  # print( model_names[
  #   which.min( c(gof_null$mae[i], gof_srrm2$mae[i], gof_srrm3$mae[i], gof_srrm4$mae[i]) )
  #   ] )

  # print("\nMedian AE")
  # print( model_names[
  #   which.min( c(gof_null$median_ae[i], gof_srrm2$median_ae[i], gof_srrm3$median_ae[i], gof_srrm4$median_ae[i]) )
  #   ] )
}

# construct and save table of root mean square errors
rmsd = as.data.frame(matrix(c(
  (gof_null$rmse),
  (gof_srrm2$rmse),
  (gof_srrm3$rmse),
  (gof_srrm4$rmse)
), ncol=4, nrow=4, byrow=T))

names(rmsd) = c("SD ego means",	"SD alter means",	"Dyadic correlations", "Triadic dependence")
rmsd$Model = model_names
rmsd = rmsd %>% select(Model, everything())  # put Model column first

write_csv(rmsd, file.path(results.dir, "social relations model - root mean square errors.csv"))

#######################################################################
## Simulate models' predictions of observed data and calculate performance using F_1 score and Accuracy
##
flog.info("... accuracy and F1 scores")

#' Calculate Accuracy and F1 scores for a social relations model by simulating from the posteriors.
#'
#' @param srrm The social relations model
#' @param link_fun Link function to use for this model
#'
#' @return Named list containing F1 scores and Accuracies
#'
calc_metrics = function(srrm, link_fun)
{
  # srrm = fit_srrm3
  # link_fun = p.link_srrm3

  # get posterior mean estimates of ego and alter random effects for each observation
  a_i  = srrm$APM
  b_j  = srrm$BPM
  re = a_i[ as.character(herders.wide$Ego) ] + b_j[ as.character(herders.wide$Alter) ]

  # helper function to vectorise the adjacency matrices (and remove self-loops)
  mat_vec = function(adj) {
    diag(adj) = NA
    d = as.vector(adj[ as.character(herders$HerderID), as.character(herders$HerderID) ])
    d = na.omit(d)
    d
  }

  siida = mat_vec(adj.siida)
  r     = mat_vec(adj.kin)
  gift  = mat_vec(adj.gifts)
  coop  = mat_vec(adj.coop)

  # calculate model predictions
  # pred.raw = sapply(1:nrow(herders.wide), function(i) link_fun(srrm, herders.wide$r[i], herders.wide$SameSiida[i], herders.wide$GiftGiven[i], re[i]))
  pred.raw = sapply(1:nrow(herders.wide), function(i) link_fun(srrm, r[i], siida[i], gift[i], re[i]))
  #str(pred.raw)

  # simulate posterior predictoins
  # - one column for each observed dyad
  # - one row for each simulation
  post_pred = sapply(1:ncol(pred.raw), function(s) {
    rbinom(nrow(pred.raw), size = 1, prob = pred.raw[, s])
  })

  # for each column (simulated posterior prediction), was it correct?
  true_pos = c(); true_neg = c(); false_pos = c(); false_neg = c()
  for (i in 1:nrow(post_pred))
  {
    true_pos[i]  = sum(coop==1 & post_pred[i,]==1)
    true_neg[i]  = sum(coop==0 & post_pred[i,]==0)
    false_pos[i] = sum(coop==0 & post_pred[i,]==1)
    false_neg[i] = sum(coop==1 & post_pred[i,]==0)
  }

  # calc precision and recall
  precision = true_pos / (true_pos + false_pos)
  recall = true_pos / (true_pos + false_neg)

  # F_1 score
  f1 = (2 * precision * recall) / (precision + recall)

  # accuracy
  accuracy = (true_pos + true_neg) / (true_pos + true_neg + false_pos + false_neg)

  return(list(
    f1 = f1,
    accuracy = accuracy
  ))
}

# calculate metrics
metrics_null  = calc_metrics(fit_null_ind, p.link_null)
metrics_srrm2 = calc_metrics(fit_srrm2, p.link_srrm2)
metrics_srrm3 = calc_metrics(fit_srrm3, p.link_srrm3)
metrics_srrm4 = calc_metrics(fit_srrm4, p.link_srrm4)

# put everything into one table for plotting
metrics = data.frame(
  Model = rep(model_names, each=length(metrics_srrm2$f1)),
  ModelNum = rep(1:4, each=length(metrics_srrm2$f1)),
  F1 = c(metrics_null$f1, metrics_srrm2$f1, metrics_srrm3$f1, metrics_srrm4$f1),
  Accuracy = c(metrics_null$accuracy, metrics_srrm2$accuracy, metrics_srrm3$accuracy, metrics_srrm4$accuracy)
)

# plot F1 scores and accuracies, and save into single image
plt_f1 = ggplot(metrics, aes(x=factor(ModelNum), y=F1)) +
  geom_boxplot() +
  xlab("Social relations model") +
  ylab("F1 scores") +
  ggtitle("a") +
  common_theme

plt_acc = ggplot(metrics, aes(x=factor(ModelNum), y=Accuracy)) +
  geom_boxplot() +
  xlab("Social relations model") +
  ylab("Accuracy") +
  ggtitle("b") +
  common_theme

png(file.path(plots.dir, "SRM - metrics.png"), height=10, width=20, units="cm", res=300)
  gridExtra::grid.arrange(plt_f1, plt_acc, ncol=2)
dev.off()

pdf(file.path(plots.dir, "SRM - metrics.pdf"), height=5, width=10)
  gridExtra::grid.arrange(plt_f1, plt_acc, ncol=2)
dev.off()

# done
save(model_names, gof_diffs, gof_null, gof_srrm2, gof_srrm3, gof_srrm4, rmsd,
     calc_metrics, metrics, metrics_null, metrics_srrm2, metrics_srrm3, metrics_srrm4,
     file=file.path(models.dir, "social relations models - comparison.rdata"))

flog.info("Finished comparing")


#install package FuzzyR if not already installed
if(!require(FuzzyR)){
  install.packages("FuzzyR")
  library(FuzzyR)
}
#criar objeto first
fis= newfis("study")

#adicionar as variaveis de entrada e saida
fis= addvar(fis, 'input', 'conhecimento previo', c(0,25))
fis= addvar(fis, 'input', 'dificuldade', c(0,25))
fis= addvar(fis, 'input', 'dificuldade para colar', c(0,25))
fis= addvar(fis, 'output', 'horas de antecedencia para estudar', c(0,25))

#adicionar as funcoes de pertinencia
fis= addmf(fis, 'input', 1, 'zerado', 'gaussmf', c(3,3))
fis= addmf(fis, 'input', 1, 'mais ou menos', 'gaussmf', c(3,13))
fis= addmf(fis, 'input', 1, 'expert', 'gaussmf', c(3,19))

fis= addmf(fis, 'input', 2, 'facil', 'trapmf', c(0,0,4,7))
fis= addmf(fis, 'input', 2, 'mais ou menos', 'trapmf', c(5, 7, 11, 15))
fis= addmf(fis, 'input', 2, 'dificil', 'trapmf', c(10,16,21,25))

fis= addmf(fis, 'input', 3, 'facil', 'trimf', c(0, 6, 9))
fis= addmf(fis, 'input', 3, 'mais ou menos', 'trimf', c(8, 13, 18))
fis= addmf(fis, 'input', 3, 'dificil', 'trimf', c(17, 20, 25))

fis= addmf(fis, 'output', 1, 'durante a prova', 'trapmf', c(0, 0, 6, 12))
fis= addmf(fis, 'output', 1, 'noite anterior', 'gaussmf', c(3, 12))
fis= addmf(fis, 'output', 1, 'cedo', 'trimf', c(15, 20, 25))

#columns:
# 1st -> first input variable
# 2nd -> second input variable
# 3rd -> thrid input variable
# 4th -> output variable
# 5th -> weigth of the rule
# 6th -> 1 for AND, 2 for OR

rules= rbind(c(3, 1, 0, 1, 1, 1),
             c(3, 2, 0, 2, 1, 1),
             c(3, 3, 0, 2, 1, 1),
             c(0, 1, 1, 1, 1, 1),
             c(0, 2, 1, 1, 1, 1),
             c(0, 3, 1, 2, 1, 1),
             c(1, 3, 0, 3, 1, 1),
             c(2, 3, 0, 3, 1, 1),
             c(0, 1, 3, 2, 1, 1),
             c(0, 3, 2, 3, 1, 1),
             c(0, 2, 2, 3, 1, 1),
             c(0, 1, 2, 2, 1, 1),
             c(0, 3, 1, 2, 1, 1),
             c(0, 2, 1, 2, 1, 1))

#adicionar regras ao objeto
fis= addrule(fis, rules)
showrule(fis)

#plot das funcoes de pertinencia
png('mf1.png')
plotmf(fis, 'input', 1)
dev.off()

png('mf2.png')
plotmf(fis, 'input', 2)
dev.off()

png('mf3.png')
plotmf(fis, 'input', 3)
dev.off()

png('out1.png')
plotmf(fis, 'output', 1)
dev.off()

#Interface grafica da biblioteca
showGUI(fis)


one_of_n <- function(n)
{
  choice <- 1L

  for (i in 2:n)
  {
    if (i*runif(1) < 1)
      choice <- i
  }

  return(choice)
}

table(sapply(1:1000000, function(i) one_of_n(10)))


face.sparse <- function(data, newdata = NULL,
                        center=TRUE,argvals.new=NULL,
                        knots=7,
                        # knots.option="equally-spaced",
                        p=3,m=2,lambda=NULL,lambda_mean=NULL,
                        search.length=14,
                        lower=-3,upper=10, lower2 = -3, upper2=5,
                        calculate.scores=FALSE,pve=0.99,two_step=FALSE){

  if(!two_step){
    fit <- face.sparse.inner(data = data, newdata=newdata, W = NULL,
                             argvals.new = argvals.new,
                             center=center,
                             knots=knots,
                             # knots.option = knots.option,
                             p = p, m = m, lambda= lambda, lambda_mean = lambda_mean,
                             lower=lower,upper=upper,search.length=search.length,
                             calculate.scores=calculate.scores, pve = pve)

  }else{
    fit <- face.sparse.inner(data = data, newdata=NULL, W = NULL,
                             argvals.new = argvals.new,
                             center=center,
                             knots=knots,
                             # knots.option = knots.option,
                             p = p, m = m, lambda= lambda, lambda_mean = lambda_mean,
                             lower=lower,upper=upper,search.length=search.length,
                             pve = pve)

    W <- weight.construct(fit,data)

    fit <- face.sparse.inner(data = data, newdata=newdata, W = W,
                             argvals.new = argvals.new,
                             center=center,
                             knots=knots,
                             # knots.option = knots.option,
                             p = p, m = m, lambda= lambda, lambda_mean = lambda_mean,
                             lower=lower2,upper=upper2,search.length=length(lower2:upper2),
                             calculate.scores=calculate.scores,pve=pve)
  }

  return(fit)
}


library(readr)
library(Amelia)
library(magrittr)
suppressMessages(library(dplyr))
library(ggplot2)
suppressMessages(library(tidyr))

responses <- read_csv("C:/Users/meghana/Desktop/dm/dm project/responses.csv")
hni = responses[, 32:63] #hobbies and interests
gen = responses[, 145] #genders
#gen = ifelse(gen == "male", 0, 1) #converting categorical to binary data
data = cbind(hni, gen)

#data visualization
# Helper functions
analyze_grp_diff <- function(dafr, group, start, end) {
  avgs_group <-  dafr %>%
    dplyr::rename_(group = group) %>%
    select_("group", paste0("`", start, "`:`", end,"`")) %>%
    dplyr::group_by(group) %>%
    dplyr::summarise_all(mean, na.rm = TRUE) %>%
    na.omit

  vars_by_difference <- avgs_group %>%
    dplyr::select(-group) %>%
    apply(2, function(x) x[1] - x[2]) %>%
    sort %>%
    names

  avgs_group %>%
    tidyr::gather(Variable, `average response`, -group) %>%
    ggplot(aes(x = Variable, y = `average response`, group = group, colour = group)) +
    geom_point(size = 5) +
    scale_x_discrete(limits = vars_by_difference) +
    ylim(1, 5) +
    geom_hline(yintercept = 3) +
    coord_flip() +
    theme(axis.text.y = element_text(face="bold", color="Black", size=12),
          legend.position="right")

}

dafr = data
dafr %>% analyze_grp_diff("Gender", "History", "Pets")

#create train and test data
rnum = nrow(gen)
t = rnum * 0.7 #train set
train = data[1:t,]
test = data[t:rnum,]
gen = ifelse(gen == "male", 0, 1) #converting categorical to binary data
#gen = as.numeric(gen)
data = cbind(hni, gen)

#Find missing data
sapply(data,function(x) sum(is.na(x)))
missmap(data, main = "Missing values vs observed")

#replace missing data
for (i in 1:ncol(data)){
  data[,i][is.na(data[,i])] <- round(mean(data[,i],na.rm=T))
}

train = data[1:t,]
test = data[t:rnum,]

#generalized linear model
fit <- glm(train$Gender~.,data=train,family=gaussian())
anova(fit, test="Chisq")
predict = predict(fit, type = "response")
fitted.results <- predict(fit,test,type='response')
fitted.results <- ifelse(fitted.results > 0.5,1,0)
misClasificError <- mean(fitted.results != test$Gender)
accur = 1-misClasificError
print(paste('Accuracy', accur*100,'%'))


suppressMessages(library(Hmisc))
## Imports data from master_data.csv
fname1       <- read.table(file="../../data/modtran/radiance/modtran.csv", sep=",", header=TRUE, strip.white=TRUE)
fname2       <- read.table(file="../../data/modtran/temp_offset_wvs1/modtran.csv", sep=",", header=TRUE, strip.white=TRUE)
fname3       <- read.table(file="../../data/modtran/modtran_wps1.csv", sep=",", header=TRUE, strip.white=TRUE)
fname4       <- read.table(file="../../data/modtran/temp_offset_wsv_half/modtran.csv", sep=",", header=TRUE, strip.white=TRUE)
# num_integration <- function(x,y){
# 	y <- as.numeric(y)
# 	x <- as.numeric(x)
# 	sum = y[1]
#   dx = x[2] - x[1]
# 	for (i in 3:(length(y)-1)){
#     if ((i %% 2) == 0){
#       sum = sum + 2 * y[i]
#     }else{
#       sum = sum + 4 * y[i]
#     }
# 	}
# 	sum = sum + y[length(y)]
# 	result = dx/3.0 * sum
# 	return(result)
# }

modtran_plot <- function(xran,fname,offset, leg, xran1, fname1, offset1, leg1) {
    planck_curve <- function(x, T){
        c1  = 1.191042*10^8
        c2  = 1.4387752*10^4
        B   = c1/(x^5*(exp(c2/(x*T)) - 1)) * pi
        return(B)
    }
    temp_planck_curve <- function(x, B){
        c1  = 1.191042*10^8
        c2  = 1.4387752*10^4
        t   = (x/c2) * log(((c1*pi)/(B*x^5)) + 1)
        T   = 1/t
        return(T)
    }
    rad <- function(data){
        intensity <- data * pi * 10^4
        return(intensity)
    }

    color = c("#0055D788", "#FF880088", "#AB2E8788", "#D90000", "#8F00C9", "#FF3383")

    par(mar=c(5,4,0,0), oma = c(0, 0, 3, 2), xpd=FALSE)
    layout(matrix(c(1,2,1,2), 2, 2, byrow=TRUE))

    plot(fname[,1], rad(fname[,2]), type='n', xlab=NA, ylab=NA,
    main=NA, xlim=xran, ylim=c(0, 25))
    minor.tick(nx=2, ny=2, tick.ratio=0.5, x.args = list(), y.args = list())

    lines(fname[,1], rad(fname[,2]), col=color[1], cex=0.6, lty=1)
    lines(fname[,1], rad(fname[,3]), col=color[2], cex=0.6, lty=1)
    lines(fname[,1], rad(fname[,4]), col=color[3], cex=0.6, lty=1)
    mtext(bquote("Intensity (W "*m^{-2}*mu*m^{-1}*")"), side=2, line=2)
    mtext(bquote("Wavelength ("*mu*m*")"), side=1, line=3)

    avg_4 <- avg_3 <- avg_1 <- avg_2 <- avg_0 <- list()
    for(i in 1:length(fname[,1])){
        if(fname[i,1] >= xran[1]){
            if(fname[i,1] <= xran[2]){
                avg_0 <- append(avg_0, fname[i,1])
                avg_1 <- append(avg_1, rad(fname[i,2]))
                avg_2 <- append(avg_2, rad(fname[i,3]))
                avg_3 <- append(avg_3, rad(fname[i,4]))
            }
        }
    }
    avg0 <- Reduce("+", avg_0)/length(avg_0)
    avg1 <- Reduce("+", avg_1)/length(avg_1)
    avg2 <- Reduce("+", avg_2)/length(avg_2)
    avg3 <- Reduce("+", avg_3)/length(avg_3)

    curve(planck_curve(x, temp_planck_curve(avg0, avg1)), add=TRUE)
    curve(planck_curve(x, temp_planck_curve(avg0, avg2)), add=TRUE)
    curve(planck_curve(x, temp_planck_curve(avg0, avg3)), add=TRUE)

    points(avg0, avg1, pch=16, col=substr(color[1], start=1, stop=7))
    points(avg0, avg2, pch=16, col=substr(color[2], start=1, stop=7))
    points(avg0, avg3, pch=16, col=substr(color[3], start=1, stop=7))

    # text(9.5,offset[1], label=paste("T = ", round(temp_planck_curve(avg0, avg1), 2), "K"), srt=15, cex=0.75)
    # text(9.5,offset[2], label=paste("T = ", round(temp_planck_curve(avg0, avg2), 2), "K"), srt=15, cex=0.75)
    # text(9.5,offset[3], label=paste("T = ", round(temp_planck_curve(avg0, avg3), 2), "K"), srt=15, cex=0.75)
		lab_temp1 = paste("T = ",round(temp_planck_curve(avg0, avg1), 2), "K")
		lab_temp2 = paste("T = ",round(temp_planck_curve(avg0, avg2), 2), "K")
		lab_temp3 = paste("T = ",round(temp_planck_curve(avg0, avg3), 2), "K")
		space = "                             "
    legend("topright", col=c(color[1], color[2], color[3], NA, "black", "black", "black"), lty=c(1,1,1,0,1,1,1), pch=NA, legend=c(leg,"",lab_temp1, lab_temp2, lab_temp3))
		legend("topright", col=c(substr(color[1], start=1, stop=7),
                             substr(color[2], start=1, stop=7),
                             substr(color[3], start=1, stop=7),
														 NA,
													 	 substr(color[1], start=1, stop=7),
													 	 substr(color[2], start=1, stop=7),
												 		 substr(color[3], start=1, stop=7)), lty=c(0,0,0,0), pch=c(16,16,16,0,16,16,16), legend=c(space,space,space,space,space,space,space), bty="n")

    legend("bottomright", "(a)", bty="n")
	 #
    plot(fname1[,1], rad(fname1[,2]), type='n', xlab=NA, ylab=NA,
    main=NA, xlim=xran, ylim=c(0, 25))
    minor.tick(nx=2, ny=2, tick.ratio=0.5, x.args = list(), y.args = list())

    lines(fname1[,1], rad(fname1[,2]), cex=0.6, col=color[1])
    lines(fname1[,1], rad(fname1[,3]), cex=0.6, col=color[2])
    lines(fname1[,1], rad(fname1[,4]), cex=0.6, col=color[3])

    mtext(bquote("Intensity (W "*m^{-2}*mu*m^{-1}*")"), side=2, line=2)
    mtext(bquote("Wavelength ("*mu*m*")"), side=1, line=3)

    avg_4 <- avg_3 <- avg_1 <- avg_2 <- avg_0 <- list()
    for(i in 1:length(fname1[,1])){
        if(fname1[i,1] >= xran[1]){
            if(fname1[i,1] <= xran[2]){
                avg_0 <- append(avg_0, fname1[i,1])
                avg_1 <- append(avg_1, rad(fname1[i,2]))
                avg_2 <- append(avg_2, rad(fname1[i,3]))
                avg_3 <- append(avg_3, rad(fname1[i,4]))
            }
        }
    }
    avg0 <- Reduce("+", avg_0)/length(avg_0)
    avg1 <- Reduce("+", avg_1)/length(avg_1)
    avg2 <- Reduce("+", avg_2)/length(avg_2)
    avg3 <- Reduce("+", avg_3)/length(avg_3)

    curve(planck_curve(x, temp_planck_curve(avg0, avg1)), add=TRUE)
    curve(planck_curve(x, temp_planck_curve(avg0, avg2)), add=TRUE)
    curve(planck_curve(x, temp_planck_curve(avg0, avg3)), add=TRUE)

    points(avg0, avg1, pch=16, col=substr(color[1], start=1, stop=7))
    points(avg0, avg2, pch=16, col=substr(color[2], start=1, stop=7))
    points(avg0, avg3, pch=16, col=substr(color[3], start=1, stop=7))

		mtext(bquote("Evaluaion of MODTRAN6 for "*.(xran1[1])*"-"*.(xran1[2])*mu*m), cex=1, outer=TRUE, at=0.55, padj=-1)

		lab_temp1 = paste("T = ",round(temp_planck_curve(avg0, avg1), 2), "K")
		lab_temp2 = paste("T = ",round(temp_planck_curve(avg0, avg2), 2), "K")
		lab_temp3 = paste("T = ",round(temp_planck_curve(avg0, avg3), 2), "K")
		space = "                         "
    legend("topright", col=c(color[1], color[2], color[3], NA, "black", "black", "black"), lty=c(1,1,1,0,1,1,1), pch=NA, legend=c(leg1,"",lab_temp1, lab_temp2, lab_temp3))

		legend("bottomright", "(b)", bty="n")
		legend("topright", col=c(substr(color[1], start=1, stop=7),
                             substr(color[2], start=1, stop=7),
                             substr(color[3], start=1, stop=7),
														 NA,
													 	 substr(color[1], start=1, stop=7),
													 	 substr(color[2], start=1, stop=7),
												 		 substr(color[3], start=1, stop=7)), lty=c(0,0,0,0), pch=c(16,16,16,0,16,16,16), legend=c(space,space,space,space,space,space,space), bty="n")
}

modtran_plot1 <- function(fname){
    plot(fname[,5], fname[,2], xlab="Water Pressure (mbar)", ylab="Altitude (km)",
    main="Altitude and Water Pressure Correlation")
}
pdf("../../figs/modtran.pdf")
modtran_plot(c(7,10), fname1, c(10,12.74,15),
  c("TPW = 5.7 mm","TPW = 11.4 mm", "TPW = 22.7 mm"),c(7,10), fname2, c(11.5, 12.75, 14), c("-5 K Offset", "0 K Offset", "+5 K Offset"))
# modtran_plot(c(7,10), fname4, c(10, 11.25, 12.5), c("-5 K Offset", "0 K Offset", "+5 K Offset"))
modtran_plot(c(8,12), fname1, c(1,2.5,6),
  c("TPW = 5.7 mm","TPW = 11.4 mm", "TPW = 22.7 mm"),c(8,12), fname2, c(11.5, 12.75, 14), c("-5 K Offset", "0 K Offset", "+5 K Offset"))

graphics.off()


library(ggplot2) # Import library
dataset = read.csv("/Salaries.csv", header = TRUE) # Open CSV

salaryMean = mean(dataset$Salary)
salarySD = sd(dataset$Salary)

ggplot(data=dataset, aes(dataset$Salary)) +
  geom_histogram(aes(y=..density..),
                 colour="black", fill="white") +
  stat_function(fun = dnorm, args = c(mean = salaryMean, sd = salarySD), col="#32CD32", geom = 'area', fill = '#00FF00', alpha = 0.2)+
  labs(title="Normal Distribution - Salary", x="Salary", y="Density")


library(MASS)

donne <- 8
uomini <- 10

donne_elette <- 2
uomini_eletti <- 2

domanda_2 <- 3
domanda_3 <- 3
domanda_4_uomini <- 1
domanda_4_donne <- 1

print(fractions(choose(donne,donne_elette)*choose(uomini, uomini_eletti)))
print(fractions(choose(donne,donne_elette)*(choose(uomini-domanda_2,uomini_eletti)
               +domanda_2*choose(uomini-domanda_2,uomini_eletti-1))))
print(fractions(choose(uomini,uomini_eletti)*(choose(donne-domanda_3,donne_elette)
               +domanda_3*choose(donne-domanda_3,donne_elette-1))))
print(fractions(choose(uomini-domanda_4_uomini,uomini_eletti)*choose(donne-domanda_4_donne,donne_elette)
               +choose(uomini-domanda_4_uomini,uomini_eletti)*choose(donne-domanda_4_donne,donne_elette-domanda_4_donne)
               +choose(uomini-domanda_4_uomini,uomini_eletti-domanda_4_uomini)*choose(donne-domanda_4_donne,donne_elette)))


source("llr.r")

p = 0.01
n1 = 1000
n2 = 1000
n0 = 400
k0 = 10
step = 20
k1 = seq(from=k0, to=n0, by=step)
z = data.frame(
    k1 = k1,
    k2 = floor(n1 * rep(seq(40,800,by=5)/1000, each=length(k1))),
    llr = 0,
    chi2 = 0
)
n = dim(z)[1]

x2 = function(data) {
    total = sum(data)
    m = dim(data)[1]
    n = dim(data)[2]
    p.row = rowSums(data) / total
    p.col = colSums(data) / total
    expected = matrix(p.row, nrow=m, ncol=n, byrow=F) * matrix(p.col, nrow=m, ncol=n, byrow=T)
    expected = total * expected
    sum((data-expected)^2/expected)
}

for (i in 1:n) {
    table = matrix(c(z$k1[i], n1 - z$k1[i], z$k2[i], n2 - z$k2[i]), nrow=2)
    z$llr[i] = llr(table)
    z$chi2[i] = x2(table)
}

pdf('fig2.pdf', width=5, height=6)
par(mar=c(4,5,1,1))
plot(llr ~ chi2, z, cex=0.7, xlim=c(0,200), ylim=c(0,200),ylab=NA, xlab=NA, yaxt='n')
mtext(expression(-2 ~ log ~ lambda), side=1, line=3, las=1, cex=1.3)
mtext(expression(chi^2), side=2, line=3, las=2, cex=1.3)
axis(2, at=seq(0,200,by=50), las=2)
dev.off()


library(caret); library(kernlab); data(spam)

inTrain <- createDataPartition(y=spam$type,
                              p=0.75, list=FALSE)

training <- spam[inTrain,]
testing <- spam[-inTrain,]

dim(training)

set.seed(32343)
modelFit <- train(type ~.,data=training, method="glm")

modelFit

modelFit <- train(type ~.,data=training, method="glm")
modelFit$finalModel

predictions <- predict(modelFit,newdata=testing)

predictions

confusionMatrix(predictions,testing$type)


MGRAST_preprocessing <<- function(
                                  file_in,     # name of the input file (tab delimited text with the raw counts)
                                  file_out = "preprocessed_data",    # name of the output data file (tab delimited text of preprocessed data)
                                  remove_sg = TRUE, # boolean to remove singleton counts
                                  sg_threshold = 1 # rows with a sum of counts equal to or less than this value will be removed if remove_sg=TRUE
                                  )
  {

# Sub to remove singletons
    remove.singletons <- function (x, lim.entry = sg_threshold, lim.row = sg_threshold, ...) {
      x <- as.matrix (x)
      x [is.na (x)] <- 0
      x [x <= lim.entry] <- 0
      x [apply (x, MARGIN = 1, sum) >= lim.row, ]
    }

# functiona that performs normalization (log transformation, standardization, scaling fro m 0 to 1)
    normalize <- function (x, method = c("standard"), ...) {
      method <- match.arg(method)
      x <- as.matrix(x)
      x[is.na(x)] <- 0
      x <- log2(x + 1)
      mu <- matrix(apply(x, 2, mean), nr = nrow(x), nc = ncol(x),
                   byrow = TRUE)
      sigm <- apply(x, 2, sd)
      sigm <- matrix(ifelse(sigm == 0, 1, sigm), nr = nrow(x),
                     nc = ncol(x), byrow = TRUE)
      x <- (x - mu)/sigm
      shift <- min(x, na.rm = TRUE)
      scale <- max(x, na.rm = TRUE) - shift
      if (scale != 0) x <- (x - shift)/scale
      x
    }

###### MAIN
### Input the data
    input_data = data.matrix(read.table(file_in, row.names=1, header=TRUE, sep="\t", comment.char="", quote=""))

### remove singletons
    if(remove_sg==TRUE){
      input_data <- remove.singletons(x=input_data)
    }

### Norm, standardize, and scale the data
    input_data <- normalize(x=input_data)

###### write the log transformed and centered data to a file
    write.table(input_data, file=file_out, sep="\t", col.names = NA, row.names = TRUE, quote = FALSE)
  }


library(quantmod)

rm(list = ls())

stock <- na.omit(get(getSymbols('AAPL')))

pl <- setNames( rep( 0, length(Cl(stock)) ), time(stock) ) # [p]rofit and [l]ose vector

hi_max <- lag(runMax(Hi(stock), 5))
lo_min <- lag(runMin(Lo(stock), 3))

cum_long <- 0
n <- 0
for (m in 6:(nrow(stock)-1)) {
    if (Cl(stock)[m] > hi_max[m]) {
        long <- as.numeric( Op(stock)[m+1] )
        cum_long <- cum_long + long
        n <- n + 1
    }
    else if (Cl(stock)[m] < lo_min[m]) {
        pl[m] <- as.numeric( Op(stock)[m+1] ) * n - cum_long
        cum_long <- 0
        n <- 0
    }
}

plot( cumsum(pl), type='l', col='red', lwd=2 )


library(WGCNA)
library("flashClust")
library("doParallel")
# options(stringsAsFactors = FALSE);

### CAP_sepsis ###
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("GSE65682_series_all_mortality.Rdat")
affyData_CAP <- affyData_out[,pheno$d == "cap"]
phenotype_CAP <- pheno$mort[pheno$d == "cap"]

datExpr = t(affyData_CAP)
GeneNames = rownames(affyData_CAP)

# Calculate a soft-treshold power
powers = c(c(1:10), seq(from = 12, to=30, by=2));
sft=pickSoftThreshold(datExpr,dataIsExpr = TRUE,powerVector = powers,
  corFnc = cor,corOptions = list(use = 'p'), networkType = "unsigned")

################################################################################
# Plot the results
sizeGrWindow(9, 5)
par(mfrow = c(1,2));
cex1 = 0.9;

# Scale-free topology fit index as a function of the soft-thresholding power
plot(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2],xlab="Soft Threshold (power)",ylab="Scale Free Topology Model Fit, signed R^2",type="n", main = paste("Scale independence"));
text(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2],labels=powers,cex=cex1,col="red");

# Red line corresponds to using an R^2 cut-off
abline(h=0.80,col="red")

# Mean connectivity as a function of the soft-thresholding power
plot(sft$fitIndices[,1], sft$fitIndices[,5],xlab="Soft Threshold (power)",ylab="Mean Connectivity", type="n",main = paste("Mean connectivity"))
text(sft$fitIndices[,1], sft$fitIndices[,5], labels=powers, cex=cex1,col="red")
################################################################################
# Choose a soft-treshold power

softPower = 12;

#calculate the adjacency matrix
adj <- adjacency(datExpr,type = "unsigned", power = softPower);

#turn adjacency matrix into a topological overlap matrix (TOM) to minimize the effects of noise and spurious associations
# TOM <- TOMsimilarityFromExpr(datExpr,networkType = "unsigned", TOMType = "unsigned", power = softPower);
TOM <- TOMsimilarity(adj,  TOMType = "unsigned")
rownames(TOM) <- GeneNames
colnames(TOM) <- GeneNames
dissTOM <- 1-TOM

#hierarchical clustering of the genes based on the TOM dissimilarity measure
geneTree = flashClust(as.dist(dissTOM),method="average");

#plot the resulting clustering tree (dendrogram)
plot(geneTree, xlab="", sub="",cex=0.3);

# Set the minimum module size
minModuleSize = 10;

# Module identification using dynamic tree cut
dynamicMods = cutreeDynamic(dendro = geneTree,  method="tree", minClusterSize = minModuleSize);
#dynamicMods = cutreeDynamic(dendro = geneTree, distM = dissTOM, method="hybrid", deepSplit = 2, pamRespectsDendro = FALSE, minClusterSize = minModuleSize);

#the following command gives the module labels and the size of each module. Lable 0 is reserved for unassigned genes
table(dynamicMods)

#Plot the module assignment under the dendrogram; note: The grey color is reserved for unassigned genes
dynamicColors = labels2colors(dynamicMods)
table(dynamicColors)

datME = moduleEigengenes(datExpr,dynamicColors)$eigengenes

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("CAP_WGCNA.Rdat")


# 4. faza: Analiza podatkov

Sestevek_po_pridelkih_regijah$leto <- as.character(Sestevek_po_pridelkih_regijah$leto)
Sestevek_po_pridelkih_regijah$Kolicina <- as.character(Sestevek_po_pridelkih_regijah$Kolicina)

Sestevek_po_pridelkih_regijah <- Sestevek_po_pridelkih_regijah %>% mutate(leto = parse_integer(leto), Kolicina = parse_number(Kolicina))
prileganje <- lm(Kolicina ~ leto, data = Sestevek_po_pridelkih_regijah)
predict(prileganje, data.frame(leto=seq(2010,2022,1)))

graf_napoved <- ggplot(Sestevek_po_pridelkih_regijah, aes(x=leto, y=Kolicina)) + geom_point() +
  geom_smooth(method='lm', formula=y ~ poly(x,2,raw=TRUE), fullrange=TRUE, color='green') + scale_x_continuous('leto', breaks = seq(2010, 2022, 1), limits = c(2010,2022))+ xlab('Leto') + ylab('Količina ton/ha proizvedbe')


#devtools::test("asremlPlus")
context("model_selection")

cat("#### Test for wheat76 example with asreml4\n")
test_that("Wheat_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  ## use asremlPlus to analyse the wheat (barley) example from section 8.6 of the asreml manual (Butler et al. 2010)
  data(Wheat.dat)

  # Fit initial model
  current.asr <- asreml(yield ~ Rep + WithinColPairs + Variety,
                        random = ~ Row + Column + units,
                        residual = ~ ar1(Row):ar1(Column),
                        data=Wheat.dat)
  summary(current.asr)
  info <- infoCriteria(current.asr)
  testthat::expect_equal(info$varDF, 5)
  testthat::expect_lt(abs(info$AIC - 1346.768), 0.10)

  # Load current fit into an asrtests object
  current.asrt <- as.asrtests(current.asr, NULL, NULL,
                              label = "Maximal model", IClikelihood = "full")
  testthat::expect_lt(abs(current.asrt$test.summary$AIC - 1653.1), 0.50)

  # Check for and remove any boundary terms
  current.asrt <- rmboundary(current.asrt, IClikelihood = "full")

  #Check term for within Column pairs
  current.asrt <- testranfix(current.asrt, term = "WithinColPairs",
                             drop.fix.ns=TRUE, IClikelihood = "full")

  # Test nugget term
  current.asrt <- testranfix(current.asrt, "units", positive=TRUE, IClikelihood = "full")

  # Test Row autocorrelation
  current.asrt <- testresidual(current.asrt, "~ Row:ar1(Column)",
                               label="Row autocorrelation", simpler=TRUE,
                               IClikelihood = "full")

  # Test Col autocorrelation (depends on whether Row autocorrelation retained)
  p <- getTestPvalue(current.asrt, label = "Row autocorrelation")
  testthat::expect_true((abs(p - 2.314881e-06) < 1e-05))
  { if (p <= 0.05)
    current.asrt <- testresidual(current.asrt, "~ ar1(Row):Column",
                                 label="Col autocorrelation", simpler=TRUE,
                                 IClikelihood = "full", update=FALSE)
    else
      current.asrt <- testresidual(current.asrt, "~ Row:Column",
                                   label="Col autocorrelation", simpler=TRUE,
                                   IClikelihood = "full", update=FALSE)
  }
  print(current.asrt)
  testthat::expect_equal(length(current.asrt), 3)
  testthat::expect_equal(nrow(current.asrt$wald.tab), 3)
  testthat::expect_equal(nrow(current.asrt$test.summary), 6)
  testthat::expect_lt(abs(current.asrt$test.summary$AIC[6] - 1651.329), 0.10)
  testthat::expect_lt(abs(current.asrt$test.summary$BIC[6] - 1756.701), 0.10)
  info <- infoCriteria(current.asrt$asreml.obj)
  testthat::expect_equal(info$varDF, 5)
  testthat::expect_lt(abs(info$AIC - 1353.762), 1e-03)

  # Get current fitted asreml object
  current.asr <- current.asrt$asreml.obj
  current.asr <- update(current.asr, aom=TRUE)

  # Do residuals-versus-fitted values plot
  plot(fitted(current.asr),residuals(current.asr))

  #Produce variogram and variogram faces plot (Stefanaova et al, 2009)
  if (requireNamespace("lattice"))
  {
    plot.varioGram(varioGram.asreml(current.asr))
  }
  V <- estimateV(current.asr)
  faces <- variofaces(current.asr, V=V, maxiter=50, units="addtores")
  testthat::expect_equal(nrow(faces$face1), 10)
  testthat::expect_equal(nrow(faces$face2), 15)

  #Get Variety predictions and all pairwise prediction differences and p-values
  Var.diffs <- predictPlus(classify = "Variety",
                           asreml.obj=current.asr,
                           error.intervals="halfLeast",
                           wald.tab=current.asrt$wald.tab,
                           tables = "predictions",
                           sortFactor = "Variety")
  testthat::expect_equal(nrow(Var.diffs$predictions), 25)
  testthat::expect_equal(ncol(Var.diffs$predictions), 6)
  testthat::expect_equal(nrow(Var.diffs$differences), 25)
  testthat::expect_equal(ncol(Var.diffs$differences), 25)
  testthat::expect_equal(nrow(Var.diffs$p.differences), 25)
  testthat::expect_equal(ncol(Var.diffs$p.differences), 25)
  testthat::expect_equal(length(Var.diffs$LSD), 8)
  testthat::expect_true("lower.halfLeastSignificant.limit" %in% names(Var.diffs$predictions))
  testthat::expect_equal(Var.diffs$backtransforms, NULL)
  testthat::expect_equal(as.character(Var.diffs$predictions$Variety[[1]]),"10")
  testthat::expect_silent(plotPvalues(Var.diffs))
  testthat::expect_silent(plotPvalues(Var.diffs, show.sig = TRUE, alpha = 0.05))

  #Test for single-value LSDs
  diffs <- predictPlus(classify = "Variety",
                           asreml.obj=current.asr,
                           error.intervals="halfLeast",
                           LSDtype = "fact", LSDby = "Variety",
                           wald.tab=current.asrt$wald.tab,
                           tables = "predictions",
                           sortFactor = "Variety")
  testthat::expect_equal(nrow(diffs$LSD), 25)
  testthat::expect_true("lower.halfLeastSignificant.limit" %in% names(diffs$predictions))
  #Are the LSDs sorted?
  testthat::expect_true(all((diffs$predictions$upper.halfLeastSignificant.limit -
                               diffs$predictions$lower.halfLeastSignificant.limit -
                               diffs$LSD$meanLSD) < 1e-05))
  diffs$predictions$upper.halfLeastSignificant.limit - diffs$predictions$lower.halfLeastSignificant.limit
})


##' @aliases ngonGrob grid.ngon ellipseGrob grid.ellipse
##' @title Regular polygon grob
##' @description Regular polygons with optional rotation, stretching, and aesthetic attributes.
##' @describeIn ngonGrob return a polygon grob
##' @param x x unit
##' @param y y unit
##' @param n number of vertices
##' @param size radius of circumscribing circle
##' @param phase angle in radians of first point relative to x axis
##' @param ar aspect ratio
##' @param angle angle of polygon in radians
##' @param position.units default units for the positions
##' @param size.units grid units for the sizes
##' @param gp gpar
##' @param ... further parameters passed to polygonGrob
##' @return A grob.
##' @export
##' @examples
##' library(grid)
##' N <- 5
##' xy <- polygon_regular(N)*2
##'
##' # draw multiple polygons
##' g <- ngonGrob(unit(xy[,1],"cm") + unit(0.5,"npc"),
##'               unit(xy[,2],"cm") + unit(0.5,"npc"),
##'               n = seq_len(N) + 2, gp = gpar(fill=1:N))
##'
##' grid.newpage()
##' grid.draw(g)
##'
##' # rotated and stretched
##' g2 <- ngonGrob(unit(xy[,1],"cm") + unit(0.5,"npc"),
##'               unit(xy[,2],"cm") + unit(0.5,"npc"),
##'               n = seq_len(N) + 2, ar = seq_len(N),
##'               phase = 0, angle = pi/(seq_len(N) + 2),
##'               size = 1:N + 5)
##'
##' grid.newpage()
##' grid.draw(g2)
##'
##' # ellipse
##' g3 <- ellipseGrob(unit(xy[,1],"cm") + unit(0.5,"npc"),
##'                   unit(xy[,2],"cm") + unit(0.5,"npc"),
##'                   angle = -2*seq(0,N-1)*pi/5 + pi/2,
##'                   size = 5, ar = 1/3)
##'
##' grid.newpage()
##' grid.draw(g3)
ngonGrob <- function (x, y, n = 5, size = 5, phase = pi/2,
                      angle = 0, ar = 1,
                      gp = gpar(colour = "black", fill = NA,
                                linejoin = "mitre"), ...,
                      position.units = "npc", size.units="mm")
{
  N <- length(x)
  stopifnot(length(y) == N)

  if (!is.unit(x))
    x <- unit(x, position.units)
  if (!is.unit(y))
    y <- unit(y, position.units)

  xv <- convertX(x, position.units, TRUE)
  yv <- convertY(y, position.units, TRUE)

  if (length(n) < N)
    n <- rep(n, length.out = N)
  if (length(size) < N)
    size <- rep(size, length.out = N)
  if (length(phase) < N)
    phase <- rep(phase, length.out = N)
  if (length(angle) < N)
    angle <- rep(angle, length.out = N)
  if (length(ar) < N)
    ar <- rep(ar, length.out = N)

  lngon <- mapply(polygon_regular, n = n, phase = phase,
                  SIMPLIFY = FALSE)
  vertices <- sapply(lngon, nrow)

  stretch_rotate_move <- function(p, size, ar, angle, x, y){
    central <- size * p %*%
      diag(c(sqrt(ar), 1/sqrt(ar))) %*%
      rbind(c(cos(angle), -sin(angle)),
            c(sin(angle),  cos(angle)))

    list(x = unit(central[,1], size.units) + unit(x, position.units),
         y = unit(central[,2], size.units) + unit(y, position.units))

  }

  lxy <- mapply(stretch_rotate_move, p=lngon,
                size=size, ar=ar, angle=angle,
                x=xv, y=yv,
                SIMPLIFY = FALSE)

  allx <- do.call("unit.c", lapply(lxy, "[[", 1))
  ally <- do.call("unit.c", lapply(lxy, "[[", 2))

  polygonGrob(allx, ally, id.lengths = vertices, gp = gp, ...)

}

#' @describeIn ngonGrob draw a polygon grob on the current device
#' @inheritParams ngonGrob
#' @export
grid.ngon <- function(...)
{
  grid.draw(ngonGrob(...))
}

#' @describeIn ngonGrob return an ellipse grob
#' @inheritParams ngonGrob
#' @export
ellipseGrob <- function(x, y, size = 5,
                        angle = pi/4, ar = 1, n = 50,
                        gp = gpar(colour = "black", fill = NA,
                                  linejoin = "mitre"), ...,
                        position.units = "npc", size.units="mm")  {

  ngonGrob(x, y, n = n , phase = 0,
           size = size, angle = angle, ar = ar,
           gp = gp, position.units = position.units,
           size.units = size.units, ...)
}

#' @describeIn ngonGrob draw an ellipse grob
#' @inheritParams ngonGrob
#' @export
grid.ellipse <- function(...)
{
  grid.draw(ellipseGrob(...))
}

#' @describeIn ngonGrob return the x,y coordinates of a regular polygon inscribed in the unit circle
#' @inheritParams ngonGrob
#' @export
polygon_regular <- function(n = 5, phase = 0){
  stopifnot(n > 2)
  cc <- exp(seq(0, n)*2i*pi/n) * exp(1i*(phase+pi/2))
  cbind(Re(cc), Im(cc))
}