# cod North Sea

firstAge<-1
maxAge<-20
nSeasons<-4
FbarAge<-c(2,4)  # expanded relative to normal

dicardLength<-40   # Knife edge selection for discard

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

f.season<-1
l.season<-nSeasons

#### Natural moratlity
M<-c(0.8,0.35,0.25,rep(0.2,maxAge-firstAge))                  # annual values
M<-rep(M/nSeasons,each=nSeasons)                              # quarterly values, assume equaly split
propMat<-c(0.01,0.05,0.23,0.62,0.86,rep(1,maxAge-firstAge))   # annual values
propMat<-rep(propMat,each=nSeasons)

####  von Bertalanffy growth  parameters
K<-0.219
loo<-126
CV<-0.15  # CV of length distribution within an age

vonBertalanffy<-function(tid,loo,K,t0=0) {
  return(loo*(1-exp(-K*(tid-t0))))
}

#### length weight relation.  Fishbase North Sea Netherlands
a<-0.0068E-3
b<-3.101
lw<-function(len){a*len^b}
#########

# first try, No fishing
age<-seq(firstAge,maxAge,1/nSeasons)
age<-age[1:(length(age)-1)]
age
M<-M[1:length(age)]
propMat<-propMat[1:length(age)]

len<-vonBertalanffy(tid=age,loo=loo,K=K)
W<-lw(len)
N<-M #copy structure
N[1]<-1
for (i in 2:length(N)) N[i]<-N[i-1]*exp(-M[i])
biomass<-N*W
SSB<-biomass*propMat

nox<-2; noy<-2;
  newplot(dev='screen',nox,noy);
optAge<-age[which(biomass==max(biomass))]

plot(age,len,ylab="cm",main='Length at age')
abline(v=optAge)
plot(age,W,ylab="kg", main="Weight at age")
abline(v=optAge)
plot(age,N,ylab=" ", main="Stock number at age")
abline(v=optAge)

plot(age,biomass,ylab="kg", main="TSB and SSB at age")
lines(age,SSB)
abline(v=optAge)

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

# "North Sea Cod" data from Niels Madsen
mesh<-c(70,80,90,100,110,120,130,140,150)
L50<-c(21.22,24.99,28.75,32.52,36.28,40.05,43.81,47.58,51.35)
SR<-c(3.98,4.69,5.40,6.10,6.81,7.52,8.22,8.93,9.64)
selection<-data.frame(mesh=mesh,L50=L50,SR=SR)
# plot(mesh,L50); abline(lm(L50~mesh))
# plot(mesh,SR); abline(lm(SR~mesh))
L50par<-lm(L50~mesh,  data=selection)
SRpar<-lm(SR~mesh,  data=selection)
selection<-data.frame(L50a=L50par$coefficients[1],L50b=L50par$coefficients[2],SRa=SRpar$coefficients[1],SRb=SRpar$coefficients[2])

meshSelection<-function(mesh,len) {
  L50<-selection$L50a[1]+mesh*selection$L50b[1]
  SR<- selection$SRa[1]+mesh*selection$SRb[1]
  S1<-L50*log(3)/(SR/2)
  S2<-S1/L50
  SL<-1/(1+exp(S1-S2*len))
  return (list(SL,L50))
}

l<-seq(10,100)  # fish length in cm
col<-1
firstMesh<-70
a<- meshSelection(mesh=firstMesh,len=l)
plot(l,a[[1]],type='l',col=col,xlab="length (cm)",ylab="selection")
abline(h=0.5)
abline(v=a[[2]],col=col)
text(a[[2]],0.55,formatC(firstMesh,width=3,digits=3),col=col)
for (mesh in (seq(firstMesh+20,200,20))) {
  col<-col+1
  a<-meshSelection(mesh=mesh,len=l)
  lines(l,a[[1]],col=col)
  text(a[[2]],0.55,formatC(mesh,width=3,digits=3),col=col)
  abline(v=a[[2]],col=col)
}

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

 YPR<-function(EffortMult=1,len=len, mesh=mesh,minSize=40)
# Yield Per Recruit function using size dependent F, where F(a,length)=SL(length)*effort
# effortMult is effort multiplier
# len is length at age vector
# mesh is mesh size of trawl
# minSize is minimum landing size, Knife edge select: below means discard, above means landed
# Return values:
#  yield: landed weigth per recruir
#  discard: discarded weight per recruit
#  meanWLanded: mean weight of landed fish
#  Fbar: average F over specified ages
 {
      Fmort<-meshSelection(mesh,len)[[1]]*EffortMult

      N<-Fmort # copy structure
      N[]<-0
      N[1]<-1

      Z<-M+Fmort

      Z[is.na(Z)]<-0
      C<-Z  #copy structure
      for (t in (2:length(Z))) {
        N[t]<-N[t-1]*exp(-Z[t])     # exponential decay
      }
      #plot(age,N)
      Nbar<-N*(1-exp(-Z))/Z   # average N within time step
      #lines(age,Nbar)
      C<-Nbar*Fmort       # total catch numbers
      Clanded<-C          # copy structure
      Clanded[len<minSize]<-0;        # extract landed (length>minimum size)
      mw<-sum(Clanded*W)/sum(Clanded)
      Cdiscard<-C         # copy structure
      Cdiscard[len>=minSize]<-0;

      deadM<-Nbar*M     # number dead of natural causes
      dead<-deadM+C     # total number dead

      yield<-sum(Clanded*W)    # yield weight
      discard<-sum(Cdiscard*W) # discarded weight

      # TSB and SSB in start of the first season
      TSB<-matrix(N,nrow=nSeasons)[1,]*matrix(W,nrow=nSeasons)[1,]
      SSB<-sum(TSB*matrix(propMat,nrow=nSeasons)[1,])
      TSB<-sum(TSB)

      C<-apply(matrix(C,nrow=nSeasons),2,sum) #sum into C at age
      dead<-apply(matrix(dead,nrow=nSeasons),2,sum) # sum total dead at age
      Z<-apply(matrix(Z,nrow=nSeasons),2,sum) #age Z
      Fmort<-Z*C/dead  # annual F at age
      #print(Fmort)
      Fbar<-mean(Fmort[FbarAge[1]:FbarAge[2]])
      return(list(yield=yield,meanWLanded=mw,discard=discard,Fbar=Fbar,TSB=TSB,SSB=SSB))
 }

 YPR(EffortMult=0.1,len=len, mesh=90,minSize=dicardLength)

 # the next exercise is to check the model and to define the range of effort multiplier (myMult)
 myMult<-seq(0.0,0.5,0.001)
 myMesh<-seq(40,180,20)
 design<-data.frame(myMesh=rep(myMesh,length(myMult)),myMult=rep(myMult,each=length(myMesh)))

a<- by(design,list(design$myMesh,design$myMult),function(x) {
      YPR(EffortMult=x$myMult,len=len, mesh=x$myMesh,minSize=dicardLength)
 })

b<-data.frame(as.matrix(design),matrix(unlist(a),ncol=6,byrow = T))
names(b)<-list("myMesh", "myMult", "Yield" ,    "meanWLanded" ,    "discard" ,    "Fbar", "TSB","SSB"  )

#b<-b[order(b$myMesh,b$myMult),]

levelplot(Yield~myMesh*myMult, data=b,xlab="Mesh size (mm)",ylab="effort multiplier",main="Yield per recruit",contour=T)

levelplot(Yield~myMesh*Fbar, data=b,xlab="Mesh size (mm)",ylab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''),main="Yield per recruit",contour=T)

xyplot( Yield~Fbar|as.factor(paste (formatC(myMesh,,wid=3,flag="0"),'mm')), data=b,ylab='Yield (kg)', xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''),xlim=c(0,1))

xyplot( Yield~Fbar, data=b, xlim=c(0,1),ylab='Yield (kg) per recruit', xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( discard~Fbar, data=b,  xlim=c(0,1),ylab='Discard (kg) per recruit',xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( SSB~Fbar, data=b,  xlim=c(0,1),ylab='SSB (kg) per recruit',xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( TSB~Fbar, data=b,  xlim=c(0,1),ylab='TSB (kg) per recruit',xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( meanWLanded~Fbar, data=b, xlim=c(0,1),ylab="mean landings weight (kg)",xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))


# rho_xy.r
# computes correlation between events;
# r stands for response and R for reinforcer
# ==========================================================================
# Inputs:
#   t_ev: matrix of 2x2 with [time,event]
#   R: id of first event (e.g., reinforcer)
#   r: id of second event (e.g., response)
#   sec_mult: resolution of the correlation. For example, if tvec
#     is in seconds and we want to compute correlation in milliseconds,
#     we must put sec_mult = 1000.
#   bin_res: resolution of bin. If we want to compute correlation in bins of
#     200 millisenconds, put bin_res = 200
# NOTE:
# This function depends on get_bins
# ==========================================================================

rho.rR <- function(t_ev,r,R,sec_mult,bin_res){

  # The max time at which subject get a reinforfer
  max_t <- max(t_ev[t_ev[,2] == R,1]) * sec_mult

  # vector of events
  v_events <- c(r,R)

  # Matrix of 3 columns for bins and frecuencies of events in those bins
  m_rR <-
    seq(0, max_t, bin_res) %>%
    seq_along() %>%
    data.frame(bin_r = .,
               r = NA,
               R = NA)

  for(j in 1:2){

    e <- v_events[j]
    event_bins <- t_ev[which(t_ev[ ,2] == e), 1] * sec_mult %>%
      get_bins(.,1,max_t,bin_res)

    for(i in 1:nrow(m_rR)){

      sum    <-  sum(m_rR[i,1] == event_bins)
      m_rR[i, j + 1] <- sum # j + 1 because m_rR have 3 columns

    }
  }

  cor(m_rR[ ,2],m_rR[ ,3])
}


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.

principal.start <- 30e6  # pool principal
n.peryr <- 12  # monthly = 12 payments per year
T <- 30   # 30-year mortgage
r <- 0.0625  # 6.25%
t <- 1:(n.peryr*T)

## tranche info
attach.pts <- list(a=0.22, b=0.14, c=0.05, z=0)
principal <- list(a=24e6,b=3e6,c=3e6,z=0)
interestbase <- list(a=(1-attach.pts$a)*principal.start,
                     b=(attach.pts$a-attach.pts$b)*principal.start,
                     c=(attach.pts$b-attach.pts$c)*principal.start,
                     z=(attach.pts$c-attach.pts$z)*principal.start)

## calculate level monthly payment
pmt.level <- principal.start*r/(n.peryr*(1-1/(1+r/n.peryr)^(n.peryr*T)))

## 100% PSA prepayment: rate up to 6% annual at 30 months
psa.speed <- 100  # 100% PSA
max.rate <- psa.speed/100*0.06
seasoned.month <- 30  # at 30 months, PSA says mortgages are seasoned
prepay.rate <- c(seq(max.rate/seasoned.month, max.rate, max.rate/seasoned.month),
                 rep(max.rate, n.peryr*T-seasoned.month))
prepay.monthly.survival <- (1-prepay.rate)^(1/n.peryr)
prepay.monthly.rate <- 1-prepay.monthly.survival

## In production code, this would be more elegant; however,
## a for loop shows the intuition better than other approaches
### Use fullword.variables for pool payments...
num.pmts <- n.peryr*T
principal.left <- c(principal.start, rep(0,num.pmts-1))
pmt.perperiod <- c(pmt.level, rep(0,num.pmts-1))
pmt.interest <- rep(0, num.pmts)
pmt.principal <- rep(0, num.pmts)
pmt.prepays <- rep(0, num.pmts)
### ... and use abbr.vars (abbreviated) for tranche payments
pmt.prin.a <- pmt.prin.b <- pmt.prin.c <- rep(0, num.pmts)
pmt.int.a <- pmt.int.b <- pmt.int.c <- pmt.int.z <- rep(0, num.pmts)
stop.loop <- FALSE
for (i in 1:num.pmts) {
    ## determine pool cashflows
    pmt.interest[i] <- principal.left[i]*r/n.peryr
    pmt.principal[i] <- pmt.perperiod[i] - pmt.interest[i]
    if (pmt.principal[i] > principal.left[i]) {
        ## do not repay more than principal remaining
        pmt.principal[i] <- principal.left[i]
        ## stop the loop; pool is paid off!
        stop.loop <- TRUE
    } else {
        ## do not prepay more than principal remaining after normal payment
        pmt.prepays[i] <- (principal.left[i]-pmt.principal[i])*prepay.monthly.rate[i]
        if ((pmt.principal[i] + pmt.prepays[i]) > principal.left[i]) {
            pmt.prepays[i] <- principal.left[i] - pmt.principal[i]
            ## stop the loop; pool is paid off!
            stop.loop <- TRUE
        }
    }
    ## allocate payments to tranches
    prin.to.allocate <- pmt.principal[i]+pmt.prepays[i]
    prinleft.a <- principal$a - sum(pmt.prin.a)
    prinleft.b <- principal$b - sum(pmt.prin.b)
    prinleft.c <- principal$c - sum(pmt.prin.c)
    ## Scale interest payments by fraction not repaid*interestbase
    ## Remaining interest will get allocated to principal repayment
    ## and then deferrred interest on the z tranche
    pmt.int.a[i] <- prinleft.a/principal$a*interestbase$a*r/n.peryr
    pmt.int.b[i] <- prinleft.b/principal$b*interestbase$b*r/n.peryr
    pmt.int.c[i] <- prinleft.c/principal$c*interestbase$c*r/n.peryr
    prin.to.allocate <- prin.to.allocate + pmt.interest[i] -
        pmt.int.a[i] - pmt.int.b[i] - pmt.int.c[i]
    ## A is first in line for principal (Andropov is the name to say)
    if (prinleft.a > 0) {
        pmt.prin.a[i] <- min(prinleft.a, prin.to.allocate)
        prin.to.allocate <- prin.to.allocate - pmt.prin.a[i]
    }
    ## The letter B is next in line (for principal, Brezhnev's dead so he'll do just fine)
    if (prinleft.b > 0 & prin.to.allocate > 0) {
        pmt.prin.b[i] <- min(prinleft.b, prin.to.allocate)
        prin.to.allocate <- prin.to.allocate - pmt.prin.b[i]
    }
    ## The letter C is next for principal (C is for Chernenko)
    if (prinleft.c > 0 & prin.to.allocate > 0) {
        pmt.prin.c[i] <- min(prinleft.c, prin.to.allocate)
        prin.to.allocate <- prin.to.allocate - pmt.prin.c[i]
    }
    ## Finally, if any cashflows are left, they go to the Z tranche
    if (prin.to.allocate > 0)
        pmt.int.z[i] <- prin.to.allocate

    ## prepare for next iteration of loop
    if (i < num.pmts) {
        principal.left[i+1] <- principal.left[i] - pmt.principal[i] - pmt.prepays[i]
        pmt.perperiod[i+1] <- pmt.perperiod[i]*prepay.monthly.survival[i]
    }

    if (stop.loop)
        break
}

areaplot(t,data.frame(pmt.int.c,pmt.int.b,pmt.int.a,
                      pmt.prin.a,pmt.prin.b,pmt.prin.c,pmt.int.z),
         col=c("green","yellow","lightblue","blue","orange","darkgreen","red"),
         ylab="", border=FALSE)
text(100, 150000, "A", cex=2, col="white")
text(210, 60000, "B", cex=2)
text(255, 40000, "C", cex=2, col="white")
text(310, 20000, "Z", cex=2)


require(dplyr)

bmi <- function(weight, height) {
  index <- weight/height**2
  case_when(
    index <= 18.5 ~ "Underweight",
    index <= 25.0 ~ "Normal",
    index <= 30.0 ~ "Overweight",
    TRUE          ~ "Obese"
  )
}


library(caret)

setwd("C:/Users/lukaszbinden/git/jmcs-pattern-recognition/Exercise_4")

data = read.csv("predictions.csv", header = TRUE)

predictions = data[2-3]
result = table(predictions, dnn=c("Prediction", "Ground truth"))
result
confM = confusionMatrix(t, dnn=c("Prediction", "Ground truth"))
confM

# plot(confM)
fourfoldplot(confM$table)


library(coop)
library(rbenchmark)
cols <- cols <- c("test", "replications", "elapsed", "relative")
reps <- 25

m <- 10000
n <- 250
x <- matrix(rnorm(m*n), m, n)

benchmark(cor(x), pcor(x), replications=reps, columns=cols)


install.packages("dplyr")
install.packages("readr")
install.packages("tidyverse")
install.packages("zeallot")
install.packages("vctrs")

library("readr")
library("dplyr")
library(tidyverse)

cotton_prices <- read_csv("/Users/prudhviteja/desktop/Cotton_Price-Forecasting/prices.csv")

# Take a glimpse at the contents
glimpse(cotton_prices)

cotton_prices <- read_csv("/Users/prudhviteja/desktop/Cotton_Price-Forecasting/prices.csv",
                          col_types = cols_only(
                            state = "c",
                            market="c",
                            commodity="c",
                            month="i",
                            year="i",
                            modal_price="d"))

cotton_prices_renamed<-rename(cotton_prices,
       region=state,
       market=market,
       commodity_kg=commodity,
       month=month,
       year=year,
       price_rwf=modal_price )

glimpse(cotton_prices_renamed)
cotton_prices_renamed %>% head()

library(lubridate)
library(dplyr)

cotton_prices_cleaned <- cotton_prices_renamed %>%

  mutate(date = ymd(paste(year, month, "01", sep="-"))) %>%
  select(-c(month, year))

glimpse(cotton_prices_cleaned)
cotton_prices_cleaned %>% head()

p

cotton_prices_summarized <- cotton_prices_cleaned %>%
  group_by(date) %>%
  summarize(median_price_rwf = median(price_rwf))

glimpse(cotton_prices_summarized)
cotton_prices_summarized %>% head()

library(magrittr)
cotton_time_series <- cotton_prices_summarized %$%
  ts(
    median_price_rwf,
    start = c(year(min(date)), month(min(date))),
    end   = c(year(max(date)), month(max(date))),
    frequency = 12
  )

glimpse(cotton_time_series)
cotton_time_series

install.packages("forecast")
library(forecast)

cotton_price_forecast <- cotton_time_series %>% forecast()

cotton_price_forecast

cotton_price_forecast %>% autoplot(main = "Cotton price forecast")


S30AAJ Example Program Results

Black-Scholes-Merton formula
European Call :
  Spot       =  55.0000
  Volatility =  0.3000
  Rate       =  0.1000
  Dividend   =  0.0000

    Strike      Expiry  Option Price
    58.0000     0.7000  5.9198
    58.0000     0.8000  6.5506
    60.0000     0.7000  5.0809
    60.0000     0.8000  5.6992
    62.0000     0.7000  4.3389
    62.0000     0.8000  4.9379


library(merkhet)
library(stats)
suppressMessages(library(fmlr))
set.seed(1234)

m = 7500
n = 500
type = "double"
set.seed(1234)

b = bench(sprintf("cov - %dx%d (%s) type=%s", m, n, as.character(howbig(m, n, type=type)), type))

x = matrix(rnorm(m*n), m, n)
x_cpumat = as_cpumat(x, copy=FALSE)

b$time(name="R", reps=5, {
  ret1 = cov(x)
})

b$time(name="fmlr", reps=5, {
  dimops_scale(x=x_cpumat)
  alpha = 1 / max(1, nrow(x)-1)
  ret2 = linalg_crossprod(alpha, x_cpumat)
})

ret2 = ret2$to_robj()
all.equal(ret1[lower.tri(ret1)], ret2[lower.tri(ret2)])

b$print()


# load and inspect gapminder data
library(dslabs)
data(gapminder)
head(gapminder)

# Faceted smooth density plots

# see the code below the previous video for variable definitions

# smooth density plots - area under each curve adds to 1
gapminder %>%
    filter(year == past_year & country %in% country_list) %>%
    mutate(group = ifelse(region %in% west, "West", "Developing")) %>% group_by(group) %>%
    summarize(n = n()) %>% knitr::kable()

# smooth density plots - variable counts on y-axis
p <- gapminder %>%
    filter(year == past_year & country %in% country_list) %>%
    mutate(group = ifelse(region %in% west, "West", "Developing")) %>%
    ggplot(aes(dollars_per_day, y = ..count.., fill = group)) +
    scale_x_continuous(trans = "log2")
p + geom_density(alpha = 0.2, bw = 0.75) + facet_grid(year ~ .)

# Add new region groups with case_when

# add group as a factor, grouping regions
gapminder <- gapminder %>%
    mutate(group = case_when(
        .$region %in% west ~ "West",
        .$region %in% c("Eastern Asia", "South-Eastern Asia") ~ "East Asia",
        .$region %in% c("Caribbean", "Central America", "South America") ~ "Latin America",
        .$continent == "Africa" & .$region != "Northern Africa" ~ "Sub-Saharan Africa",
        TRUE ~ "Others"))

# reorder factor levels
gapminder <- gapminder %>%
    mutate(group = factor(group, levels = c("Others", "Latin America", "East Asia", "Sub-Saharan Africa", "West")))

Code: Stacked density plot

# note you must redefine p with the new gapminder object first
p <- gapminder %>%
  filter(year %in% c(past_year, present_year) & country %in% country_list) %>%
    ggplot(aes(dollars_per_day, fill = group)) +
    scale_x_continuous(trans = "log2")

# stacked density plot
p + geom_density(alpha = 0.2, bw = 0.75, position = "stack") +
    facet_grid(year ~ .)

# Weighted stacked density plot

# weighted stacked density plot
gapminder %>%
    filter(year %in% c(past_year, present_year) & country %in% country_list) %>%
    group_by(year) %>%
    mutate(weight = population/sum(population*2)) %>%
    ungroup() %>%
    ggplot(aes(dollars_per_day, fill = group, weight = weight)) +
    scale_x_continuous(trans = "log2") +
    geom_density(alpha = 0.2, bw = 0.75, position = "stack") + facet_grid(year ~ .)

## The ecological fallacy is assuming that conclusions made from the average of a group apply to all members of that group.
# add additional cases
gapminder <- gapminder %>%
    mutate(group = case_when(
        .$region %in% west ~ "The West",
        .$region %in% "Northern Africa" ~ "Northern Africa",
        .$region %in% c("Eastern Asia", "South-Eastern Asia") ~ "East Asia",
        .$region == "Southern Asia" ~ "Southern Asia",
        .$region %in% c("Central America", "South America", "Caribbean") ~ "Latin America",
        .$continent == "Africa" & .$region != "Northern Africa" ~ "Sub-Saharan Africa",
        .$region %in% c("Melanesia", "Micronesia", "Polynesia") ~ "Pacific Islands"))

# define a data frame with group average income and average infant survival rate
surv_income <- gapminder %>%
    filter(year %in% present_year & !is.na(gdp) & !is.na(infant_mortality) & !is.na(group)) %>%
    group_by(group) %>%
    summarize(income = sum(gdp)/sum(population)/365,
                        infant_survival_rate = 1 - sum(infant_mortality/1000*population)/sum(population))
surv_income %>% arrange(income)

# plot infant survival versus income, with transformed axes
surv_income %>% ggplot(aes(income, infant_survival_rate, label = group, color = group)) +
    scale_x_continuous(trans = "log2", limit = c(0.25, 150)) +
    scale_y_continuous(trans = "logit", limit = c(0.875, .9981),
                                       breaks = c(.85, .90, .95, .99, .995, .998)) +
    geom_label(size = 3, show.legend = FALSE)


solve(crossprod(X), crossprod(X, Y))


# [Petunjuk Penyelesaian Project](https://academy.dqlab.id/main/projectcode/16/109/516)
library(arules)

transaksi_tabular <- read.transactions(file="transaksi_dqlab_retail.tsv",
                                       format="single", sep="\t", cols=c(1,2), skip=1)
write(transaksi_tabular, file="test_project_retail_1.txt", sep=",")

# [Output Awal: Statistik Top 10](https://academy.dqlab.id/main/projectcode/16/109/517)
library(arules)

data <- read.transactions(file = "transaksi_dqlab_retail.tsv",
                          format = "single", sep = "\t", cols = c(1,2), skip = 1)
top_10 <- sort(itemFrequency(data, type="absolute"), decreasing = TRUE)[1:10]
hasil <- data.frame("Nama Produk" = names(top_10), "Jumlah" = top_10, row.names = NULL)
write.csv(hasil, file="top_10.txt")

# [Output Awal: Statistik Bottom 10](https://academy.dqlab.id/main/projectcode/16/109/518)
library(arules)

data <- read.transactions(file = "transaksi_dqlab_retail.tsv",
                          format = "single", sep = "\t", cols = c(1,2), skip = 1)
bottom_10 <- sort(itemFrequency(data, type = "absolute"), decreasing = FALSE)[1:10]
hasil <- data.frame("Nama Produk" = names(bottom_10), "Jumlah" = bottom_10, row.names = NULL)
write.csv(hasil, file="bottom10_item_retail.txt")

# [Mendapatkan Kombinasi Produk yang menarik](https://academy.dqlab.id/main/projectcode/16/109/519)
library(arules)
nama_file <- "transaksi_dqlab_retail.tsv"
transaksi_tabular <- read.transactions(file=nama_file, format="single", sep="\t", cols=c(1,2), skip=1)
apriori_rules <- apriori(transaksi_tabular,
                         parameter=list(supp=10/length(transaksi_tabular), conf=0.5, minlen=2, maxlen=3))
apriori_rules <- head(sort(apriori_rules, by='lift', decreasing = T),n=10)
inspect(apriori_rules)
write(apriori_rules, file="kombinasi_retail.txt")

# [Mencari Paket Produk yang bisa dipasangkan dengan Item Slow-Moving](https://academy.dqlab.id/main/projectcode/16/109/520)
library(arules)

nama_file <- "transaksi_dqlab_retail.tsv"
transaksi_tabular <- read.transactions(file=nama_file, format="single", sep="\t", cols=c(1,2), skip=1)
jumlah_transaksi<-length(transaksi_tabular)
jumlah_kemunculan_minimal <- 10
apriori_rules <- apriori(
  transaksi_tabular,
  parameter= list(supp=jumlah_kemunculan_minimal/jumlah_transaksi,
                  conf=0.1, minlen=2, maxlen=3))

# Filter
apriori_rules1 <- subset(apriori_rules, lift > 1 & rhs %in% "Tas Makeup")
apriori_rules1 <- sort(apriori_rules1, by='lift', decreasing = T)[1:3]
apriori_rules2 <- subset(apriori_rules, lift > 1 & rhs %in% "Baju Renang Pria Anak-anak")
apriori_rules2 <- sort(apriori_rules2, by='lift', decreasing = T)[1:3]
apriori_rules <- c(apriori_rules1, apriori_rules2)
inspect(apriori_rules)
write(apriori_rules,file="kombinasi_retail_slow_moving.txt")

R/Project/Project Machine Learning for Retail with R Product Packaging/Project Machine Learning for Retail with R Product Packaging.r


 b<-read.table("y-mRNA1.txt",sep="\t",header=T)
  b$ptile = rank(b$score) / nrow(b)
  m = min( b$ptile ) / 2.0
  b$ptile  = b$ptile  - m

   b$netz = qnorm(1 - b$ptile,lower.tail=FALSE)

  d = b[order(-b$netz,b$netz),]

write.table(d,"netz-mRNA.txt",sep="\t",quote=F)


library(BIBtests, quietly=TRUE)

CHECK <- function(test, truth) stopifnot(all.equal(test, truth))
TESTING <- function(what) cat(paste0(what, ": "))
OK <- function() cat("ok!\n")

set.seed(1234)
m = 10
n = 3
x = matrix(rnorm(m*n), m, n)

cat("# Level 2\n")

TESTING("crossprod")
test = bib_crossprod(x)
truth = crossprod(x)
CHECK(test, truth)
OK()

TESTING("tcrossprod")
test = bib_tcrossprod(x)
truth = tcrossprod(x)
CHECK(test, truth)
OK()

TESTING("mvprod")
y = 1:n
test = bib_mvprod(FALSE, x, y)
truth = x %*% y
dim(truth) <- NULL
CHECK(test, truth)

y = 1:m
test = bib_mvprod(TRUE, x, y)
truth = t(x) %*% y
dim(truth) <- NULL
CHECK(test, truth)
OK()

cat("\n")


sal = read.csv("Salaries.csv", header = TRUE)
ServiceYears = sal$Yrs.service
Salary = sal$Salary
SincePhd = sal$Yrs.since.phd
Model = lm (Salary ~SincePhd+ServiceYears)
predict(Model,data.frame(SincePhd=2,ServiceYears=3)))
corval = cor(salary,SincePhd,method="pearson")


# Exercise 2

# 1) Create the following:
#
#  a) a variable containing the word "chicken"
#  b) a numeric vector with the number 2, 4, 6, and 8
#  c) a 3 X 3 matrix of nine numbers (these can be sequential)
#
#  Now create a list that contains the three data structures

# Answer:
c <- "chicken"
v <- c(2, 4, 6, 8)
m <- matrix(1:9, ncol = 3)

my_list <- list(char = c,
                vec = v,
                mat = m)
my_list

# 2) Find the average number of green shapes in the 'shapes' matrix

# Answer:
mean(shapes[,2])
# or
color <- c("red", "green", "blue")
shape <- c("circle", "square", "rectangle", "triangle")
colnames(shapes) <- color
rownames(shapes) <- shape
mean(shapes[,"green"])
# 6.5


library(tidyverse)
library(psych)

diabetes_raw_data_col_num = 2
bp_raw_data_col_num = 3
poor_physical_health_raw_data_col_num = 1

to_return_data_value_col_num = 3

mileage_start_value = 0.001
mileage_increment_value = 0.25

raw_data = read.csv("data/faNorfolkData.csv", header=T)
labeled_data = read.csv("data/norfolkDataForScript.csv", header=T)
cor_matrix = cor(raw_data, method="spearman")

factor_analysis = psych::fa(cor_matrix, 3, n.obs = nrow(raw_data))
old_factor_scores = factor.scores(raw_data, factor_analysis)

pretty_bundle_values_from_last_iter = function(cur_diabetes, min_diabetes, med_diabetes, max_diabetes,
                                               cur_bp, min_bp, med_bp, max_bp,
                                               cur_phsy_health, min_phys_health, med_phys_health, max_phys_health)
{
  to_return = matrix(nrow=12, ncol=3)

  to_return[1,] = c("Diabetes", "Current State", cur_diabetes)
  to_return[2,] = c("Diabetes", "Min Improvement", min_diabetes)
  to_return[3,] = c("Diabetes", "Median Improvement", med_diabetes)
  to_return[4,] = c("Diabetes", "Max Improvement", max_diabetes)

  to_return[5,] = c("High BP", "Current State", cur_bp)
  to_return[6,] = c("High BP", "Min Improvement", min_bp)
  to_return[7,] = c("High BP", "Median Improvement", med_bp)
  to_return[8,] = c("High BP", "Max Improvement", max_bp)

  to_return[9,] = c("Poor Phys. Health", "Current State", cur_phsy_health)
  to_return[10,] = c("Poor Phys. Health", "Min Improvement", min_phys_health)
  to_return[11,] = c("Poor Phys. Health", "Median Improvement", med_phys_health)
  to_return[12,] = c("Poor Phys. Health", "Max Improvement", max_phys_health)

  to_return = as.data.frame(to_return)
  colnames(to_return) = c("HealthMeasure", "ForecastType", "PrctofPopulationWithoutHealthIssue")
  forecast_type_levels_in_order = c("Current State", "Min Improvement", "Median Improvement", "Max Improvement")
  to_return$ForecastType = factor(to_return$ForecastType, levels=forecast_type_levels_in_order)
  to_return[,3] = as.numeric(as.character(to_return[,3]))
  return(to_return)
}

bundle_values_to_return_into_df = function(index_of_tract, diabetes_scores, bp_scores, poor_physical_health_scores)
{

  to_return = matrix(nrow=12, ncol=3)

  to_return[1,] = c("Diabetes", "Current State", raw_data[index_of_tract, diabetes_raw_data_col_num])
  to_return[2,] = c("Diabetes", "Min Improvement", min(diabetes_scores, na.rm=T))
  to_return[3,] = c("Diabetes", "Median Improvement", median(diabetes_scores, na.rm=T))
  to_return[4,] = c("Diabetes", "Max Improvement", max(diabetes_scores, na.rm=T))

  to_return[5,] = c("High BP", "Current State", raw_data[index_of_tract, bp_raw_data_col_num])
  to_return[6,] = c("High BP", "Min Improvement", min(bp_scores, na.rm=T))
  to_return[7,] = c("High BP", "Median Improvement", median(bp_scores, na.rm=T))
  to_return[8,] = c("High BP", "Max Improvement", max(bp_scores, na.rm=T))

  to_return[9,]  = c("Poor Phys. Health", "Current State", raw_data[index_of_tract, poor_physical_health_raw_data_col_num])
  to_return[10,] = c("Poor Phys. Health", "Min Improvement", min(poor_physical_health_scores, na.rm=T))
  to_return[11,] = c("Poor Phys. Health", "Median Improvement", median(poor_physical_health_scores, na.rm=T))
  to_return[12,] = c("Poor Phys. Health", "Max Improvement", max(poor_physical_health_scores, na.rm=T))

  to_return = as.data.frame(to_return)
  colnames(to_return) = c("HealthMeasure", "ForecastType", "PrctofPopulationWithoutHealthIssue")
  forecast_type_levels_in_order = c("Current State", "Min Improvement", "Median Improvement", "Max Improvement")
  to_return$ForecastType = factor(to_return$ForecastType, levels=forecast_type_levels_in_order)
  to_return[,3] = as.numeric(as.character(to_return[,3]))

  return(to_return)
}

get_index_of_requested_census_tract = function(census_tract_to_edit)
{
  tract_diffs = abs(as.numeric(as.character(census_tract_to_edit)) - as.numeric(as.character(labeled_data$TractFIPS)))
  index_of_tract = which.min(tract_diffs)
  return(index_of_tract)
}

get_bike_factor_census_tract_comps = function(new_data_factor_scores, index_of_tract)
{
  newBikeScore = new_data_factor_scores$scores[52,3]
  healthBackComp = labeled_data$MR1[index_of_tract]
  higherHealthComps = subset(labeled_data, MR1 > healthBackComp)

  bikeDiff = abs(newBikeScore - higherHealthComps$MR2)
  biking_factor_comparables = c(higherHealthComps$MR1[which.min(bikeDiff)])
  bikeDiff[which.min(bikeDiff)] = NA
  biking_factor_comparables = c(biking_factor_comparables, higherHealthComps$MR1[which.min(bikeDiff)])
  bikeDiff[which.min(bikeDiff)] = NA
  biking_factor_comparables = c(biking_factor_comparables, higherHealthComps$MR1[which.min(bikeDiff)])
  bikeDiff[which.min(bikeDiff)] = NA
  biking_factor_comparables = c(biking_factor_comparables, higherHealthComps$MR1[which.min(bikeDiff)])
  bikeDiff[which.min(bikeDiff)] = NA
  biking_factor_comparables = c(biking_factor_comparables, higherHealthComps$MR1[which.min(bikeDiff)])

  healthBikeComp2 = new_data_factor_scores$scores[52,3]
  biking_factor_comparables = c(biking_factor_comparables, max(healthBikeComp2, healthBackComp))
}

get_improvement_distribution_for_census_tract = function(census_tract_to_edit, mileage_to_add)
{

  # values that go in the df getting initialized
  cur_diabetes = 0
  min_diabetes = 0
  med_diabetes = 0
  max_diabetes = 0

  cur_bp = 0
  min_bp = 0
  med_bp = 0
  max_bp = 0

  cur_phsy_health = 0
  min_phys_health = 0
  med_phys_health = 0
  max_phys_health = 0

  i= mileage_start_value

  while ( i <= mileage_to_add)
  {
    index_of_tract = get_index_of_requested_census_tract(census_tract_to_edit)
    hypothetical_tract_to_add = raw_data[index_of_tract,]

    hypothetical_tract_to_add[1,10] = hypothetical_tract_to_add[1,10] + i

    new_data_with_hypothetical_tract = rbind(raw_data, hypothetical_tract_to_add)
    new_data_factor_scores = factor.scores(new_data_with_hypothetical_tract, factor_analysis)

    biking_factor_comparables = get_bike_factor_census_tract_comps(new_data_factor_scores, index_of_tract)

    index_of_new_max_biking_factor_score = which.min(abs(max(biking_factor_comparables, na.rm=T) - labeled_data$MR1))
    index_of_new_median_biking_factor_score = which.min(abs(median(biking_factor_comparables, na.rm=T) - labeled_data$MR1))
    index_of_new_min_biking_factor_score = which.min(abs(min(biking_factor_comparables, na.rm=T) - labeled_data$MR1))

    diabetes_scores = c(max(raw_data[index_of_new_max_biking_factor_score, 2], raw_data[index_of_tract, 2])) #2
    bp_scores = c(max(raw_data[index_of_new_max_biking_factor_score, 3], raw_data[index_of_tract, 3])) #3
    poor_physical_health_scores = c(max(raw_data[index_of_new_max_biking_factor_score, 1], raw_data[index_of_tract, 1])) #1

    diabetes_scores = c(diabetes_scores, max(raw_data[index_of_new_median_biking_factor_score, 2], raw_data[index_of_tract, 2]))
    bp_scores = c(bp_scores, max(raw_data[index_of_new_median_biking_factor_score, 3], raw_data[index_of_tract, 3]))
    poor_physical_health_scores = c(poor_physical_health_scores, max(raw_data[index_of_new_median_biking_factor_score, 1], raw_data[index_of_tract, 1]))

    diabetes_scores = c(diabetes_scores, max(raw_data[index_of_new_min_biking_factor_score, 2], raw_data[index_of_tract, 2]))
    bp_scores = c(bp_scores, max(raw_data[index_of_new_min_biking_factor_score, 3], raw_data[index_of_tract, 3]))
    poor_physical_health_scores = c(poor_physical_health_scores, max(raw_data[index_of_new_min_biking_factor_score, 1], raw_data[index_of_tract, 1]))

    iter_value_df = bundle_values_to_return_into_df(index_of_tract, diabetes_scores, bp_scores, poor_physical_health_scores)

    # ensure we didn't go backwards by adding mileage
    this_iter_cur_diabetes = iter_value_df[1,to_return_data_value_col_num]
    this_iter_min_diabetes = iter_value_df[2,to_return_data_value_col_num]
    this_iter_med_diabetes = iter_value_df[3,to_return_data_value_col_num]
    this_iter_max_diabetes = iter_value_df[4,to_return_data_value_col_num]

    this_iter_cur_bp = iter_value_df[5,to_return_data_value_col_num]
    this_iter_min_bp = iter_value_df[6,to_return_data_value_col_num]
    this_iter_med_bp = iter_value_df[7,to_return_data_value_col_num]
    this_iter_max_bp = iter_value_df[8,to_return_data_value_col_num]

    this_iter_cur_phys_health = iter_value_df[9,to_return_data_value_col_num]
    this_iter_min_phys_health = iter_value_df[10,to_return_data_value_col_num]
    this_iter_med_phys_health = iter_value_df[11,to_return_data_value_col_num]
    this_iter_max_phys_health = iter_value_df[12,to_return_data_value_col_num]

    cur_diabetes = this_iter_cur_diabetes
    min_diabetes = max(min_diabetes, this_iter_min_diabetes)
    med_diabetes = max(med_diabetes, this_iter_med_diabetes)
    max_diabetes = max(max_diabetes, this_iter_max_diabetes)

    cur_bp = this_iter_cur_bp
    min_bp = max(min_bp, this_iter_min_bp)
    med_bp = max(med_bp, this_iter_med_bp)
    max_bp = max(max_bp, this_iter_max_bp)

    cur_phsy_health = this_iter_cur_phys_health
    min_phys_health = max(min_phys_health, this_iter_min_phys_health)
    med_phys_health = max(med_phys_health, this_iter_med_phys_health)
    max_phys_health = max(max_phys_health, this_iter_max_phys_health)

    i=i+mileage_increment_value
  }

  # when loop ends values these values have our "sanity checked" answers
  final_value_df = pretty_bundle_values_from_last_iter(cur_diabetes, min_diabetes, med_diabetes, max_diabetes,
                                                       cur_bp, min_bp, med_bp, max_bp,
                                                       cur_phsy_health, min_phys_health, med_phys_health, max_phys_health)

  return(final_value_df)
}


library(quantmod)

rm(list=ls())

HI_MAX_D <- 5
LO_MIN_D <- 3
M_START <- max(HI_MAX_D, LO_MIN_D) + 1

# Transaction commission fee is 0.1425%.
# Seller must also pay 0.3% government tax.
long <- function(price) {
    return(price * (1 + 0.001425))
}

short <- function(price) {
    return(price * (1 - 0.001425 - 0.003))
}

# Prepare data.
stock <- na.omit(get(getSymbols('2330.TW')))
opp <- Op(stock) # [op]en [p]rices
clp <- Cl(stock) # [cl]ose [p]rices
hi_max <- lag( runMax( Hi(stock), HI_MAX_D) )
lo_min <- lag( runMin( Lo(stock), LO_MIN_D) )

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

# Assess the strategy.
win_rate <- length( pl[pl > 0] ) / length( pl[pl != 0] )
gain_rate <- mean( pl[pl > 0] ) / abs( mean( pl[pl < 0] ) )
profit_factor <- sum( pl[pl > 0] ) / abs( sum( pl[pl < 0] ) )
cum_pl <- cumsum(pl)
dd <- cum_pl - cummax(cum_pl) # [d]raw[d]own
mdd <- mean(dd)
max_ddd <- max( diff( which(dd==0) ) ) # [max]imum [d]raw[d]own [d]uration
View( cbind(win_rate, gain_rate, profit_factor, mdd, max_ddd) )

# Plot the strategy.
y_range <- range(dd, cum_pl)
plot(dd, type='h', col='#91d18b', ylim=y_range)
par(new=T)
plot(cum_pl, type='h', col='#e11d74', lwd=2, ylim=y_range)
points( which(dd == 0), cummax(cum_pl)[ which(dd == 0) ], pch=4, col='#440047' )


library("lattice")

mydata <- read.table("http://archive.ics.uci.edu/ml/machine-learning-databases/auto-mpg/auto-mpg.data")

colnames(mydata) <- c("mpg","cylinders","displacement","horsepower","weight","acceleration","model.year","origin","car.name")

cloud(mpg~cylinders*weight, data=mydata)


> permutation.test(c(85, 88, 75, 66, 25, 29, 83, 39, 97),
+                  c(68, 41, 10, 49, 16, 65, 32, 92, 28, 98))
    under      over
0.8719717 0.1280283


outlierOmar <- function(var) {
     var_name = var
     na1 <- sum(is.na(var_name))
     m1 <- mean(var_name, na.rm = T)
     par(mfrow=c(2, 2), oma=c(0,0,3,0))
     boxplot(var_name, horizontal=TRUE, main="With outliers")
     hist(var_name, main="With outliers", xlab=NA, ylab=NA)
     outlier <- boxplot.stats(var_name)$out
     mo <- mean(outlier)
     var_name <- ifelse(var_name %in% outlier, NA, var_name)
     boxplot(var_name, horizontal=TRUE, main="Without outliers")
     hist(var_name, main="Without outliers", xlab=NA, ylab=NA)
     title("Outlier Check", outer=TRUE)
     na2 <- sum(is.na(var_name))
     cat("Outliers identified:", na2 - na1, "\n")
     cat("Propotion (%) of outliers:", round((na2 - na1) / sum(!is.na(var_name))*100, 1), "\n")
     cat("Mean of the outliers:", round(mo, 2), "\n")
     m2 <- mean(var_name, na.rm = T)
     cat("Mean without removing outliers:", round(m1, 2), "\n")
     cat("Mean if we remove outliers:", round(m2, 2), "\n")

}


# Always generate the same data
set.seed(111)

# Number of samples
sample_size = 3000
training_size = 0.9 * sample_size
test_size = 0.1 * sample_size

###################################################################
# To generate the waveform data we use mlbench
# mlbench uses Breiman's original waveform source modified for R
library(mlbench)
waves = mlbench.waveform(sample_size)
data = data.frame(cbind(waves$x, waves$class))

# Create train, test and validation sets for the entire data
training_set = data[1:training_size, ]
test_set = data[-(1:training_size), ]
###################################################################

###################################################################
# Use LDA or QDA to classify
# We use MASS for the lda function
library(MASS)

# Classify using a LDA with equal priors
# fit = lda(X22 ~ ., data = training_set, prior = c(1, 1, 1)/3)
# plot(fit)

# QDA with equal priors
fit = qda(X22 ~ ., data = training_set, prior = c(1, 1, 1)/3)

# Compute the accuracy on the test set
count = 0
for (i in 1:nrow(test_set)) {
	if (predict(fit, test_set[i, -22])$class == test_set[i, 22]) {
		count = count + 1
	}
}
rate = count / nrow(test_set)
###################################################################


suppressPackageStartupMessages(library(float))
set.seed(1234)
tol=1e-6

same = function(test, truth) stopifnot(all.equal(dbl(test), truth, tol=tol))

x1 = matrix(-4:5, 5)
s1 = fl(x1)

x2 = x1
x2[3, 1] = NA_integer_
x2[4, 2] = NA_integer_
s2 = fl(x2)

y = 1L
z = 1.0
s3 = flrunif(5)

### min
test = min(s1)
truth = min(x1)
same(test, truth)

test = min(s1, s3)
truth = min(x1, dbl(s3))
same(test, truth)

test = min(s1, y)
truth = min(x1, y)
same(test, truth)

# NA
test = sum(s2, na.rm=FALSE)
truth = sum(x2, na.rm=FALSE)
same(test, truth)

test = sum(s2, na.rm=TRUE)
truth = sum(x2, na.rm=TRUE)
same(test, truth)

### max
test = max(s1)
truth = max(x1)
same(test, truth)

test = max(s1, s3)
truth = max(x1, dbl(s3))
same(test, truth)

test = max(s1, y)
truth = max(x1, y)
same(test, truth)

# NA
test = sum(s2, na.rm=FALSE)
truth = sum(x2, na.rm=FALSE)
same(test, truth)

test = sum(s2, na.rm=TRUE)
truth = sum(x2, na.rm=TRUE)
same(test, truth)

# which
test = which.min(s1)
truth = which.min(x1)
same(test, truth)

test = which.min(s2)
truth = which.min(x2)
same(test, truth)

test = which.max(s1)
truth = which.max(x1)
same(test, truth)

test = which.max(s2)
truth = which.max(x2)
same(test, truth)


data<- read_csv("podatki/korona_po svetu_csv.csv",

                                    col_types=cols(.default=col_number(),

                                                   iso_code=col_character(),

                                                   continent=col_character(),

                                                   location=col_character(),

                                                   date=col_date(),

                                                   tests_units=col_character()))

data$date = as.integer(as.Date(data$date,format="Y%-m%-d%")) - min(as.integer(as.Date(data$date,format="Y%-m%-d%")))
data_SLO=data %>% filter(location == "Slovenia",is.na(total_tests)==FALSE,is.na(total_cases)==FALSE)
data = data %>% filter(location != "Slovenia")
data = data[,c(4,9,14,23,25:27,30:31,36)]
data_SLO = data_SLO[,c(4,9,14,23,25:27,30:31,36)]
data = data %>% filter(is.na(total_cases_per_million)==FALSE,is.na(total_tests)==FALSE,
                       is.na(median_age)==FALSE,is.na(aged_65_older)==FALSE,is.na(cardiovasc_death_rate)==FALSE,
                       is.na(aged_70_older)==FALSE)

data=as.matrix(data)
data=  mapply(data, FUN=as.numeric)
data <- matrix(data, ncol=10, nrow=10472)
dimnames(data)= NULL
training = data[,c(1,3:10)]
traingingtarget=data[,c(2)]

data_SLO = as.matrix(data_SLO)
data_SLO =  mapply(data_SLO, FUN=as.numeric)
data_SLO<- matrix(data_SLO, ncol=10, nrow=145)
dimnames(data_SLO)= NULL
test = data_SLO[,c(1,3:10)]
testtarget = data_SLO[,c(2)]
#normalize
m <- colMeans(training)
s <- apply(training,2,sd)
training <- scale(training, center=m,scale= s)
test <- scale(test,center=m,scale=s)

#model
model <- keras_model_sequential()

model %>%
  layer_dense(units = 50,activation = "relu", input_shape = c(9)) %>%
  layer_dropout(rate=0.4) %>%
  layer_dense(units = 10,activation = "relu", input_shape = c(9)) %>%
  layer_dropout(rate=0.2) %>%
  layer_dense(units=1)

#compile

model %>% compile(loss="mse",
                  optimizer = "rmsprop",
                  metrics = "mae")
#fit model
mymodel <- model  %>% fit(training,
                          traingingtarget,
                          epochs=80,
                          batch_size=36,
                          validation_split=0.2)

df <- data.frame("cases_per_million"= c(model %>% predict(test),testtarget),
                 "tip" = c(rep("predikcija",length(model %>% predict(test))),
                           rep("realizacija",length(testtarget))),
                 "datum" = c(seq(as.Date("2020-03-12"),
                                 as.Date("2020-08-03"),"day"),
                             seq(as.Date("2020-03-12"),
                                 as.Date("2020-08-03"),"day")))

ggplot(df,aes(x=datum, y=cases_per_million,col=tip))+geom_line()


library(dplyr)
library(readr)
library(forcats)
library(ggplot2)
library(causaleffect)
library(igraph)
library(tensorA)
source(glue::glue("{here::here()}/helper_functions.r"))
source(glue::glue("{here::here()}/get_expression.r"))
library(data.tree)
library(latex2exp)

g <- graph.formula(
  y -+ x
, y -+ z
, x -+ z
)
plot(g)

effect <- causal.effect(
  y = "y"
, x = "z"
, G = g
, primes = TRUE
, simp = TRUE
, prune = TRUE
, expr = FALSE
)
cat(get.expression(effect), "\n")

cat(get.operation(effect), "\n")
TeX(glue::glue("${get.expression(effect)}$"))

g <- graph.formula(
  smoke -+ tar
, tar -+ cancer
, hidden -+ smoke
, hidden -+ cancer
)
plot(g)

effect <- causal.effect(
  y = "cancer"
, x = "smoke"
, G = g
, primes = TRUE
, simp = TRUE
, prune = TRUE
, expr = FALSE
)
cat(get.expression(effect, primes = TRUE), "\n")

effect_tree <- convert_probability_to_data_tree(effect)

# UC Berkeley data

g <- graph.formula(
  Gender -+ Admit
, Dept -+ Gender
, Dept -+ Admit
)
plot(g)

effect <- causal.effect(
  y = "Admit"
, x = c("Gender")
, G = g
, primes = TRUE
, simp = TRUE
, prune = TRUE
, expr = FALSE
)
get.expression(effect)
effect_tree <- convert_probability_to_data_tree(effect)

data(UCBAdmissions)

UCBAdmissions_tensor <- UCBAdmissions %>% {
  out <- to.tensor(as.vector(.), dim(.), ndimnames = dimnames(.))
  dimnames(out) <- dimnames(.)
  return(out)
}
UCBAdmissions_tensor

UCBAdmissions_tensor %>% {
term_1 <- conditional_probability.tensor(
  .
, var_set = "Admit"
, cond_set = c("Gender", "Dept")
)
term_2 <- conditional_probability.tensor(
  .
, var_set = "Dept"
)
term_1 %e% term_2
}

margin.tensor(UCBAdmissions_tensor, i = c("Admit", "Gender", "Dept"))
UCBAdmissions_tensor %>% ftable

# Adapt the get.expression function to tensor operations
# Write tests for each of the possibilities:
# Just a single probability statement
# A single conditional probability statement
# A product of two distributions
# A einstien summation
# A division
# A remaining do() (throws error; unidentifiable)
# Something with primes in it
# An initial test to make sure it returns a function which acts on tensors, and
# throws a warning when the input tensor has the wrong indices


# Load any custom functions called in this file####

#one Regression does a regression based on an azimuth (e.g. how well does northeasting (045) explain variation in my data?) This kernal geodetic regression is analogous to a best-fit line, and thus describes a steady variation, not a sudden change in orientation.
oneRegression <-
  function(follins,
           domain,
           pValuePerms,
           directionality) {
    regression <-
      oriGeodesicRegression(
        cos((directionality) * pi / 180) * follins$northing[domain] + sin((directionality) *
                                                                            pi / 180) * follins$easting[domain],
        follins$rotation[domain],
        oriLineInPlaneGroup,
        numSteps = 10000
      )

    if (pValuePerms > 0) {
      RSquareds <-
        oriGeodesicRegressionPermutations(
          cos((directionality) * pi / 180) * follins$northing[domain] + sin((directionality) *
                                                                              pi / 180) * follins$easting[domain],
          follins$rotation[domain],
          numPerms = pValuePerms,
          group = oriLineInPlaneGroup
        )
      sum(RSquareds > regression$rSquared)
      p <- sum(RSquareds > regression$rSquared) / length(RSquareds)
    } else {
      p <- 0
    }
    regressionStats <- zeros(1, 5)
    regressionStats[1, 1] = directionality
    regressionStats[1, 2] = regression$error
    regressionStats[1, 3] = regression$minEigenvalue
    regressionStats[1, 4] = regression$rSquared
    regressionStats[1, 5] = p
    names(regressionStats) = c("azimuth", "error", "minEigenValue", "R^2", "P")
    regression$stats <- regressionStats
    return(regression)
  }

#regressionSweep does a series of directional regressions from 0-180°, given an increment, and also calculates the pValue for each regression. BEWARE: doing this with p-values can take days-weeks-or-months of computing time. I suggest first running the function with degreeIncrement = 10 and pValuePerms=0. This may still take a couple hours, but will give you a first order picture of whether it is interesting to proceed.
regressionSweep <-
  function(follins,
           degreeIncrement,
           domain,
           pValuePerms) {
    v <- rbind(1)
    intervals <- 180 / degreeIncrement
    for (x in 2:intervals) {
      vTemp <- x
      v <- rbind(v, vTemp)
    }
    v <- as.matrix(as.vector(v))
    # Geodesic regression of pole vs. northing in domain 4. Check that error is 0 and minEigenvalue is positive.
    regressions <- list()
    regressionStats <- zeros(nrow(v), 5)
    for (i in 1:nrow(v)) {
      regressionTemp <-
        oriGeodesicRegression(
          cos((v[i, 1] - 1) * degreeIncrement * pi / 180) * follins$northing[domain] + sin((v[i, 1] -
                                                                                1) * degreeIncrement * pi / 180) * follins$easting[domain],
          follins$rotation[domain],
          oriLineInPlaneGroup,
          numSteps = 10000
        )
      regressions[[i]] <- regressionTemp
      regressionStats[i, 1] = (i - 1) * degreeIncrement
      regressionStats[i, 2] = regressionTemp$error
      regressionStats[i, 3] = regressionTemp$minEigenvalue
      regressionStats[i, 4] = regressionTemp$rSquared
      if (pValuePerms > 0) {
        RSquareds <-
          oriGeodesicRegressionPermutations(
            cos((v[i, 1] - 1) * degreeIncrement * pi / 180) * follins$northing[domain] + sin((v[i, 1] -1) * degreeIncrement * pi / 180) * follins$easting[domain],
            follins$rotation[domain],
            numPerms = pValuePerms,
            group = oriLineInPlaneGroup)
        length(RSquareds)
        sum(RSquareds > regressionTemp$rSquared)
        p <-
          sum(RSquareds > regressionTemp$rSquared) / length(RSquareds)
      }
      else {
        p <- "nan"
      }

      regressionStats[i, 5] = p
    }
    regressions[[i + 1]] <- regressionStats
    return(regressions)
  }

#take two bootstrapped mean clouds and the number of data points in each, and calculate a distribution of angular differences. Probably not the most statistically robust.
distHist <- function(bootsOne, bootsTwo, numPerms, group) {
  distances <- list()
  boots1 <- bootsOne$bootstraps
  boots2 <- bootsTwo$bootstraps
  for (i in 1:numPerms) {
    a <- round(runif(1, 1, length(boots1)), 0)
    b <- round(runif(1, 1, length(boots2)), 0)
    distances[[i]] <- oriDistance(boots1[[a]], boots2[[b]], group)
  }

  return(distances)
}

#Using one two-sample bootstrapped mean difference cloud, calculate the distribution of angular differences. Probably not the most statistically robust.
diffDistHist <- function(bootsDiff, numPerms, group) {
  boots <- bootsDiff$bootstraps
  distances <-
    lapply(boots, function(s)
      oriDistance(s, diag(3), group) * 180 / pi)
  return(distances)
}


#' Function for classification of patients by chosen category via discriminant analysis
#'
#' This function allows you to test classification of patients by some chosen category via discriminant analysis.
#' @param data Accepts a list with first row containing adult data and second row containing child data.
#' @param variable Accepts a variable upon which to attempt to classify the data
#' @param modelType Accepts the type of model to use. Options are MclustDA, which models the classes as a a mixture model of multiple normal distributions, or EDDA, which models each class as a single normal distribution. Defaults to MclustDA.
#' @param modelNames Accepts the name of the matrix constraint on the covariance matrix. See Mclust documentation for names of of constraints. Defaults to NULL.
#' @keywords Discriminant analysis
#' @export
#' @examples
#' DA()
DA <- function(data, variable, modelType = "MclustDA", modelNames = NULL){
	require(mclust)

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

	#Find which columns correspond to the given variable
	var_col <- which(colnames(data_adults)== variable)
	if(length(var_col) == 0){
		print('Entered variable does not exist in dataset')
		return(NULL)
	}

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

	#Remove NAs
	data_adults <- na.omit(data_adults);
	data_children<-na.omit(data_children);

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

	#If gender is the variable, it is necessary to remove unknowns
	if (var_col == 8){
		#Remove "Unknown" from the gender column
		data_adults_baseline <- as.data.frame(data_adults_baseline[!(data_adults_baseline[1] == "Unknown"),]);
		data_adults_concentration <- as.data.frame(data_adults_concentration[!(data_adults_concentration[1] == "Unknown"),]);
		data_adults_combined <- as.data.frame(data_adults_combined[!(data_adults_combined[1] == "Unknown"),]);
		data_children_baseline <- as.data.frame(data_children_baseline[!(data_children_baseline[1] == "Unknown"),]);
		data_children_concentration <- as.data.frame(data_children_concentration[!(data_children_concentration[1] == "Unknown"),]);
		data_children_combined <- as.data.frame(data_children_combined[!(data_children_combined[1] == "Unknown"),]);

		#Remove "Unknown" as a possible gender level
		data_adults_baseline <- droplevels(data_adults_baseline);
		data_adults_concentration <- droplevels(data_adults_concentration);
		data_adults_combined <- droplevels(data_adults_combined);
		data_children_baseline <- droplevels(data_children_baseline);
		data_children_concentration <- droplevels(data_children_concentration);
		data_children_combined <- droplevels(data_children_combined);
	}

	#Adults Baseline%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	results_1 <- MclustDA(data_adults_baseline[,-1],data_adults_baseline[,1], modelType =  modelType, modelNames = modelNames)
	error_1 <- cv.MclustDA(results_1, nfold = 10, verbose = TRUE)
	#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	#Repeat the above operations for all following data sets

	#Adults Concentration%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	results_2 <- MclustDA(data_adults_concentration[,-1],data_adults_concentration[,1], modelType =  modelType, modelNames = modelNames)
	error_2 <- cv.MclustDA(results_2, nfold = 10, verbose = TRUE)
	#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	#Adults Combined%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	results_3 <- MclustDA(data_adults_combined[,-1],data_adults_combined[,1], modelType =  modelType, modelNames = modelNames)
	error_3 <- cv.MclustDA(results_3, nfold = 10, verbose = TRUE)
	#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	#Children Baseline%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	results_4 <- MclustDA(data_children_baseline[,-1],data_children_baseline[,1], modelType =  modelType, modelNames = modelNames)
	error_4 <- cv.MclustDA(results_4, nfold = 10, verbose = TRUE)
	#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	#Children Concentration%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	results_5 <- MclustDA(data_children_concentration[,-1],data_children_concentration[,1], modelType =  modelType, modelNames = modelNames)
	error_5 <- cv.MclustDA(results_5, nfold = 10, verbose = TRUE)
	#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	#Children Combined%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	results_6 <- MclustDA(data_children_combined[,-1],data_children_combined[,1], modelType =  modelType, modelNames = modelNames)
	error_6 <- cv.MclustDA(results_6, nfold = 10, verbose = TRUE)
	#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	# results <- list(summary(results_1),as.character(error_1$error),summary(results_2), as.character(error_2$error),summary(results_3),as.character(error_3$error),summary(results_4),as.character(error_4$error),summary(results_5),as.character(error_5$error),summary(results_6),as.character(error_6$error))
	# return(capture.output(results))
	average_error <- 1 - mean(c(error_1$error,error_2$error,error_3$error,error_4$error,error_5$error,error_6$error))
	result <- paste('The average error is ',as.character(average_error))
}


# Decision Tree Regression

# Libraries
library(ggplot2)
library(rpart)

# Importing dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Fitting The Decision Tree Regressor to the dataset
regressor = rpart(formula = Salary ~ .,
                  data = dataset,
                  control = rpart.control(minsplit = 1))

# Predicting a new result
y_pred = predict(regressor, data.frame(Level = 6.5))

# Visualising the Decision Tree Regression Results
x_grid = seq(min(dataset$Salary), max(dataset$Salary), 0.01)

ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour = 'red') +
  geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level = x_grid))),
            colour = 'blue') +
  ggtitle('Truth or Bluff (Decision Tree)') +
  xlab('Level') +
  ylab('Salary')


## --------------------
## --------------------
## --------------------
## This file contains the functions for implementing the Lee-Carter Model.
## --------------------
## --------------------
## --------------------

LC <- function(X, n.pc) {

    ## this function adopt codes from the demorgraphy package, X is the data matrix
    ## row is age group
    ## column is year

    ax <- apply(X, 1, mean, na.rm = TRUE) # ax is mean of X by column

    cX <- sweep(X, 1, ax) ## make sum(kt) = 0

    svd.mx <- svd(cX)

    kt <- matrix(NA, nrow = n.pc, ncol = ncol(X))

    bx <- matrix(NA, nrow = nrow(X), ncol = n.pc)

    for (i in seq(1, n.pc)) {
        sumu <- sum(svd.mx$u[, i])

        ## to make sum(bx)=1

        bx[, i] <- svd.mx$u[, i] / sumu

        kt[i, ] <- svd.mx$d[i] * svd.mx$v[, i] * sumu
    }

    fitted <- sweep(bx %*% kt, 1, -ax)
    svd_d <- svd(X)$d
    return(list(bx = bx, kt = kt, rowmean = ax, fitted = fitted, d = svd_d))
}

# predict the Lee-Carter model, Using RWWD (random walk with drift) model

LC.predict <- function(X, n.pred, n.pc) {
    tmp <- LC(X, n.pc = n.pc)

    kt.pred <- matrix(NA, nrow = n.pc, ncol = n.pred)

    for (i in seq(1, n.pc)) {
        rw.fit <- forecast::rwf(tmp$kt[i, ], drift = TRUE)

        kt.pred[i, ] <- tmp$kt[i, length(tmp$kt[i, ])] + seq(1, n.pred) * rw.fit$model$par$drift
    }

    return(sweep(tmp$bx %*% kt.pred, 1, -tmp$rowmean))
}

LC.forecast <- function(tnsr, n.pred, n.pc, year) {
    cs1 <- LC.predict(tnsr[1, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    c1 <- LC.predict(tnsr[2, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    rs1 <- LC.predict(tnsr[3, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    inf1 <- LC.predict(tnsr[4, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    ext1 <- LC.predict(tnsr[5, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    oth1 <- LC.predict(tnsr[6, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    m_tensor <- array(NA, dim = c(6, 19, n.pred))

    m_tensor[1, , ] <- cs1
    m_tensor[2, , ] <- c1
    m_tensor[3, , ] <- rs1
    m_tensor[4, , ] <- inf1
    m_tensor[5, , ] <- ext1
    m_tensor[6, , ] <- oth1
    ###

    return(as.tensor(m_tensor))
}

LC.fit <- function(tnsr, n.pc, year) {
    cs1 <- LC(tnsr[1, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    c1 <- LC(tnsr[2, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    rs1 <- LC(tnsr[3, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    inf1 <- LC(tnsr[4, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    ext1 <- LC(tnsr[5, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    oth1 <- LC(tnsr[6, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    m_tensor <- array(NA, dim = c(6, 19, dim(tnsr)[3] - year))

    m_tensor[1, , ] <- cs1
    m_tensor[2, , ] <- c1
    m_tensor[3, , ] <- rs1
    m_tensor[4, , ] <- inf1
    m_tensor[5, , ] <- ext1
    m_tensor[6, , ] <- oth1
    ###

    return(as.tensor(m_tensor))
}

################# cross_validation

LC.cv <- function(tnsr, year, k = 5, leave_test = TRUE) {
    if (leave_test) {
        tnsr <- tnsr[, , 1:(dim(tnsr)[3] - year)]
    }
    ### training data
    train_ls <- list()
    for (i in 1:k) {
        train_ls[[i]] <- tnsr[, , 1:(dim(tnsr)[3] - i + 1 - year)]
    }
    ### validating data
    validate_ls <- list()
    for (i in 1:k) {
        validate_ls[[i]] <- tnsr[, , (dim(tnsr)[3] - i + 2 - year):(dim(tnsr)[3] - i + 1)]
    }
    ### record minMSE
    minMSE <- 999999
    mincomponent <- 1
    for (i in 1:19) {
        ### record each component statistics
        temp <- NULL
        for (j in 1:k) {
            temp <- c(temp, fnorm(lcforecast(train_ls[[j]], n.pred = year, n.pc = i, year = 0) - validate_ls[[j]]))
        }
        if (mean(temp) < minMSE) {
            minMSE <- mean(temp)
            mincomponent <- i
        }
    }
    return(list(optimal_component = mincomponent, min_MSE = minMSE))
}


# ZEMLJEVID - CLUSTERING ####
skupineDelez <- kmeans(delezi$delez, 5, nstart = 1500)
centers <- sort(skupineDelez$centers) # uredimo skupine po deležu
skupineDelez <- kmeans(delezi$delez, centers = centers, nstart = 1500)

zemljevidCluster <- tm_shape(merge(svet, data.frame(country = delezi$country,
                                                    skupina = factor(skupineDelez$cluster)),
                             by.x = "NAME", by.y = "country")) +
  tmap_options(max.categories = 5) +
  tm_polygons("skupina", title = "Skupina") +
  tm_layout(main.title = "Države razdeljene glede na delež priseljencev") +
  tm_legend(position = c("left", "center"))

napakaClust1 <- skupineDelez$tot.withinss

# DRŽAVE - korelacijski oblak (v shiny) ####
grafBdp <- grafBdp + geom_smooth(method = "lm")
korelacija <- cor(master$BDP, y = master$imigracija, use = "na.or.complete")

# NAPOVEDOVANJE MIGRCIJE ####
grafMigracija <- ggplot(master %>% gather(preselitev, stevilo, 8:9) %>%
                                            group_by(leto, preselitev) %>%
                                            summarise(stevilo = mean(stevilo)),
                         aes(x = leto, y = stevilo)) +
  facet_grid(~preselitev) + xlim(1990, 2025) +
  geom_smooth(method = "lm", se = FALSE, fullrange = TRUE) +
  xlab("Leto") + ylab("Število") +
  ggtitle("Povprečna emigracija in imigracija v obdobju 1990-2019") +
  geom_smooth(method = "loess", se = FALSE, fullrange = TRUE, col = "yellow") +
  geom_point()
grafMigracija

grafTest <- ggplot(master %>% gather(preselitev, stevilo, 8:9),
                   aes(x = leto, y = stevilo, group = leto)) +
  facet_grid(~preselitev) +
  geom_boxplot() + scale_y_log10()

cor(imigracija$Year, y = imigracija$number, use = "na.or.complete")

linImigracija <- lm(data = master, imigracija ~ leto)
napoved <- data.frame(leto = seq(1990, 2025, 1))
napoved$imigracija <- predict(linImigracija, napoved) # kaj model napove

linEmigracija <- lm(data = master, emigracija ~ leto)
napoved$emigracija <- predict(linEmigracija, napoved)

loessImigracija <- loess(data = master, imigracija ~ leto)
napoved$lImi <- predict(loessImigracija, napoved)

loessEmigracija <- loess(data = master, emigracija ~ leto)
napoved$lEmi <- predict(loessEmigracija, napoved)

# napake <- sapply(list(linImigracija, kv, mls, mgam), function(x) sum(x$residuals^2))

# RAZVRŠČANJE DRŽAV V SKUPINE ####
povprecje <- master %>% group_by(country) %>%
  summarise(emigracija = mean(emigracija, na.rm = TRUE),
            imigracija = mean(imigracija, na.rm = TRUE),
            populacija = mean(populacija, na.rm = TRUE),
            BDP = mean(BDP, na.rm = TRUE),
            BDPpc = mean(BDPpc, na.rm = TRUE),
            izobrazenost = mean(izobrazenost, na.rm = TRUE),
            HDI = mean(HDI, na.rm = TRUE)) %>%
  mutate(emigracija = emigracija / populacija, imigracija = imigracija / populacija)

skupineEmigracija <- kmeans(povprecje$emigracija, 6, nstart = 1500)
centersEmi <- sort(skupineEmigracija$centers)
skupineEmigracija <- kmeans(povprecje$emigracija, centers = centersEmi, nstart = 1500)

zemljevidEmi <- tm_shape(merge(svet, data.frame(country = povprecje$country,
                                                    skupina = factor(skupineEmigracija$cluster)),
                                   by.x = "NAME", by.y = "country")) +
  tmap_options(max.categories = 6) +
  tm_polygons("skupina", title = "Skupina") +
  tm_layout(main.title = "Države razdeljene glede na povprečno emigracijo") +
  tm_legend(position = c("left", "center"))

skupineImigracija <- kmeans(povprecje$imigracija, 6, nstart = 1500)
centersImi <- sort(skupineImigracija$centers)
skupineImigracija <- kmeans(povprecje$imigracija, centers = centersImi, nstart = 1500)

zemljevidImi <- tm_shape(merge(svet, data.frame(country = povprecje$country,
                                                skupina = factor(skupineImigracija$cluster)),
                               by.x = "NAME", by.y = "country")) +
  tmap_options(max.categories = 6) +
  tm_polygons("skupina", title = "Skupina") +
  tm_layout(main.title = "Države razdeljene glede na povprečno imigracijo") +
  tm_legend(position = c("left", "center"))

povprecje <- povprecje %>% inner_join(data.frame(country = povprecje$country,
                                                 skupinaE = factor(skupineEmigracija$cluster))) %>%
  inner_join(data.frame(country = povprecje$country,
                        skupinaI = factor(skupineImigracija$cluster)))
povprecje <- data.frame(povprecje)


euclidean <- function(x, q) {
	ret = sqrt(sum((x - q)^2))
	ret
}

knn <- function(base, query, k=3) {

	nAttrs = ncol(base)-1
	classAttr = ncol(base)

	distances = c()

	for (i in 1:nrow(base)) {
		distances = c(distances, euclidean(base[i,1:nAttrs], query))
	}

	# ordenar as distancias
	ids = sort.list(distances)[1:k]
	classes = base[ids,classAttr]

	result = sum(classes) / k

	result
}

test <- function() {
	b = read.table("../datasets/logistic/logistic-3.8.dat")
	test = read.table("../datasets/logistic/logistic-test.dat")
	ver = read.table("../datasets/logistic/logistic-test-verificar.dat")

	print(cbind(test, ver))

	input = test[1,]

	allResults = c()
	for (i in 1:10) {
		result = knn(b, input)
		allResults = c(allResults, result)
		input = result
	}

	ts.plot(cbind(ver))
	points(allResults, col=2)
}


suppressMessages(library(tidyverse))
suppressMessages(library(patchwork))
suppressMessages(library(ggpmisc))

args <- commandArgs(trailingOnly=TRUE)

if (length(args) != 2)
    stop("Expected two arguments")

input_file <- args[1]
output_file <- args[2]

df <- read.csv(input_file) %>% filter(strategy == "Balanced")

f <- y ~ x

plot <-
    ggplot(df, aes(x=log10_squared_edges,
                   y=iterations,
                   col=graph_type)) +
    geom_point() +
    geom_smooth(method="lm", formula=f, fullrange=TRUE) +
    stat_poly_eq(aes(label = ..eq.label..), formula=f, parse=TRUE) +
    labs(y="Iterations",
         x=expression("log"^2 ~ "m"),
         col='Graph type')

ggsave(output_file, plot)


library(calibrate)
png("fig2.png", width=800, height=400)
df<-read.csv("./hampapprovalVSpopvote.csv",header=T)
row.names(df)<-df$state
linearStepModel<-lm(hamp_approval_rate~1+popular_vote2012+sign(popular_vote2012)+sign(popular_vote2012)*popular_vote2012, df)
plot(df$popular_vote2012,df$hamp_approval_rate,
	xlab="2012 Popular Vote %Romney - %Obama",
	ylab="MSA HAMP Loan Modification Approval Rate (%)")
pre<-predict(linearStepModel)
lines(df$popular_vote2012,pre,col="green")
segments(df$popular_vote2012,df$hamp_approval_rate,df$popular_vote2012,pre,col="orange")
textxy(df$popular_vote2012, df$hamp_approval_rate, df$state, cex=0.7)
dev.off()


library(dbscan)
cl <- dbscan(iris[,-5], eps = .5, minPts = 5)
plot(iris[,-5], col = cl$cluster)


### Exemple 1 : with only one factor
#Let's create datas. We will consider 7 varieties of wheat / 20 samples per variety / a degree of resistance to a disease (mark from 0 to 20) for each sample:

variety=c(rep("soldur", 20) , rep("silur", 20) , rep("lloyd", 20), rep("pescadou", 20),
        rep("X4582", 20) , rep("Dudur", 20) , rep("Classic", 20))
note=c( sample(2:5, 20 , replace=T) , sample(6:10, 20 , replace=T),
        sample(1:7, 30 , replace=T), sample(3:10, 70 , replace=T) )
data=data.frame(variety, note)

#Using R it is really easy to make a basic boxplot
png("#9_ordered_boxplot_step1.png" ,  width = 480, height = 480)
boxplot(data$note ~ data$variety , col="grey")
dev.off()

#Nevertheless, it is quite difficult to understand the results. It would be more clear if genotypes were ordered from the most sensible to the most resistant !
#I'm gonna create a vector named "new_order" containing the desired order, and ask to boxplot using this vector !
new_order <- with(data, reorder(variety , note, median , na.rm=T))
png("#9_ordered_boxplot_step2.png" ,  width = 480, height = 480)
boxplot(data$note ~ new_order , ylab="sickness" , col="darkgreen",
        boxwex=0.4 , main="")
dev.off()

### EXEMPLE 2 : Multifactorial
#This time we still have several varieties of wheat. But each genotype have 20 samples grown in high temperature, and 20 in low temperature. So we have 2 factors : variety and treatment.
variety=c(rep("soldur" , 40), rep("silur" , 40), rep("lloyd" , 40),
          rep("pescadou" , 40) , rep("X4582" , 40) ,
          rep("Dudur" , 40) , rep("Classic" , 40))

treatment= rep(c(rep("high" , 20) , rep("low" , 20)) , 7)

note=c( rep(c(sample(0:4, 20 , replace=T) , sample(1:6, 20 , replace=T)),2),
          rep(c(sample(5:7, 20 , replace=T), sample(5:9, 20 , replace=T)),2),
          c(sample(0:4, 20 , replace=T) , sample(2:5, 20 , replace=T),
          rep(c(sample(6:8, 20 , replace=T) , sample(7:10, 20 , replace=T)),2) ))

data=data.frame(variety, treatment ,  note)

#I reorder the variety from the most sensible to the most resistant. (mixing low and high treatments for the calculations)
new_order <- with(data, reorder(variety , note, mean , na.rm=T))

#Then I make the boxplot, asking to use the 2 factors : variety (in the good order) AND treatment :
png("#9_ordered_boxplot_step3.png" ,  width = 480, height = 480)
par(mar=c(3,4,3,1))

#Make the boxplot
myplot=boxplot(note ~ treatment*new_order , data=data  , boxwex=0.4 , ylab="sickness",
        main="sickness of several wheat lines" , col=c("slateblue1" , "tomato") ,  xaxt="n")

#To add the label of x axis
my_names=sapply(strsplit(myplot$names , '\\.') , function(x) x[[2]] )
my_names=my_names[seq(1 , length(my_names) , 2)]
axis(1, at = seq(1.5 , 14 , 2), labels = my_names , tick=FALSE , cex=0.3)
for(i in seq(0.5 , 20 , 2)){ abline(v=i,lty=1, col="grey")}

#Add a legend
legend("bottomright", legend = c("High treatment", "Low treatment"), col=c("slateblue1" , "tomato"),
       pch = 15, bty = "n", pt.cex = 3, cex = 1.2,  horiz = F, inset = c(0.1, 0.1))

dev.off()


=begin
[((<index|URL:index.html>))]
= Algebra::AlgebraicParser
((*(Class of Evaluation of Algebraic Expression)*))

== File Name:
* ((|algebraic-parser.rb|))

== SuperClass:

* ((|Object|))

== Included Module:

none.

== Class Methods:
--- Algebra::AlgebraicParser.eval(string, ring)
    Calculates the ((|string|)) on ((|ring|)).

== Methods:

none.

== Specification:

=== Evaluation

The value of variable is obtained by the class method
((|indeterminate|)) of ((|ring|)). The value of numeral is
the return value of the class method ((|indeterminate|)) of
((|ring.ground|)).

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

((|indeterminate|)) of ((|Integer|)) is defined as following:

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

in algebra-supplement.rb which is required by algebraic-parser.rb

=== Identifier
Identifier is "a alphabet + some digits". For example,

        "a13bc04def0"

is interpreted as

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

=== Operations
The order of strength of operations:

  ;               intermediate evaluation
  +, -            sum, difference
  +, -            unary +, unary -
  *, /            product, quotient
  (juxtaposition) product
  **, ^           power

=== Example:
In ((|Algebra::Polynomial|)) and ((|Algebra::MPolynomial|)),
((|indeterminate|))
and((|ground|)) are defined suitably. So we can obtain the
value of strings as following:

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

In ((|Algebra::MPolynomial|)), ((|indeterminate|)) resists the objects
representing
variables in order that they appear. So we may set the order, using `;'.

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

=end


library(optparse)
library(lattice)
library(ggplot2)
library(caret)
require(gbm)

parse.path <- function(path) {
    if (is.null(path)){
        print_help(opt_parser)
        stop("path is a mandatory argument", call.=FALSE)
    }
    return(path)
}

parse.target <- function(target) {
    if (is.null(target)){
        print_help(opt_parser)
        stop("target is a mandatory argument", call.=FALSE)
    }
    return(target)
}

load.data <- function(type, path, target) {
    x <- read.csv(paste(path, "/features_", type, ".csv", sep = ""))
    y <- read.csv(paste(path, "/labels_", type, ".csv", sep = ""))

    data = x
    data[length(x) + 1] = y

    #data[[target]] = as.factor(data[[target]])
    data = as.data.frame(data)
    return(data)
}

option_list = list(
    make_option(c("-p", "--path"), type="character", default=NULL, help="path to features and labels files", metavar="character"),
    make_option(c("-t", "--target"), type="character", default=NULL, help="target feature", metavar="character"),
    make_option(c("-i", "--trees"), type="integer", default=4, help="number of trees", metavar="integer")
)

opt_parser = OptionParser(option_list=option_list)
opt = parse_args(opt_parser)

path = parse.path(opt$path)
target = parse.target(opt$target)
trees = parse.target(opt$trees)

train = load.data("train", path, target)
test = load.data("test", path, target)

common <- intersect(names(train), names(test))
for (p in common) {
    if (class(train[[p]]) == "factor") {
        levels(test[[p]]) <- levels(train[[p]])
    }
}

#gbmr <- gbm(    formula(paste(target, "~.")),     data=train, distribution="gaussian")
#prediction <- predict(gbmr, test, n.trees=trees)
#summary = summary(prediction)
#rmse = sqrt(mean((prediction[1]-data.matrix(test[target]))^2))
#result = paste("rmse:", rmse, ":max_error:", summary["Max."], sep = "")
#cat(result)

modelBDT <- gbm(formula(paste(target, "~.")), data=train, distribution="gaussian")
predictionsBDT <- predict(modelBDT, newdata = test)
test$bdt = predictionsBDT
rmseBDT =sqrt(mean((as.numeric(test$bdt)-as.numeric(test[[target]]))^2))
maxerrorBDT = max(as.numeric(test$bdt)-as.numeric(test[[target]]))

y_true = as.numeric(test[[target]])
rss = sum((predictionsBDT - y_true) ^ 2)
tss = sum((y_true - mean(y_true)) ^ 2)
rsq = 1 - rss / tss

result <- paste("rmse:", rmseBDT, ":r2_score:", rsq, ":max_error:", maxerrorBDT, sep = "")
cat(result)


## Functions for plotting the results from the linear dimensionality reduction analyses

plot.pca <- function(Y,title = NULL) {
  df <- data.frame(PC1 = Y[,1],PC2 = Y[,2])

  r <- rev(RColorBrewer::brewer.pal(11, "Spectral"))
  g <- ggplot(df, aes(PC1, PC2)) +  stat_binhex(binwidth = 0.2) + ggtitle(title) +
    scale_fill_gradientn(colours=r, limits=c(0,70)) + geom_density2d(colour = "black", size = 0.1) +
    ylim(c(-6,6)) + xlim(c(-6,6))

  return(g)
}

explained.variance <- function(sdev){
  return(100*sdev^2/sum(sdev^2))
}

plot.jive <- function(f,titles) {
  if(!require(r.jive)){
    install.packages("r.jive")
    require(r.jive)
  }

  l <- length(f$data)
  VarJoint = rep(0, l)
  for (i in 1:l) VarJoint[i] = norm(f$joint[[i]], type = "F")^2/norm(f$data[[i]], type = "F")^2

  VarIndiv = rep(0, l)
  for (i in 1:l) VarIndiv[i] = norm(f$individual[[i]], type = "F")^2/norm(f$data[[i]], type = "F")^2

  VarResid = 1 - VarJoint - VarIndiv

  df = data.frame( case = factor(as.vector(matrix(sapply(titles,rep,3),nrow = 1)), levels = titles),
                   variable = factor(rep(c("Joint","Individual","Residual"),l), levels = c("Joint","Individual","Residual")),
                   value = matrix(rbind(VarJoint, VarIndiv, VarResid),6,1) )

  # df$case = factor(df$case, levels = title)

  r <- rev(RColorBrewer::brewer.pal(11, "Spectral"))
  g <- ggplot(df,aes(fill = variable, y = value, x = case)) + ggtitle("Variation Explained") +
    geom_bar(stat="identity", position = position_fill(reverse = TRUE)) + scale_fill_manual(values = r[1:3])+
    theme(axis.title.x = element_blank(),
          axis.title.y = element_blank(),
          legend.title = element_blank(),
          axis.text = element_text(color="gray30", size=6),
          axis.text.x = element_text(angle=0,vjust=0.5),
          plot.title = element_text(size=8),
          text = element_text(size=8),
          legend.position="bottom",
          legend.justification="center",
          legend.key.size = unit(3,"mm"),
          legend.key.width = unit(3,'mm'),
          legend.text = element_text(margin = margin(r = 2, unit = "mm"),size = 6),
          legend.margin = margin(0,0,0,0)
    )
  return(g)
}

plot.MDS <- function(df){
  if(!require(ggrepel)){
    install.packages('ggrepel')
    require(ggrepel)
  }

  ggplot(df, aes(x = MDS1, y = MDS2, color = condition)) +
    geom_point(size = 2, alpha = 0.8) +
    ggrepel::geom_label_repel(aes(label = sample_id), point.padding = 0.2) +
    theme_bw() +
    scale_color_manual(values = c("#1F78B4","#B15928"))
}

dimensionality reduction and phenotyping/plotLinDR.r


##############################
## tidyverse version of Housing_R.r
##
## Karl Cottenie
##
## 2017-12-11
##
##############################
setwd('/Users/Cam/Desktop/Code/bin/kaggle_code/california_housing')

library(tidyverse)
library(viridis)
# + scale_color/fill_viridis(discrete = T/F)
theme_set(theme_light())

# Startup ends here

# KC: how fast does this code run?
# select from this line to the next proc.time statement, and execute the code
start_time_tidy = proc.time()

housing.tidy = read_csv('housing.csv')

housing.tidy # KC: but not really necessary, bc you can just double click on it in line 17

summary(housing.tidy)

# par(mfrow=c(2,5))
# KC: I don't think par influences ggplot statements

# colnames(housing), not really needed in tidyverse
# KC: housing will give you all the column names
# piping will recognize the column names anyway

housing.tidy %>% gather(longitude:median_house_value, key = "variable", value = "value") %>%
  ggplot(aes(x = value)) +
  geom_histogram(bins = 30) + facet_wrap(~ variable, scales = 'free_x')

housing.tidy %>% ggplot(aes(x = ocean_proximity)) +
  geom_bar() # KC: missing from Housing_R.r

housing.tidy %>% mutate(total_bedrooms_c = ifelse(is.na(total_bedrooms),
                                                  median(total_bedrooms, na.rm = T),
                                                  total_bedrooms)) %>%
  summary()
# KC: this is just to show how I would check whether it did it correctly

housing.tidy = housing.tidy %>%
  mutate(total_bedrooms = ifelse(is.na(total_bedrooms),
                                 median(total_bedrooms, na.rm = T),
                                 total_bedrooms),
         mean_bedrooms = total_bedrooms/households,
         mean_rooms = total_rooms/households) %>%
  select(-c(total_rooms, total_bedrooms))

# KC: this is one fast way to do it, but relies on some knowledge of an obscure function
# cat_housing.tidy = housing.tidy %>%
#   model.matrix( ~ ocean_proximity - 1, data = .) %>%
#   as.tibble()
#
# names(cat_housing.tidy) = names(cat_housing.tidy) %>% # cleaning up the column names
#   strsplit("ocean_proximity") %>% map_chr(function(x) x[2])

# KC: this would be a second option, using a very general approach
categories = unique(housing.tidy$ocean_proximity) # all categories
cat_housing.tidy = categories %>% # compare the full vector against each category consecutively
  lapply(function(x) as.numeric(housing.tidy$ocean_proximity == x)) %>% # convert to numeric
  do.call("cbind", .) %>% as.tibble() # clean up
colnames(cat_housing.tidy) = categories # make nice column names

cleaned_housing.tidy = housing.tidy %>%
  select(-c(ocean_proximity, median_house_value)) %>%
  scale() %>% as.tibble() %>%
  bind_cols(cat_housing.tidy) %>%
  add_column(median_house_value = housing.tidy$median_house_value)

cleaned_housing.tidy %>% summary()

running_time_tidy = proc.time() - start_time_tidy
# KC: this is the end of the timing event
# 3 times faster compared to base R code

set.seed(19) # Set a random seed so that same sample can be reproduced in future runs

sample = sample.int(n = nrow(cleaned_housing.tidy), size = floor(.8*nrow(cleaned_housing.tidy)), replace = F)
train = cleaned_housing.tidy[sample, ] #just the samples
test  = cleaned_housing.tidy[-sample, ] #everything but the samples

head(train)

nrow(train) + nrow(test) == nrow(cleaned_housing.tidy)

library('boot')

?cv.glm # note the K option for K fold cross validation

glm_house = glm(median_house_value~median_income+mean_rooms+population, data=cleaned_housing.tidy)
k_fold_cv_error = cv.glm(cleaned_housing.tidy , glm_house, K=5)

k_fold_cv_error$delta

glm_cv_rmse = sqrt(k_fold_cv_error$delta)[1]
glm_cv_rmse #off by about $83,000... it is a start

names(glm_house) #what parts of the model are callable?

glm_house$coefficients

library('randomForest')

?randomForest

names(train)

set.seed(1738)

train_y = train[,'median_house_value']
train_x = train[, names(train) !='median_house_value']

head(train_y)
head(train_x)

#some people like weird r format like this... I find it causes headaches
#rf_model = randomForest(median_house_value~. , data = as.matrix(train), ntree =50, importance = TRUE)
rf_model = randomForest(train_x, y = as.matrix(train_y) , ntree = 50, importance = TRUE)
# KC: this is the only problem, need to convert to matrix before you can feed it to random forest

names(rf_model) #these are all the different things you can call from the model.

rf_model$importance

oob_prediction = predict(rf_model) #leaving out a data source forces OOB predictions

#you may have noticed that this is avaliable using the $mse in the model options.
#but this way we learn stuff!
train_mse = mean(as.numeric((oob_prediction - train_y)^2))
oob_rmse = sqrt(train_mse)
oob_rmse

test_y = test[,'median_house_value']
test_x = test[, names(test) !='median_house_value']

y_pred = predict(rf_model , test_x)
test_mse = mean(((y_pred - test_y)^2))
test_rmse = sqrt(test_mse)
test_rmse


# Calculate SD of monthly mean temperatures from CMIP5
# For 1986-2005 and 2081-2100

source('analysis/image.scale.r') # for plotting color bar on image
require(ncdf4)
require(RColorBrewer)
require(raster)

# read in rcp85 temperatures
infile <- nc_open('data/cmip5/tas_Amon_modmean_rcp85_ave.nc') # multi-model mean for each month 1861-2100. near-surface air.
	#print(infile)
	lst <- ncvar_get(infile, 'tas') # lst lon  x lat x time (144x72x2880)
	dim(lst)
	dimnames(lst) <- list(lon=1:144, lat=1:72, time=1:2880)
	dimnames(lst)[[1]] <- infile$var[['tas']]$dim[[1]]$vals # add lon
	dimnames(lst)[[2]] <- infile$var[['tas']]$dim[[2]]$vals # add lat
	dimnames(lst)[[3]] <- infile$var[['tas']]$dim[[4]]$vals # add time
	nc_close(infile)

infile <- nc_open('data/cmip5/tos_Omon_modmean_rcp85_ave.nc') # multi-model mean for each month 1861-2100. sea.
	#print(infile)
	sst <- ncvar_get(infile, 'tos') # lon  x lat x time (288x144x2880)
	dim(sst)
	dimnames(sst) <- list(lon=1:288, lat=1:144, time=1:2880)
	dimnames(sst)[[1]] <- infile$var[['tos']]$dim[[1]]$vals # add lon
	dimnames(sst)[[2]] <- infile$var[['tos']]$dim[[2]]$vals # add lat
	dimnames(sst)[[3]] <- infile$var[['tos']]$dim[[4]]$vals # add time
	nc_close(infile)

# Mask out ocean from tas
searast <- raster(t(!is.na(sst[,,1]))[ncol(sst):1,], xmn=0, xmx=360, ymn=-90, ymx=90)
landrast <- raster(t(!is.na(lst[,,1]))[ncol(lst):1,], xmn=0, xmx=360, ymn=-90, ymx=90)
seamask <- round(resample(searast, landrast, method='bilinear')) # includes areas 50% land as land (floor): 0 is land, 1 is ocean
seamask <- t(as.matrix(seamask)) # rearrange again to match lst
seamask <- seamask[,ncol(seamask):1]
seamask[seamask==1] <- NA # turn ocean to NA

lst2 <- lst
for(i in 1:dim(lst)[3]){
	lst2[,,i] <- lst[,,i] + seamask # turns ocean to NAs
}

# Detrend historical and future time-periods within each grid cell
dt <- function(x){
	if(all(!is.na(x))){
		resid(lm(x ~ I(1:length(x))))
	} else {
		return(rep(NA, length(x)))
	}
}
mohist1 <- (1986-1861)*12
mohist2 <- (2005-1861)*12+11
lstdthist <- apply(lst2[,,mohist1:mohist2], MARGIN=c(1,2), FUN=dt) # dimensions now time x lon x lat
sstdthist <- apply(sst[,,mohist1:mohist2], MARGIN=c(1,2), FUN=dt)

mofut1 <- (2081-1861)*12
mofut2 <- (2100-1861)*12+11
lstdtfut <- apply(lst2[,,mofut1:mofut2], MARGIN=c(1,2), FUN=dt)
sstdtfut <- apply(sst[,,mofut1:mofut2], MARGIN=c(1,2), FUN=dt)

# SD (seasonality)
lst_sdhist <- apply(lstdthist, MARGIN=c(2,3), FUN=sd)
sst_sdhist <- apply(sstdthist, MARGIN=c(2,3), FUN=sd)

lst_sdfut <- apply(lstdtfut, MARGIN=c(2,3), FUN=sd)
sst_sdfut <- apply(sstdtfut, MARGIN=c(2,3), FUN=sd)

# Plot of SD historical, SD future, and difference of SDs (tas)
zlims1 <- range(c(lst_sdhist, lst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
zlims2 <- range(lst_sdfut - lst_sdhist, na.rm=TRUE)
bks2 <- seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=1)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tas_cmip5_hist&fut_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdfut-lst_sdhist, col=cols2, breaks=bks2, main='(2081-2100) minus (1986-2005)')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()

# Plot of SD historical, SD future, and difference of SDs (tos)
zlims1 <- range(c(sst_sdhist, sst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
zlims2 <- range(sst_sdfut - sst_sdhist, na.rm=TRUE)
bks2 <- seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=1)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tos_cmip5_hist&fut_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdfut-sst_sdhist, col=cols2, breaks=bks2, main='(2081-2100) minus (1986-2005)')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()

# Plot of SD historical, SD future, and ratio of SDs (tas)
zlims1 <- range(c(lst_sdhist, lst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
zlims2 <- range(log(lst_sdfut/lst_sdhist), na.rm=TRUE)
bks2 <- seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=0.1)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tas_cmip5_hist-futratio_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), log(lst_sdfut/lst_sdhist), col=cols2, breaks=bks2, main='log((2081-2100) / (1986-2005))')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()

# Plot of SD historical, SD future, and ratio of SDs (tos)
zlims1 <- range(c(sst_sdhist, sst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
#zlims2 <- range(log(sst_sdfut/sst_sdhist), na.rm=TRUE)
zlims2 <- c(-3,3) # force narrow
bks2 <- c(-30, seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=0.1), 30)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tos_cmip5_hist-futratio_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), log(sst_sdfut/sst_sdhist), col=cols2, breaks=bks2, main='(2081-2100) minus (1986-2005)')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()


#' Shrinkage-mean-based Diagonal Linear Discriminant Analysis (SmDLDA) from
#' Tong, Chen, and Zhao (2012)
#'
#' Given a set of training data, this function builds the Shrinkage-mean-based
#' Diagonal Linear Discriminant Analysis (SmDLDA) classifier from Tong, Chen,
#' and Zhao (2012). The SmDLDA classifier incorporates a Lindley-type shrunken
#' mean estimator into the DLDA classifier from Dudoit et al. (2002). For more
#' about the DLDA classifier, see [lda_diag()].
#'
#' The DLDA classifier belongs to the family of Naive Bayes classifiers, where
#' the distributions of each class are assumed to be multivariate normal and to
#' share a common covariance matrix.
#'
#' The DLDA classifier is a modification to the well-known LDA classifier, where
#' the off-diagonal elements of the pooled sample covariance matrix are assumed
#' to be zero -- the features are assumed to be uncorrelated. Under multivariate
#' normality, the assumption uncorrelated features is equivalent to the
#' assumption of independent features. The feature-independence assumption is a
#' notable attribute of the Naive Bayes classifier family. The benefit of these
#' classifiers is that they are fast and have much fewer parameters to estimate,
#' especially when the number of features is quite large.
#'
#' The matrix of training observations are given in `x`. The rows of `x`
#' contain the sample observations, and the columns contain the features for each
#' training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations belonging
#' to each class. Otherwise, `prior` should be a vector with the same length
#' as the number of classes in `y`. The `prior` probabilities should be
#' nonnegative and sum to one.
#'
#' @export
#'
#' @inheritParams lda_diag
#' @return `lda_shrink_mean` object that contains the trained SmDLDA classifier
#'
#' @references Tong, T., Chen, L., and Zhao, H. (2012), "Improved Mean
#' Estimation and Its Application to Diagonal Discriminant Analysis,"
#' Bioinformatics, 28, 4, 531-537.
#' \url{http://bioinformatics.oxfordjournals.org/content/28/4/531.long}
#' @references Dudoit, S., Fridlyand, J., & Speed, T. P. (2002). "Comparison of
#' Discrimination Methods for the Classification of Tumors Using Gene Expression
#' Data," Journal of the American Statistical Association, 97, 457, 77-87.
#' @examples
#' library(modeldata)
#' data(penguins)
#' pred_rows <- seq(1, 344, by = 20)
#' penguins <- penguins[, c("species", "body_mass_g", "flipper_length_mm")]
#' smdlda_out <- lda_shrink_mean(species ~ ., data = penguins[-pred_rows, ])
#' predicted <- predict(smdlda_out, penguins[pred_rows, -1], type = "class")
#'
#' smdlda_out2 <- lda_shrink_mean(x = penguins[-pred_rows, -1], y = penguins$species[-pred_rows])
#' predicted2 <- predict(smdlda_out2, penguins[pred_rows, -1], type = "class")
#' all.equal(predicted, predicted2)
lda_shrink_mean <- function(x, ...) {
  UseMethod("lda_shrink_mean")
}

#' @rdname lda_shrink_mean
#' @export
lda_shrink_mean.default <- function(x, y, prior = NULL, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  obj <- diag_estimates(x = x, y = y, prior = prior, pool = TRUE,
                        est_mean = "tong")

  # Creates an object of type 'lda_shrink_mean'
  obj$col_names <- colnames(x)
  obj <- new_discrim_object(obj, "lda_shrink_mean")

  obj
}

#' @inheritParams lda_diag
#' @rdname lda_shrink_mean
#' @importFrom stats model.frame model.matrix model.response
#' @export
lda_shrink_mean.formula <- function(formula, data, prior = NULL, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- lda_shrink_mean.default(x = x, y = y, prior = prior)
  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a SmDLDA classifier object.
#'
#' Summarizes the trained SmDLDA classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @keywords internal
#' @export
print.lda_shrink_mean <- function(x, ...) {
  cat("Shrinkage-Mean-Based Diagonal LDA\n\n")
  print_basics(x, ...)
  invisible(x)
}

#' SmDLDA prediction of the class membership of a matrix of new observations.
#'
#' The SmDLDA classifier is a modification to LDA, where the off-diagonal
#' elements of the pooled sample covariance matrix are set to zero.
#'
#' @rdname lda_shrink_mean
#' @export
#' @inheritParams predict.lda_diag

predict.lda_shrink_mean <- function(object, newdata, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- apply(newdata, 1, function(obs) {
    sapply(object$est, function(class_est) {
      with(class_est, sum((obs - xbar)^2 / object$var_pool) + log(prior))
    })
  })

  if (type == "prob") {
    # Posterior probabilities via Bayes Theorem
    means <- lapply(object$est, "[[", "xbar")
    covs <- replicate(n=object$num_groups, object$var_pool, simplify=FALSE)
    priors <- lapply(object$est, "[[", "prior")
    res <- posterior_probs(x = newdata, means = means, covs = covs, priors = priors)
    res <- as.data.frame(res)

  } else if (type == "class") {
    res <- score_to_class(scores, object)
  } else {
    res <- t(scores)
    res <- as.data.frame(res)
  }
  res
}