#--------------------------------------------------------------
#--------------------------------------------------------------
library(rstudioapi) # setting working directory
setwd(dirname(getActiveDocumentContext()$path))
library(tidyverse)
library(dplyr)
library(ggplot2)
library(scales)
library(vtree)

df <- data.frame(read.csv("sg-housing-resale-data.csv",sep=",",skip = "0"))

### EDA AND VISUALIZATION

### USING DPLYR

df%>%
  filter(year> 2015, flat_type =="2 ROOM")

df%>%
  filter(year> 2015, flat_type %in% c("2 ROOM","5 ROOM"))

df%>%
  filter(year> 2015, flat_type %in% c("2 ROOM","5 ROOM"))%>%
  arrange(desc(resale_price))

df%>%
  group_by(year)%>%
  summarise(
    resale_price = mean(resale_price)
  )

#
df%>%
  group_by(year)%>%
  summarise(
    resale_price = mean(resale_price)
  )%>%
  ggplot( aes(x=year, y=resale_price)) +
  geom_line(color="darkorchid4")+
  scale_y_continuous(labels = comma)
#

ggplot(df , aes(x= as.factor(year), y=resale_price, color = as.factor(year)))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=1, color="red", fill="red")+
  scale_y_continuous(breaks = round(seq(0, max(df$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

ggplot(df , aes(x= as.factor(year), y=price_m2, color = as.factor(year)))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=1, color="red", fill="red")+
  scale_y_continuous(breaks = round(seq(0, 15000, by = 500),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")+
  labs(
         x= "Year",
         y = "Price/m2"
       )

#we notice that for prediction data prior to 2010 might be not relevant.
df1 <- df %>%
  filter(year >= 2010)

# df1 %>%
#   ggplot( aes(x=date, y=resale_price)) +
#   geom_line(color="#69b3a2") +
#   scale_y_continuous(labels = comma,breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
#   labs(
#     x= "Date",
#     y = "Resale Price"
#   )

# another way to calculate and plot the mean.
df1%>%
  group_by(year)%>%
  summarise(
    resale_price = mean(resale_price)
  )%>%
  ggplot( aes(x=year, y=resale_price)) +
  geom_line(color="darkorchid4")+
  scale_x_continuous(breaks = round(seq(2010, 2022, by = 1),1))+
  scale_y_continuous(labels = comma)

# another way

# df1 %>%
#   ggplot( aes(x=date, y=resale_price)) +
#   geom_line(color="#69b3a2") +
#   labs(
#     x= "Date",
#     y = "Resale Price"
#   )+
#   scale_y_continuous(labels = comma,breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
#   scale_x_date(NULL, date_labels = "%b %y", breaks = "year")

# this is another way to draw the value.

#we can see the the value shown in the graph are all observation in every month (as the data is month in year). We might need to summary this data and plot only the average value.

ggplot(df1 , aes(x= as.factor(year), y=resale_price, color = as.factor(year)))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=1, color="red", fill="red")+
  scale_y_continuous(labels = comma,breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

ggplot(df1 , aes(x= as.factor(year), y=price_m2, color = as.factor(year)))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=1, color="red", fill="red")+
  scale_y_continuous(labels=comma,breaks = round(seq(0, 15000, by = 500),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

# it is very difficult to narrate meaningful narrative on this, as it seems the prices keep changed up and down even within a short period, the reason for this is that our data is a mixed data and spready in a long time. Let break it down.

# draw a histogram of price/m2
ggplot(df1, aes(x=resale_price))+
  geom_histogram(fill="deepskyblue2")+
  scale_x_continuous(breaks = round(seq(0, max(df$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))

# density plot

ggplot(df1, aes(x=resale_price))+
  geom_density(fill="deepskyblue2")+
  geom_histogram(aes(y = ..density..),
                 colour = 1, fill = "white",alpha=0.2)+
  scale_x_continuous(labels=comma,breaks = round(seq(0, max(df$resale_price), by = 50000),1))+
  scale_y_continuous(labels=comma)+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))

# draw a histogram of price/m2
ggplot(df1, aes(x=price_m2))+
  geom_histogram(fill="deepskyblue2")+
  scale_x_continuous(labels=comma,breaks = round(seq(0, max(df$price_m2), by = 500),1))+
  scale_y_continuous(labels=comma)+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))

# density plot

ggplot(df1, aes(x=price_m2))+
  geom_density(fill="deepskyblue2")+
  geom_histogram(aes(y = ..density..),
                 colour = 1, fill = "white",alpha=0.2)+
  scale_x_continuous(labels=comma,breaks = round(seq(0, max(df$price_m2), by = 500),1))+
  scale_y_continuous(labels=comma)+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))

# as we can see from this graph there is a wide variety of price. This is because we consider all observations in the graph and observations are mixed of flat_type and flat_model, town, streat, blocks and floor ranges. We need later to separate them.

#one way to separate them is to use boxplot.

#bloxplot for flatype
ggplot(df1 , aes(x= flat_type, y=price_m2, color = flat_type))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  scale_y_continuous(labels=comma,breaks = round(seq(0, 15000, by = 1000),1))+
  theme(legend.position = "none")

#we can see from this graph that the price/m2 keep increase with number of room. The means of price for all flat types are on the higher side of the price in most of cases.

# The most expensive flat type is executive. Multiple-generation flat types also have high price compared to other. Probably in Singapore, multiple generation flat type have multiple rooms as well, therefore it should be more expensive.

vtree(df1, "flat_type", palette = 3, sortfill = TRUE,horiz = TRUE)

# histogram for flat_type
ggplot(df1,aes(x=price_m2)) +
  geom_histogram(colour = "firebrick") +
  # geom_smooth(size = 0.75, se = F) +
  facet_wrap(~flat_type)
# in term of number, we can see that people prefers to have 3-5 bed rooms and executive flats.

ggplot(df1%>%
         count(flat_type),aes(x=flat_type,y=n, color = flat_type)) +
  geom_bar(stat = "identity",fill='steelblue', alpha = 0.3)+
  scale_y_continuous(labels=comma)+
  geom_text(aes(label = prettyNum(n, big.mark = ",", scientific = FALSE)), vjust = -0.5)+
  theme(axis.text.x = element_text(angle=25, vjust=1,hjust=1))+
  theme(legend.position = "none")+
  labs(
    x="flat type",
    y = "Number"
  )

#reorder the graph and put in color.
ggplot(df1%>%
         count(flat_type),aes(x=reorder(flat_type,-n),y=n, color = flat_type)) +
  geom_bar(stat = "identity",fill='steelblue', alpha = 0.3) +
  scale_y_continuous(labels=comma)+
  geom_text(aes(label = prettyNum(n, big.mark = ",", scientific = FALSE)), vjust = -0.5)+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  labs(
    x="Flat Type",
    y="Number"
  )+
  theme(legend.position = "none")

# type of room vs price

df1%>%
  group_by(flat_type)%>%
  summarise(
    resale_price = mean(resale_price)
  ) %>%
  ggplot(aes(x=reorder(flat_type,-resale_price), y=resale_price,color = flat_type)) +
  geom_bar(stat = "identity", fill='steelblue', alpha = 0.3)+
  scale_y_continuous(labels = comma)+
  geom_text(aes(label = prettyNum(resale_price, big.mark = ",", scientific = FALSE)), vjust = -0.5)+
  labs(
    x="Flat Type",
    y="Mean value of resale price"
  )+
  theme(legend.position = "none")

#we repeat this for other factors

#boxplot for flat_model

ggplot(df1 , aes(x= reorder(flat_model,-resale_price), y=resale_price, color = flat_model))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

ggplot(df1 , aes(x= reorder(flat_model,-resale_price), y=resale_price))+
  geom_bar(position ="dodge", stat = "summary", fun.y ="mean", fill="blue", alpha=0.4) +
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

ggplot(df1 , aes(x= reorder(flat_model,-price_m2), y=price_m2, color = flat_model))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  scale_y_continuous(labels=comma,breaks = round(seq(0, 15000, by = 1000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

#facet type
ggplot(df1,aes(x=price_m2)) +
  geom_histogram(colour = "firebrick") +
  scale_y_continuous(labels=comma)+
  facet_wrap(~flat_model)

#barplots
ggplot(df1,aes(x=price_m2,y=flat_model,fill=flat_type)) +
  scale_x_continuous(labels=comma)+
  geom_bar(position="stack", stat="identity")

head(df1%>%
  filter(flat_model == "Model A"))%>%
  ggplot(aes(price_m2,flat_type, fill=flat_type))+
  geom_bar(stat="identity")

head(df1%>%
  filter(year >= 2021))

tail(df1%>%
       filter(year >= 2021))

df1%>%
  count(block)%>%
  tally()

df1%>%
  count(street_name)%>%
  tally()

df1%>%
  count(town)%>%
  tally()

## plot for town
# counting
ggplot(df1%>%
         count(town),aes(x=reorder(town,-n),y=n, color = town)) +
  geom_bar(stat = "identity",fill='steelblue', alpha = 0.3) +
  scale_y_continuous(labels=comma)+
  geom_text(aes(label = prettyNum(n, big.mark = ",", scientific = FALSE)), vjust = -0.5)+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  labs(
    x="Town",
    y="Number"
  )+
  theme(legend.position = "none")

# mean
ggplot(df1 , aes(x= reorder(town,-resale_price), y=resale_price, color = town))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

ggplot(df1 , aes(x= reorder(town,-resale_price), y=resale_price, color = town))+
  geom_bar(position ="dodge", stat = "summary", fun.y ="mean", fill="blue", alpha=0.4) +
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

## Story range

# counting
ggplot(df1%>%
         count(storey_range),aes(x=reorder(storey_range,-n),y=n, color = storey_range)) +
  geom_bar(stat = "identity",fill='steelblue', alpha = 0.3) +
  scale_y_continuous(labels=comma)+
  geom_text(aes(label = prettyNum(n, big.mark = ",", scientific = FALSE)), vjust = -0.5)+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  labs(
    x="storey_range",
    y="Number"
  )+
  theme(legend.position = "none")

# mean
ggplot(df1 , aes(x= reorder(storey_range,-resale_price), y=resale_price, color = storey_range))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

ggplot(df1 , aes(x= reorder(storey_range,-resale_price), y=resale_price, color = storey_range))+
  geom_bar(position ="dodge", stat = "summary", fun.y ="mean", fill="blue", alpha=0.4) +
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df1$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  theme(legend.position = "none")

# how is about remaining lease

df2 <- na.omit(df1)

head(df1)

# counting
ggplot(df2%>%
         count(remaining_lease),aes(x=reorder(remaining_lease,-n),y=n, color = remaining_lease)) +
  geom_bar(stat = "identity",fill='steelblue', alpha = 0.3) +
  scale_y_continuous(labels=comma)+
  geom_text(aes(label = prettyNum(n, big.mark = ",", scientific = FALSE)), vjust = -0.5)+
  theme(axis.text.x = element_text(angle=45, vjust=1,hjust=1))+
  labs(
    x="remaining_lease",
    y="Number"
  )+
  theme(legend.position = "none")

## what is the problem here? this is because the remaining lease contains characters --> this needs to be corrected.

library(stringr)
library(purrr)

df2_1 <- df2%>%
        mutate(remaining_lease01 = gsub(" years", "", remaining_lease), .after = remaining_lease )%>%
        mutate(remaining_lease02 = gsub(" year", "", remaining_lease01), .after = remaining_lease01 )%>%
        mutate(remaining_lease03 = gsub(" months", "", remaining_lease02), .after = remaining_lease02 )%>%
        mutate(remaining_lease04 = gsub(" month", "", remaining_lease03), .after = remaining_lease03)%>%
        mutate(remaining_lease05 = gsub(" ", ".", remaining_lease04), .after = remaining_lease04)%>%
        mutate(remaining_lease06 = gsub("..0", ".", remaining_lease05), .after = remaining_lease05)%>%
        mutate(remaining_lease07 = round(as.numeric(remaining_lease06),0), .after = remaining_lease06)

df3 <- df2%>%
  mutate(remaining_lease = gsub(" years", "", remaining_lease))%>%
  mutate(remaining_lease = gsub(" year", "", remaining_lease))%>%
  mutate(remaining_lease = gsub(" months", "", remaining_lease))%>%
  mutate(remaining_lease = gsub(" month", "", remaining_lease))%>%
  mutate(remaining_lease = gsub(" ", ".", remaining_lease))%>%
  mutate(remaining_lease = gsub("..0", ".", remaining_lease))%>%
  mutate(remaining_lease = round(as.numeric(remaining_lease),0))

ggplot(df3%>%
         count(remaining_lease),aes(x=reorder(remaining_lease,-n),y=n, color = remaining_lease)) +
  geom_bar(stat = "identity",fill='steelblue', alpha = 0.3) +
  scale_y_continuous(labels=comma)+
 # geom_text(aes(label = prettyNum(n, big.mark = ",", scientific = FALSE)), vjust = -0.5, angle=90)+
  theme(axis.text.x = element_text(angle=90, vjust=1,hjust=1))+
  labs(
    x="remaining_lease",
    y="Number"
  )+
  theme(legend.position = "none")

# mean
ggplot(df3 , aes(x= reorder(remaining_lease,-resale_price), y=resale_price, color = remaining_lease))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df3$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=90, vjust=1,hjust=1))+
  theme(legend.position = "none")

ggplot(df3 , aes(x= reorder(remaining_lease,-resale_price), y=resale_price, color = remaining_lease))+
  geom_bar(position ="dodge", stat = "summary", fun.y ="mean", fill="blue", alpha=0.4) +
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df3$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=90, vjust=1,hjust=1))+
  theme(legend.position = "none")

### Commenced dates

ggplot(df3%>%
         count(lease_commence_date),aes(x=reorder(lease_commence_date,-n),y=n, color = lease_commence_date)) +
  geom_bar(stat = "identity",fill='steelblue', alpha = 0.3) +
  scale_y_continuous(labels=comma)+
  # geom_text(aes(label = prettyNum(n, big.mark = ",", scientific = FALSE)), vjust = -0.5, angle=90)+
  theme(axis.text.x = element_text(angle=90, vjust=1,hjust=1))+
  labs(
    x="remaining_lease",
    y="Number"
  )+
  theme(legend.position = "none")

ggplot(df3 , aes(x= reorder(lease_commence_date,-resale_price), y=resale_price, color = lease_commence_date))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  scale_y_continuous(labels = comma, breaks = round(seq(0, max(df3$resale_price), by = 50000),1))+
  theme(axis.text.x = element_text(angle=90, vjust=1,hjust=1))+
  theme(legend.position = "none")

## correlation analysis

cor(df3%>%
      select(floor_area_sqm,lease_commence_date,remaining_lease),use = "all.obs")
glimpse(df3)

### TABLE PIVOTING
library(reshape)
library(reshape2)

df4 <- aggregate(df3$resale_price, by=list(flat_type = df3$flat_type), FUN=sum)%>%filter(x>0)

df3 %>%
  group_by(town, flat_type) %>%
  summarize(resale_price = sum(resale_price))%>%
  filter(resale_price>0)

df3 %>%
  group_by(town, flat_type) %>%
  summarize(resale_price = mean(resale_price))%>%
  filter(resale_price>0)

cast(df3 %>%
       group_by(town, flat_type) %>%
       summarize(resale_price = sum(resale_price))%>%
       filter(resale_price>0),
     town~flat_type,sum)

epsilon <- 1000000

p<-df3%>%
  filter(resale_price >0)%>%
  ggplot(aes(x=reorder(town,resale_price, sum),y=resale_price, fill=flat_type))+
  geom_col()+
 # scale_y_continuous(labels=comma,breaks = round(seq(0, max(df4$x)*1.2, by = epsilon),1))+
  scale_y_continuous(labels=comma)+
  geom_text(aes(town, resale_price, label = stat(prettyNum(y, big.mark = ",", scientific = FALSE)), group = town), stat = 'summary', fun=sum, vjust = -1)+
  # theme(legend.position = "none")+
  labs(
    x="town",
    y = "Singaporean Dollars"
  )+
  coord_flip()

p


#==========================================================
if(!require(grDevices))
  warning("This function requires the package [grDevices].\nInstalll it to continue.")
if(!require(scales))
  warning("This function requires the package [scales].\nInstalll it to continue.")

#==========================================================
bubbleplot = function (x, ...) UseMethod("bubbleplot")
#==========================================================
bubbleplot.default = function(x, y, col="black", bg="grey",
                              pch=19, alpha=0.5, mcex=5, add=FALSE,
                              mobs = NULL, ...)
{
  cols = c(col, bg)
  cols = scales::alpha(cols, alpha=alpha)

  dat = data.frame(grDevices::xyTable(x,y))

  if(is.null(mobs))
    mobs = max(dat[,3])

  dat$radius = sqrt(dat[,3])
  maxr = sqrt(mobs)

  dat$radius = mcex * dat$radius/maxr

  n = pretty(dat[,3])
  if(0 %in% n)
    n[n == 0] = 1

  cexs = mcex * sqrt(n)/maxr

  if(!add)
    plot(dat$x, dat$y, cex=dat$radius, col=cols[1], bg=cols[2], pch=pch,...)
  else
    points(dat$x, dat$y, cex=dat$radius, col=cols[1], bg=cols[2], pch=pch,...)

  invisible(list(n=n, cex=cexs))
}
#==========================================================
bubbleplot.formula = function(formula, col="black", bg="grey",
                              pch=19, alpha=0.5, mcex=5, add=FALSE, mobs=NULL,
                              data=NULL,...)
{
  if (is.null(data))
    mf = model.frame(formula)
  else
    mf = model.frame(formula, data)

  ans = list()

  ans = bubbleplot.default(x = mf[,2], y=mf[,1], col = col,
                           bg=bg, pch=pch, alpha=alpha, mcex=mcex, add=add, mobs = mobs, ...)

  invisible(ans)
}
#==========================================================
#Example
#x11()
#par(mfrow=c(1,2))
#x = round(rnorm(100, 10, 2))
#z = round(rnorm(100, 10, 2))
#y = round(2*x-z + sample((1:5)/2, 100, replace=TRUE))

#bubbleplot(y~x, alpha=0.5)
#bubbleplot(y=y, x=z, alpha=0.5)
#==========================================================


obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }

  razdalje = dist(podatki)

  k.obrisi = tibble()
  for (k in od:do) {
    if (hc) {
      o.k = hclust(razdalje) %>%
        cutree(k) %>%
        silhouette(razdalje)
    } else {
      set.seed(42) # zato, da so rezultati ponovljivi
      o.k = kmeans(podatki, k)$cluster %>%
        silhouette(razdalje)
    }
    k.obrisi = k.obrisi %>% bind_rows(
      tibble(
        k = rep(k, n),
        obrisi = o.k[, "sil_width"]
      )
    )
  }
  k.obrisi$k = as.ordered(k.obrisi$k)

  k.obrisi
}

obrisi.povprecje = function(k.obrisi) {
  k.obrisi.povprecje = k.obrisi %>%
    group_by(k) %>%
    summarize(obrisi = mean(obrisi))
}

obrisi.k = function(k.obrisi) {
  obrisi.povprecje(k.obrisi) %>%
    filter(obrisi == max(obrisi)) %>%
    summarize(k = min(k)) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

diagram.obrisi = function(k.obrisi) {
  ggplot() +
    geom_boxplot(
      data = k.obrisi,
      mapping = aes(x = k, y = obrisi)
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = k, y = obrisi),
      color = "red"
    ) +
    geom_line(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = as.integer(k), y = obrisi),
      color = "red"
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi) %>%
        filter(obrisi == max(obrisi)) %>%
        filter(k == min(k)),
      mapping = aes(x = k, y = obrisi),
      color = "blue"
    ) +
    xlab("število skupin (k)") +
    ylab("obrisi (povprečje obrisov)") +
    ggtitle(paste("Maksimalno povprečje obrisov pri k =", obrisi.k(k.obrisi))) +
    theme_classic()
}


forecastTS = function(df)
{
   library(dplyr)
   library(zoo)
   library(car)
   library(forecast)
   library(tseries)
   library(fUnitRoots)
   library(PerformanceAnalytics)

   data = df

   Date =as.Date(data$Date,format="%d/%m/%y")
   maxDate=max(as.Date(data$Date,format="%d/%m/%y"))

   #creating ts models
   TS = xts(data$TransactionAmount, order.by = as.Date(data$Date))
   m1=auto.arima(TS)

   #forecasting
   fore = forecast::forecast(m1, h=30)
   ar = as.data.frame(fore)
   sepdf=ar[,c(1,4,5)]
   date=seq(from=maxDate+1,to=maxDate+30,by=1)
   Forecast=cbind(date,sepdf)

   Date=format(date, "%Y-%m-%d")

   Forecast=ar[, 1]
   Low95=ar[,4]
   High95=ar[,5]

   return(data.frame(
   Date,Forecast,Low95,High95
   ))

}

getOutputSchema <- function() {
   return (data.frame(
   Date = prep_date(),
   Forecast = prep_decimal(),
   Low95 = prep_decimal(),
   High95 = prep_decimal()
   ))
}

Chapter08/Sample Files 8.3 - Forecasting Time Series Using R/forecast.r


#

# Section 1 -  2013 American Community Survey (ACS)

# URL to AC survey data
acs_url <- "http://s3.amazonaws.com/assets.datacamp.com/production/course_835/datasets/ac_survey.RData"

# Import data in .RData file at acs_url
load(url(acs_url))

# Print head of ac_survey
print(head(ac_survey, 20))

# ac_survey and dplyr are available
library(dplyr)

# data frame that translates SCHL to Degree
degree_codes <- data.frame(SCHL = c(21, 22, 24),
                           Degree = c("Bachelor", "Masters", "Doctorate"))

# Add code to remove NAs, filter and join
ac_survey_clean <- ac_survey %>% tbl_df() %>% na.omit("NA") %>% filter(SCHL %in% c(21, 22, 24)) %>% inner_join(degree_codes)

# Print out ac_survey_clean
print(ac_survey_clean)

# ac_survey_clean and dplyr are available

# group_by() and summarize()
degree_holders <- ac_survey_clean %>% group_by(Degree) %>% summarize(count = n())

# Print out degree_holders
print(degree_holders)

# Load the ggplot2 package
library(ggplot2)

# Visualize the number of Bachelor, Master and PhD holders
ggplot(degree_holders, aes(x = Degree, y = count, fill = Degree)) +
  geom_bar(stat = "identity") +
  xlab("Degree") +
  ylab("No of People") +
  ggtitle("Comparing Degree Holders in the US")

  # income is available in the workspace, ggplot2 is pre-loaded

# Create the boxplots
ggplot(income, aes(x = Degree, y = MedianIncome, fill = Degree)) +
  geom_boxplot() +
  ggtitle("Comparing Income of Degrees Holders")

# Section 2 - Analyzing Other Data

# pigeon is pre-loaded

# Load required packages
library(dplyr)
library(ggplot2)

# Finish the chain of dplyr functions
pigeon %>%
  group_by(Color) %>%
  summarize(count = n()) %>%
  filter(count > 10) %>%
  inner_join(pigeon) %>%
  group_by(Color) %>%
  summarise(AvgSpeed = mean(Speed))

# Plot Speed against Pos
ggplot(pigeon, aes(x = Pos, y = Speed)) +
  geom_point() +
  xlab("Rank") +
  ylab("Pigeon Speed") +
  ggtitle("The correlation between speed and rank")

# Chopstick preloaded
# Finish the ggplot() command
ggplot(chopstick, aes(x = pinching_eff, fill = chopstick_length)) +
  geom_density(alpha = 0.3) +
  xlab("Food Pinching Efficiency") +
  ylab("Relative Frequency")

# Silver preloaded

# Silver minted over time
ggplot(silver, aes(x = year, y = silver_minted)) +
  geom_area(alpha = 0.3)

# Add cum_silver_minted column to silver
silver$cum_silver_minted <- cumsum(silver$silver_minted)

# Cumulative silver minted over time
ggplot(silver, aes(x = year, y = cum_silver_minted)) +
  geom_area(alpha = 0.5)

# Weed dataframe preloaded
# Get the average price per state
avg_weed <- weed %>%
  group_by(state) %>%
  summarise(avg_price = mean(price))

# Update column names
colnames(avg_weed) <- c("region", "value")

# Create a choropleth map
state_choropleth(avg_weed, title = "Average Weed Price Per State", legend = "Price in $")


library(Boruta)
library(ggplot2)
library(lubridate)
library(randomForest)
library(readr)

set.seed(1)

train <- read_csv("str_num_train.csv")
train <- train[c(-17,-76,-100),]
test  <- read_csv("str_num_test.csv")

features <- c(names(train)[c(-1,-42)])

train$Revenue <- train$revenue / 1e6
train$LogRevenue <- log(train$revenue)

boruta <- Boruta(train[,features], train$LogRevenue,maxRuns = 1000)

important_features <- features[boruta$finalDecision!="Rejected"]
rf <- randomForest(train[,important_features], train$LogRevenue,ntree=1000,nPerm=1.1, importance=TRUE)

submission <- data.frame(Id=test$Id)
submission$Prediction <- exp(predict(rf, test[,important_features]))


#' ARIMA model choice automation
#'
#' This function allows to select by informational criteria and performance results one or a serie of different models allowing for best performance in and out of sample. The function is a wrapper for forecast and tseries packages.
#'
#' @param seriex A univariate time serie to be studied
#' @param order The maximum limit for p, d and q for ordinary ARIMA part
#' @param seasonallim The maximum limit for P, D and Q for SARIMA part
#' @param crossvalid The point for cross-validation
#' @param limit A maximum number of models to be selected by criteria (3 in sample and 3 out of sample criterias are used)
#' @param method The estimation method to be applied (as in the timeserie package)
#' @param adf.plim ADF selection probability limit
#' @param partlim Part of autocorrelated lags in lags
#'
#' @return A list of selected models estimated with SARIMA with additional performance information
#'
#' @keywords ARIMAanalyse
#' @export
#' @examples
#' ARIMAanalyse = function(seriex,
#'    orderlim = c(1, 1, 1), seasonallim = c(1, 1, 1),
#'    crossvalid = c(2015, 4), limit = 3,
#'    method = "ML", adf.plim = 0.1, partlim = 0.3)
#'
#' @import tidyverse
#' @import tseries
#' @import ggfortify
#' @import gridExtra
#' @import forecast
#' @import car
#' @import lmtest
#'
ARIMAanalyse = function(seriex, # Time serie
    orderlim = c(1, 1, 1), # Difference limit
    seasonallim = c(1, 1, 1), # Seasonal part limit
    crossvalid = c(2015, 4), # Validation division point
    limit = 3, # Number of models selected by criteria
    method = "ML", # Estimation method
    adf.plim = 0.1, # ADF selection probability limit
    partlim = 0.3 # Part of autocorrelated lags in lags
    ) {
    #######+###################
    # Tests+# Exploratory plots
    #######+###################
    # Lagorder
    lago = crossing(d = 0:orderlim[2], D = 0:seasonallim[2])
    # Frame creation
    tests = data.frame(matrix(NA,
        nrow = nrow(lago),
        ncol = 5))
    names(tests) = c("d", "D",
        "ADF", "KPSS.L", "KPSS.T")
    tests[,1] = lago[,1]
    tests[,2] = lago[,2]
    # Statistics frame creation
    statistics = data.frame(matrix(NA,
        nrow = nrow(lago),
        ncol = 6))
    names(statistics) = c("d", "D",
        "ADF", "KPSS.L", "KPSS.T",
        "DW")
    statistics[,1] = lago[,1]
    statistics[,2] = lago[,2]
    # Correlation
    acorrelation = list()
    pcorrelation = list()
    # Plots
    cfplots = list()
    # Loop
    for (i in 0:(nrow(lago)-1)) {
        if (statistics[i+1,1] != 0) {
            ser = diff(seriex,
                lag = attributes(seriex)$tsp[3],
                dif = tests[i+1,1])
        } else {ser = seriex}
        if (statistics[i+1,2] != 0) {
            ser = diff(ser,
                lag = 1,
                dif = tests[i+1,2])
        } else {ser = ser}
        # Tests P-VALUES dataframe
        tests[i+1, 3] = adf.test(ser)$p.value
        tests[i+1, 4] = kpss.test(ser,null = "Level")$p.value
        tests[i+1, 5] = kpss.test(ser,null = "Trend")$p.value
        statistics[i+1, 3] = adf.test(ser)$statistic
        # Tests STATISTICS dataframe
        statistics[i+1, 4] = kpss.test(ser,null = "Level")$statistic
        statistics[i+1, 5] = kpss.test(ser,null = "Trend")$statistic
        statistics[i+1, 6] = durbinWatsonTest(as.integer(ser))
        # Values
        s_level =
            qnorm((1 + 0.95)/2)/sqrt(sum(!is.na(ser)))
        acorrelation[[i+1]] =
            sum(abs(acf(ser, plot = F)$acf)/s_level > 1)/as.integer(10*log10(length(ser)))
        pcorrelation[[i+1]] =
            sum(abs(pacf(ser, plot = F)$acf)/s_level > 1)/as.integer(10*log10(length(ser)))
        # CFs
        cf = ggAcf(ser, plot = F)
        pcf = ggPacf(ser, plot = F)
        # Plots
        placf = autoplot(cf) +
            ggtitle(paste("Differences :", tests[i+1,1], tests[i+1,2], sep = " "))
        plpacf = autoplot(pcf) +
            ggtitle(paste("Differences :", tests[i+1,1], tests[i+1,2], sep = " "))
        cfplots[[i+1]] = grid.arrange(placf, plpacf, nrow = 1)
    }
    ##############################
    # Analyse and preselect models
    ##############################
    # Selection by correlation
    nn = intersect(which(acorrelation < partlim),
        which(pcorrelation < partlim))
    # Selection by test results
    an = tests[nn,] %>%
        filter(ADF < adf.plim &
            (KPSS.L >= 0.1 | KPSS.T >= 0.1)) %>%
        select(d, D)
    #######################
    # Combinations creation
    #######################
    dbin = as.integer(an$d)
    Dbin = as.integer(an$D)
    comb = crossing(p = c(0:orderlim[1]),
        d = dbin,
        q = c(0:orderlim[3]),
        P = c(0:seasonallim[1]),
        D = Dbin,
        Q = c(0:seasonallim[3]))
    if (nrow(comb) == 0) {
        results = list(tests = list(pval = tests,
                stat = statistics),
            plots = cfplots)
        return(results)
        stop("No satisfying difference orders detected")
        }
    comb = comb %>%
        mutate(n = 1:nrow(comb))
    ##############
    # Modelisation
    ##############
    # Auxilary list
    model = list()
    ## seriex = ts_data[,2]
    serie = window(seriex, end = crossvalid)
    # Cycle
    for (i in 1:nrow(comb)) {
        # Order selection
        yearly = as.numeric(comb[i, 1:3])
        season = as.numeric(comb[i, 4:6])
        # Model
        model[[i]] = Arima(serie,
            order = yearly,
            seasonal = season,
            method = method)
    }
    # Results extraction
    # Auxilary frame
    frame = data.frame(AIC = NA, BIC = NA,
        loglik = NA, pseudoR2 = NA, sigma2 = NA, n = NA)[-1,]
    # Model description
    for (i in 1:nrow(comb)) {
        frame[i,] = frame[i,] %>%
            mutate(AIC = model[[i]]$aic,
                BIC = model[[i]]$bic,
                loglik = model[[i]]$loglik,
                sigma2 = model[[i]]$sigma2,
                pseudoR2 = 0,
                n = i)
    }
    # Loglik normalisation
    lago = crossing(d = dbin, D = Dbin)
    # Loop
    for (i in 1:nrow(lago)) {
        sell = left_join(lago[i,], comb, by = c("d", "D")) %>%
            mutate(ko = i,
                kk = as.integer(p == 0 &
                    q == 0 &
                    P == 0 &
                    Q == 0)) %>%
            select(n, ko, kk)
        frame[sell$n[sell$kk == 0],] =
            frame[sell$n[sell$kk == 0],] %>%
            mutate(pseudoR2 =
                1 - loglik/frame$loglik[sell$n[sell$kk == 1]])
        frame[sell$n[sell$kk == 1],] =
            frame[sell$n[sell$kk == 1],] %>%
            mutate(pseudoR2 = 0)
    }
    # Reorganisation
    frameX = frame %>%
        dplyr::arrange(AIC) %>%
        mutate(ak = 1:nrow(frame)) %>%
        dplyr::arrange(BIC) %>%
        mutate(bk = 1:nrow(frame)) %>%
        dplyr::arrange(pseudoR2) %>%
        mutate(lk = nrow(frame):1) %>%
        dplyr::arrange(sigma2) %>%
        mutate(sk = 1:nrow(frame)) %>%
        mutate(CC4 = ak + bk + lk + sk,
            CC3 = ak + bk + lk,
            CC2 = ak + bk)
    ################
    # Optimums study
    ################
    # Criteria
    cca = frameX %>%
        dplyr::arrange(AIC) %>%
        head(limit) %>%
        select(n) %>%
        mutate(TYPE = "AIC")
    ccb = frameX %>%
        dplyr::arrange(BIC) %>%
        head(limit) %>%
        select(n) %>%
        mutate(TYPE = "BIC")
    # ccl = frameX %>%
    #     dplyr::arrange(lk) %>%
    #     head(limit) %>%
    #     select(n) %>%
    #     mutate(TYPE = "Log-Lik")
    ccs = frameX %>%
        dplyr::arrange(sigma2) %>%
        head(limit) %>%
        select(n) %>%
        mutate(TYPE = "Sigma2")
    ccx = rbind(cca, ccb) %>%
        rbind(ccs)
    # Presentation results
    cc = left_join(ccx, comb)
    ##########################
    # Testing models forecasts
    ##########################
    # Aux
    forec_list = list()
    res = data.frame(erm = NA, er2m = NA,
        sigma2 = NA, somme = NA, n = NA)[-1,]
    # Loop
    for (i in 1:length(model)) {
        # Forecasts
        forec = forecast(model[[i]],
            h = (length(seriex) - length(serie)),
            level = c(50, 90))
        # Forecasts organisation
        forec_list[[i]] = data.frame(pred = forec$mean,
                orig = seriex[(length(serie)+1):length(seriex)]) %>%
            mutate(er = pred - orig,
                er2 = er^2)
        # Results
        res[i, ] = data.frame(erm = sum(forec_list[[i]]$er),
            er2m = sum(forec_list[[i]]$er2),
            sigma2 = model[[i]]$sigma2,
            somme = sum(forec_list[[i]]$er2) + model[[i]]$sigma2,
            n = i)
    }
    ##############
    # New criteria
    ##############
    ## Square error
    rsq = res %>%
        dplyr::arrange(er2m) %>%
        head(limit)
    ## Mean error
    rm = res %>%
        dplyr::arrange(pmax(erm, -erm)) %>%
        head(limit)
    ## Overall square error
    rosq = res %>%
        dplyr::arrange(somme) %>%
        head(limit)
    # Combination
    rtot = rbind(rsq, rm) %>%
        rbind(rosq)
    # Merge
    rcc = left_join(rtot, comb)
    #######
    # Plots
    #######
    ################
    # Study criteria
    # Aux
    I = 1:length(unique(cc$n))
    x = 1
    # Ploting frame
    toplot1 = data.frame(matrix(NA,
        ncol = length(I)+1,
        nrow = length(window(seriex, start = crossvalid))))
    names(toplot1)[2:(length(I)+1)] =
        paste0("n", unique(as.integer(cc$n)))
    names(toplot1)[1] = "original"
    # toplot1[,x] = seriex
    toplot1[,x] = window(seriex, start = crossvalid)
    # Loop
    for (i in unique(as.integer(cc$n))) {
        x = x + 1
        # Forecasts
        forec = forecast(model[[i]],
            h = (length(seriex) - length(serie)),
            level = c(50, 90))
        # series = append(serie, forec$mean)
        # toplot1[, x] = series
        toplot1[, x] = append(serie[length(serie)], forec$mean)
    }
    # Ts conversion
    toplot1 = ts(toplot1,
        start = attributes(serie)$tsp[2],
        freq = attributes(serie)$tsp[3])
    ###############
    # Test criteria
    # Aux
    I = 1:length(unique(rcc$n))
    x = 1
    # Ploting frame
    toplot2 = data.frame(matrix(NA,
        ncol = length(I)+1,
        nrow = length(window(seriex, start = crossvalid))))
    names(toplot2)[2:(length(I)+1)] =
        paste0("n", unique(as.integer(rcc$n)))
    names(toplot2)[1] = "original"
    # toplot2[,x] = seriex
    toplot2[,x] = window(seriex, start = crossvalid)
    # Loop
    for (i in unique(as.integer(rcc$n))) {
        x = x + 1
        # Forecasts
        forec = forecast(model[[i]],
            h = (length(seriex) - length(serie)),
            level = c(50, 90))
        # series = append(serie, forec$mean)
        # toplot2[, x] = series
        toplot2[, x] = append(serie[length(serie)], forec$mean)
    }
    # Ts conversion
    toplot2 = ts(toplot2,
        start = attributes(serie)$tsp[2],
        freq = attributes(serie)$tsp[3])
    #########
    # Results
    #########
    crit = list(study = cc,
        test = rcc)
    plotx = list(study = toplot1,
        test = toplot2)
    tests = list(stat = statistics,
        pval = tests)
    results = list(crit = crit,
        predict = plotx,
        tests = tests,
        models = model,
        cfplots = cfplots)
    # Output
    return(results)
}


#Red neurona sin PCA
library(neuralnet)

indice<-sample(1:nrow(y),87)

set.seed(500)
library(MASS)
data <- Boston
apply(data,2,function(x) sum(is.na(x)))
index <- sample(1:nrow(data),round(0.75*nrow(data)))
train <- data[index,]
test <- data[-index,]
lm.fit <- glm(medv~., data=train)
summary(lm.fit)
pr.lm <- predict(lm.fit,test)
MSE.lm <- sum((pr.lm - test$medv)^2)/nrow(test)

######################################
# Creamos el objeto red neuronal feedforward
#############################
# PRUEBA CON variables cuantitativas
##############################
## Creamos dos conjuntos de datos artificiales: ''P'' es el conjunto
#de datos de entrada y ''target'' el de salida. con el 80% de los datos
######################
target<-clase
target
##
## inicialmente con Comp1 Comp2 con el 88% de la infomarcion de los datos
########################
P2<-data[indice,1:5]
P2

## Creamos el objeto red neuronal feedforward
############################################
net2 <- newff(n.neurons=c(5,3,2,2), learning.rate.global=1e-2, momentum.global=0.5,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
#############################
##Se entrena la red
#######################
result2 <- train(net2,P2 , target, error.criterium="LMS", report=TRUE, show.step=10000, n.shows=39 )
######################
# se grafica la red entrenada con los datos de entrenamiento
####
s <- sim(result1$net2, P2)
cbind(round(s),(apply(clase,1,sum)+1))
round(s)
###################
# Validacion con el 20% restante
##############
P_v <-data[-indice,1:5]
s <- sim(result2$net, P_v)
round(s)
dist_uno_uno <- dist(rbind(c(1,1),s))[1:39]
dist_cero_uno <- dist(rbind(c(0,1),s))[1:39]
dist_cero_cero <- dist(rbind(c(0,0),s))[1:39]

salT<-cbind(ytest,
round(s), #Se une el vector de salida redondeado
	dist_uno_uno,
	dist_cero_uno,
	dist_cero_cero,
	cbind(((dist_uno_uno)/rowSums(cbind(dist_uno_uno,dist_cero_uno,dist_cero_cero))),
		((dist_cero_uno)/rowSums(cbind(dist_uno_uno,dist_cero_uno,dist_cero_cero))),
		((dist_cero_cero)/rowSums(cbind(dist_uno_uno,dist_cero_uno,dist_cero_cero)))
	)
)
salT<-data.frame(salT)
colnames(salT)<-c("M_1","M_2","M_3","_M_4","P","X1","X2","D1_1_1","D2_0_1","D3_0_0","P_1_1","P_0_1","P_0_0")
print(salT,digits=5)

s
cbind(round(s), claseT)
tasa<-rep(FALSE,nrow(s))
tasa[round(s)[,1]== claseT[,1] & round(s)[,2]== claseT[,2]]<-TRUE
tasa <- sum(tasa==TRUE)*100/length(tasa)

tasa

ECM_2 <- error.LMS(c(s,claseT,net1))
ECM_2


#-------------------------------------------------------------------------------
#
# P-values correction for gene set analysis (SnpEff gsa)
#
#
#															Pablo Cingolani 2013
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# Main
#-------------------------------------------------------------------------------

show = FALSE	# Used for production
show = TRUE		# Used for debugging

pvalCoefThreshold = 10^-12	# Adjust only if linearmodel p-value is less than this

#---
# Parse command line arguments
#---
if( ! exists('fileName') ) {
    args <- commandArgs(trailingOnly = TRUE)
    fileName = args[1]
    outFileName = args[2]
    minScoreCount = args[3]
}

#---
# Read data
#---
d = read.table(fileName, sep="\t", header=TRUE)

# p-values or scores.
# Note: the conversion 'as.numeric(as.character())' is necesary
# because R reads '0.6049666666666666' as a number,
# but reads       '0.60496666666666666' as a string (yes, R is amazing!)
p = as.numeric(as.character(d$score))
c = d$scoreCount	# number of variants

# Filter out p-values of zero OR counts of zero (because of log)
#keep = (p > 0) & (c > 0)
keep = (p > 0) & (p < 1 ) & (c > 0) & (c > minScoreCount)

p = p[keep]
lp = qnorm(p)				# Convert to z-scores using an inverse normal distribution

c = c[keep]
lc = log10(c)

#---
# Linear model
#---
lmfit = lm( lp ~ lc )
sumLmfit =  summary(lmfit)
pvalCoef = sumLmfit$coefficients[2,4]

res = lmfit$residuals		# Residuals
padj = p						# Keep some un-adjusted values
padj[keep] = pnorm(res)			# Adjusted p-values

if( show ) {
	print(sumLmfit)
	cat('Slope:\t', sumLmfit$coefficients[2], '\tp-value:\t', pvalCoef, 'File:\t', fileName, '\n');

	par(mfrow=c(2,2))
	smoothScatter( lc, lp, main="Z-Scores", xlab="Number of scores", ylab="Z-Score" )
	lines(lowess(lc, lp ), col='orange')

	smoothScatter( lc, res, main="Adjusted Z-Scores", xlab="Number of scores", ylab="Z-Score" )
	lines(lowess(lc, res ), col='orange')

	plot( density(lp) , main="Z-Scores distribution", xlab="red:Adjusted black:Unadjusted")
	lines( density(res) , col='red')

	plot( density(lc) , main="log10(Number of scores)", xlab="")
}

#---
# Decide whether to use corrected scores or not.
# Not very significant? Use original scores
#---
if( pvalCoef > pvalCoefThreshold ) { padj = d$score	}

#---
# Create output file
#---
dout = data.frame( geneId = d$geneId, score = padj )
write.table( dout, file=outFileName, quote=FALSE, row.names = FALSE, col.names = FALSE, sep="\t")


#' Create an example adjacency matrix
#'
#' @return
#' @export

create_example_adjacency <- function() {
    A <-
    data.frame(A = c(rpois(2,lambda=10),rep(0,10)),
               B = c(rpois(3,lambda=15),rep(0,9)),
               C = c(rep(0,1),rpois(5,lambda=100),rep(0,6)),
               D = c(rep(0,2),rpois(4,lambda=50),rep(0,6)),
               E = c(rep(0,2),rpois(4,lambda=400),rep(0,6)),
               F = c(rep(0,2),rpois(4,lambda=100),rep(0,6)),
               G = c(rep(0,5),rpois(1,lambda=50), rpois(3,lambda=100),rep(0,1),rpois(2,lambda=500)),
               H = c(rep(0,6),rpois(5,lambda=100),0),
               I = c(rep(0,6),rpois(5,lambda=50),0),
               J = c(rep(0,7),rpois(4,lambda=200),0)
    ) %>%
    as.matrix()
    colnames(A) <- paste0("HOSP_",colnames(A))
    # force geo_8 to be a small monopoly from the perspective of the ZIP
    A[8,] = c(rep(0,9),25)
    rownames(A) <- paste0("GEO_",1:12)
    geo_hosp_A <- A
    return(geo_hosp_A)
}


#' Compute payment plan
#'
#' @param balance current balance or principal
#' @param income adjusted gross income
#' @param rate interest rate on loan
#' @param years number of years to calculate. Most debt forgiven after 25 years.
#' @param plan which payment plan to use
#' @param subsidized whether the government will help subsidze accrued interest
#' @param income_increase Expected increase in income per year.
#' @export
compute_payments <- function(balance, income, rate, years,
                             plan = c("repaye"),
                             subsidized = FALSE,
                             income_increase = 0.05,
                             family_size = 1
                             ) {
  # inputs
  plan <- match.arg(plan)
  interest <- 0
  repaye_rate <- 0.1

  df <- vector("list", years)

  # compute loan payments over time
  for (yr in seq_len(years)) {
    # calculate payment per month
    ppm <- compute_ppm(income, family_size, repaye_rate)

    # payment_per_year - interest_accrued
    net_payment <- compute_net_payment(balance, rate, ppm)

    # subsidized interest
    if (plan == "repaye") {
      govt_help <- ifelse(subsidized*(yr <= 3), 1, 0.5)
    } else {
      govt_help <- 0
    }
    subsidized_interest <- compute_subsidized_interest(net_payment, govt_help)

    # new balances. pay off the interest first!
    if (net_payment < 0) {
      # interest more than payment
      payment_to_interest <- -subsidized_interest
      payment_to_balance <- 0
    } else {
      # payment more than interest
      payment_to_interest <- min(interest, net_payment)
      payment_to_balance <- net_payment - payment_to_interest
    }

    new_balance <- balance - payment_to_balance
    new_interest <- interest - payment_to_interest

    # update list
    df[[yr]] <- tibble::tibble(
      year = yr,
      principal_before = balance,
      interest_per_month = balance*rate/12,
      payment_per_month = ppm,
      govt_help = govt_help,
      principal_after = new_balance,
      interest_accrued = new_interest
    )

    # update balance
    balance <- new_balance
    interest <- new_interest

    # income increase causes payment increase
    income <- income*(1 + income_increase)
  }

  # bind list
  dplyr::bind_rows(df) %>%
    dplyr::filter(!!rlang::sym("principal_before") >= 0) %>%
    dplyr::mutate(principal_after = pmax(0, !!rlang::sym("principal_after")))
}

#' Compute the net yearly payment
#'
#' Subracts student payment from accrued interest
#' @param balance current balance
#' @param rate interest rate
#' @param ppm payment per month
#'
#' @keywords internal
compute_net_payment <- function(balance, rate, ppm) {
  12*ppm - balance*rate
}

#' Compute the subsidized interest
#'
#' Interest may be subsidized depending on your repayment plan.
#'
#' @param net_payment net payment
#' @param govt_help percentage of subsidzation the government will provide
compute_subsidized_interest <- function(net_payment, govt_help) {
  if (net_payment >= 0) return(0)
  -net_payment*(1 - govt_help)
}

compute_poverty_line <- function(family_size) {
  n <- nrow(poverty)
  if (family_size <= n) {
    poverty[["poverty_line"]][family_size]
  } else {
    poverty[["poverty_line"]][n] + 4320*(family_size - n)
  }
}

#' Payments per month
#'
#' @param income adjusted gross income
#' @param family_size members in family including self, spouse, and dependents
#' @param repaye_rate REPAYE max payment rate is 10% of adjusted income
compute_ppm <- function(income, family_size, repaye_rate = 0.1) {
  poverty_line <- compute_poverty_line(family_size)
  ppm <- (income - 1.5*poverty_line)*repaye_rate/12
  max(ppm, 0)
}


linear.bounded <- function(x, a, b, minY = 0, maxY = 1) {
	y = a * x + b
	y[y>maxY] = maxY
	y[y<minY] = minY
	return(y)
}


## Classification Metrics ------------------------------------------------------

two_class_sample_data <- read.csv("../extdata/two-class-sample-data.csv")
sklearn_metrics_two_class <- read.csv("../extdata/sklearn-metrics-two-class.csv")

expect_equal(
    with(two_class_sample_data, mtr_accuracy(act, pred)),
    target = sklearn_metrics_two_class$accuracy_score
)

expect_equal(
    with(two_class_sample_data, mtr_auc_roc(act, pred)),
    target = sklearn_metrics_two_class$auc
)

## expect_equal(
##     with(two_class_sample_data, mtr_average_precision(act, pred)),
##     target = sklearn_metrics_two_class$average_precision_score
## )

expect_equal(
    with(two_class_sample_data, mtr_balanced_accuracy(act, pred)),
    target = sklearn_metrics_two_class$balanced_accuracy
)

expect_equal(
    with(two_class_sample_data, mtr_brier_score(act, pred)),
    target = sklearn_metrics_two_class$brier_score
)

expect_equal(
    with(two_class_sample_data, mtr_cohen_kappa(act, pred)),
    target = sklearn_metrics_two_class$cohen_kappa_score
)

expect_equal(
    with(two_class_sample_data, mtr_f1score(act, pred)),
    target = sklearn_metrics_two_class$f1_score
)

expect_equal(
    with(two_class_sample_data, mtr_mean_log_loss(act, pred)),
    target = sklearn_metrics_two_class$log_loss
)

expect_equal(
    with(two_class_sample_data, mtr_matthews_corr_coef(act, pred)),
    target = sklearn_metrics_two_class$matthews_corrcoef
)

expect_equal(
    with(two_class_sample_data, mtr_precision(act, pred)),
    target = sklearn_metrics_two_class$precision
)

expect_equal(
    with(two_class_sample_data, mtr_recall(act, pred)),
    target = sklearn_metrics_two_class$recall
)

## Regression Metrics ----------------------------------------------------------

regression_sample_data <- read.csv("../extdata/regression-sample-data.csv")
sklearn_metrics_regression <- read.csv("../extdata/sklearn-metrics-regression.csv")

expect_equal(
    with(regression_sample_data, mtr_explained_variance(act, pred)),
    target = sklearn_metrics_regression$explained_variation
)

expect_equal(
    with(regression_sample_data, mtr_max_error(act, pred)),
    target = sklearn_metrics_regression$max_error
)

expect_equal(
    with(regression_sample_data, mtr_mean_absolute_error(act, pred)),
    target = sklearn_metrics_regression$mean_absolute_error
)

expect_equal(
    with(regression_sample_data, mtr_mean_squared_error(act, pred)),
    target = sklearn_metrics_regression$mean_squared_error
)

expect_equal(
    with(regression_sample_data, mtr_mean_squared_log_error(act, pred)),
    target = sklearn_metrics_regression$mean_squared_log_error
)

expect_equal(
    with(regression_sample_data, mtr_mean_absolute_error(act, pred)),
    target = sklearn_metrics_regression$mean_absolute_error
)

expect_equal(
    with(regression_sample_data, mtr_r2(act, pred)),
    target = sklearn_metrics_regression$r2
)


metrop.rwalker.proposal.fun <- function(theta){
  # finding the right scaling factor is more of an art than science
  # or try and error to look for the best fit on acceptance %, ideally .234
  # good starting point 2.38/sqrt(N.dimensions)
  # looking to replace rnorm with multivariate version mvrnorm ?

  n.theta  <- length(theta)
  scale.sd <- round(2.38/sqrt(n.theta), 2)
  return(rnorm(n=n.theta, mean=theta, sd=rep(scale.sd, n.theta)))
}

hamiltonian.proposal.fun <- function(theta){
  #forget it.. it is a good theory
  # H(q, p) = U(q) + K(p) .. the potential and kinetic energy
  # simulate data by the way of the physical system moves than a random walk
  # faster convergence
  # more parameters to worry: epsilon, M, t, L
  # not to mention the change of proposal..
  #   U(q) = -log[pi(q) * L(q|D)]
  # hmc proposal and actual simulation is tight up
  #  condition:
  #     runif(1) < exp(-U(q*)+U(q)-K(p*)+K(p))
  # no to mention the painful gradient (log likelihood function)
  # there are research work being done on the gradient free hamiltonian
  # don't quote on me, it is still an exciting new area
  #
  # good read, I'll leave the work for others :)
  # indeed, please refer to hmc.r
  #
  # for now, it does exactly the random walk if hmc = TRUE

  return(theta+rnorm(length(theta), sd=2.38))
}

# Metroplis Hasting Monte Carlo Simulation
# currently not support thinning nor multiple chains
# fun .......... the logged posterior sampling function
# theta.init ... initial parameter(s) value
# nmc .......... number of iterations for the chain
# nbi .......... number of burn-ins
# hmc .......... reserved for future Hamiltonian or RWHMC implementation
mcmc <- function(fun, theta.init, nmc, nbi, hmc = FALSE, ...) {

  iterations <- nmc + nbi
  chain <- array(dim = c(iterations, length(theta.init)))
  chain[1, ] <- theta.init

  # choose the proposal function
  if(hmc){
    propose <- hamiltonian.proposal.fun          #hamiltonian
  }else{
    propose <- metrop.rwalker.proposal.fun       #metroplis
  }

  for(i in 1:(iterations-1)) {
    proposal <- propose(chain[i, ])
    p <- exp(fun(proposal, ...) - fun(chain[i, ], ...))

    if(runif(1) < p) {
      chain[i+1, ] <- proposal       #accept
    }else{
      chain[i+1, ] <- chain[i, ]     #reject
    }
  }

  return(chain[-(1:nbi), ])
}


=begin
[((<index|URL:index.html>))]
= Algebra::ElementaryDivisor
((*(Elementary Divisor Module)*))

Module to get the elementary divisors of the matrix of polynomial.
This is included by the class ((|Algebra::MatrixAlgebra|)).

== File Name:

* ((|elementary-divisor.rb|))

== Included Modules:

none.

== Associated Functions:

--- Algebra::MatrixAlgebra#i2o
    Converts the matrix of polynomials into the polynomial of matrices.

--- Algebra::MatrixAlgebra#e_deg
    Returns the max degree of the matrix of polynomials.

== Class Methods:

--- ::factorize(ary)

    Returns the array of the factors (instances of ((|Algebra::Factors|))),
    factorizing the each entries of the array ((|ary|))
    of the elementary divisors of a matrix.

== Methods:

--- e_diagonalize!
    Deforms to the diagonal matrix of the elementary divisors.
    If can't, raise an error.

--- e_diagonalize
    Same as (({dup.e_diagonalize!})).

--- elementary_divisor
    Returns the array of the elementary divisors.

--- e_inverse
    Returns the inverse matrix of the matrix over Euclidian ring.
    If can't, raise an error.

=end


# Using changepoint to compute binary segmentation models up to 5 segments
# Plot segement means on top of data

if(!require(changepoint)) {
    install.packages("changepoint")
}

if(!require(neuroblastoma)) {
    install.packages("neuroblastoma")
}

# import and load neuroblastoma dataset
library('neuroblastoma')
data('neuroblastoma')

# using np as neuro.profiles for profile data
np = neuroblastoma$profiles
xy = np[np$profile.id == 4 & np$chromosome == 2, ]
x = xy$position
y = xy$logratio

# calculate changepoints
model <- changepoint::cpt.meanvar(y,penalty="Manual",pen.value='2*log(n)',method='BinSeg', Q=10)
cm = coef(model)
change.points = cpts(model)
segment.mean = cm[1]

# detected changepoints
print(change.points)

# segment means
print(segment.mean)

# plot changepoint and segment mean over data
svg('Medium/task2.svg')
plot(model, xlab="Segments", ylab="logpoint ratios of the probe", main="Neuroblastoma changepoint detection using 'changepoint'")
grid()
legend(x=5, y=-0.5,legend=c("position vs logpoint data", "segment mean", "changepoint"), col=c("black","red","blue"), lty=c(1,1,NA), pch=c(NA,NA,'X'), cex=0.8, bg='lightblue')

# add changepoints
points(change.points, as.numeric(segment.mean[[1]])[1:5], col='blue', pch='X')

dev.off()


DySyn <- function(ts, measure){

  MF <- seq(0.1,0.9,0.2)
  result <- NULL
  rD <- NULL

  for(ti in 1:length(MF)){
    scores <- MoSS(1000, 0.5, MF[ti])
    test.p <- scores[scores[,3]==1,1]
    test.n <- scores[scores[,3]==2,1]

    ifelse(measure=="sord", rQnt <- DySyn_SORD(test.p, test.n, ts), rQnt <- DySyn_DyS(test.p, test.n, ts, measure))

    rD <- c(rD, rQnt[[2]])
    result <- c(result, rQnt[[1]][1])

  }
  result <- round(result[which.min(rD)],2)
  result <- c(result, 1-result)
  return(list(result, min(rD)))
}

DySyn_DyS <- function(p.score, n.score, test, measure="hellinger"){

  alpha <- seq(0,1,by=0.01)

  b_sizes <- c(seq(2,20,2),30)

  result <- NULL

  for(hi in 1:length(b_sizes)){

    Sty_1 <- getHist(p.score, b_sizes[hi])
    Sty_2 <- getHist(n.score, b_sizes[hi])
    Uy    <- getHist(test, b_sizes[hi])

    vDist <- NULL
    vDistAll <- NULL

    f <- function(x){
      return(DySyn_distance(rbind((Sty_1*x)+ (Sty_2*(1-x)), Uy), method = measure))
    }

    result <- c(result, TernarySearch(0, 1, f, 1e-2))
    vDistAll <- c(vDistAll, f(result))
  }

  result <- median(result)
  result <- c(result, 1 - result)
  names(result) <- c("1", "2")
  return(list(round(result,2),vDistAll[order(vDistAll)[1]]))

}

PNTDiff <- function(pos, neg, test, pos_prop){
  p_w <- pos_prop / length(pos)
  n_w <- (1 - pos_prop) / length(neg)
  t_w <- -1 / length(test) # repare no -1 (menos um) !!

  # Cria listas com (valor da observacao), peso [fixo pra cada lista])
  #p <- list(map(lambda x: (x, p_w), pos))
  p <- cbind(pos, rep(p_w, length(pos)))
  #n <- list(map(lambda x: (x, n_w), neg))
  n <- cbind(neg, rep(n_w, length(neg)))
  #t <- list(map(lambda x: (x, t_w), test))
  t <- cbind(test, rep(t_w, length(test)))

  # Concatena numa lista soh e ordena pelos valores de obervacao
  #v <- sorted(p + n + t, key = lambda x: x[0])
  v <- rbind(p, n, t)
  v <- v[order(v[,1]),]

  #acc <- v[0][1] # inicializa acc com o peso do primeiro elemento
  acc <- v[1,2]
  total_cost <- 0

  # comeca a iterar no SEGUNDO elemento (python eh 0-indexado)
  for( i in 2:nrow(v)){
    cost_mul <- v[i,1] - v[i - 1, 1] # custo da movimentacao
    total_cost <- total_cost + abs(cost_mul * acc) #movimenta o que esta acumulado
    acc <- acc + v[i,2]
  }

  return(total_cost)
}

DySyn_SORD <- function(p.score, n.score, test){

  alpha <- seq(0,1,by=0.01)
  vDist <- NULL
  vDistAll <- NULL
  f <- function(x){
    return(PNTDiff(p.score, n.score, test, x))
  }

  result <- TernarySearch(0, 1, f, 1e-5)
  vDist  <- f(result)

  result <- c(result, 1 - result)
  names(result) <- c("1", "2")
  return(list(round(result,2), vDist))

}


# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

### fixed seed to allow repeatable results
set.seed(63)

### Original driver data. This will force our final results to be constrained
### to a 3-dimensional manifold
dim = 4
hidden = 10
embed = 15
raw.train = matrix(rnorm(dim*10000), ncol=dim, nrow=10000)
raw.test = matrix(rnorm(dim*10000), ncol=dim)

### Transformation to final data. This is a simple neural network kind of thing.
w1 = matrix(rnorm(dim*hidden), nrow=dim)
w2 = matrix(rnorm(hidden*embed), nrow=hidden)

sig = function(x) {1/(1+exp(-x)) - 0.5}
xform = function(input, w1, w2) {
    sig(input %*% w1) %*% w2
}

### The final data is 8 dimensional, but only looks complicated
train.data = xform(raw.train, w1, w2)
test.data = xform(raw.test, w1, w2)

### The encoder simply finds the nearest centroids
closest = function(v, k) {
    ## This is same as (centers - v)^2 but works with matrix centers and vector v
    ## numerical stability is probably poor
    distances = rowSums(k$centers^2) + sum(v^2) - 2 * k$centers %*% v
    close = min(distances)
    which(distances == close)
}

encode = function(data, k) {
    apply(data, 1, function(v){closest(v, k)})
}

decode = function(kx, k) {
    as.matrix(k$centers[kx,])
}

reconstruction.error = function(data, k) {
    mean(sqrt(rowSums((data - decode(encode(data, k), k))^2)))
}

k.10 = kmeans(train.data, centers=10, nstart=10, iter.max=50)
x.10 = reconstruction.error(train.data, k.10)
y.10 = reconstruction.error(test.data, k.10)
print(10)

k.20 = kmeans(train.data, centers=20, nstart=10, iter.max=50)
x.20 = reconstruction.error(train.data, k.20)
y.20 = reconstruction.error(test.data, k.20)
print(20)

k.50 = kmeans(train.data, centers=50, nstart=10, iter.max=50)
x.50 = reconstruction.error(train.data, k.50)
y.50 = reconstruction.error(test.data, k.50)
print(50)

k.100 = kmeans(train.data, centers=100, nstart=10, iter.max=50)
x.100 = reconstruction.error(train.data, k.100)
y.100 = reconstruction.error(test.data, k.100)
print(100)

k.200 = kmeans(train.data, centers=200, nstart=10, iter.max=50)
x.200 = reconstruction.error(train.data, k.200)
y.200 = reconstruction.error(test.data, k.200)
print(200)

k.500 = kmeans(train.data, centers=500, nstart=10, iter.max=50)
x.500 = reconstruction.error(train.data, k.500)
y.500 = reconstruction.error(test.data, k.500)
print(500)

k.1000 = kmeans(train.data, centers=1000, nstart=5, iter.max=50)
x.1000 = reconstruction.error(train.data, k.1000)
y.1000 = reconstruction.error(test.data, k.1000)
print(1000)

k.2000 = kmeans(train.data, centers=2000, nstart=3, iter.max=50)
x.2000 = reconstruction.error(train.data, k.2000)
y.2000 = reconstruction.error(test.data, k.2000)
print(2000)

points.fig = function() {
    plot(c(10,20,50,100,200,500,1000, 2000),
     c(x.10, x.20, x.50, x.100, x.200, x.500, x.1000, x.2000),
     ylab="Error", xlab="Centroids", type='b',
     ylim=c(0,2), lwd=2,
     main="Reconstruction error for random points"
     )

    lines(c(10,20,50,100,200,500,1000,2000),
          c(y.10, y.20,  y.50,  y.100,  y.200,  y.500,  y.1000,  y.2000),
          col='red', lwd=2, type='b')

    legend(1000, 1.9, legend=c("Training data", "Held-out data"), col=c("black", "red"), pch=21, lwd=2)
}

cube.root.fig = function() {
    x = data.frame(
        k=c(10, 20,  50,  100,  200,  500,  1000,  2000),
        test=c(y.10, y.20,  y.50,  y.100,  y.200,  y.500,  y.1000,  y.2000),
        train=c(x.10, x.20,  x.50,  x.100,  x.200,  x.500,  x.1000,  x.2000))
    x$rootK = x$k^(1/3)
    x$inv.train = 1/x$train
    x$inv.test = 1/x$test
    m.train = lm(inv.train ~ rootK, x)
    m.test = lm(inv.test ~ rootK, x)

    plot(train~k,x,type='b', xlab="k", ylab="Error", main="Error is approximately cube root of k",
         lwd=2, ylim=c(0,2))
    lines(test~k,x,type='b', col='darkgray', lwd=2)
    lines(x$k,1/predict(m.train, newdata=data.frame(rootK=exp(log(x$k)*0.33333))),
          lwd=2, lty=4, col='red')
    lines(x$k,1/predict(m.test, newdata=data.frame(rootK=exp(log(x$k)*0.33333))),
          lwd=2, lty=4, col='red')
    legend(1000, 1.8, legend=c("Training data", "Test data", "Cube root model"), col=c("black", "darkgray", "red"), pch=21, lwd=2)
}

pdf(file="points.pdf", width=5, height=5)
points.fig()
dev.off()

png(file="images/points.png", width=400, height=400, pointsize=12)
points.fig()
dev.off()

pdf(file="cube-root.pdf", width=5, height=5)
cube.root.fig()
dev.off()

png(file="images/cube-root.png", width=400, height=400, pointsize=12)
cube.root.fig()
dev.off()


args <- commandArgs(TRUE)

#library("RColorBrewer")

Matrix_f = args[1]

mat = read.table(file = Matrix_f, header=T)
dat_matrix = data.matrix(mat[,seq(2,ncol(mat))])
dat_matrix = cor(dat_matrix, method=c("pearson"))
print(dat_matrix)
#dat_matrix = abs(dat_matrix)
#dat_matrix = cor(dat_matrix)

library("gplots")
pdf(file = paste(Matrix_f,".pdf",sep=""))

# plan 1
#heatmap.2(dat_matrix,trace="none", dendrogram="both", col=rev(redblue(100)), margins = c(8, 8), keysize = 1, symkey=FALSE, density.info="none", Rowv=T,Colv=T, cellnote=round(dat_matrix,2), notecol="black", notecex=0.5)
#heatmap.2(dat_matrix,trace="none", dendrogram="both", col=rev(redblue(100)), margins = c(8, 8), keysize = 1, symkey=FALSE, density.info="none", Rowv=T,Colv=T, cellnote=round(dat_matrix,1), notecex=0.2, notecol="black", cexRow = 0.2, cexCol=0.2)

heatmap.2(dat_matrix,trace="none", dendrogram="both", col=rev(redblue(100)), margins = c(8, 8), keysize = 1, symkey=FALSE, density.info="none", Rowv=T,Colv=T, cexRow = 1, cexCol=1, notecol="black")

write.table(dat_matrix,file=paste(Matrix_f,".tab",sep=""), quote=FALSE, sep = "\t", row.names = TRUE, col.names = FALSE)
# plan 2
#my_palette <- colorRampPalette(c("blue","white","red"))(n=599)
#col_breaks = c(seq(0,0.33,length=200),seq(0.331,0.66, length=200),seq(0.661,1,length=200))
#heatmap.2(dat_matrix,trace="none", dendrogram="none", col=my_palette, breaks=col_breaks, margins = c(8, 8), keysize = 1, symkey=FALSE, density.info="none", Rowv=F,Colv=F)

# plan X
# cellnote = dat_matrix,
#heatmap.2(dat_matrix,trace="none",hclustfun = hclust,dendrogram="none", col=my_palette, breaks=col_breaks, margins = c(8, 8), keysize = 1.5, symkey=FALSE, density.info="none", Rowv=F,Colv=F)

dev.off()

#col=brewer.pal(11,"RdBu"),


x = read.table("/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/tfinal/prp.2020-10-07-1504.data.96158bda-377c-437c-bd0f-0d7f2a583c9c.txt")

RT1 = x[,8]
RT2 = x[,9]
correct = x[,10]==1 & x[,11]==1
soa = x[,7]
RT2 = RT2 + RT1 - soa
soas = sort(unique(soa))
realdata = x[,1]==2

rt1 = numeric(4)
rt2 = numeric(4)

rt1[1]=mean( RT1[ correct & realdata & soa==soas[1] ] )
rt1[2]=mean( RT1[ correct & realdata & soa==soas[2] ] )
rt1[3]=mean( RT1[ correct & realdata & soa==soas[3] ] )
rt1[4]=mean( RT1[ correct & realdata & soa==soas[4] ] )

rt2[1]=mean( RT2[ correct & realdata & soa==soas[1] ] )
rt2[2]=mean( RT2[ correct & realdata & soa==soas[2] ] )
rt2[3]=mean( RT2[ correct & realdata & soa==soas[3] ] )
rt2[4]=mean( RT2[ correct & realdata & soa==soas[4] ] )

r=c(min(c(rt1,rt2)),max(c(rt1,rt2)))
plot( soas, rt1 , col="red" ,ylim=r,type="b",las=1)
lines( soas, rt2 , ylim=r,col="blue",type="b")
legend("topright",c("RT1","RT2"),fill=c("red","blue"))


##Ядерные функции. По умолчанию используется первая.
nuclearFunction<-function(z, x = 1, r = 2, s = 3) {
  if (x == 1) {
    p<-(1-(z^r))^s
  }
  else if (x == 2) {
    p<-exp(-s*(z^r))
  }
  else if (x == 3) {
    p<-1/(s*(z^r)+1)
  }
  else if (x == 4) {
    p<-1/(z^s)
   }
  else
    p <- 0
  return(p)
}

f<- function(x, y)
{
  z<-function(x)
    return(-(1/((x-1)^2 + 0.2))-(1/(2*(x-2)^2 + 0.15)) -(1/(3*(x-3)^2 + 0.3)))
  return(z(x)+z(y))
}

Ruban <- function(x, deltaX, f, lower, upper, n = 500, e = 0.001, M = 1000, y = 1, q = 2, numberOfNuclearFunc = 1, r = 2, s = 100) {
  if (length(x)!= length(deltaX) || length(x)!= length(lower)  || length(x)!= length(upper))
    stop("Ошибка, не соблюдение размерности у входящих параметров (x, deltaX, upper, lower)!")
  if (n<0)
    stop("Ошибка, количество пробных точек должно быть больше 0!")
  if (e<0)
    stop("Ошибка, константа точности не должна быть меньше 0!")
  if (M<0)
    stop("Ошибка, максимальное количество итераций не должно быть меньше 0!")
  if (y<0)
    stop("Ошибка, (y) не должен быть меньше 0!")
  k<-1 ##Будем использовать для проверки первого критерия останова - превышения числа итераций
  testX<-matrix(0, n, length(x)) ## В матрицу будут записываться пробные точки.
  ## Где n - количество пробных точек,
  ## length(x) - количество координатых направлений
  functionValues<-rep(0, n) ## А эта матрица содержит значения функции в пробных точках
  uValues<-matrix(0, n, length(x)) ##В этой матрице будут храниться значения u для генерации пробных точек
  p<-rep(0, n) ##Ядра
  pNorm<-rep(0, n) ##нормированные ядра
  allX<-matrix(0, M, length(x)) ##Сюда записываем все X
  allX[1,]<-x
  allResults<-f(x[1],x[2]) ##Сюда записываем все результаты. Если число циклов превысит M, то мы выберем из всех результатов наименьший
  while(k<M) {
    pastIterationX<-x ##Запоминаем текущую точку, мы будем использовать ее для условия выхода
    plot(pastIterationX[1], pastIterationX[2], xlim=c(lower[1],upper[1]), ylim=c(lower[2],upper[2]), col="red")
    ##Шаг первый - инициализация пробных точек и расчет значений функции в них:
    for (i in 1:n) {
      for (j in 1:length(x))
        uValues[i,j]<-runif(1, 0, 1)*2 - 1 ##Генерируем u от -1 до 1
      testX[i,]<- x + deltaX * uValues[i,]  ##Генерируем пробную точку
      functionValues[i] <- f(testX[i,1],testX[i,2]) ##Находит значение функции в этой точке(f - какая-то функция)
      points(testX[i,1],testX[i,2], col="blue")
    }
    gmin<-rep(0, n)
    ##Шаг второй - рассчитываем ядра и нормированные ядра:
    for (i in 1:n)
      gmin[i]<-(functionValues[i] - min(functionValues)) / (max(functionValues) - min(functionValues))
    for(i in 1:n) ##Вычисляем ядра
      p[i]<-nuclearFunction(x = numberOfNuclearFunc, z = gmin[i], r=r, s=s)
    for (i in 1:n) ##Вычисляем нормированные ядра
      pNorm[i]<-p[i]/sum(p)
    ##Шаг третий - вычисляем новый центр прямоугольника и его длину:
    for (i in 1:length(x))
      x[i]<-x[i] + deltaX[i] * sum(sapply(1:n, function(x){uValues[x,i]*pNorm[x]}))
    print("---------------")
    cat("Результат ", k, "итерации: x=", x,"\n")
    if (x[1]<lower[1])
      x[1]<-lower[1]
    if (x[2]<lower[2])
      x[2]<-lower[2]
    if (x[1]>upper[1])
      x[1]<-upper[1]
    if (x[2]>upper[2])
      x[2]<-upper[2]
    for (i in 1:length(x))
      deltaX[i]<-y*deltaX[i] * ((sum(sapply(1:n, function(x){(abs(uValues[x,i])^(q)) * pNorm[x]})))^(1/q))
    cat("deltaX=", deltaX, "\n")
    k<-k+1 ##Увеличиваем счетчик итераций
    allX[k,]<-x
    allResults<-c(allResults,f(x[1],x[2]))
    flag <- (max(deltaX) <= e)
    if (flag == TRUE)
      break
    #if (sqrt(sum(deltaX^2)) < e)
    #  break
  }
  cat("Сделано шагов: ", k, "\n")
  return(allX[which.min(allResults),])
}


library(quantmod)

rm(list=ls())

par(mfrow=c(2,3))

# 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))
}

assess_n_plot_strategy <- function(pl) {
    # Assess.
    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.
    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' )
}

# Strategy 1 - buy first.
strategy_1 <- function(is_singular) {
    HI_MAX_D <- BU_HI_MAX_D
    LO_MIN_D <- BU_LO_MIN_D
    M_START <- max(HI_MAX_D, LO_MIN_D) + 1

    hi_max <- lag( runMax( Hi(stock), HI_MAX_D) )
    lo_min <- lag( runMin( Lo(stock), LO_MIN_D) )
    pl <- setNames( rep( 0, length(clp) ), time(stock) )

    if (is_singular) {
        is_bought <- FALSE
        for (m in M_START:yesterday) {
            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
            }
        }
    }
    else {
        bought <- 0
        bought_n <- 0
        for (m in M_START:yesterday) {
            if (clp[m] < lo_min[m]) {
                bought <- bought + long( as.numeric( opp[m+1] ) )
                bought_n <- bought_n + 1
            }
            else if (clp[m] > hi_max[m]) {
                pl[m] <- short( as.numeric( opp[m+1] ) * bought_n ) - bought
                bought <- 0
                bought_n <- 0
            }
        }
    }

    assess_n_plot_strategy(pl)
}

# Strategy 2 - borrow to sell first.
strategy_2 <- function(is_singular) {
    HI_MAX_D <- SE_HI_MAX_D
    LO_MIN_D <- SE_LO_MIN_D
    M_START <- max(HI_MAX_D, LO_MIN_D) + 1

    hi_max <- lag( runMax( Hi(stock), HI_MAX_D) )
    lo_min <- lag( runMin( Lo(stock), LO_MIN_D) )
    pl <- setNames( rep( 0, length(clp) ), time(stock) )

    if (is_singular) {
        is_sold <- FALSE
        for (m in M_START:yesterday) {
            if (!is_sold && clp[m] > hi_max[m]) {
                sold <- short( as.numeric( opp[m+1] ) )
                is_sold <- TRUE
            }
            else if (is_sold && clp[m] < lo_min[m]) {
                pl[m] <- sold - long( as.numeric( opp[m+1] ) )
                is_sold <- FALSE
            }
        }
    }
    else {
        sold <- 0
        sold_n <- 0
        for (m in M_START:yesterday) {
            if (clp[m] > hi_max[m]) {
                sold <- sold + short( as.numeric( opp[m+1] ) )
                sold_n <- sold_n + 1
            }
            else if (clp[m] < lo_min[m]) {
                pl[m] <- sold - long( as.numeric( opp[m+1] ) * sold_n )
                sold <- 0
                sold_n <- 0
            }
        }
    }

    assess_n_plot_strategy(pl)
}

# Strategy 1 & 2 running simultaneously.
strategy_3 <- function(is_singular) {
    bu_hi_max <- lag( runMax( Hi(stock), BU_HI_MAX_D) )
    bu_lo_min <- lag( runMin( Lo(stock), BU_LO_MIN_D) )

    se_hi_max <- lag( runMax( Hi(stock), SE_HI_MAX_D) )
    se_lo_min <- lag( runMin( Lo(stock), SE_LO_MIN_D) )

    pl <- setNames( rep( 0, length(clp) ), time(stock) )

    if (is_singular) {
        is_bought <- FALSE
        is_sold <- FALSE
        for (m in 1:yesterday) {
            if (m > max(BU_HI_MAX_D, BU_LO_MIN_D)) {
                if (!is_bought && clp[m] < bu_lo_min[m]) {
                    bought <- long( as.numeric( opp[m+1] ) )
                    is_bought <- TRUE
                }
                else if (is_bought && clp[m] > bu_hi_max[m]) {
                    pl[m] <- pl[m] + short( as.numeric( opp[m+1] ) ) - bought
                    is_bought <- FALSE
                }
            }

            if (m > max(SE_HI_MAX_D, SE_LO_MIN_D)) {
                if (!is_sold && clp[m] > se_hi_max[m]) {
                    sold <- short( as.numeric( opp[m+1] ) )
                    is_sold <- TRUE
                }
                else if (is_sold && clp[m] < se_lo_min[m]) {
                    pl[m] <- pl[m] + sold - long( as.numeric( opp[m+1] ) )
                    is_sold <- FALSE
                }
            }
        }
    }
    else {
        bought <- 0
        bought_n <- 0
        sold <- 0
        sold_n <- 0
        for (m in 1:yesterday) {
            if (m > max(BU_HI_MAX_D, BU_LO_MIN_D)) {
                if (clp[m] < bu_lo_min[m]) {
                    bought <- bought + long( as.numeric( opp[m+1] ) )
                    bought_n <- bought_n + 1
                }
                else if (clp[m] > bu_hi_max[m]) {
                    pl[m] <- pl[m] + short( as.numeric( opp[m+1] ) * bought_n ) - bought
                    bought <- 0
                    bought_n <- 0
                }
            }

            if (m > max(SE_HI_MAX_D, SE_LO_MIN_D)) {
                if (clp[m] > se_hi_max[m]) {
                    sold <- sold + short( as.numeric( opp[m+1] ) )
                    sold_n <- sold_n + 1
                }
                else if (clp[m] < se_lo_min[m]) {
                    pl[m] <- pl[m] + sold - long( as.numeric( opp[m+1] ) * sold_n )
                    sold <- 0
                    sold_n <- 0
                }
            }
        }
    }

    assess_n_plot_strategy(pl)
}

stock <- na.omit(get(getSymbols('2330.TW')))
opp <- Op(stock) # [op]en [p]rices
clp <- Cl(stock) # [cl]ose [p]rices
yesterday <- nrow(stock) - 1

# Strategies' variables.
BU_HI_MAX_D <- 5 # [BU]y first [HI]gh [MAX] [D]uration
BU_LO_MIN_D <- 3 # [BU]y first [LO]w [MIN] [D]uration

SE_HI_MAX_D <- 6 # borrow to [SE]ll first [HI]gh [MAX] [D]uration
SE_LO_MIN_D <- 1 # borrow to [SE]ll first [LO]w [MIN] [D]uration

# Execute strategies
strategy_1(TRUE)
strategy_2(TRUE)
strategy_3(TRUE)

strategy_1(FALSE)
strategy_2(FALSE)
strategy_3(FALSE)


# 4. faza: Analiza podatkov
source('lib/libraries.r', encoding = 'UTF-8')

#Napoved prirastka za države z največjim in najnižjim BDP

najrazvitejse <- neto_tabela %>% filter(Država %in% najvecji.bdp$Država)
najmanj_razvite <- neto_tabela %>% filter(Država %in% najnizji.bdp$Država)
najmanj_razvite[is.na(najmanj_razvite)] <- 0

najrazvitejse <- najrazvitejse %>% group_by(Leto) %>% summarise(Neto = sum(Neto))
najmanj_razvite <- najmanj_razvite %>% group_by(Leto) %>% summarise(Neto = sum(Neto))

fit <- lm(data=najrazvitejse, Neto ~ Leto +I(Leto^2))
leta <- data.frame(Leto=seq(2011, 2021))
predict(fit, leta)
napoved.prirastka1 <- mutate(leta, Neto=predict(fit, leta))

podatki <- lm(data=najmanj_razvite, Neto ~ Leto)
cas <- data.frame(Leto=seq(2011, 2021))
predict(podatki, cas)
napoved.prirastka2 <- mutate(cas, Neto=predict(podatki, cas))

graf.napovedi.prirastka1 <- ggplot(data=najrazvitejse, aes(x=Leto, y=Neto/1000)) +
  geom_smooth(method = "lm", formula = y ~ x + I(x^2), fullrange = TRUE) +
  geom_point(data=napoved.prirastka1 %>% filter(Leto>2016)) +
  labs(title = 'Napoved prirastka za države z največjim BDP') +
  geom_point(color = 'red') +
  ylab('Neto prirastek v tisočih')

graf.napovedi.prirastka2 <- ggplot(data=najmanj_razvite, aes(x=Leto, y=Neto/1000)) +
  geom_smooth(method = "lm", formula = y ~ x , fullrange = TRUE) +
  geom_point(data=napoved.prirastka2 %>% filter(Leto>2016)) +
  labs(title = 'Napoved prirastka za države z najmanjšim BDP') +
  geom_point(color='red') +
  ylab('Neto prirastek v tisočih')


#!/usr/bin/env Rscript

source("/tmp/class-libs.R")

class_name = "2019 Fall Stat 131a"
class_libs = c(
  "alluvial", "0.1-2",
  "latticeExtra", "0.6-28",
  "DAAG", "1.22",
  "faraway", "1.0.7",
  "fdrtool", "1.2.15",
  "gpairs", "1.2",
  "gplots", "3.0.1.1",
  "hexbin", "1.27.3",
  "leaps", "2.9",
  "NMF", "0.21.0",
  "randomForest", "4.6-12",
  "RColorBrewer", "1.1-2",
  "rjson", "0.2.20",
  "rpart.plot", "3.0.7",
  "scatterplot3d", "0.3-41",
  "shape", "1.4.4",
  "sm", "2.2-5.6"
  # "vioplot", "0.3.0"
)
class_libs_install_version(class_name, class_libs)

# 0.3.0 via mran 2019-07-05
install.packages('vioplot')


sum=0;
sq=0;
res = 0;
n = 10;

sum = n*(n+1)/2;
sq=(n*(n+1)*(2*n+1))/6;
res=sum*sum-sq;
print(res)


library(rstan)

d <- read.csv(file='…/ch.5/input/data3a.csv')
d_conv <- data.frame(X=c(0, 1))
rownames(d_conv) <- c('C', 'T')
data <- list(N=nrow(d), Y=d$y, X=d$x, F=d_conv[d$f,])
fit <- stan(file='…/ch.5/e/ex6.stan', data=data, seed=1234)


#######################################################################################
# Impact of Gestational Diabetes Mellitus Screening Strategies on Perinatal Outcomes:
# a Simulation Study
# Coded by: Isaias Prestes; reviewed by Maicon Falavigna
# Performed on R version 2.11.1
# Packages required: hdrcde, boa
# Date: 01/06/12
#######################################################################################

# Simulation study for screening for gestational diabetes WHO

# Settings
n <- 1000000 ;
alfa <- 0.05

# The Beta distribution with parameters shape1 = a and shape2 = b has density
#
# G(a+b)/(G(a)G(b))x^(a-1)(1-x)^(b-1)
#
# for a > 0, b > 0 and 0 = x = 1 where the boundary values at x=0 or x=1 are defined as by continuity (as limits).
# The mean is a/(a+b) and the variance is ab/((a+b)^2 (a+b+1)).

# Given a and b, return a array with mean, variance, deviation, lower endpoint and upper endpoint of the 100(1-alfa)% confidence interval for Beta distribution.
beta.parametros <- function(a, b, alfa, digits = 5) {
	media <- a / (a+b)
	variancia <- (a * b)/ ( (a+b)^2 * (a+b+1) )
	liminf <- qbeta(alfa/2, a, b)
	limsup <- qbeta(1 - alfa/2, a, b)
	return( round( c("Mean"=media,"Var"=variancia,"SD"=variancia^.5, "LL"=liminf, "UL"=limsup) , digits=5) )
}
# Example :
beta.parametros(3, 6, alfa)

# Set RNG seed
set.seed(37589411)

# Values for PWHO
# PWHO <- seq(0.05,0.15,0.01)
PWHO <- 0.05

# Simulated parameters values

# LGA Birth (LGA)
LGA_Iwho_negative <- rbeta(n, 1.5*900, 1.5*9100 ) ; c <- 1.5; beta.parametros(c*900, 9100*c, alfa)
LGA_logRRwho <- rnorm(n, 0.4256, 0.0494) ;		# Distribution for log(RR)
LGA_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # approximated solution
LGA_logRPiadpsg <- rnorm(n, 0.4055, 0.0730) ;		# Distribution for log(RP)
LGA_logRRtreatment <- rnorm(n, -0.6095, 0.1245) ;	# Distribution for log(RR)
LGA_logRRiadpsg <- rnorm(n, 0.5503, 0.1558) ;		# Distribution for log(RR)

# Preeclampsia (PE)
PE_Iwho_negative <- rbeta(n, 22.5, 477.5 ) ; c <- 0.5; beta.parametros(c*45, c*955, alfa)
PE_logRRwho <- rnorm(n, 0.5260, 0.1288) ;		# Distribution for log(RR)
PE_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # approximated solution
PE_logRPiadpsg <- rnorm(n, 0.4055, 0.0730) ;		# Distribution for log(RP)
PE_logRRtreatment <- rnorm(n, -0.4903, 0.1413) ;	# Distribution for log(RR)
PE_logRRiadpsg <- rnorm(n, 0.5374, 0.1108) ;		# Distribution for log(RR)

# Caesarean section (CS)
CS_Iwho_negative <- rbeta(n, 11.7475, 51.7525 ) ; beta.parametros(11.7475, 51.7525, alfa)
CS_logRRwho <- rnorm(n, 0.3144, 0.0508) ;		# Distribution for log(RR)
CS_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # approximated solution
CS_logRPiadpsg <- rnorm(n, 0.4055, 0.0730) ;		# Distribution for log(RP)
CS_logRRtreatment <- rnorm(n, -0.1100, 0.0797) ;		# Distribution for log(RR)
CS_logRRiadpsg <- rnorm(n, 0.2086, 0.1035) ;		# Distribution for log(RR)

# Set simulated block
set.idiaf <- function( PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {
	IDIAF <- ( ( PWHO * Iwho_negative * exp(logRRwho) ) ) + ( ( 1 - PWHO ) * Iwho_negative ) / ( (1 - ( PWHO * exp(logRPiadpsg) ) ) + ( exp(logRRiadpsg) * PWHO * exp(logRPiadpsg) ) )
	return(IDIAF)
}

# Functions for model simulation
simula.nao.rastrear <- function ( n , PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {
	Iwho_positive <- Iwho_negative * exp(logRRwho) # Iwho_positive = Iwho_negative * RRwho

	ans <- 	(
				( PWHO * Iwho_positive ) + ( ( 1 - PWHO ) * Iwho_negative )
			)

	return(ans)
}

simula.who <- function ( n , PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {
	Iwho_positive <- Iwho_negative * exp(logRRwho)

	ans <- 	(
				( ( 1 - PWHO ) * Iwho_negative ) +
				( PWHO * ( 1 - Ptreatment ) * Iwho_positive ) +
				( PWHO * Ptreatment * exp(logRRtreatment) * Iwho_positive )
			)

	return(ans)
}

simula.iadpsg <- function ( n , PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {

	Piadpsg <- PWHO * exp(logRPiadpsg)	# Piadpsg = Pwho * PRiadpsg

	Iiadpsg_negative <- ( ( PWHO * Iwho_negative * exp(logRRwho) ) +
						( ( 1 - PWHO) * Iwho_negative ) ) / ( ( ( 1 - (PWHO * exp(logRPiadpsg) ) ) )  +
						( PWHO * exp(logRPiadpsg) * exp(logRRiadpsg) ) )

	Iiadpsg_positive <- Iiadpsg_negative * exp(logRRiadpsg)

	ans <- 	(
				( ( 1 - Piadpsg ) * Iiadpsg_negative ) +
				( Piadpsg * Iiadpsg_positive * Ptreatment * exp(logRRtreatment) ) +
				( Piadpsg * Iiadpsg_positive * ( 1 - Ptreatment ) )
			)

	return(ans)
}

# Looping PWHO values
datasummary <- array(,10)
datasummary.diff <- array(,10)
datasummary.table.diff <- array(,3)

names(datasummary) <- c("PWHO", "Strategy", "Min.",    "1st Qu.", "Median",  "Mean",    "3rd Qu.", "Max.")
names(datasummary.diff) <- c("PWHO", "Strategy", "Min.",    "1st Qu.", "Median",  "Mean",    "3rd Qu.", "Max.")

for ( i in PWHO ) {
	arrayPWHO <- rep(i, n)
	# Compute values for each screening strategies
	resultados.IADPSG.LGA <- simula.iadpsg(  n , arrayPWHO, LGA_Iwho_negative, LGA_logRRwho, LGA_Ptreatment, LGA_logRRtreatment, LGA_logRPiadpsg, LGA_logRRiadpsg)
	resultados.IADPSG.PE <- simula.iadpsg(  n , arrayPWHO, PE_Iwho_negative, PE_logRRwho, PE_Ptreatment, PE_logRRtreatment, PE_logRPiadpsg, PE_logRRiadpsg)
	resultados.IADPSG.CS <- simula.iadpsg(  n , arrayPWHO, CS_Iwho_negative, CS_logRRwho, CS_Ptreatment, CS_logRRtreatment, CS_logRPiadpsg, CS_logRRiadpsg)

	resultados.NR.LGA <- simula.nao.rastrear(  n , arrayPWHO, LGA_Iwho_negative, LGA_logRRwho, LGA_Ptreatment, LGA_logRRtreatment, LGA_logRPiadpsg, LGA_logRRiadpsg)
	resultados.NR.PE <- simula.nao.rastrear(  n , arrayPWHO, PE_Iwho_negative, PE_logRRwho, PE_Ptreatment, PE_logRRtreatment, PE_logRPiadpsg, PE_logRRiadpsg)
	resultados.NR.CS <- simula.nao.rastrear(  n , arrayPWHO, CS_Iwho_negative, CS_logRRwho, CS_Ptreatment, CS_logRRtreatment, CS_logRPiadpsg, CS_logRRiadpsg)

	resultados.WHO.LGA <- simula.who(  n , arrayPWHO, LGA_Iwho_negative, LGA_logRRwho, LGA_Ptreatment, LGA_logRRtreatment, LGA_logRPiadpsg, LGA_logRRiadpsg)
	resultados.WHO.PE <- simula.who(  n , arrayPWHO, PE_Iwho_negative, PE_logRRwho, PE_Ptreatment, PE_logRRtreatment, PE_logRPiadpsg, PE_logRRiadpsg)
	resultados.WHO.CS <- simula.who(  n , arrayPWHO, CS_Iwho_negative, CS_logRRwho, CS_Ptreatment, CS_logRRtreatment, CS_logRPiadpsg, CS_logRRiadpsg)

	resultado.final <- data.frame(
		"PWHO" = arrayPWHO,
		"NR.LGA" = resultados.NR.LGA,
		"NR.PE" = resultados.NR.PE,
		"NR.CS" = resultados.NR.CS,
		"WHO.LGA" = resultados.WHO.LGA,
		"WHO.PE" = resultados.WHO.PE,
		"WHO.CS" = resultados.WHO.CS,
		"IADPSG.LGA" = resultados.IADPSG.LGA,
		"IADPSG.PE" = resultados.IADPSG.PE,
		"IADPSG.CS" = resultados.IADPSG.CS
		)

	write.csv2( resultado.final , paste("table_data_PWHO_", i,".csv", sep="") )

	# Compute differences
	Delta.NR.WHO.LGA <- resultados.NR.LGA  -  resultados.WHO.LGA
	Delta.NR.IADPSG.LGA <- resultados.NR.LGA  -  resultados.IADPSG.LGA
	Delta.WHO.IADPSG.LGA <- resultados.WHO.LGA - resultados.IADPSG.LGA

	Delta.NR.WHO.PE <- resultados.NR.PE  -  resultados.WHO.PE
	Delta.NR.IADPSG.PE <- resultados.NR.PE  -  resultados.IADPSG.PE
	Delta.WHO.IADPSG.PE <- resultados.WHO.PE - resultados.IADPSG.PE

	Delta.NR.WHO.CS <- resultados.NR.CS  -  resultados.WHO.CS
	Delta.NR.IADPSG.CS <- resultados.NR.CS  -  resultados.IADPSG.CS
	Delta.WHO.IADPSG.CS <- resultados.WHO.CS - resultados.IADPSG.CS

	# Compute p-values empirical # Pr { standart strategy > alternative strategy }
	comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")
	resultados.pvalue <- array(,0)

	for (i in comptype) {
		ans <- c(i, eval(parse(text=paste("sum( ifelse(Delta.",i ," < 0 , 1, 0) ) / n",sep=""))) )
		resultados.pvalue <- rbind(resultados.pvalue, ans)
		print( ans )
	}

	write.csv2( resultados.pvalue , paste("Summary_pvalues.csv", sep=""))

	# NNS for screening strategies
	NNS.Delta.NR.WHO.LGA <- 1 / Delta.NR.WHO.LGA
	NNS.Delta.NR.IADPSG.LGA <- 1 / Delta.NR.IADPSG.LGA
	NNS.Delta.WHO.IADPSG.LGA <- 1 / Delta.WHO.IADPSG.LGA

	NNS.Delta.NR.WHO.PE <- 1 / Delta.NR.WHO.PE
	NNS.Delta.NR.IADPSG.PE <- 1 / Delta.NR.IADPSG.PE
	NNS.Delta.WHO.IADPSG.PE <- 1 / Delta.WHO.IADPSG.PE

	NNS.Delta.NR.WHO.CS <- 1 / Delta.NR.WHO.CS
	NNS.Delta.NR.IADPSG.CS <- 1 / Delta.NR.IADPSG.CS
	NNS.Delta.WHO.IADPSG.CS <- 1 / Delta.WHO.IADPSG.CS

	# Compute binary variables for proportions
	Bin.Delta.NR.WHO.LGA <- ifelse(Delta.NR.WHO.LGA > 0, 1, 0)
	Bin.Delta.NR.IADPSG.LGA <- ifelse(Delta.NR.IADPSG.LGA > 0, 1, 0)
	Bin.Delta.WHO.IADPSG.LGA <- ifelse(Delta.WHO.IADPSG.LGA > 0, 1, 0)

	Bin.Delta.NR.WHO.PE <- ifelse(Delta.NR.WHO.PE > 0, 1, 0)
	Bin.Delta.NR.IADPSG.PE <- ifelse(Delta.NR.IADPSG.PE > 0, 1, 0)
	Bin.Delta.WHO.IADPSG.PE <- ifelse(Delta.WHO.IADPSG.PE > 0, 1, 0)

	Bin.Delta.NR.WHO.CS <- ifelse(Delta.NR.WHO.CS > 0, 1, 0)
	Bin.Delta.NR.IADPSG.CS <- ifelse(Delta.NR.IADPSG.CS > 0, 1, 0)
	Bin.Delta.WHO.IADPSG.CS <- ifelse(Delta.WHO.IADPSG.CS > 0, 1, 0)

	comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")

	for (i in comptype) {
		ans <- eval(parse(text=paste("table(Bin.Delta.",i,")",sep="")))
		print(ans)

		if ( length(ans) < 2 ) ans <- c("0" = 0, ans[1] )
 		datasummary.table.diff <- rbind( datasummary.table.diff, as.array(c(i,ans)) )
	}

	# Save data
	datasummary.table.diff <- datasummary.table.diff[ !is.na(datasummary.table.diff[,1]) ,]

	datasummary.table.diff <- data.frame(
		"Comparação" = as.character(datasummary.table.diff[,1]),
		"Freq 0" = as.numeric(as.character(datasummary.table.diff[,2])),
		"Freq 1" = as.numeric(as.character(datasummary.table.diff[,3])),
		"Fr 0" = (100 * (as.numeric(as.character(datasummary.table.diff[,2])) / n )),
		"Fr 1" = (100 * (as.numeric(as.character(datasummary.table.diff[,3])) / n ))
		)

	write.csv2( datasummary.table.diff , "Estatísticas_Binarias_Prop_Comp.csv", row.names=FALSE )

	resultado.final.diff <- data.frame(
		"PWHO" = arrayPWHO,
		"NR vs WHO - LGA" = Delta.NR.WHO.LGA,
		"NR vs IADPSG - LGA" = Delta.NR.IADPSG.LGA,
		"WHO vs IADPSG - LGA" = Delta.WHO.IADPSG.LGA,

		"NR vs WHO - PE" = Delta.NR.WHO.PE,
		"NR vs IADPSG - PE" = Delta.NR.IADPSG.PE,
		"WHO vs IADPSG - PE" = Delta.WHO.IADPSG.PE,

		"NR vs WHO - CS" = Delta.NR.WHO.CS,
		"NR vs IADPSG - CS" = Delta.NR.IADPSG.CS,
		"WHO vs IADPSG - CS" = Delta.WHO.IADPSG.CS

		)

	write.csv2( resultado.final.diff , paste("table_data_Differences_PWHO_", i,".csv", sep=""), row.names=FALSE )

	# Compute summary tables
	datasummary <- rbind( datasummary, c( i, "NR.LGA", c(summary(resultado.final$"NR.LGA",)) ,
		quantile(resultado.final$"NR.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "NR.PE", c(summary(resultado.final$"NR.PE")) ,
		quantile(resultado.final$"NR.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "NR.CS", c(summary(resultado.final$"NR.CS")) ,
		quantile(resultado.final$"NR.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	datasummary <- rbind( datasummary, c( i, "WHO.LGA", c(summary(resultado.final$"WHO.LGA")) ,
		quantile(resultado.final$"WHO.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "WHO.PE", c(summary(resultado.final$"WHO.PE")) ,
		quantile(resultado.final$"WHO.PE", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "WHO.CS", c(summary(resultado.final$"WHO.CS")) ,
		quantile(resultado.final$"WHO.CS", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	datasummary <- rbind( datasummary, c( i, "IADPSG.LGA", c(summary(resultado.final$"IADPSG.LGA")) ,
		quantile(resultado.final$"IADPSG.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "IADPSG.PE", c(summary(resultado.final$"IADPSG.PE")) ,
		quantile(resultado.final$"IADPSG.PE", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "IADPSG.CS", c(summary(resultado.final$"IADPSG.CS")) ,
		quantile(resultado.final$"IADPSG.CS", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary tables for differences
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs WHO - LGA", c(summary(Delta.NR.WHO.LGA)) ,
		quantile(Delta.NR.WHO.LGA, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs IADPSG - LGA", c(summary(Delta.NR.IADPSG.LGA)) ,
		quantile(Delta.NR.IADPSG.LGA, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary : screening strategies WHO vs IADPSG for LGA
	datasummary.diff <- rbind( datasummary.diff, c( i, "WHO vs IADPSG - LGA", c(summary(Delta.WHO.IADPSG.LGA)) ,
		quantile(Delta.WHO.IADPSG.LGA, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs WHO - PE", c(summary(Delta.NR.WHO.PE)) ,
		quantile(Delta.NR.WHO.PE, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs IADPSG - PE", c(summary(Delta.NR.IADPSG.PE)) ,
		quantile(Delta.NR.IADPSG.PE, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary : screening strategies WHO vs IADPSG for PE
	datasummary.diff <- rbind( datasummary.diff, c( i, "WHO vs IADPSG - PE", c(summary(Delta.WHO.IADPSG.PE)) ,
		quantile(Delta.WHO.IADPSG.PE, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs WHO - CS", c(summary(Delta.NR.WHO.CS)) ,
		quantile(Delta.NR.WHO.CS, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs IADPSG - CS", c(summary(Delta.NR.IADPSG.CS)) ,
		quantile(Delta.NR.IADPSG.CS, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary : screening strategies WHO vs IADPSG for CS
	datasummary.diff <- rbind( datasummary.diff, c( i, "WHO vs IADPSG - CS", c(summary(Delta.WHO.IADPSG.CS)) ,
		quantile(Delta.WHO.IADPSG.CS, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
}

# Save summary data
datasummary <- datasummary[ !is.na(datasummary[,1]) ,]
datasummary.diff <- datasummary.diff[ !is.na(datasummary.diff[,1]) ,]

datasummary <- data.frame(datasummary)
names(datasummary) <- c(names(datasummary)[1:(length(names(datasummary))-2)],
paste("Percentil ",round((alfa/2)*100, digits=1),sep=""), paste("Percentil ",round((1-alfa/2)*100, digits=1),sep=""))

datasummary.diff <- data.frame(datasummary.diff)
names(datasummary.diff) <- c(names(datasummary.diff)[1:(length(names(datasummary))-2)],
paste("Percentil ",round((alfa/2)*100, digits=1),sep=""), paste("Percentil ",round((1-alfa/2)*100, digits=1),sep=""))

write.csv2( datasummary , paste("Summary_statistics.csv", sep=""), row.names=FALSE )
write.csv2( datasummary.diff , paste("Summary_statistics_for_differences.csv", sep=""), row.names=FALSE )

# Summary - distribution - Compute the Highest Posterior Density Interval (HPD)
require(hdrcde)
require(boa)

comptype <- c("NR.LGA","NR.PE","NR.CS","WHO.LGA","WHO.PE","WHO.CS","IADPSG.LGA","IADPSG.PE","IADPSG.CS")

for (i in comptype) {
	print(paste("Computing HPD Interval for ",i,sep=""))

	graphname <- paste("grafico_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- hdr.den(resultado.final[,i])
	dev.off()

	# Using boa package
	ans <- boa.hpd(resultado.final[,i], alpha = 0.05)
	write.csv2( ans , paste("HPD ",i,".csv", sep=""))
	print( ans )

}

comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")

for (i in comptype) {
	print(paste("Computing HPD Interval for Difference ",i,sep=""))

	graphname <- paste("grafico_IDiff_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- eval(parse(text=paste("hdr.den(Delta.",i,")",sep="")))
	dev.off()

	# Using boa package
	ans <- eval(parse(text=paste("boa.hpd(Delta.",i,", alpha = 0.05)",sep="")))
	write.csv2( ans , paste("HPD Diff ",i,".csv", sep=""))
	print( ans )

}

comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")

for (i in comptype) {
	print(paste("Computing HPD Interval for NNS",i,sep=""))

	graphname <- paste("grafico_NNS_Diff_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- eval(parse(text=paste("plot(density(NNS.Delta.",i,"))",sep="")))
	dev.off()

	# Using boa package
	ans <- eval(parse(text=paste("boa.hpd(NNS.Delta.",i,", alpha = 0.05)",sep="")))
	write.csv2( ans , paste("HPD Diff ",i,".csv", sep=""))
	print( ans )

}

###############################
# Sensitivity analysis - HAPO #
###############################

# Screening strategies settings
LGA_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # melhor solução encontrada
LGA_logRRtreatment <- rnorm(n, -0.6095, 0.1245) ;	# A distribuição de log(RR)

PE_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # melhor solução encontrada
PE_logRRtreatment <- rnorm(n, -0.4903, 0.1413) ;	# A distribuição de log(RR)

CS_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # melhor solução encontrada
CS_logRRtreatment <- rnorm(n, -0.1100, 0.0797) ;		# A distribuição de log(RR)

# Common parameters settings
Pwho_HAPO <- 0.114
Piadpsg_HAPO <- 0.161
LGA_Iwhopos_HAPO <- 0.137
PE_Iwhopos_HAPO <- 0.076
CS_Iwhopos_HAPO <- 0.244
LGA_Iiadpsgpos_HAPO <- 0.162
PE_Iiadpsgpos_HAPO <- 0.091
CS_Iiadpsgpos_HAPO <- 0.244

# Compute incidence reduction - WHO
RI_LGA_WHO <- Pwho_HAPO * LGA_Iwhopos_HAPO * LGA_Ptreatment * (1-exp(LGA_logRRtreatment))
NNS_LGA_WHO <- 1 / RI_LGA_WHO

RI_PE_WHO  <- Pwho_HAPO * PE_Iwhopos_HAPO * PE_Ptreatment * (1-exp(PE_logRRtreatment))
NNS_PE_WHO <- 1 / RI_PE_WHO

RI_CS_WHO <- Pwho_HAPO * CS_Iwhopos_HAPO * CS_Ptreatment * (1-exp(CS_logRRtreatment))
NNS_CS_WHO <- 1 / RI_CS_WHO

# Compute incidence reduction - IADPSG
RI_LGA_IADPSG <- Piadpsg_HAPO * LGA_Iiadpsgpos_HAPO * LGA_Ptreatment * (1-exp(LGA_logRRtreatment))
NNS_LGA_IADPSG <- 1 / RI_LGA_IADPSG

RI_PE_IADPSG <- Piadpsg_HAPO * PE_Iiadpsgpos_HAPO * PE_Ptreatment * (1-exp(PE_logRRtreatment))
NNS_PE_IADPSG <- 1 / RI_PE_IADPSG

RI_CS_IADPSG <- Piadpsg_HAPO * CS_Iiadpsgpos_HAPO * CS_Ptreatment * (1-exp(CS_logRRtreatment))
NNS_CS_IADPSG <- 1 / RI_CS_IADPSG

# Save data
resultado.final.sa <- data.frame(
	"RI_LGA_WHO" = RI_LGA_WHO,
	"NNS_LGA_WHO" = NNS_LGA_WHO,
	"RI_PE_WHO" = RI_PE_WHO,
	"NNS_PE_WHO" = NNS_PE_WHO,
	"RI_CS_WHO" = RI_CS_WHO,
	"NNS_CS_WHO" = NNS_CS_WHO,

	"RI_LGA_IADPSG" = RI_LGA_IADPSG,
	"NNS_LGA_IADPSG" = NNS_LGA_IADPSG,
	"RI_PE_IADPSG" = RI_PE_IADPSG,
	"NNS_PE_IADPSG" = NNS_PE_IADPSG,
	"RI_CS_IADPSG" = RI_CS_IADPSG,
	"NNS_CS_IADPSG" = NNS_CS_IADPSG
	)

write.csv2( resultado.final.sa , "table_data_sensitivity analysis.csv" )

# Compute summary tables
tabela.resumo.sa <- array(,9)

vet.nomeselementos <- c("RI_LGA_WHO","NNS_LGA_WHO","RI_PE_WHO","NNS_PE_WHO","RI_CS_WHO","NNS_CS_WHO",
                        "RI_LGA_IADPSG", "NNS_LGA_IADPSG", "RI_PE_IADPSG", "NNS_PE_IADPSG", "RI_CS_IADPSG", "NNS_CS_IADPSG")

for (i in vet.nomeselementos) {
	ans <- eval(parse(text=i))
	tabela.resumo.sa <- rbind( tabela.resumo.sa, c( i, summary(ans), quantile(ans, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
}

tabela.resumo.sa <- tabela.resumo.sa[ !is.na(tabela.resumo.sa[,1]) ,]

tabela.resumo.sa <- data.frame(tabela.resumo.sa)
names(tabela.resumo.sa) <- c("Estatística/Estratégia", names(tabela.resumo.sa)[2:(length(names(tabela.resumo.sa))-2)],
paste("Percentil ",round((alfa/2)*100, digits=1),sep=""), paste("Percentil ",round((1-alfa/2)*100, digits=1),sep=""))

write.csv2( tabela.resumo.sa , paste("Summary_AS_HAPO.csv", sep=""), row.names=FALSE )

# Summary - Highest Posterior Density Interval (HPD)
vet.nomeselementos1 <- c("RI_LGA_WHO","RI_PE_WHO","RI_CS_WHO","RI_LGA_IADPSG", "RI_PE_IADPSG", "RI_CS_IADPSG")
vet.nomeselementos2 <- c("NNS_LGA_WHO", "NNS_LGA_IADPSG","NNS_PE_WHO", "NNS_PE_IADPSG", "NNS_CS_WHO", "NNS_CS_IADPSG")
vet.nomeselementos <- c(vet.nomeselementos1, vet.nomeselementos2)

for (i in vet.nomeselementos) {
	print(paste("HPD Interval for ",i," | Sensitivity analysis HAPO",sep=""))

	graphname <- paste("grafico_AS_HAPO_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- eval(parse(text=paste("plot(density(",i,"))",sep="")))
	dev.off()

	ans <- eval(parse(text=paste("boa.hpd(",i,", alpha = 0.05)",sep="")))
	write.csv2( ans , paste("HPD Sensitivity analysis HAPO ",i,".csv", sep=""))
	print( ans )

}

dev.off()

####################
# End of the syntaxe
####################

Simulation Gestational Diabetes WHO/Simulation main.r


# instalando o pacote ExpDes (Experimental Designs)
#
install.packages("ExpDes")
# requerendo o ExpDes
require(ExpDes)
# sintaxe do comando que faz a ANOVA no ExpDes
# crd(treat, resp, quali = TRUE, mcomp = "tukey", sigT = 0.05, sigF = 0.05)
crd(trat,insulina,mcomp=F)