#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：voltage_stable , OV电压与BV电压之差，即stable 稳定电压与三种液体之间随流量、极间距离、针头直径变化的影响

######################读取文件模块###################
#setwd("D:/data")
library(xlsx)

#读取v~Q的数据
de_q<-read.xlsx("voltage.xls",sheetName="ethanol_q",header=TRUE)
da_q<-read.xlsx("voltage.xls",sheetName="acetone_q",header=TRUE)
di_q<-read.xlsx("voltage.xls",sheetName="iso_q",header=TRUE)

#保存pdf
pdf("voltage_3liquids_stable.pdf")

#画图-乙醇
plot(de_q$flowrate, de_q$stable,  pch=6, col=0, xaxs="i", xlim=c(-0.002, 0.032), ylim=c(0.3, 1.2),
xlab="Q(ml/min)", mgp=c(1, 0, 0),
tck=0.02,cex.lab=1.1,
ylab=expression(V["stable"](kv)))

title(main="Stable voltage zones with Q",line=0.5,cex.main=1.1)

model_qsv <- loess(de_q$stable ~ de_q$flowrate)
fit <- fitted(model_qsv)
ord <- order(de_q$flowrate)

lines(de_q$flowrate[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2) # 乙醇的拟合曲线

#画图-丙酮
#points(da_q$flowrate, da_q$OV,  pch=23, col="blue")

model_asv <- loess(da_q$stable ~ da_q$flowrate)
fit <- fitted(model_asv)
ord <- order(da_q$flowrate)

lines(da_q$flowrate[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2) # 丙酮的拟合曲线

#画图-异丙醇
#points(di_q$flowrate, di_q$OV,  pch=23, col="green")

model_isv <- loess(di_q$stable ~ di_q$flowrate)
fit <- fitted(model_isv)
ord <- order(di_q$flowrate)

lines(di_q$flowrate[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2) # 异丙醇的拟合曲线

#图例标注
legend("bottomright", c("Ethanol", "Acetone", "Isoproply"), bty= "n",
       inset=.1,  pch=c(6, 23, 24), col=c("red", "blue", "darkgreen"), lty=2, lwd=2.5, cex=1)

dev.off()


# VIZUALIZACIJA

#KAZALNIKI, TORTNI DIAGRAMI

#graficni prikaz gostote prebivalstva v Sloveniji
st_zelo_redkih <- sum(gostota$'skupina' == 'zelo_redka')
st_redkih <- sum(gostota$'skupina' == 'redka')
st_gostih <- sum(gostota$'skupina' == 'gosta')
st_zelo_gostih <- sum(gostota$'skupina' == 'zelo_gosta')
Število <- c(st_zelo_redkih, st_redkih, st_gostih, st_zelo_gostih)
Skupina <- c("zelo redka","redka","gosta","zelo gosta")
gostota_zag <- data.table(Skupina, Število)

t1 <- ggplot(gostota_zag, aes(x="", y=Število, fill=Skupina)) + geom_bar(stat="identity", width=1) +
  coord_polar("y", start=0) + scale_fill_manual(values=c("#55DDE0", "#33658A", "#2F4858", "#F6AE2D")) +
  labs(x = NULL, y = NULL, fill = NULL, title = "Gostota prebivalstva v Sloveniji leta 2015") +
  theme_classic() + theme(axis.line = element_blank(),axis.text = element_blank(),axis.ticks = element_blank(),plot.title = element_text(hjust = 0.5, color = "#666666")) +
  geom_text(aes(label = paste(round(Število / sum(Število) * 100, 1), "%"), x = 1.3),position = position_stack(vjust = 0.5))

#graficni prikaz kriticnosti brezposelnosti v Sloveniji (izračun kritičnih in nekritičnih, nov data table s podatki, izris tortnega diagrama)
st_kriticnih <- sum(brezposelni$'kriticnost' == 'kritična')
st_nekriticnih <- sum(brezposelni$'kriticnost' == 'nekritična')
Kritičnost <- c("kritična","nekritična")
Število <- c(st_kriticnih, st_nekriticnih)
kriticnost <- data.table(Kritičnost, Število)

t2 <- ggplot(kriticnost, aes(x="", y=Število, fill=Kritičnost)) + geom_bar(stat="identity", width=1) +
  coord_polar("y", start=0) + scale_fill_manual(values=c("#F26419", "#999999")) +
  labs(x = NULL, y = NULL, fill = NULL, title = "Kritičnost brezposelnosti v Sloveniji leta 2015") +
  theme_classic() + theme(axis.line = element_blank(),axis.text = element_blank(),axis.ticks = element_blank(),plot.title = element_text(hjust = 0.5, color = "#666666")) +
  geom_text(aes(label = paste(round(Število / sum(Število) * 100, 1), "%"), x = 1.3),position = position_stack(vjust = 0.5))

#graficni prikaz povprečne mesečne neto plače (indeks) v Sloveniji (glede na delitev na tri skupine) ((izračun 'razredov', nov data table s podatki, izris tortnega diagrama))
prva <- sum(placa_indeks$'razred' == 'nizka')
druga <- sum(placa_indeks$'razred' == 'srednja')
tretja <- sum(placa_indeks$'razred' == 'visoka')
Višina <- c("nizka", "srednja", "visoka")
Število <- c(prva, druga, tretja)
place <- data.table(Višina, Število)

t3 <- ggplot(place, aes(x="", y=Število, fill=Višina)) + geom_bar(stat="identity", width=1) +
  coord_polar("y", start=0) + scale_fill_manual(values=c("#2F4858", "#F6AE2D", "#999999")) +
  labs(x = NULL, y = NULL, fill = NULL, title = "Povprečne mesečne neto plače leta 2015") +
  theme_classic() + theme(axis.line = element_blank(),axis.text = element_blank(),axis.ticks = element_blank(),plot.title = element_text(hjust = 0.5, color = "#666666"))+
  geom_text(aes(label = paste(round(Število / sum(Število) * 100, 1), "%"), x = 1.3),position = position_stack(vjust = 0.5))

#NAPELJAVE, GRAFI

#graficni prikaz vodovoda in gostote
g1 <- ggplot(leta.skupine.vod) + aes(x=leto, y=povprecje, color=skupina) + geom_line() + geom_point() +
  labs(x="Leto",y="Povprečno število stanovanj z vodovodom",title="Število vodovodnih napeljav glede na gostoto poselitve", color = "Gostota poselitve") +
  theme(legend.position = "bottom")

#graficni prikaz kanalizacije in gostote
g2 <- ggplot(leta.skupine.kan) + aes(x=leto, y=povprecje, color=skupina) + geom_line() + geom_point() +
  labs(x="Leto",y="Povprečno število stanovanj s kanalizacijo",title="Število napeljav kanalizacije glede na gostoto poselitve", color = "Gostota poselitve") +
  theme(legend.position = "bottom")

#graficni prikaz plac in ogrevanja
g3 <- ggplot(leta.razredi) + aes(x=leto, y=povprecje, color=razred) + geom_line() + geom_point() +
  labs(x="Leto",y="Povprečno število stanovanj z ogrevanjem",title="Število ogrevalnih napeljav in plače prebivalstva", color = "Povprečna višina plač") +
  theme(legend.position = "bottom")

#POMANKLJIVOSTI, TORTNI PRIKAZ

#graficni prikaz pomankljivo opremljenih stanovanj v Sloveniji
st_zelo_nizkih <- sum(delezi$'pomankljivost' == 'zelo nizka')
st_nizkih <- sum(delezi$'pomankljivost' == 'nizka')
st_visokih <- sum(delezi$'pomankljivost' == 'visoka')
st_zelo_visokih <- sum(delezi$'pomankljivost' == 'zelo visoka')
Stopnja <- c("zelo nizka", "nizka", "visoka", "zelo visoka")
Število <- c(st_zelo_nizkih, st_nizkih, st_visokih, st_zelo_visokih)
pomankljivi <- data.table(Stopnja, Število)

tr <- ggplot(pomankljivi, aes(x="", y=Število, fill=Stopnja)) + geom_bar(stat="identity", width=1) +
  coord_polar("y", start=0) + scale_fill_manual(values=c("#999999", "#E69F00", "#56B4E9", "#009E73")) +
  labs(x = NULL, y = NULL, fill = NULL, title = "Delež občin s pomankljivo opremljenostjo stanovanj leta 2015") +
  theme_classic() + theme(axis.line = element_blank(),axis.text = element_blank(),axis.ticks = element_blank(),plot.title = element_text(hjust = 0.5, color = "#666666")) +
  geom_text(aes(label = paste(round(Število / sum(Število) * 100, 1), "%"), x = 1.3),position = position_stack(vjust = 0.5))

#KAZALNIKI, ZEMLJEVIDI

#gostota prebivalstva
proj4string(obcine)<- CRS("+proj=utm +zone=10+datum=WGS84")

z1 <- tm_shape(merge(obcine, gostota_z, by.x="OB_UIME", by.y="Obcina")) + tm_polygons("vrednost", title="Gostota naseljenosti (preb/km^2)") +
  tm_layout(title="Gostota prebivalstva Slovenije leta 2015", legend.position=c(0.65,0.005), legend.height=0.7, title.size=1.5, legend.title.size=0.8)

#place
z2 <- tm_shape(merge(obcine, placa_indeks_z, by.x="OB_UIME", by.y="Obcina")) + tm_polygons("vrednost", title="Vrednost indeksa") +
  tm_layout(title="Povprečne mesečne neto plače leta 2015",legend.position=c(0.72,0.005), legend.height=0.7, title.size=1.5)

#brezposelni
z3 <- tm_shape(merge(obcine, brezposelni_z, by.x="OB_UIME", by.y="Obcina")) + tm_polygons("vrednost", title="Odstotki") +
  tm_layout(title="Stopnja reg. brezposelnosti v letu 2015",legend.position=c(0.82,0.005), legend.height=0.7, title.size=1.5)

#stevilo stanovanj na 1000 prebivalcev
z4 <- tm_shape(merge(obcine, stanovanja_z, by.x="OB_UIME", by.y="Obcina")) + tm_polygons("vrednost", title="Število stanovanj na 1000 preb.") +
  tm_layout(title="Število stanovanj v letu 2015",legend.position=c(0.68,0.005), legend.height=0.7, title.size=1.5, legend.title.size=0.8)

#LINEARNA REGRESIJA

#linearen model med ogrevanjem in placami
fit <- lm(delez ~ Place, data=t)
summary(fit)
m1 <- ggplot(t, aes(x = Place, y = t$delez)) +
  geom_point() +
  geom_smooth(method=lm, se=FALSE) + labs(x = "Plače glede na slovensko povprečje (indeks = 100)", y = "Delež stanovanj brez centralnega ogrevanja (v %)", fill = NULL, title = "Ponazoritev premice linearne regresije - \n vpliv plač na centralno ogrevanje")

#linearen model med ogrevanjem in brezposelnostjo
fit <- lm(delez ~ Brezposelni_ods , data=t)
summary(fit)
m2 <- ggplot(t, aes(x = Brezposelni_ods, y = t$delez)) +
  geom_point() +
  geom_smooth(method=lm, se=FALSE) + labs(x = "Stopnja brezposelnosti (v %)", y = "Delež stanovanj brez centralnega ogrevanja (v %)", fill = NULL, title = "Ponazoritev premice linearne regresije - \n vpliv brezposelnosti na centralno ogrevanje")


#!/usr/bin/env Rscript
library(ggplot2)
library(gridExtra)
data <- read.csv("./data.csv")
b = ggplot(data)
ptsize <- 0.2
png(filename="./phase_space.png", width=700, height=1200)
print(
  grid.arrange(
    b + geom_point(aes(r, vr), size=ptsize)
    , b + geom_point(aes(z, vz), size=ptsize)
    , b + geom_point(aes(y, vy), size=ptsize)
    , b + geom_point(aes(theta, w), size=ptsize)
    , b + geom_point(aes(t, r), size=ptsize)
    , b + geom_point(aes(t, z), size=ptsize)
    , b + geom_point(aes(t, y), size=ptsize)
    , b + geom_point(aes(theta, z), size=ptsize)
    , ncol=2)
  )
dev.off()

data1 <- read.csv("./returnmap.csv")
b1 = ggplot(data1)
ptsize <- 1.0
png(filename="./yearly.png", width=700, height=1200)
print(
  grid.arrange(
    b1 + geom_point(aes(t, period), size=ptsize)
    , b1 + geom_point(aes(t, z), size=ptsize)
    , b1 + geom_point(aes(t, r), size=ptsize)
    , b1 + geom_point(aes(z, vz), size=ptsize)
    , ncol=1)
  )
dev.off()


# do site https://cdr.ibpad.com.br/ggplot2.html

# Carregando ggplot e dplyr para trabalhar com gráficos
library("ggplot2")
library("dplyr")

# carregando as tabelas de exemplo do R
data("mtcars")
data("mpg")

# visualizando os dados no RStudio
View(mtcars)
View(mpg)

# gerando o gráfico com ggplot
ggplot(mpg, aes(x=displ, y=hwy)) +
  geom_point(aes(color=class, size=cyl)) +
  geom_smooth(method="lm", aes(lty=drv)) + # methods = "auto", "lm", "glm", "gam", "loess"
  facet_wrap(~manufacturer)
 #facet_wrap(~manufacturer~model)

#--------------------------------------------------------------------------------------------

g <- ggplot(mtcars)
g <- g + geom_point(aes(x=hp, y=mpg, color=factor(am)), size=3)
g <- g + scale_color_manual("Automatic", values=c("red","blue"), labels=c("No","Yes"))
g <- g + labs(title = "Relação entre consumo, potência e tipo de câmbio", y="Consumo", x="Potência")
g

#--------------------------------------------------------------------------------------------

g1 <- ggplot(mtcars, aes(y = mpg, x = disp)) + geom_point()
g1

#--------------------------------------------------------------------------------------------

mtcars <- mtcars %>% mutate(name=rownames(mtcars))
ggplot(mtcars, aes(y=mpg, x=disp)) + geom_point() + geom_smooth() + facet_wrap(~carb)

#--------------------------------------------------------------------------------------------

data("iris")
View(iris)

# Escalas automáticas
ggplot(iris, aes(x=Petal.Length, y=Petal.Width, color=Species)) + geom_point()

# Escalas manuais
ggplot(iris, aes(x=Petal.Length, y=Petal.Width, color=Species)) +
  geom_point() +
  scale_color_manual(values=c("orange", "black", "red"))

# Definindo as quebras
ggplot(iris, aes(x = Petal.Length, y = Petal.Width, color = Species)) +
  geom_point() +
  scale_color_manual(values = c("orange", "black", "red")) +
  scale_x_continuous(name = "Petal Length", breaks = 1:7) +
  scale_y_continuous(name = "Petal Width", breaks = 0:3, limits = c(0, 3))

#--------------------------------------------------------------------------------------------
# Variáveis contínuas
library("ISLR")

View(Wage)

ggplot(Wage, aes(x=age, y=wage, color=education)) +
  geom_point() +
  scale_x_continuous("Idade", breaks = seq(0,80,5), expand=c(0,5)) +
  scale_y_continuous("Salário", labels = function(x) paste0("US$ ", x), limits = c(0,400))

#--------------------------------------------------------------------------------------------
# Variáveis discretas
View(Default)

ggplot(Default, aes(x = default, y = balance)) +
  geom_boxplot() +
  scale_x_discrete("Calote", labels = c("Não", "Sim")) +
  labs(y = "Valor devido médio após o pagamento mensal")

ggplot(Default, aes(x = default, y = balance)) +
  geom_boxplot() +
  scale_x_discrete("Calote", limits = c("Yes", "No"), labels = c("Sim", "Não")) +
  labs(y = "Valor devido médio após o pagamento mensal")

#--------------------------------------------------------------------------------------------
# Variáveis de datas
View(economics)

ggplot(economics, aes(x=date, y=unemploy)) +
  geom_line() +
  scale_x_date(date_labels = "%b/%Y")

ggplot(economics, aes(x = date, y = unemploy)) +
  geom_line() +
  scale_x_date(date_breaks = "5 years", date_labels = "%Y")

#--------------------------------------------------------------------------------------------
library(RColorBrewer)

# Escalas de cores
display.brewer.all(n=NULL, type="all", select=NULL, exact.n=TRUE,
                   colorblindFriendly=FALSE)

paleta.gradientn <- brewer.pal(n = 9, name = 'Reds')
Credit %>%
  group_by(Cards, Student) %>%
  summarise(Balance = mean(Balance), n = n()) %>%
  ggplot(aes(x = Cards, y = Student, fill = Balance)) +
  geom_tile() +
  scale_fill_gradientn(colors = rev(paleta.gradientn)) +
  scale_x_continuous(breaks = 1:9)

# paleta própria de cores da viridis
Credit %>%
  group_by(Cards, Student) %>%
  summarise(Balance = mean(Balance), n = n()) %>%
  ggplot(aes(x = Cards, y = Student, fill = Balance)) +
  geom_tile() +
  viridis::scale_fill_viridis() +
  scale_x_continuous(breaks = 1:9)

# definindo escala de cores manuais
ggplot(Wage, aes(y = wage, x = age, color = education)) +
  geom_point() +
  scale_color_manual(values = c("#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", "#A6D854"))

#--------------------------------------------------------------------------------------------
# 9.4 Subplots (facet)
View(diamonds)

#--
ggplot(diamonds, aes(x = carat, y = price)) + geom_point()

#--
ggplot(diamonds, aes(x = carat, y = price, color = factor(color))) +
  geom_point() +
  facet_wrap(~cut)

#--
ggplot(diamonds, aes(x = carat, y = price, color = factor(color))) +
  geom_point() +
  facet_wrap(~cut, scales="free_y")

#--
ggplot(diamonds, aes(x = carat, y = price, color = factor(color))) +
  geom_point() +
  facet_wrap(~clarity~cut)

#--
nomes_cut <- c(
  Fair = "FAIR",
  Good = "GOOD",
  `Very Good` = "VERY GOOD",
  Premium = "PREMIUM",
  Ideal = "IDEAL"
)

ggplot(diamonds, aes(x = carat, y = price)) +
  geom_point() +
  facet_wrap(~ cut, scales = "free_y",
             labeller = labeller(cut = nomes_cut))

#--------------------------------------------------------------------------------------------
# 9.5 Temas
install.packages('ggThemeAssist')

ggplot(diamonds, aes(x=carat, y=price)) +
  geom_point() +
  labs(title = "Carat vs Price") +
  theme(text = element_text(face="bold"),
        panel.grid.major = element_line(colour="gray80"),
        axis.title = element_text(size = 14),
        panel.background = element_rect(fill = "gray100"))

# temas disponíveis

p <- ggplot(diamonds, aes(x = carat, y = price)) +
  geom_point()

p + theme_gray() +
  labs(title = "theme_gray()")

p + theme_bw() +
  labs(title = "theme_bw()")

p + theme_linedraw() +
  labs(title = "theme_linedraw()")

p + theme_light() +
  labs(title = "theme_light()")

p + theme_minimal() +
  labs(title = "theme_minimal()")

p + theme_classic() +
  labs(title = "theme_classic()")

p + theme_dark() +
  labs(title = "theme_dark()")

p + theme_void() +
  labs(title = "theme_void()")

#--------------------------------------------------------------------------------------------
# hrbrthemes
install.packages("hrbrthemes")
library(hrbrthemes)

hrbrthemes::import_roboto_condensed()

ggplot(diamonds, aes(x = carat, y = price)) +
  geom_point() +
  labs(title = "theme_ipsum()") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

#--------------------------------------------------------------------------------------------
# Setando o tema globalmente
theme_set(theme_ipsum(plot_title_size = 12,
                     axis_title_size = 10) +
           theme(text = element_text(angle = 0)))

# exemplo usando o guide_legend()
ggplot(diamonds, aes(x = carat, y = price, color = cut, shape = cut)) +
  geom_point() +
  guides(color = guide_legend(title = "Cor", title.position = "left", keywidth = 5),
         shape = guide_legend(title = "Forma", title.position = "right", override.aes = aes(size = 5)))

#--------------------------------------------------------------------------------------------
# 9.7 Escolhendo o tipo de gráfico
install.packages("treemapify")
library(treemapify)
View(G20)

ggplot(G20, aes(area = gdp_mil_usd, fill = hdi, label = country)) +
  geom_treemap() +
  geom_treemap_text(fontface = "italic", colour = "white", place = "centre", grow = TRUE) +
  theme(legend.position = 'bottom')

#--------------------------------------------------------------------------------------------
# 9.8 Gráficos de dispersão
install.packages("gapminder")
library(gapminder)
library(ggplot2)
library(tidyverse)
library(dplyr)
library(hrbrthemes)
library(gapminder)

gapminder %>%
  filter(year==max(year)) %>%
  ggplot(aes(x=gdpPercap, y=lifeExp)) +
  geom_point() +
  labs(title="Relação entre Renda per Capita e Expectativa de Vida - 2007",
       x="Renda per Capita",
       y="Expectativa de Vida") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# usando logaritmo
gapminder %>%
  filter(year == max(year)) %>%
  ggplot(aes(x = gdpPercap, y = lifeExp)) +
  geom_point() +
  scale_x_log10() +
  labs(title = "Relação entre Renda per Capita e Expectativa de Vida - 2007",
       x = "Renda per Capita (escala log 10)",
       y = "Expectativa de Vida") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# usando shape
gapminder %>%
  filter(year == max(year)) %>%
  ggplot(aes(x = gdpPercap, y = lifeExp,
             color = continent,
             shape = continent)) +
  geom_point() +
  scale_x_log10() +
  scale_color_discrete("Continent") +
  scale_shape_discrete("Continent") +
  labs(title = "Relação entre Renda per Capita e Expectativa de Vida - 2007",
       x = "Renda per Capita (escala log 10)",
       y = "Expectativa de Vida") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# alterando formas e shapes
gapminder %>%
  filter(year == max(year)) %>%
  ggplot(aes(x = gdpPercap, y = lifeExp,
             color = continent, shape = continent)) +
  geom_point(fill = "black", size = 3, stroke = 1) +
  scale_x_log10() +
  scale_color_discrete("Continente") +
  scale_shape_manual("Continente", values=c(19,21,22,23,24)) +
  labs(title = "Relação entre Renda per Capita e Expectativa de Vida - 2007",
       x = "Renda per Capita (escala log 10)",
       y = "Expectativa de Vida")

#--------------------------------------------------------------------------------------------
# 9.9 Gráficos de Bolhas

gapminder %>%
  filter(year == max(year)) %>%
  ggplot(aes(x = gdpPercap, y = lifeExp,
             size = pop)) +
  geom_point() +
  scale_size_continuous("População (milhões)", labels = function(x) round(x/1e6)) +
  scale_x_log10() +
  labs(title = "Relação entre Renda per Capita e Expectativa de Vida - 2007",
       x = "Renda per Capita (escala log 10)",
       y = "Expectativa de Vida") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

#--------------------------------------------------------------------------------------------
# 9.10 Gráficos de Barras

ggplot(diamonds, aes(x=cut)) +
  geom_bar() +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# outro exemplo
gapminder %>%
  filter(year == max(year),
         continent == "Americas") %>%
  ggplot(aes(x = country, y = lifeExp)) +
  geom_bar(stat = "identity", fill="dodgerblue") +
  labs(title = "Expectativa de vida por país",
       subtitle = "2007",
       x = "País",
       y = "Expectativa de vida")+
  theme(axis.text.x = element_text(angle = 90, hjust = 1))

# usando o geom_col()
gapminder %>%
  filter(year == max(year),
         continent == "Americas") %>%
  ggplot(aes(x = country, y = lifeExp)) +
  geom_col(fill = "dodgerblue") +
  labs(title = "Expectativa de vida por país",
       subtitle = "2007",
       x = "País",
       y = "Anos") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1))

# usando reorder() para ordenar de forma crescente ou decrescente as barras
gapminder %>%
  filter(year == max(year),
         continent == "Americas") %>%
  ggplot(aes(x = reorder(country, -lifeExp), y = lifeExp)) +
  geom_col(fill = "dodgerblue") +
  labs(title = "Expectativa de vida por país",
       subtitle = "2007",
       x = "País",
       y = "Anos") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1))

# outro exemplo
gapminder %>%
  filter(year %in% c(1957, 2007)) %>%
  # Converte o ano para factor - será categoria no gráfico
  mutate(year = factor(year)) %>%
  group_by(continent, year) %>%
  summarise(lifeExp = mean(lifeExp)) %>%
  ggplot(aes(x = continent, y = lifeExp, fill = year)) +
  geom_col() +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# outro exemplo com barras lado a lado
gapminder %>%
  filter(year %in% c(1957, 2007)) %>%
  # Converte o ano para factor - será categoria no gráfico
  mutate(year = factor(year)) %>%
  group_by(continent, year) %>%
  summarise(lifeExp = mean(lifeExp)) %>%
  ggplot(aes(x = continent, y = lifeExp, fill = year)) +
  geom_col(position = "dodge") +
  labs(title = "Expectativa de vida por continente",
       x = "Continente",
       y = "Anos",
       fill = "Ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# outro exemplo com barras horizontais lado a lado
gapminder %>%
  filter(year %in% c(1957, 2007)) %>%
  # Converte o ano para factor - será categoria no gráfico
  mutate(year = factor(year)) %>%
  group_by(continent, year) %>%
  summarise(lifeExp = mean(lifeExp)) %>%
  ggplot(aes(x = continent, y = lifeExp, fill = year)) +
  geom_col(position = "dodge") +
  coord_flip() +
  labs(title = "Expectativa de vida por continente",
       x = "Continente",
       y = "Anos",
       fill = "Ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

#--------------------------------------------------------------------------------------------
# 9.11 Gráficos de linhas
library(dplyr)
library(ggplot2)
library(gapminder)
library(hrbrthemes)

gapminder %>%
  group_by(continent, year) %>%
  summarise(lifeExp = mean(lifeExp)) %>%
  ggplot(aes(x=year, y=lifeExp, color=continent)) +
  geom_line()

# com marcações
gapminder %>%
  group_by(continent, year) %>%
  summarise(lifeExp = mean(lifeExp)) %>%
  ggplot(aes(x = year, y = lifeExp, color = continent)) +
  geom_line() +
  geom_point(aes(shape = continent)) +
  labs(title = "Evolução da expectativa de vida por continente",
       x = "Ano",
       y = "Anos de vida",
       color = "Continente",
       shape = "Continente") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

#--------------------------------------------------------------------------------------------
# 9.12 Histogramas e freqpoly

# histograma
gapminder %>%
  filter(year == 2007) %>%
  ggplot(aes(x=lifeExp)) +
  geom_histogram(binwidth = 5, fill = 'dodgerblue', color = 'black') +
  labs(title = "Distribuição da expectativa de vida", x = "Anos", y = "Contagem") +
  theme_ipsum(plot_title_size = 12,
              axis_text_size = 10)

# freqpoly
gapminder %>%
  filter(year == "2007") %>%
  ggplot(aes(x=lifeExp)) +
  geom_freqpoly(binwidth = 5) +
  labs(title = "Distribuição da expectativa vida",
       x = "Anos",
       y = "Contagem") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# transformando em proporção
gapminder %>%
  filter(year == 2007) %>%
  ggplot(aes(x=lifeExp)) +
  geom_histogram(aes(y = ..count../sum(..count..)), binwidth = 5, fill= "dodgerblue", color = "black") +
  labs(title = "Distribuição da expectativa de vida", x = "Anos", y = "Contagem") +
  scale_y_continuous(labels = scales::percent_format()) +
  theme_ipsum(plot_title_size = 12,
              axis_text_size = 10)

#--------------------------------------------------------------------------------------------
# 9.13 Boxplots, jitterplots e violinplots

# boxplot
ggplot(gapminder, aes(x = factor(year), y = lifeExp)) +
  geom_boxplot(fill = "dodgerblue") +
  labs(y = "Anos de vida",
       x = "Ano",
       title = "Distribuição da expectativa de vida por ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# violinplot
ggplot(gapminder, aes(x = factor(year), y = lifeExp)) +
  geom_violin(fill = "dodgerblue") +
  labs(y = "Anos de vida",
       x = "Ano",
       title = "Distribuição da expectativa de vida por ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# jitterplot
ggplot(gapminder, aes(x = factor(year), y = lifeExp)) +
  geom_point() +
  labs(y = "Anos de vida",
       x = "Ano",
       title = "Distribuição da expectativa de vida por ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

ggplot(gapminder, aes(x = factor(year), y = lifeExp)) +
  geom_jitter() +
  labs(y = "Anos de vida",
       x = "Ano",
       title = "Distribuição da expectativa de vida por ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

#--------------------------------------------------------------------------------------------
# 9.14 Anotações

# descobrindo o outlier do gráfico de boxplot
gapminder %>%
  filter(year == 1992, lifeExp == min(lifeExp))

# gerando uama anotação para este outlier
ggplot(gapminder, aes(x = factor(year), y = lifeExp)) +
  geom_boxplot(fill = "dodgerblue") +
  annotate("text", x = "1992", y = 27, label = "Ruanda") +
  labs(y = "Anos de vida", x = "Ano",
       title = "Distribuição da expectativa de vida por ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# adicionando um segmento para dar destaque
ggplot(gapminder, aes(x = factor(year), y = lifeExp)) +
  annotate("text", x = "1992", y = 27, label = "Ruanda") +
  annotate("rect", xmin = "1982", ymin = 20,
           xmax = "2002", ymax = 95, alpha = 0.2) +
  geom_boxplot(fill = "dodgerblue") +
  labs(y = "Anos de vida",
       x = "Ano",
       title = "Distribuição da expectativa de vida por ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

#--------------------------------------------------------------------------------------------
# 9.15 Cleveland Dot Plot

gapminder %>%
  filter(year == 2007,
         continent == "Americas") %>%
  ggplot(aes(x = lifeExp, y = reorder(country, lifeExp))) +
  geom_point(size = 3, color = "dodgerblue") +
  labs(title = "Expectativa de vida por país - 2007",
       y = "País",
       x = "Anos") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10) +
  theme(panel.grid.major.y = element_line(linetype = "dashed"))

# apresentando mais de um ponto por categoria
gapminder %>%
  filter(year %in% c(1987, 2007),
         continent == "Americas") %>%
  ggplot(aes(x = lifeExp, y = country, color = factor(year))) +
  geom_point(aes(color = factor(year))) +
  labs(title = "Expectativa de vida por país - 1987 e 2007",
       y = "País",
       x = "Anos",
       color = "Ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10) +
  theme(panel.grid.major.y = element_line(linetype = "dashed"))

# exemplo de connected dot plot
gapminder %>%
  filter(year %in% c(1987, 2007),
         continent == "Americas") %>%
  ggplot(aes(x = lifeExp, y = country)) +
  geom_line(aes(group = country)) +
  geom_point(aes(color = factor(year))) +
  labs(title = "Expectativa de vida por país - 1987 e 2007",
       y = "País",
       x = "Anos",
       color = "Ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10) +
  theme(panel.grid.major.y = element_line(linetype = "dashed"))

# ordenando o eixo y pela expectativa de vida
gapminder %>%
  filter(year %in% c(1987, 2007),
         continent == "Americas") %>%
  ggplot(aes(x = lifeExp, y = reorder(country, lifeExp, max))) +
  geom_line(aes(group = country), color = "grey50") +
  geom_point(aes(color = factor(year))) +
  labs(title = "Expectativa de vida por país - 1987 e 2007",
       y = "País",
       x = "Anos",
       color = "Ano") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)  +
  theme(panel.grid.major.y = element_line(linetype = "dashed"))

#--------------------------------------------------------------------------------------------
# 9.16 Textos/Rótulos

# Para adicionar textos ou rótulos, utilizamos, respectivamente, o geom_text() e o geom_label()
gapminder %>%
  filter(year == 2007,
         continent == "Americas") %>%
  ggplot(aes(x = lifeExp, y = reorder(country, lifeExp))) +
  geom_segment(x = 0, aes(xend = lifeExp, yend = country),
               color = "grey50") +
  geom_point(size = 3, color = "dodgerblue") +
  geom_text(aes(label = round(lifeExp))) +
  labs(title = "Expectativa de vida por país - 2007",
       y = "País",
       x = "Anos") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# ajustando a posição dos labels usando hjust, vjust, nudge_x e nudge_y.
# O hjust e vjust podem assumir valor entre 0 (direita/embaixo)
# e 1(esquerda/em cima) ou “left”, “middle”, “right”, “bottom”, “center”
# e “top”, além de “inward” e “outward”.
gapminder %>%
  filter(year == 2007,
         continent == "Americas") %>%
  ggplot(aes(x = lifeExp, y = reorder(country, lifeExp))) +
  geom_point(size = 3, color = "dodgerblue") +
  geom_text(aes(label = round(lifeExp)), nudge_x = 1) +
  labs(title = "Expectativa de vida por país - 2007",
       y = "País",
       x = "Anos") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)  +
  theme(panel.grid.major.y = element_line(linetype = "dashed"))

# colocando um box no label
gapminder %>%
  filter(year == 2007,
         continent == "Americas") %>%
  ggplot(aes(x = lifeExp, y = reorder(country, lifeExp))) +
  geom_point(size = 3, color = "dodgerblue") +
  geom_label(aes(label = round(lifeExp)), nudge_x = 1, size = 3) +
  labs(title = "Expectativa de vida por país - 2007",
       y = "País",
       x = "Anos") +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)  +
  theme(panel.grid.major.y = element_line(linetype = "dashed"))

#--------------------------------------------------------------------------------------------
# 9.17 Plotando fuções

# exemplo 1
reta <- function(a, b, x){
  a + b * x
}

data <- data.frame(x = seq(0, 10, by = 0.1))
ggplot(data, aes(x = x)) +
  stat_function(fun = reta, args = list(a = 1, b = 2)) +
  stat_function(fun = reta, args = list(a = 1, b = 3), col = 'red')

# exemplo 2
sigmoid <- function(a = 1,z){
  1/(1 + exp(-a * z))
}

data <- data.frame(x = -6:6)
ggplot(data, aes(x = x)) +
  stat_function(fun = sigmoid, args = list(a = 1)) +
  stat_function(fun = sigmoid, args = list(a = 0.5), color = "blue") +
  stat_function(fun = sigmoid, args = list(a = 2), color = "red")

# exemplo 3
logit <- function(a, z){
  log(sigmoid(a, z)/(1 - sigmoid(a, z)))
}

data <- data.frame(x = -6:6)
ggplot(data, aes(x = x)) +
  stat_function(fun = logit, args = list(a = 1), aes(color = "a = 1")) +
  stat_function(fun = logit, args = list(a = 0.5), aes(color = "a = 0.5")) +
  stat_function(fun = logit, args = list(a = 2), aes(color = "a = 2"))

#--------------------------------------------------------------------------------------------
# 9.18 Mapas
library(readr)

# exemplo carregando dados com coordenadas --------------------
# carregando coordenadas dos países
world_map <- read_delim('dados/world_map.csv', delim = ";",
                        locale = locale(encoding = "ISO-8859-1",
                                        decimal_mark = ","))

# Remover Antarctica
world_map <- world_map %>%
  filter(id != "Antarctica")

# carregando dados de exportações por país de destino no ano de 2015
exp.2015 <- read_delim('dados/EXP_2015_PAIS.csv', delim = ";",
                       locale = locale(encoding = "ISO-8859-1"),
                       col_types = 'ccd')

# juntando informações dos mapas com as exportações
world_map <- left_join(world_map, exp.2015, by = "NO_PAIS_POR") %>%
  mutate(class = cut(VL_FOB, breaks = c(0, 1e6, 10e6, 100e6, 1e9, 10e9, Inf)))

# plotando o mapa
ggplot(world_map, aes(x = long, y = lat, group = group)) +
  geom_polygon(aes(fill = class), col = 'black', size = 0.1) +
  scale_fill_brewer(palette = "Reds", breaks = levels(world_map$class),
                    labels = c("(0, 1 Mi]", "(1 Mi, 10 Mi]", "(10 Mi, 100 Mi]",
                               "(100 Mi, 1 Bi]", "(1 Bi, 10 Bi]", "> 10 Bi"),
                    na.value = 'grey70') +
  labs(title = "Exportações Brasileiras - 2015",
       subtitle = 'Valor FOB') +
  coord_quickmap() +
  theme(axis.text.x = element_blank(),
        axis.text.y = element_blank(),
        axis.title.x = element_blank(),
        axis.title.y = element_blank())

# exemplo carregando dados do IBGE ----------------------------
install.packages("rgdal","maptools","rgeos")
library(rgdal)
library(maptools)
library(rgeos)
library(broom)

ogrListLayers('dados/mapas/mg_municipios/31MUE250GC_SIR.shp')

mg_mapa <- readOGR('dados/mapas/mg_municipios/31MUE250GC_SIR.shp',
                   layer = '31MUE250GC_SIR')

mg_mapa_data <- data.frame(mg_mapa)

mg_mapa <- tidy(mg_mapa, region = "CD_GEOCMU")

# Para adicionar os nomes dos municípios
mg_mapa <- left_join(mg_mapa, mg_mapa_data, by = c("id" = "CD_GEOCMU"))

ggplot(mg_mapa, aes(x = long, y = lat, group = group)) +
  geom_polygon(color = 'black', fill = 'white', size = 0.1) +
  coord_quickmap()

# dados que serão plotados
REM_RAIS_MG_2015 <- read_delim('dados/REM_RAIS_MG_2015.csv',
                               delim = ";",
                               col_types = 'cd',
                               skip = 1,
                               col_names = c("Mun.Trab", "mediana"),
                               locale = locale(encoding = 'ISO-8859-1'))

REM_RAIS_MG_2015 <- REM_RAIS_MG_2015 %>%
  mutate(mediana = ifelse(mediana > 1500, 1500, mediana))
head(REM_RAIS_MG_2015)

# plotando...
mg_mapa <- mg_mapa %>%
  mutate(Mun.Trab = substr(id, 1, 6))

mg_mapa <- left_join(mg_mapa, REM_RAIS_MG_2015, by = "Mun.Trab")

cores.viridis <- viridis::viridis(n = 20)
ggplot(mg_mapa, aes(x = long, y = lat, group = group, fill = mediana)) +
  geom_polygon(color = 'black', size = 0.1) +
  scale_fill_gradientn(colours = cores.viridis,
                       breaks = c(800, 1150, 1500),
                       labels = c("\u2264 800", "1.150", "\u2265 1.500")) +
  labs(title = "Mediana da Remuneração ",
       subtitle = "Minais Gerais - Dezembro/2015. Valores em R$",
       caption = "Fonte: RAIS/MTE") +
  coord_quickmap() +
  theme(axis.text.x = element_blank(),
        axis.text.y = element_blank(),
        axis.title.x = element_blank(),
        axis.title.y = element_blank())

# simplificando o shapefile para tornar a renderização mais leve
library(rgeos)

mg_mapa <- readOGR('dados/mapas/mg_municipios/31MUE250GC_SIR.shp',
                   layer = '31MUE250GC_SIR')

df <- data.frame(mg_mapa)
mg_mapa <- gSimplify(mg_mapa, tol=0.01, topologyPreserve = TRUE)
mg_mapa = SpatialPolygonsDataFrame(mg_mapa, data=df)

mg_mapa <- tidy(mg_mapa, region = "CD_GEOCMU")

# Para adicionar os nomes dos municípios
mg_mapa <- left_join(mg_mapa, mg_mapa_data, by = c("id" = "CD_GEOCMU"))

ggplot(mg_mapa, aes(x = long, y = lat, group = group)) +
  geom_polygon(color = 'black', fill = 'white', size = 0.1) +
  coord_quickmap()

# Encoding dos dados do shapefile
mg_mapa <- readOGR('dados/mapas/mg_municipios/31MUE250GC_SIR.shp',
                   layer = '31MUE250GC_SIR')
mg_mapa@data$NM_MUNICIP <- iconv(mg_mapa@data$NM_MUNICIP,
                                 from = "UTF-8",
                                 to = "ISO-8859-1")

#--------------------------------------------------------------------------------------------
# 9.19 Salvando gráficos

knitr::include_graphics('images/salvar_plot.gif')

# ou

ggsave(filename, plot = last_plot(), device = NULL, path = NULL,
       scale = 1, width = NA, height = NA, units = c("in", "cm", "mm"),
       dpi = 300, limitsize = TRUE, ...)

#--------------------------------------------------------------------------------------------
# 9.20 Extensões do ggplot2

# Galeria: http://www.ggplot2-exts.org/gallery/

# ggrepel
library(ggrepel)
data(mtcars)

ggplot(mtcars, aes(wt, mpg)) +
  geom_point(color = 'red') +
  geom_text_repel(aes(label = rownames(mtcars))) +
  theme_ipsum(plot_title_size = 12,
              axis_title_size = 10)

# gganimate
install.packages("devtools")
install.packages("gganimate")

library(devtools)
devtools::install_github("dgrtwo/gganimate")

library(gganimate)

p <- ggplot(gapminder, aes(x = gdpPercap, y = lifeExp,
                           size = pop, color = continent,
                           frame = year)) +
  geom_point() +
  scale_x_log10()

animation::ani.options(interval = 1)
x <- gganimate(p, filename = 'images/gapminder1.gif',
               ani.width = 750,
               ani.height = 450)

# suavizando a animação com o tweenr
library(tweenr)

years <- unique(gapminder$year)
gapminder_list <- list()
for(i in 1:length(years)){
  j <- years[i]
  gapminder_list[[i]] <- gapminder %>%
    filter(year == j)
}

tf <- tween_states(gapminder_list,
                   tweenlength = 2,
                   statelength = 0,
                   ease = rep("linear", length(gapminder_list)),
                   nframes = 308)

tf2 <- expand.grid(y = 80, x = 10^(2.5), year = seq(1957, 2007, 5))
tf2 <- split(tf2, tf2$year)
tf2 <- tween_states(tf2,
                    tweenlength = 2,
                    statelength = 0,
                    ease = rep("linear", length(tf2)),
                    nframes = 308)
tf2 <- tf2 %>%
  mutate(year = rep(seq(1957, 2007, 5), each = 29)[1:310])

p2 <- ggplot(tf,
             aes(x=gdpPercap, y=lifeExp, frame = .frame)) +
  geom_point(aes(size=pop, color=continent), alpha=0.8) +
  geom_text(data = tf2, aes(x = x, y = y, label = year)) +
  xlab("GDP per capita") +
  ylab("Life expectancy at birth") +
  scale_x_log10()
animation::ani.options(interval = 1/20)
x <- gganimate(p2, filename = 'images/gapminder2.gif',
               ani.width = 750,
               ani.height = 450,
               title_frame = FALSE)


#######DESCRIPTION###############################
#fits 'rating curves' between oserved downstream discharge and upstream stage
#fits 'rating curves' between calcuated discharge and upstream stage
#saves as rdata object for use in flood forecasting code
#################################################
##load libraries
library(tools)
library(ncdf4)
library(dplyr)
library(data.table)
library(ggplot2)
library(minpack.lm)
library(hydroGOF)
library(R.utils)
library(scales)
library(RColorBrewer)
nlc = nls.control(maxiter = 1000)

##user inputs
#processed data location
dir_dat = '/Volumes/gonggong/flood forecasting/data/'
#reference table location
dir_ref = '/Volumes/gonggong/flood forecasting/data/reference tables/'
#plot location (if desired)
dir_plots = '/Users/danbroman/Google Drive/Graduate School/Flood Forecasting/'
npts_thresh = 20
nse_thresh = 0.3
#subset list...fit only for set of stations
subset_list = c('001-MGD4PTN', '015-mgd4ptn', '007-mgd4ptn', '002-MGD4PTN', '006-mgd4ptn', '005-mgd4ptn', '004-MGD4PTN', '029-mgd5ptn', '024-MGD4PTN', '023-mgd4ptn', '022-mgd4ptn', '025-mgd4ptn', '019-mgd4ptn')

##read in data
discharge_dat = data.table(readRDS(file.path(dir_dat, 'discharge_obs.rda')))
stage_dat = readRDS(file.path(dir_dat, 'stage.rda'))

stage_weight_tbl = readRDS(file.path(dir_ref, 'stage_weight_tbl.rda'))

##mutate data
#grabs stage data closest to noon
stage_dat_6hr = stage_dat %>% dplyr::filter(hour %in% c(6:18)) %>% dplyr::mutate(hour_min = hour - 12) %>% group_by(year, month, day, sta_id) %>% dplyr::slice(which.min(hour_min)) %>% ungroup() %>% dplyr::select(date, sta_id, basin, stage) %>% dplyr::mutate(date = as.Date(date)) %>% data.table()

discharge_dat = discharge_dat %>% dplyr::mutate(date = as.Date(date)) %>% dplyr::filter(flow >= 0)

#fit rating curves...use downstream discharge only
sta_id_set = stage_dat_6hr %>% distinct(sta_id) %>% dplyr::select(sta_id, basin)
rating_curve_set = data.table(sta_id_set, lag = rep(0:20, each = nrow(sta_id_set)))

rating_curve_tbl = NULL
for(i in 1:nrow(rating_curve_set)){
	rating_curve_set_temp = rating_curve_set[i]
	sta_id_temp = rating_curve_set_temp$sta_id
	basin_temp = rating_curve_set_temp$basin
	sta_id_ds_temp = paste(basin_temp, 'discharge', sep = '_')
	lag_temp = rating_curve_set_temp$lag
	# scale_temp = stage_weight_tbl %>% dplyr::filter(sta_id == sta_id_ds_temp, sta_id_us == sta_id_temp) %>% dplyr::select(scale) %>% as.numeric()
	scale_temp = 1
	stage_dat_temp = stage_dat_6hr %>% dplyr::filter(sta_id == sta_id_temp) %>% dplyr::mutate(date = date - lag_temp)
	discharge_dat_temp = discharge_dat %>% dplyr::filter(basin == basin_temp)
	stage_discharge_dat_temp = stage_dat_temp %>% left_join(discharge_dat_temp) %>% dplyr::filter(!is.na(stage), !is.na(flow))
	rating_curve_temp = data.table(sta_id = sta_id_us_temp, lag = lag_temp, C = NA, a = NA, n = NA, nse = NA, scale = scale_temp, sta_id_ds = sta_id, npts = NA, err = NA)
	if(scale_temp <= 1 & !is.na(scale_temp) & nrow(stage_discharge_dat_temp) > 0){
		fit_dat = data.frame(dplyr::select(stage_discharge_dat_temp, flow, stage)) %>% dplyr::mutate(flow = flow / 1000) #pulls out just stage and flow; divides flow by 1000
		power.nls = try(nlsLM(flow~C*(stage+a)^n, data = fit_dat, start = list(C=1, a=0, n=1), control = nlc)) #fits function; optimize using nonlinear least squares
		if(class(power.nls) != 'try-error'){
			fit_pred = predict(power.nls)
			nse_skill = round(NSE(fit_pred, fit_dat$flow), 4)
			npts = nrow(fit_dat)
			err = (1 / npts) * sum((fit_dat$flow - fit_pred)^2)
			rating_curve_temp = data.table(sta_id = sta_id_temp, lag = lag_temp, C = coef(power.nls)["C"], a = coef(power.nls)["a"], n = coef(power.nls)["n"], nse = nse_skill, npts = nrow(fit_dat), scale = scale_temp, sta_id_ds = paste(basin_temp, 'discharge', sep = '_'), npts = npts, err = err)  #stores current station rating curve values
		}

	}
	rating_curve_tbl = bind_rows(rating_curve_tbl, rating_curve_temp)	#stores all rating curve values
	}
}

#calculate optimal lag using dischage only...filter using min npts and nse
rating_curve_opt_tbl = rating_curve_tbl %>% group_by(sta_id) %>% dplyr::filter(npts >= npts_thresh, nse >= nse_thresh) %>% dplyr::slice(which.max(nse)) %>% data.table()

saveRDS(rating_curve_tbl, paste0(dir_dat, 'rating_curve_discharge.rda'))
saveRDS(rating_curve_opt_tbl, paste0(dir_dat, 'rating_curve_opt_discharge.rda'))

# rating_curve_opt_tbl = readRDS(paste0(dir_dat, 'rating_curve_opt_discharge.rda'))
#calculate discharge using optimal rating curve
rating_curve_tbl = readRDS(paste0(dir_dat, 'rating_curve_discharge.rda'))
discharge_calc_dat = stage_dat_6hr %>% left_join(rating_curve_opt_tbl) %>% dplyr::filter(!is.na(C)) %>% dplyr::mutate(flow = C*(stage+a)^n * 1000 * scale) %>% dplyr::select(sta_id, sta_id_ds, lag, date, basin, flow, nse)

saveRDS(rating_curve_opt_tbl, paste0(dir_dat, 'rating_curve_opt_discharge.rda'))

#fit rating curves...daisy chain upstream
stage_weight_tbl = stage_weight_tbl %>% dplyr::filter(!sta_id %in% c('ganges_discharge', 'brahmaputra_discharge', 'meghna_discharge'))
rating_curve_us_set = data.table(stage_weight_tbl, lag = rep(0:20, each = nrow(stage_weight_tbl)))
rating_curve_us_set = rating_curve_us_set %>% dplyr::filter(sta_id %in% subset_list)

rating_curve_us_tbl = NULL
for(i in 1:nrow(rating_curve_us_set)){
	rating_curve_set_temp = rating_curve_us_set[i]
	sta_id_temp = rating_curve_set_temp$sta_id
	sta_id_us_temp = rating_curve_set_temp$sta_id_us
	lag_temp = rating_curve_set_temp$lag
	# scale_temp = rating_curve_set_temp$scale
	scale_temp = 1
	stage_dat_temp = stage_dat_6hr %>% dplyr::filter(sta_id == sta_id_us_temp) %>% dplyr::mutate(date = date - lag_temp) %>% dplyr::select(date, stage, basin)

	discharge_calc_sta_id_ds = discharge_calc_dat %>% dplyr::filter(sta_id == sta_id_temp) %>% dplyr::select(sta_id_ds, nse) %>% dplyr::slice(which.max(nse)) %>% dplyr::select(sta_id_ds) %>% as.character()
	discharge_calc_dat_temp = discharge_calc_dat %>% dplyr::filter(sta_id == sta_id_temp, sta_id_ds == discharge_calc_sta_id_ds) %>% dplyr::select(sta_id, date, flow) %>% data.table()

	stage_discharge_dat_temp = stage_dat_temp %>% left_join(discharge_calc_dat_temp) %>% dplyr::filter(!is.na(stage), !is.na(flow))

	rating_curve_temp = data.table(sta_id = sta_id_us_temp, lag = lag_temp, C = NA, a = NA, n = NA, nse = NA, scale = scale_temp, sta_id_ds = sta_id, npts = NA, err = NA)

	if(scale_temp <= 1 & !is.na(scale_temp) & nrow(stage_discharge_dat_temp) > 0){
		fit_dat = data.frame(dplyr::select(stage_discharge_dat_temp, flow, stage, basin, date)) %>% dplyr::mutate(flow = flow / 1000) #pulls out just stage and flow; divides flow by 1000
		power.nls = try(nlsLM(flow~C*(stage+a)^n, data = fit_dat, start = list(C=1, a=0, n=1), control = nlc)) #fits function; optimize using nonlinear least squares
		if(class(power.nls) != 'try-error'){
			fit_pred = predict(power.nls)
			nse_skill = round(NSE(fit_pred, fit_dat$flow), 4)
			npts = nrow(fit_dat)
			err = (1 / npts) * sum((fit_dat$flow - fit_pred)^2)
			rating_curve_temp = data.table(sta_id = sta_id_us_temp, lag = lag_temp, C = coef(power.nls)["C"], a = coef(power.nls)["a"], n = coef(power.nls)["n"], nse = nse_skill, npts = nrow(fit_dat), scale = scale_temp, sta_id_ds = sta_id_temp, npts = npts, err = err)  #stores current station rating curve values
			discharge_calc_temp = data.table(fit_dat, rating_curve_temp) %>% dplyr::mutate(flow = C*(stage+a)^n * 1000 * scale_temp) %>% dplyr::select(sta_id, sta_id_ds, lag, date, basin, flow, nse)
			discharge_calc_dat = discharge_calc_dat %>% bind_rows(discharge_calc_temp)
		}
	}
	rating_curve_us_tbl = rbind_list(rating_curve_us_tbl, rating_curve_temp)	#stores all rating curve values

}

saveRDS(rating_curve_us_tbl, paste0(dir_dat, 'rating_curve_upstream-bagmati-kosi.rda'))
saveRDS(discharge_calc_dat, paste0(dir_dat, 'discharge_calculated-bagmati-kosi.rda'))

rating_curve_mg_tbl = rating_curve_us_tbl %>% bind_rows(rating_curve_tbl)
saveRDS(rating_curve_mg_tbl, paste0(dir_dat, 'rating_curve_all-bagmati-kosi.rda'))

# test = discharge_calc_dat %>% dplyr::filter(sta_id_ds == 'ganges_discharge', sta_id == '001-lgd3beh')
# test2 = discharge_dat %>% dplyr::filter(basin == 'ganges', date >= as.Date('2015-05-15'))
# ggplot() + geom_point(data = test, aes(x = date, y = flow)) + geom_point(data = test2, aes(x = date, y = flow), colour = 'red')


\name{plot.PA_result}
\alias{plot.PA_result}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
 Plotting the estimated attachment function
}
\description{
    This function plots the estimated attachment function from the corrected Newman's method or the Jeong's method. Its also plots additional information such as the estimated attachment exponenent (\eqn{\alpha} when assuming \eqn{A_k = k^\alpha}).
}
\usage{
\method{plot}{PA_result}(x,
     net_stat    = NULL,
     plot_bin    = TRUE   ,
     high_deg    = 1      ,
     line        = FALSE  ,
     col_point   = "black",
     shade_point = 0.5    ,
     pch         = 16     ,
     max_A       = NULL   ,
     min_A       = NULL   ,
     label_x     = NULL   ,
     label_y     = NULL   ,
     ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{x}{
    An object of class \code{PA_result}, containing the estimated attachment function and the estimated attachment exponenet from either \code{\link{Newman}} or \code{\link{Jeong}} functions.
  }
  \item{net_stat}{
    An object of class \code{PA_data}, containing the summerized statistics. This object is created from the function \code{\link{get_statistics}}.
  }
  \item{plot_bin}{Logical. If \code{TRUE} then only the center of each bin is plotted. Default is \code{TRUE}.}
  \item{high_deg}{Integer. Specifies the starting degree from which \eqn{A_k} is plotted. If this parameter is specified, the estimated attachment function is plotted from \code{k = high_deg}}
  \item{line}{
    Logical. Indicates whether to plot the line fitted from the log-linear model or not. Default value is \code{FALSE}.
  }
  \item{col_point}{String. The name of the color of the points. Default value is \eqn{"black"}.}
  \item{shade_point}{
    Numeric. Value between \code{0} and \code{1}. This is the transparency level of the points. Default value is \code{0.5}.
  }
\item{pch}{Numeric. The plot symbol. Default value is \code{16}.}
  \item{max_A}{Numeric. Specify the maximum of the horizontal axis.}
  \item{min_A}{Numeric. Specify the minimum of the horizontal axis.}
  \item{label_x}{String. The label of x-axis. If \code{NULL}, then \code{"Degree k"} is used.}
  \item{label_y}{String. The label of y-axis. If \code{NULL}, then \code{"Attachment function"} is used.}
    \item{\dots}{
    %%     ~~Describe \code{\dots} here~~
  }
}
\value{
  Outputs the desired plot.
}
\author{
  Thong Pham \email{thongphamthe@gmail.com}
}

\examples{
  library("PAFit")
  net        <- generate_net(N = 1000 , m = 1 , mode = 1 , alpha = 1 , s = 0)
  net_stats  <- get_statistics(net)
  result     <- Newman(net, net_stats)
  # true function
  true_A     <- result$center_k
  # plot the estimated attachment function
  plot(result , net_stats)
  lines(result$center_k, true_A, col = "red") # true attachment function
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")
}


#  James Rekow

subgroupMatcher = function(partition1, partition2){

  #  ARGS: partition1 - a partition of a numerical vector of indices. A list of vectors whose elements
  #                     are all distinct and whose union is a set A.
  #        partition2 - another partition of A.
  #
  #  RETURNS: partition2Ordered  - a partition list with the same elements (numerical vectors of indices)
  #                                as partition2, but in an order such that the ith vector in the list
  #                                corresponds to the ith vector in partition1. Corresponds in the sense that
  #                                the total number of indices placed in different subgroups than those
  #                                in partition1 is minimized

  #  TODO: add a method argument with two options, Jaccard index, and misallocated elements

  library(gtools)
  source("subgroupDifferences.r")

  #  compute number of subgroups in each partition
  numSubgroups1 = length(partition1)
  numSubgroups2 = length(partition2)

  #  create a matrix whose rows are the permutations of 1:numSubgroups 2
  partition2Permutations = permutations(n = numSubgroups2, r = numSubgroups2)

  computeSubgroupDiff = function(perm){

    #  ARGS: perm - numeric vector that is a permutation of 1:numSubgroups2
    #
    #  RETURNS: subgroupDiff - number of differences between partition1 and this permutation of partition2

    #  compute permutation of partition2
    partition2Perm = partition2[perm]

    #  compute differences between permutation of partition2 and partition1
    subgroupDiff = subgroupDifferences(partition1 = partition1, partition2 = partition2Perm)

    return(subgroupDiff)

  } #  end computeSubgroupDiff function

  #  compute the number of differences between partition1 and each permutation of partition2
  subgroupDiffs = apply(partition2Permutations, 1, computeSubgroupDiff)

  #  find the row number of the permutation that gives the minimum number of subgroup differences
  minDiffIx = which.min(subgroupDiffs)

  #  identify optimal permutation of partition2
  optimalPerm = partition2Permutations[minDiffIx, ]

  #  order subgroups in partition2 according to optimal permutation
  partition2Ordered = partition2[optimalPerm]

  return(partition2Ordered)

} #  end subgroupMatcher function


barplot(table(mtcars$mpg), main = "All")
# should capture all plots in this loop
for (numcyl in levels(as.factor(mtcars$cyl))) {
  barplot(table(mtcars$mpg[mtcars$cyl == numcyl]), main = paste("cyl = ", numcyl))
}


context("Munch")

test_that("interp works", {
    single_interp_test <- function(start, end, n) {
        i <- interp(start, end, n)
        info <- paste0("start: ", start, "; end: ", end, "; n: ", n)
        expect_equal(length(i), n, info = info)
        expect_true(start %in% i, info = info)
        expect_false(end %in% i, info = info)
        expect_true(all(i >= start), info = info)
        expect_true(all(i <= end), info = info)
    }
    single_interp_test(0, 1, 1)
    single_interp_test(0, 1, 2)
    single_interp_test(0, 1, 7)
    single_interp_test(-23, 56, 1)
    single_interp_test(-23, 56, 4)
    single_interp_test(31.276, 34.443, 1)
    single_interp_test(31.276, 34.443, 100)
})

test_that("munch_data works", {
    single_munch_test <- function(data, dist=NULL, segment_length = 0.01) {
        md <- munch_data(data, dist, segment_length)
        # all rows of dat are in md
        expect_equal(nrow(merge(md, dat)), nrow(dat))
        expect_true(nrow(md) >= nrow(dat))
    }
    dat <- data_frame(x =     c(0,  60, 30, 20, 40, 45),
                      y =     c(1,  1,  2,  2,  2,  2),
                      group = c(1L, 1L, 1L, 2L, 2L, 2L))
    dist <- dist_euclidean(dat$x, dat$y)
    dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA
    single_munch_test(dat, dist)
    single_munch_test(dat, dist, segment_length = 10)
    single_munch_test(dat, dist, segment_length = 100)
    dist <- coord_polar(theta = "x")$distance(dat$x, dat$y,
                           list(r.range = range(c(0,dat$y)),
                                theta.range = range(dat$x)))
    dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA
    single_munch_test(dat, dist)
    single_munch_test(dat, dist, segment_length = 10)
    single_munch_test(dat, dist, segment_length = 100)
    dist <- coord_polar(theta = "y")$distance(dat$x, dat$y,
                           list(r.range = range(c(0,dat$x)),
                                theta.range = range(dat$y)))
    dist[dat$group[-1] != dat$group[-nrow(dat)]] <- NA
    single_munch_test(dat, dist)
    single_munch_test(dat, dist, segment_length = 10)
    single_munch_test(dat, dist, segment_length = 100)
})


library(dplyr)
filter(iris,iris$Sepal_Length>2.5)#Sepal_Length>2.5
summarise(iris,mean(iris$Sepal_Length), mean(iris$Sepal_Width),mean(iris$Petal_Length),mean(iris$Petal_Width)) #mean
filter(emp,emp$Dept_Id==dept$Dept_Id)
inner_join(emp,dept,by="Dept_Id")
left_join(emp,dept,by="Dept_Id")
right_join(emp,dept,by="Dept_Id")
full_join(emp,dept,by="Dept_Id")

R Community/R DaraManipulation Assignments/Assignment4.r


 DSBGV Example Program Results

 Eigenvalues
       -0.8305    -0.6401     0.0992     1.8525


######################### SCRIPT 0: SUPPORTING FUNCTIONS #########################

runModel = function(indexu,indexk,NITERATION)
{
  dataset=list(
    N=dim(data0)[1],
    Kk=length(indexk),
    nk=data0[,indexk],
    Ku=length(indexu),
    nu=data0[,indexu],
    Sk=knownpop$real_data[indexk],
    Su=rep(NA,length(indexu)))

  initialisation=list(lambda=0.1)
  jagmod=jags.model(textConnection(model1),data=dataset,inits=initialisation,n.chains=2)
  update(jagmod, n.iter=5000, progress.bar="text")
  posterior = coda.samples(jagmod, c("alpha","lambda","tau","Su"),n.iter=NITERATION,progress.bar="text",thin=10)
  dicsamples = dic.samples(jagmod,type = "pD",n.iter=20000,thin=10)
  results = list(indexk=indexk,indexu=indexu,dataset = dataset,posterior=posterior,dicsamples=dicsamples)
  return(results)
}

runModel_te = function(indexu,indexk,NITERATION,x)
{
  dataset=list(
    N=dim(data0)[1],
    Kk=length(indexk),
    nk=data0[,indexk],
    Ku=length(indexu),
    nu=data0[,indexu],
    Sk=knownpop$real_data[indexk],
    Su=rep(NA,length(indexu)),
    x=x)

  initialisation=list(lambda=0.1)
  jagmod=jags.model(textConnection(model2),data=dataset,inits=initialisation,n.chains=2)
  update(jagmod, n.iter=5000, progress.bar="text")
  posterior = coda.samples(jagmod, c("alpha","lambda",'beta','sigma',"tau","Su"),n.iter=NITERATION,progress.bar="text",thin=10)
  dicsamples = dic.samples(jagmod,type = "pD",n.iter=20000,thin=10)

  results = list(indexk=indexk,indexu=indexu,dataset = dataset,posterior=posterior,dicsamples=dicsamples)

  return(results)
}

runModel_te_be = function(indexu,indexk,NITERATION,x)
{
  dataset=list(
    N=dim(data0)[1],
    Kk=length(indexk),
    nk=data0[,indexk],
    Ku=length(indexu),
    nu=data0[,indexu],
    Sk=knownpop$real_data[indexk],
    Su=rep(NA,length(indexu)),
    x=x,
    age=demo$age-40.5,
    sex=demo$sex-0.49,
    malay=demo$malay-0.15,
    indian=demo$indian-0.07)

  initialisation=list(lambda=0.1)
  jagmod=jags.model(textConnection(model3),data=dataset,inits=initialisation,n.chains=2)
  update(jagmod, n.iter=5000, progress.bar="text")
  posterior = coda.samples(jagmod, c("alpha","lambda",'beta','sigma','sigmab',"tau","Su","b1u","b2u","b3u",'b4u',"b1k","b2k",'b3k','b4k'),n.iter=NITERATION,progress.bar="text",thin=10)
  dicsamples = dic.samples(jagmod,type = "pD",n.iter=20000,thin=10)

  results = list(indexk=indexk,indexu=indexu,dataset = dataset,posterior=posterior,dicsamples=dicsamples)
  return(results)
}

### Models

model1 = 'model {

for(i in 1:N)

{

  for(k in 1:Ku)

  {

  nu[i,k] ~ dpois(lambda*alpha[i]*Su[k])

  }

  for(k in 1:Kk)

  {

  nk[i,k] ~ dpois(lambda*alpha[i]*Sk[k])

  }

  alpha[i]~dlnorm(0,tau)

}

for(k in 1:Ku)

{

  Su[k]~dunif(0,2500000)

}

for(k in 1:Kk)

{

  Sk[k]~dunif(0,2500000)

}

lambda ~ dunif(0,10)

tau ~ dunif(0,10)

}
'

model2 ='model {

for(i in 1:N)

{

  for(k in 1:Ku)

  {

  nu[i,k] ~ dpois(lambda*alpha[i]*exp(beta[k]*x[i,k])*Su[k])

  }

  for(k in 1:Kk)

  {

  nk[i,k] ~ dpois(lambda*alpha[i]*Sk[k])

  }

  alpha[i]~dlnorm(0,tau)

}

for(k in 1:Ku)

{

  Su[k]~dunif(0,2500000)

}

for(k in 1:Kk)

{

  Sk[k]~dunif(0,2500000)

}

for(k in 1:Ku)

{

  beta[k]~dnorm(0,(1/sigma)^2)

}

lambda ~ dunif(0,10)

tau ~ dunif(0,10)

sigma ~ dgamma(1,0.01)
}
'

model3 = 'model {

for(i in 1:N)

{

  for(k in 1:Ku)

  {

  nu[i,k] ~ dpois(lambda*alpha[i]*exp(beta[k]*x[i,k])*exp(b1u[k]*age[i])*exp(b2u[k]*sex[i])*exp(b3u[k]*malay[i])*exp(b4u[k]*indian[i])*Su[k])

  }

  for(k in 1:Kk)

  {

  nk[i,k] ~ dpois(lambda*alpha[i]*exp(b1k[k]*age[i])*exp(b2k[k]*sex[i])*exp(b3k[k]*malay[i])*exp(b4k[k]*indian[i])*Sk[k])

  }

  alpha[i]~dlnorm(0,tau)

}

for(k in 1:Ku)

{

  Su[k]~dunif(0,2500000)

}

for(k in 1:Kk)

{

  Sk[k]~dunif(0,2500000)
  b1k[k]~dnorm(0,(1/sigmab)^2)
  b2k[k]~dnorm(0,(1/sigmab)^2)
  b3k[k]~dnorm(0,(1/sigmab)^2)
  b4k[k]~dnorm(0,(1/sigmab)^2)
}

for(k in 1:Ku)

{

  beta[k]~dnorm(0,(1/sigma)^2)
  b1u[k]~dnorm(0,(1/sigmab)^2)
  b2u[k]~dnorm(0,(1/sigmab)^2)
  b3u[k]~dnorm(0,(1/sigmab)^2)
  b4u[k]~dnorm(0,(1/sigmab)^2)
}

lambda ~ dunif(0,10)

tau ~ dunif(0,10)

sigma ~ dgamma(1,0.01)
sigmab ~ dgamma(1,0.01)
}
'


 C05AZ Example Program results:

 Iterations

 X =  0.00000  FX=   1.0000e+00   IND =  2
 X =  1.00000  FX=  -6.3212e-01   IND =  3
 X =  0.61270  FX=  -7.0814e-02   IND =  4
 X =  0.56707  FX=   1.1542e-04   IND =  4
 X =  0.56714  FX=  -9.4481e-07   IND =  4
 X =  0.56713  FX=   1.4727e-05   IND =  4
 X =  0.56714  FX=  -9.4481e-07   IND =  4

 Solution

 X =  0.56714 Y =  0.56713


#@author: Romeo Kienzler
#This file is copyright protected - do not redistribute

library(ggplot2)
attach(mtcars)

qplot(wt,mpg, data = mtcars)

transmission = factor(mtcars$am,levels = c(0,1), labels = c("Automatic","Manual"))
mod=lm(wt~mpg,data=mtcars)
qplot(wt,mpg,
      data= mod,
      color=transmission,
      shape=transmission,
      #geom="smooth",
      geom=c("point","smooth"),
      #method="lm", formula=y~x,
      xlab = "Weight",
      ylab= "Miles per Gallon",
      main = "Regression Example")


# https://fredhelp.stlouisfed.org/fred/data/understanding-the-data/recession-bars/
# http://www.nber.org/cycles/cyclesmain.html

if (!require(ggplot2)) install.packages('ggplot2')
library(ggplot2)

unrate = getSymbols('UNRATE',src='FRED', auto.assign=F)
unrate.df = data.frame(date=time(unrate), coredata(unrate) )

recessions.df = read.table(textConnection(
"Peak, Trough
1857-06-01, 1858-12-01
1860-10-01, 1861-06-01
1865-04-01, 1867-12-01
1869-06-01, 1870-12-01
1873-10-01, 1879-03-01
1882-03-01, 1885-05-01
1887-03-01, 1888-04-01
1890-07-01, 1891-05-01
1893-01-01, 1894-06-01
1895-12-01, 1897-06-01
1899-06-01, 1900-12-01
1902-09-01, 1904-08-01
1907-05-01, 1908-06-01
1910-01-01, 1912-01-01
1913-01-01, 1914-12-01
1918-08-01, 1919-03-01
1920-01-01, 1921-07-01
1923-05-01, 1924-07-01
1926-10-01, 1927-11-01
1929-08-01, 1933-03-01
1937-05-01, 1938-06-01
1945-02-01, 1945-10-01
1948-11-01, 1949-10-01
1953-07-01, 1954-05-01
1957-08-01, 1958-04-01
1960-04-01, 1961-02-01
1969-12-01, 1970-11-01
1973-11-01, 1975-03-01
1980-01-01, 1980-07-01
1981-07-01, 1982-11-01
1990-07-01, 1991-03-01
2001-03-01, 2001-11-01
2007-12-01, 2009-06-01"), sep=',',
colClasses=c('Date', 'Date'), header=TRUE)

recessions.trim = subset(recessions.df, Peak >= min(unrate.df$date) )

g = ggplot(unrate.df) + geom_line(aes(x=date, y=UNRATE)) + theme_bw()
g + geom_rect(data=recessions.trim, aes(xmin=Peak, xmax=Trough, ymin=-Inf, ymax=+Inf), fill='pink', alpha=0.2)


"
run simulations using bootstrapped data.
"
source("model_fitting.R")
load("Flu2009.rda")
load("CasosAjustados_Diagnostico.Rda")
library(nloptr)
library(rlist)
library(ggplot2)
library(reshape2)

observed_I = Flu2009$incidence$I
# initialize beta
num_simulations= 3
raw_N = cumsum(observed_I)
lagged_N = lag(raw_N)
lagged_N[1] = 1
beta0 = rep(0.3, length(observed_I)) # rep(mean(observed_I / lagged_N), length(observed_I))
beta_min = min(observed_I / lagged_N)
beta_max = max(observed_I / lagged_N)
model = fit(observed_I, beta0=beta0, beta_min=beta_min, beta_max=beta_max,
                lambda0=1/6, lambda_min=1/8, lambda_max=1/4, alpha=6.4e+13)
simulados = get_expected_I( model$beta, model$N0, model$lambda)
bootstraped_betas = list()
# fit Nicolas's model
for( i in 1:num_simulations){
    # plot reproduction number series
    # R = model$beta / model$lambda
    print(i)
    bootstrapped_residual = bootstrap_samples(simulados, observed_I, 10, 3)
}

df <- data.frame(matrix(unlist(bootstraped_betas), nrow=length(bootstraped_betas), byrow=T))
df <- t(df)
colnames(df) <- c( 1:num_simulations)
rownames(df) <- NULL
df <- melt(df ,  id.vars = "time", variable.name = 'series')
colnames(df) <- c('time', 'series', 'value')
ggplot(df, aes(time,value)) + geom_line(aes(colour = series))


###########################################################
#####     Estimation of IBD scaling profiles to      ######
#####  investigate relationships between regression  ######
#####   beta values and distance class for pairwise  ######
#####  measures of population differentiation and    ######
#####               geographic distances             ######
###########################################################
#####     Script analyzes one species at a time.     ######
#####   Repeat it using the proper input files for   ######
#####                each species                    ######
###########################################################

##### Load required packages #####
library(mmod)
library(geosphere)
library(VPLandscapeGenetics)
library(reshape2)
library(quantreg)
data(VPLandscapeGenetics)

##### Calculate genetic distances #####
## Spotted salamanders
nei.SS <- pairwise_Gst_Nei(genind.SS, linearized = TRUE)
hedrick.SS <- pairwise_Gst_Hedrick(genind.SS, linearized = TRUE)
nei.SS.df <- melt(as.matrix(nei.SS), varnames = c("Pop1", "Pop2"))
hedrick.SS.df <- melt(as.matrix(hedrick.SS), varnames = c("Pop1", "Pop2"))

## Wood frogs
nei.WF <- pairwise_Gst_Nei(genind.WF, linearized = TRUE)
hedrick.WF <- pairwise_Gst_Hedrick(genind.WF, linearized = TRUE)
nei.WF.df <- melt(as.matrix(nei.WF), varnames = c("Pop1", "Pop2"))
hedrick.WF.df <- melt(as.matrix(hedrick.WF), varnames = c("Pop1", "Pop2"))

##### Calculate geographic distances #####
## Spotted salamanders
geoDist.SS <- as.dist(distm(latLong.SS, fun=distGeo))
geoDist.SS <- geoDist.SS/1000
attributes(geoDist.SS)$Labels <- attributes(nei.SS)$Labels
geoDist.SS.df <- melt(as.matrix(geoDist.SS), varnames = c("Pop1", "Pop2"))

## Wood frogs
geoDist.WF <- as.dist(distm(latLong.WF, fun=distGeo))
geoDist.WF <- geoDist.WF/1000
attributes(geoDist.WF)$Labels <- attributes(nei.WF)$Labels
geoDist.WF.df <- melt(as.matrix(geoDist.WF), varnames = c("Pop1", "Pop2"))

##### Assemble data frames for analysis #####
## Spotted salamanders
SS.df <- merge(geoDist.SS.df, nei.SS.df, by = c("Pop1", "Pop2"))
SS.df <- merge(SS.df, hedrick.SS.df, by = c("Pop1", "Pop2"))
colnames(SS.df) <- c("Pop1", "Pop2", "geoDist", "Nei", "Hedrick")
SS.df <- subset(SS.df, geoDist > 0) ## Remove rows with 0 geoDist
SS.df <- SS.df[!duplicated(SS.df$geoDist), ] ## Remove duplicated geographic distances

WF.df <- merge(geoDist.WF.df, nei.WF.df, by = c("Pop1", "Pop2"))
WF.df <- merge(WF.df, hedrick.WF.df, by = c("Pop1", "Pop2"))
colnames(WF.df) <- c("Pop1", "Pop2", "geoDist", "Nei", "Hedrick")
WF.df$geoDist2 <- WF.df$geoDist^2
WF.df <- subset(WF.df, geoDist > 0) ## Remove rows with 0 geoDist
WF.df <- WF.df[!duplicated(WF.df$geoDist), ] ## Remove duplicated geographic distances

###### Set up equations ######
## Spotted salamanders
nei.SS.mod <- lm(Nei ~ geoDist, data = SS.df)
nei.SS.log.mod <- lm(Nei ~ log(geoDist), data = SS.df)
hedrick.SS.mod <- lm(Hedrick ~ geoDist, data = SS.df)
hedrick.SS.log.mod <- lm(Hedrick ~ log(geoDist), data = SS.df)

## Wood frogs
nei.WF.mod <- lm(Nei ~ geoDist, data = WF.df)
nei.WF.log.mod <- lm(Nei ~ log(geoDist), data = WF.df)
hedrick.WF.mod <- lm(Hedrick ~ geoDist, data = WF.df)
hedrick.WF.log.mod <- lm(Hedrick ~ log(geoDist), data = WF.df)

WF.Nei <- WF.df$Nei
WF.geoDist <- WF.df$geoDist
WF.geoDist2 <- WF.df$geoDist2
nei.WF.quadMod <- lm(WF.Nei ~ WF.geoDist + WF.geoDist2) ## Wood frog quadratic model

###### Set up quantile equations ######
## Spotted salamanders
quant95.SS.mod <- rq(Nei ~ geoDist, data=SS.df, tau=.95)
quant05.SS.mod <- rq(Nei ~ geoDist, data=SS.df, tau=.05)

## Wood frogs
quant95.WF.mod <- rq(Nei ~ geoDist + geoDist2, data=WF.df, tau=.95)
quant05.WF.mod <- rq(Nei ~ geoDist + geoDist2, data=WF.df, tau=.05)

###### Perform plotting ######
###### Note: Only Gst plotted due to high similarity between Gst and G''st Mantel tests ######
### Spotted salamanders
plot(SS.df$geoDist, SS.df$Nei, xlab="Pairwise distance (km)", ylab=expression('G'[ST]*'/(1-G'[ST]*')'), pch=20, col="grey50", cex.axis=1.75, cex.lab=1.75, xlim=c(-0.10, 350))
abline(nei.SS.mod, lwd=3, col="black")
abline(quant95.SS.mod, lwd=3, col="black", lty=2)
abline(quant05.SS.mod, lwd=3, col="black", lty=2)

## Wood frogs quadratic model
plot(WF.df$geoDist, WF.df$Nei, xlab="Pairwise distance (km)", ylab=expression('G'[ST]*'/(1-G'[ST]*')'), pch=20, col="grey50", cex.axis=1.75, cex.lab=1.75, xlim=c(-0.10, 350))
geovalues <- seq(0,350, 1)
predictedcounts <- predict(nei.WF.quadMod, list(WF.geoDist = geovalues, WF.geoDist2 = geovalues^2))
lines(geovalues, predictedcounts, col="black", lwd=3)

predictedcounts.quad95 <- predict(quant95.WF.mod, list(geoDist=geovalues, geoDist2=geovalues^2))
lines(geovalues, predictedcounts.quad95, col="black", lwd=3, lty=2)

predictedcounts.quad05 <- predict(quant05.WF.mod, list(geoDist=geovalues, geoDist2=geovalues^2))
lines(geovalues, predictedcounts.quad05, col="black", lwd=3, lty=2)


##############################################
# This R file is used to compare the diff results between CART in R and Python

# step1: read result csv from R and Python, then plot them in one figure
# read result csv from R

# png(file="SQL.png")

data.r <- read.csv("data/SQL-R.csv") # modify #
data.r <- data.r[order(data.r$actual),] # sort by actual attribute
predict1 <- data.r$predict
actual1 <- data.r$actual

windows(width=16,height=4)
par(mfrow=c(1,2))

plot(actual1, type="l", col="green", xlab="configuration index", ylab="performance", main="(a)Performance Prediction Using R")
lines(predict1, type="l", col="blue")

# read result csv from Python
data.python <- read.csv("data/SQL-Python.csv") # modify #
data.python <- data.python[order(data.python$actual),] # sort by actual attribute
actual2 <- data.python$actual
predict2 <- data.python$predict

plot(actual2, type="l", col="green", xlab="configuration index", ylab="performance", main="(b)Performance Prediction Using Python")
lines(predict2, type="l", col="red")

# step2: calculate their mean relative errors

mean.re <- function(actual, predict){
	return (abs(actual - predict)/actual)
}

sum1 <- 0
for(index in nrow(data.r)){
	sum1 <- sum1 + mean.re(data.r$actual[index], data.r$predict[index])
}
acc1 <- 1 - (sum1)/nrow(data.r)

sum2 <- 0
for(index in nrow(data.python)){
	sum2 <- sum2 + mean.re(data.python$actual[index], data.python$predict[index])
}
acc2 <- 1 - (sum2)/nrow(data.python)

cat("[R acc]:", acc1, "[P acc]:", acc2)

# dev.off()


data <- matrix(c(9,17,20,8,12,27), ncol=3, byrow=T)
# Contingency Table
fisher.test(data)
library(vcd)
assocstats(data)


library(ggvis)

mtcars %>% ggvis(x = ~wt, y = ~mpg, fill = ~cyl) %>%
  layer_points()

mtcars %>% ggvis(x = ~wt, y = ~mpg, fill = ~cyl) %>%
  layer_points() %>%
  add_axis("x", title = "Weight")

mtcars %>% ggvis(x = ~wt, y = ~mpg, fill = ~cyl) %>%
  layer_points() %>%
  add_axis("x", title = "Weight", orient = "top")

mtcars %>% ggvis(x = ~wt, y = ~mpg, fill = ~cyl) %>%
  layer_points() %>%
  add_legend("fill", title = "Cylinders")

# Combining two properties in one legend
mtcars %>%
  ggvis(x = ~wt, y = ~mpg, fill = ~factor(cyl), shape = ~factor(cyl)) %>%
  layer_points() %>%
  add_legend(c("fill", "shape"))


create_dtm <- function( path, upper = 0.001, lower = 0.1, stopwords = c('stop_generic_fi.txt', 'stop_generic_fi_lemma.txt' ) ) {

  library(tm)
  library(slam)

  a <- Corpus( DirSource( path, encoding = "UTF-8", recursive = T ) )

  stop <- c()

  for( stopword_file in stopwords ) {

    stopword <- scan( stopword_file , what = list(""), sep = '\n' )
    stop <- c( stop, stopword, recursive=T )

  }

  ## bunch of cleanup and transformations
  a <- tm_map(a, removeNumbers )
  a <- tm_map(a, stripWhitespace )
  a <- tm_map(a, removePunctuation )
  a <- tm_map(a, content_transformer(tolower) )
  a <- tm_map(a, removeWords, stop )

  ## compute word frequencies
  dtm1 <-DocumentTermMatrix(a)

  frequency <- col_sums( dtm1 , na.rm = T )
  frequency <- sort(frequency, decreasing=TRUE)

  ## choose removal boundaries for further data analysis

  upper = floor( length( frequency ) * upper )
  ##upper = Inf
  lower = floor( length( frequency) * ( 1 - lower) )

  upper = frequency[ upper ]
  lower = frequency[ lower ]

  upper = as.integer( upper )
  lower = as.integer( lower ) + 1

  dtm2 = DocumentTermMatrix( a , control = list( bounds = list( global = c( lower, upper ) ) ) )

  ## throw away columns with 0 indicators
  dtm3 <- dtm2[ row_sums( dtm2 ) > 0, ]

  dtm <- dtm3

  return( dtm )

}

create_model <- function( dtm, k ) {

   library(topicmodels)

   ## fix randomness
   set.seed( 1 )

   burnin = 1000
   iter = 1000
   keep = 50

   model <- LDA( dtm , k = k, method = "Gibbs", control =  list(burnin = burnin, iter = iter, keep = keep) )

   return( model )

}

check_fitness_ll <- function( model ) {

  ## TODO: could we just use logLik-methods?

  library(topicmodels)
  library(Rmpfr)

  burnin = 1000
  iter = 1000
  keep = 50

  ll <- model@logLiks[ -c(1:(burnin/keep)) ]

  precision = 2000L
  llMed <- median( ll )
  ll = as.double( llMed - log( mean( exp( -mpfr(ll , prec = precision) + llMed ) ) ) )

  return( ll )

}

check_fitness_model <- function( model ) {

  library(topicmodels)
  library(Rmpfr)

  burnin = 1000
  iter = 1000
  keep = 50

  k <- model@k

  ll <- model@logLiks[ -c(1:(burnin/keep)) ]

  precision = 2000L
  llMed <- median( ll )
  ll = as.double( llMed - log( mean( exp( -mpfr(ll , prec = precision) + llMed ) ) ) )

  return( ll )

}

## from http://www.r-bloggers.com/a-link-between-topicmodels-lda-and-ldavis/

visualize_topicmodel <- function(fitted, corpus, doc_term){
    # Required packages
    library(topicmodels)
    library(dplyr)
    library(stringi)
    library(tm)
    library(LDAvis)

    # Find required quantities
    phi <- posterior(fitted)$terms %>% as.matrix
    theta <- posterior(fitted)$topics %>% as.matrix
    vocab <- colnames(phi)
    doc_length <- vector()
    for (i in 1:length(corpus)) {
        temp <- paste(corpus[[i]]$content, collapse = ' ')
        doc_length <- c(doc_length, stri_count(temp, regex = '\\S+'))
    }
    temp_frequency <- inspect(doc_term)
    freq_matrix <- data.frame(ST = colnames(temp_frequency),
                              Freq = colSums(temp_frequency))
    rm(temp_frequency)

    # Convert to json
    json_lda <- LDAvis::createJSON(phi = phi, theta = theta,
                            vocab = vocab,
                            doc.length = doc_length,
                            term.frequency = freq_matrix$Freq)

    return(json_lda)
}


rm(list = ls())
graphics.off()

my_data <- read.csv("IBM-HR-Emplyee-NoAttrition.csv")
cols <- colnames(my_data)
rownames(my_data) <- my_data$Subj
data1 <- my_data[,11:32]
data1$Age <- my_data$Age

data1$MonthlyIncome <- cut(data1$MonthlyIncome,breaks = c(min(data1$MonthlyIncome)-1,5000 ,10000, max(data1$MonthlyIncome)+1),labels = c(1,2,3))
data1$DailyRate <- cut(data1$DailyRate,breaks = c(min(data1$DailyRate)-1,600 ,1100, max(data1$DailyRate)+1),labels = c(1,2,3))
data1$HourlyRate <- cut(data1$HourlyRate,breaks = c(min(data1$HourlyRate)-1,55 ,80, max(data1$HourlyRate)+1),labels = c(1,2,3))
data1$MonthlyRate <- cut(data1$MonthlyRate,breaks = c(min(data1$MonthlyRate)-1,10000 ,17500, max(data1$MonthlyRate)+1),labels = c(1,2,3))
data1$DistanceFromHome <- cut(data1$DistanceFromHome,breaks = c(min(data1$DistanceFromHome)-1,6 , max(data1$DistanceFromHome)+1),labels = c(1,2))
data1$Education <- cut(data1$Education,breaks = c(min(data1$Education)-1, 2,3 , max(data1$Education)+1),labels = c(1,2,3))
data1$JobInvolvement <- cut(data1$JobInvolvement,breaks = c(min(data1$JobInvolvement)-1,2.5,3.5, max(data1$JobInvolvement)+1),labels = c(1,2,3))
data1$JobLevel <- cut(data1$JobLevel,breaks = c(min(data1$JobLevel)-1,2,4, max(data1$JobLevel)+1),labels = c(1,2,3))
data1$NumCompaniesWorked <- cut(data1$NumCompaniesWorked,breaks = c(min(data1$NumCompaniesWorked)-1, 2,6, max(data1$NumCompaniesWorked)+1),labels = c(1,2,3))
data1$TotalWorkingYears <- cut(data1$TotalWorkingYears,breaks = c(min(data1$TotalWorkingYears)-1, 10, max(data1$TotalWorkingYears)+1),labels = c(1,2))
data1$PercentSalaryHike <- cut(data1$PercentSalaryHike,breaks = c(min(data1$PercentSalaryHike)-1, 13,19, max(data1$PercentSalaryHike)+1),labels = c(1,2,3))
data1$WorkLifeBalance <- cut(data1$WorkLifeBalance,breaks = c(min(data1$WorkLifeBalance)-1, 2, max(data1$WorkLifeBalance)+1),labels = c(1,2))
data1$Age <- cut(data1$Age,breaks = c(min(data1$Age)-1, 30,40, max(data1$Age)+1),labels = c(1,2,3))
data1$TrainingTimesLastYear <- cut(data1$TrainingTimesLastYear,breaks = c(min(data1$TrainingTimesLastYear)-1, 2,4, max(data1$TrainingTimesLastYear)+1),labels = c(1,2,3))
data1$YearsAtCompany <- cut(data1$YearsAtCompany,breaks = c(min(data1$YearsAtCompany)-1, 5,15, max(data1$YearsAtCompany)+1),labels = c(1,2,3))
data1$YearsInCurrentRole <- cut(data1$YearsInCurrentRole,breaks = c(min(data1$YearsInCurrentRole)-1, 4,10, max(data1$YearsInCurrentRole)+1),labels = c(1,2,3))
data1$YearsSinceLastPromotion <- cut(data1$YearsSinceLastPromotion,breaks = c(min(data1$YearsSinceLastPromotion)-1, 2,7, max(data1$YearsSinceLastPromotion)+1),labels = c(1,2,3))
data1$YearsWithCurrManager <- cut(data1$YearsWithCurrManager,breaks = c(min(data1$YearsWithCurrManager)-1, 4,10, max(data1$YearsWithCurrManager)+1),labels = c(1,2,3))
library(corrplot)
data2 <- my_data[,11:32]
data2$Age <- my_data$Age
cor.my_data <- cor(data2)
corrplot(cor.my_data, method = "ellipse")

data1$PerformanceRating <- as.factor(data1$PerformanceRating)
data1$JobInvolvement <- as.factor(data1$JobInvolvement)
data1$StockOptionLevel <- as.factor(data1$StockOptionLevel)
data1$EnvironmentSatisfaction <- as.factor(data1$EnvironmentSatisfaction)
data1$JobSatisfaction <- as.factor(data1$JobSatisfaction)
data1$RelationshipSatisfaction <- as.factor(data1$RelationshipSatisfaction)

resMCA.sym <- epMCA(data1 ,make_data_nominal = TRUE ,DESIGN = my_data$Department ,make_design_nominal = TRUE,graphs = FALSE, symmetric = TRUE)

resMCA.asym <- epMCA(data1 ,make_data_nominal = TRUE ,DESIGN = my_data$Department ,make_design_nominal = TRUE,graphs = FALSE, symmetric = FALSE)

resMCA.inf <- epMCA.inference.battery(data1, make_data_nominal = TRUE, DESIGN = my_data$Department ,make_design_nominal =TRUE,graphs = FALSE)

DESIGN <- list()
DESIGN$rows$Region$labels <- unique(my_data$Department)
DESIGN$rows$Region$vec <- my_data$Department

#Convert the vector to a matrix
DESIGN$rows$Region$mat <- makeNominalData(as.matrix(DESIGN$rows$Region$vec))
automatic_colors <- createColorVectorsByDesign(DESIGN$rows$Region$mat)
DESIGN$rows$Region$color_groups <- c("red","blue","yellow")
DESIGN$rows$Region$color_observ <- as.matrix(DESIGN$rows$Region$vec)

DESIGN$rows$Region$color_observ[which(DESIGN$rows$Region$vec=="Research & Development")]    <- DESIGN$rows$Region$color_groups[1]
DESIGN$rows$Region$color_observ[which(DESIGN$rows$Region$vec=="Human Resources")]       <- DESIGN$rows$Region$color_groups[2]
DESIGN$rows$Region$color_observ[which(DESIGN$rows$Region$vec=="Sales")]     <- DESIGN$rows$Region$color_groups[3]

PlotScree(ev = resMCA.sym$ExPosition.Data$eigs,
          p.ev =  resMCA.inf$Inference.Data$components$p.vals,
          title = 'IBM-No-Attririon data Set. Eigenvalues Inference',
          plotKaiser = TRUE
)

MonthlyIncome1 <- "red"
DailyRate1 <- "pink"
HourlyRate1 <- "blue"
MonthlyRate1 <- "skyblue"
DistanceFromHome1 <- "green"
PerformanceRating1 <- "navyblue"
Education1 <- "darkolivegreen4"
JobInvolvement1 <- "darkgoldenrod3"
JobLevel1 <- "brown"
StockOptionLevel1 <- "orange"
NumCompaniesWorked1 <- "cornflowerblue"
PercentSalaryHike1 <- "chartreuse3"
TotalWorkingYears1 <- "peachpuff3"
TrainingTimesLastYear1 <- "mediumorchid2"
WorkLifeBalance1 <- "turquoise3"
YearsAtCompany1 <- "wheat4"
YearsInCurrentRole1 <-"slategray2"
YearsSinceLastPromotion1 <- "purple"
YearsWithCurrManager1 <- "magenta"
EnvironmentSatisfaction1 <- "teal"
JobSatisfaction1 <- "chromeyellow"
RelationshipSatisfaction1 <- "yellow"
Age1 <- "black"

col4J <- dplyr::recode(resMCA.sym$Plotting.Data$fj.col,
                       'JobLevel1' = JobLevel1 , 'MonthlyIncome1' = MonthlyIncome1, 'DailyRate1' = DailyRate1, 'HourlyRate'=HourlyRate1, 'MonthlyRate' =MonthlyRate1, 'DistanceFromHome'= DistanceFromHome1,
                       'PerformanceRating'= PerformanceRating1, 'Education' =Education1, 'JobInvolvement'=JobInvolvement1, 'StockOptionLevel'=StockOptionLevel1,
                      'NumCompaniesWorked'= NumCompaniesWorked1 ,  'PercentSalaryHike'= PercentSalaryHike1 ,'TotalWorkingYears'= TotalWorkingYears1, 'TrainingTimesLastYear'=TrainingTimesLastYear1,
                     'WorkLifeBalance'=WorkLifeBalance1, 'YearsAtCompany'= YearsAtCompany1, 'YearsInCurrentRole'= YearsInCurrentRole1,
                      'YearsSinceLastPromotion'= YearsSinceLastPromotion1, 'YearsWithCurrManager'=YearsWithCurrManager1 ,'EnvironmentSatisfaction'= EnvironmentSatisfaction1,
                     'JobSatisfaction'=JobSatisfaction1 ,'RelationshipSatisfaction'=RelationshipSatisfaction1,'Age'= Age1 )

## Biplot for symmetrical plot for component 1 and 2 for Department datatype

col4I <- prettyGraphsColorSelection(NCOL(resMCA.sym$Plotting.Data$fj.col))
symMap1  <- createFactorMapIJ(resMCA.sym$ExPosition.Data$fi,resMCA.sym$ExPosition.Data$fj,
                              col.points.i = DESIGN$rows$Region$color_observ,
                              col.points.j = col4I,
                              col.labels.i =  DESIGN$rows$Region$color_observ ,
                              col.labels.j = col4I ,
                              cex.i = 2.5, pch.i = 20,
                              pch.j = 21,  cex.j = 2.5,text.cex.j =2, axis1 = 1,axis2 = 2, title = "Symmetrical plot for components 1 and 2 for Department Type",
                              alpha.axes = 0.2,alpha.points.i = 1)

labels4MCA1 <- createxyLabels(resCA = resMCA.sym, x_axis = 1,y_axis = 2)

map.IJ.sym1 <- symMap1$baseMap + symMap1$I_points
map.IJ.sym2 <- symMap1$baseMap + symMap1$J_labels + symMap1$J_points + labels4MCA1
map.IJ.sym3 <- symMap1$baseMap + symMap1$I_points +
  symMap1$J_labels + symMap1$J_points + labels4MCA1
print(map.IJ.sym1)
print(map.IJ.sym2)
print(map.IJ.sym3)

## Biplot for symmetrical plot for component 2 and 3 for Department datatype

symMap2  <- createFactorMapIJ(resMCA.sym$ExPosition.Data$fi,resMCA.sym$ExPosition.Data$fj,
                              col.points.i = DESIGN$rows$Region$color_observ,
                              col.points.j = "black",
                              col.labels.i = DESIGN$rows$Region$color_observ ,
                              col.labels.j = "black" ,
                              cex.i = 5, pch.i = 20,
                              pch.j = 21,  text.cex.j =2, axis1 = 2,axis2 = 3, title = "Symmetrical plot for components 2 and 3 for Department Type",
                              alpha.axes = 0.2,alpha.points.i = 1)

labels4MCA2 <- createxyLabels(resCA = resMCA.sym, x_axis = 2, y_axis = 3)

map.IJ.sym11 <- symMap2$baseMap + symMap2$I_points
map.IJ.sym21 <- symMap2$baseMap + symMap2$J_labels + symMap2$J_points + labels4MCA2
map.IJ.sym31 <- symMap2$baseMap + symMap2$I_points +
  symMap2$J_labels + symMap2$J_points + labels4MCA2
print(map.IJ.sym11)
print(map.IJ.sym21)
print(map.IJ.sym31)

## Biplot for symmetrical plot for component 1 and 3 for Department datatype

symMap3  <- createFactorMapIJ(resMCA.sym$ExPosition.Data$fi,resMCA.sym$ExPosition.Data$fj,
                              col.points.i = DESIGN$rows$Region$color_observ ,
                              col.points.j = "black",
                              col.labels.i = DESIGN$rows$Region$color_observ  ,
                              col.labels.j = "black" ,
                              cex.i = 5, pch.i = 20,
                              pch.j = 21,  text.cex.j =2, axis1 = 1,axis2 = 3, title = "Symmetrical plot for components 1 and 3 for Department Type",
                              alpha.axes = 0.2,alpha.points.i = 1)

labels4MCA3 <- createxyLabels(resCA = resMCA.sym, x_axis = 1,y_axis = 3)

map.IJ.sym31 <- symMap3$baseMap + symMap3$I_points
map.IJ.sym32 <- symMap3$baseMap + symMap3$J_labels + symMap3$J_points + labels4MCA3
map.IJ.sym33 <- symMap3$baseMap + symMap3$I_points +
  symMap3$J_labels + symMap3$J_points + labels4MCA3
print(map.IJ.sym31)
print(map.IJ.sym32)
print(map.IJ.sym33)

# color for gender
DESIGN1 <- list()
DESIGN1$rows$Region$labels <- unique(my_data$Gender)
DESIGN1$rows$Region$vec <- my_data$Gender

#Convert the vector to a matrix
DESIGN1$rows$Region$mat <- makeNominalData(as.matrix(DESIGN1$rows$Region$vec))
automatic_colors <- createColorVectorsByDesign(DESIGN1$rows$Region$mat)
DESIGN1$rows$Region$color_groups <- c("skyblue","pink")
DESIGN1$rows$Region$color_observ <- as.matrix(DESIGN1$rows$Region$vec)

DESIGN1$rows$Region$color_observ[which(DESIGN1$rows$Region$vec=="Male")]    <- DESIGN1$rows$Region$color_groups[1]
DESIGN1$rows$Region$color_observ[which(DESIGN1$rows$Region$vec=="Female")]       <- DESIGN1$rows$Region$color_groups[2]

# inference

resMCA.sym1 <- epMCA(data1 ,make_data_nominal = TRUE ,DESIGN = my_data$Gender ,make_design_nominal = TRUE,graphs = FALSE, symmetric = TRUE)

resMCA.asym1 <- epMCA(data1 ,make_data_nominal = TRUE ,DESIGN = my_data$Gender ,make_design_nominal = TRUE,graphs = FALSE, symmetric = FALSE)

resMCA.inf1 <- epMCA.inference.battery(data1, make_data_nominal = TRUE, DESIGN = my_data$Gender ,make_design_nominal =TRUE,graphs = FALSE)

## Biplot for symmetrical plot for component 1 and 2 for Gender datatype

symMa  <- createFactorMapIJ(resMCA.sym1$ExPosition.Data$fi,resMCA.sym1$ExPosition.Data$fj,
                              col.points.i = DESIGN1$rows$Region$color_observ,
                              col.points.j = "black",
                              col.labels.i = DESIGN1$rows$Region$color_observ ,
                              col.labels.j = "black" ,
                              cex.i = 2.5, pch.i = 20,
                              pch.j = 21,  cex.j = 2.5,text.cex.j =2, axis1 = 1,axis2 = 2, title = "Symmetrical plot for components 1 and 2 for Gender Type",
                              alpha.axes = 0.2,alpha.points.i = 1)

labels4 <- createxyLabels(resCA = resMCA.sym1, x_axis = 1,y_axis = 2)

map.IJ.sym111 <- symMa$baseMap + symMa$I_points
map.IJ.sym222 <- symMa$baseMap + symMa$J_labels + symMa$J_points + labels4
map.IJ.sym333 <- symMa$baseMap + symMa$I_points +
  symMa$J_labels + symMa$J_points + labels4
print(map.IJ.sym111)
print(map.IJ.sym222)
print(map.IJ.sym333)

## Biplot for symmetrical plot for component 2 and 3 for Gender datatype

symMap21  <- createFactorMapIJ(resMCA.sym1$ExPosition.Data$fi,resMCA.sym1$ExPosition.Data$fj,
                              col.points.i = DESIGN1$rows$Region$color_observ,
                              col.points.j = "black",
                              col.labels.i = DESIGN1$rows$Region$color_observ ,
                              col.labels.j = "black" ,
                              cex.i = 5, pch.i = 20,
                              pch.j = 21,  text.cex.j =2, axis1 = 2,axis2 = 3, title = "Symmetrical plot for components 2 and 3 for Gender Type",
                              alpha.axes = 0.2,alpha.points.i = 1)

labels4MCA22 <- createxyLabels(resCA = resMCA.sym1, x_axis = 2, y_axis = 3)

map.IJ.sym1111 <- symMap21$baseMap + symMap21$I_points
map.IJ.sym211 <- symMap21$baseMap + symMap21$J_labels + symMap21$J_points + labels4MCA22
map.IJ.sym311 <- symMap21$baseMap + symMap21$I_points +
  symMap21$J_labels + symMap21$J_points + labels4MCA22
print(map.IJ.sym1111)
print(map.IJ.sym211)
print(map.IJ.sym311)

## Biplot for symmetrical plot for component 1 and 3 for Gender datatype

```{r}
symMap31  <- createFactorMapIJ(resMCA.sym1$ExPosition.Data$fi,resMCA.sym1$ExPosition.Data$fj,
                              col.points.i = DESIGN1$rows$Region$color_observ,
                              col.points.j = "black",
                              col.labels.i = DESIGN1$rows$Region$color_observ ,
                              col.labels.j = "black" ,
                              cex.i = 5, pch.i = 20,
                              pch.j = 21,  text.cex.j =2, axis1 = 1,axis2 = 3, title = "Symmetrical plot for components 1 and 3 for Gender Type",
                              alpha.axes = 0.2,alpha.points.i = 1)

labels4MCA31 <- createxyLabels(resCA = resMCA.sym1, x_axis = 1,y_axis = 3)

map.IJ.sym311 <- symMap31$baseMap + symMap31$I_points
map.IJ.sym321 <- symMap31$baseMap + symMap31$J_labels + symMap31$J_points + labels4MCA31
map.IJ.sym331 <- symMap31$baseMap + symMap31$I_points +
  symMap31$J_labels + symMap31$J_points + labels4MCA31
print(map.IJ.sym311)
print(map.IJ.sym321)
print(map.IJ.sym331)

## Biplot for asymmetrical plot for component 1

asymMap1  <- createFactorMapIJ(resMCA.asym1$ExPosition.Data$fi,resMCA.asym1$ExPosition.Data$fj,
                               col.points.i = DESIGN1$rows$Region$color_observ,
                               col.points.j = "black",
                               col.labels.i = DESIGN1$rows$Region$color_observ ,
                               col.labels.j = "black" ,
                               cex.i = 5, pch.i = 20,
                               pch.j = 21,  text.cex.j =2,
                               alpha.axes = 0.2,alpha.points.i = 1, axis1 = 1, axis2 = 2, title = " Asymmetrical plot for components 1 and 2")

alabels4MCA1 <- createxyLabels(resCA = resMCA.asym1)

map.IJ.asym1 <- asymMap1$baseMap + asymMap1$I_points +
  asymMap1$J_labels + asymMap1$J_points + alabels4MCA1
print(map.IJ.asym1)

## Bootstrap Interval

constraints.mca <- minmaxHelper(mat1 = resMCA.sym$ExPosition.Data$fi, mat2  = resMCA.sym$ExPosition.Data$fj)

color <- prettyGraphsColorSelection(NCOL(data1))
baseMap.i1 <- createFactorMap(resMCA.sym$ExPosition.Data$fi,constraints = constraints.mca,
                              col.points =  DESIGN$rows$Region$color_observ , axis1 = 1, axis2 = 2,
                              cex = 1, pch = 20,
                              display.labels = FALSE
)
label4Map1 <- createxyLabels.gen(1,2,
                                 lambda =resMCA.sym$ExPosition.Data$eigs,
                                 tau = resMCA.sym$ExPosition.Data$t)

a1 <- baseMap.i1$zeMap + baseMap.i1$zeMap_dots +label4Map1

BootCube.Gr <- Boot4Mean(resMCA.sym$ExPosition.Data$fi,
                         design = my_data$Department,
                         niter = 100,
                         suppressProgressBar = TRUE)
#_____________________________________________________________________
# Bootstrap ratios ----
bootRatios.Gr <- boot.ratio.test(BootCube.Gr$BootCube)
#*********************************************************************
# Mean Map
#  create the map for the means
#  get the means by groups

dataMeans <- getMeans(resMCA.sym$ExPosition.Data$fi, my_data$Department)
# a vector of color for the means
col4data <- DESIGN$rows$Region$color_observ
col4Means <- unique(col4data)
# the map
MapGroup <- createFactorMap(dataMeans,
                            # use the constraint from the main map
                            constraints = constraints.mca,
                            col.points = col4Means,
                            cex = 7,  # size of the dot (bigger)
                            col.labels = col4Means,
                            text.cex = 6)
# The map with observations and group means
a003.Map.I.withMeans <- a1 +
  MapGroup$zeMap_dots + MapGroup$zeMap_text
print(a003.Map.I.withMeans)
#_____________________________________________________________________
# Create the ellipses
# Bootstrapped CI ----
#_____________________________________________________________________
# Create Confidence Interval Plots
# use function MakeCIEllipses from package PTCA4CATA
GraphElli <- MakeCIEllipses(BootCube.Gr$BootCube[,1:2,],
                            names.of.factors = c("Dimension 1","Dimension 2"),
                            col = col4Means,
                            p.level = .95
)
#_____________________________________________________________________
# create the I-map with Observations, means and confidence intervals
#
a004.Map.I.withCI <-  a1 + MapGroup$zeMap_text +  GraphElli
#_____________________________________________________________________
# plot it!
dev.new()
print(a004.Map.I.withCI)

GraphTI.Hull <- PTCA4CATA::MakeToleranceIntervals(resMCA.sym$ExPosition.Data$fi,
                                                   design = my_data$Department,
                                                   # line below is needed
                                                   names.of.factors =  c("Dim1","Dim2"), # needed
                                                   col = col4Means,
                                                   line.size = .50,
                                                   line.type = 3,
                                                   alpha.ellipse = .2,
                                                   alpha.line    = .4,
                                                   p.level       = .75)
#_____________________________________________________________________
# Create the map:
a005.Map.I.withTIHull <-a1 +
  GraphTI.Hull + MapGroup$zeMap_dots +
  MapGroup$zeMap_text + MapGroup$zeMap_dots
#_____________________________________________________________________
# plot it
print(a005.Map.I.withTIHull)

# for gender

constraints.mca1 <- minmaxHelper(mat1 = resMCA.sym1$ExPosition.Data$fi, mat2  = resMCA.sym1$ExPosition.Data$fj)
baseMap.i2 <- createFactorMap(resMCA.sym1$ExPosition.Data$fi,constraints = constraints.mca1,
                              col.points = DESIGN1$rows$Region$color_observ, axis1 = 1, axis2 = 2,
                              cex = 1, pch = 20,
                              display.labels = FALSE
)
label4Map2 <- createxyLabels.gen(1,2,
                                 lambda =resMCA.sym1$ExPosition.Data$eigs,
                                 tau = resMCA.sym1$ExPosition.Data$t)

a2 <- baseMap.i2$zeMap + baseMap.i2$zeMap_dots +label4Map2

BootCube.Gr1 <- Boot4Mean(resMCA.sym1$ExPosition.Data$fi,
                         design = my_data$Gender,
                         niter = 100,
                         suppressProgressBar = TRUE)
#_____________________________________________________________________
# Bootstrap ratios ----
bootRatios.Gr1 <- boot.ratio.test(BootCube.Gr1$BootCube)
#*********************************************************************
# Mean Map
#  create the map for the means
#  get the means by groups

dataMeans1 <- getMeans(resMCA.sym1$ExPosition.Data$fi, my_data$Gender)
# a vector of color for the means
col4data1 <- DESIGN1$rows$Region$color_observ
col4Means1 <- unique(col4data1)
# the map
MapGroup1 <- createFactorMap(dataMeans1,
                            # use the constraint from the main map
                            constraints = constraints.mca1,
                            col.points = col4Means1,
                            cex = 7,  # size of the dot (bigger)
                            col.labels = col4Means1,
                            text.cex = 6)
# The map with observations and group means
a003.Map.I.withMeans1 <- a2 +
  MapGroup1$zeMap_dots + MapGroup1$zeMap_text
print(a003.Map.I.withMeans1)
#_____________________________________________________________________
# Create the ellipses
# Bootstrapped CI ----
#_____________________________________________________________________
# Create Confidence Interval Plots
# use function MakeCIEllipses from package PTCA4CATA
GraphElli1 <- MakeCIEllipses(BootCube.Gr1$BootCube[,1:2,],
                            names.of.factors = c("Dimension 1","Dimension 2"),
                            col = col4Means1,
                            p.level = .95
)
#_____________________________________________________________________
# create the I-map with Observations, means and confidence intervals
#
a004.Map.I.withCI1 <-  a2 + MapGroup1$zeMap_text +  GraphElli1
#_____________________________________________________________________
# plot it!
print(a004.Map.I.withCI1)

GraphTI.Hull1 <- PTCA4CATA::MakeToleranceIntervals(resMCA.sym1$ExPosition.Data$fi,
                                                  design = my_data$Gender,
                                                  # line below is needed
                                                  names.of.factors =  c("Dim1","Dim2"), # needed
                                                  col = col4Means1,
                                                  line.size = .50,
                                                  line.type = 3,
                                                  alpha.ellipse = .2,
                                                  alpha.line    = .4,
                                                  p.level       = .75)
#_____________________________________________________________________
# Create the map:
a005.Map.I.withTIHull1 <-a2  +
  GraphTI.Hull1 + MapGroup1$zeMap_dots +
  MapGroup1$zeMap_text + MapGroup1$zeMap_dots
#_____________________________________________________________________
# plot it
print(a005.Map.I.withTIHull1)

## Contribution for variables

signed.ctrJ <- resMCA.sym$ExPosition.Data$cj * sign(resMCA.sym$ExPosition.Data$fj)
b003.ctrJ.s.1 <- PrettyBarPlot2(signed.ctrJ[,1],
                                threshold = 1 / NROW(signed.ctrJ),
                                font.size = 5,
                                # color4bar = gplots::col2hex(col4J.ibm), # we need hex code
                                main = 'MCA on the IBM-No-Attririon data Set: Variable Contributions (Signed)',
                                ylab = 'Contributions',
                                ylim = c(1.2*min(signed.ctrJ), 1.2*max(signed.ctrJ))
)
print(b003.ctrJ.s.1)
b004.ctrJ.s.2 <- PrettyBarPlot2(signed.ctrJ[,2],
                                threshold = 1 / NROW(signed.ctrJ),
                                font.size = 5,
                                # color4bar = gplots::col2hex(col4J.ibm), # we need hex code
                                main = 'MCA on the IBM-No-Attririon dataSet: Variable Contributions (Signed)',
                                ylab = 'Contributions',
                                ylim = c(1.2*min(signed.ctrJ), 1.2*max(signed.ctrJ))
)
print(b004.ctrJ.s.2)
b004.ctrJ.s.3 <- PrettyBarPlot2(signed.ctrJ[,3],
                                threshold = 1 / NROW(signed.ctrJ),
                                font.size = 5,
                                # color4bar = gplots::col2hex(col4J.ibm), # we need hex code
                                main = 'MCA on the IBM-No-Attririon dataSet: Variable Contributions (Signed)',
                                ylab = 'Contributions',
                                ylim = c(1.2*min(signed.ctrJ), 1.2*max(signed.ctrJ))
)
print(b004.ctrJ.s.3)

## Bootstrap Ratios for Variables

BR <- resMCA.inf$Inference.Data$fj.boots$tests$boot.ratios
laDim = 1
ba001.BR1 <- PrettyBarPlot2(BR[,laDim],
                            threshold = 2,
                            font.size = 5,
                            #color4bar = gplots::col2hex(col4J.ibm),
                            main = paste0( 'MCA on the IBM-NoAttrition data Set: Bootstrap ratio ',laDim),
                            ylab = 'Bootstrap ratios'
                            #ylim = c(1.2*min(BR[,laDim]), 1.2*max(BR[,laDim]))
)
print(ba001.BR1)
#
laDim = 2
ba002.BR2 <- PrettyBarPlot2(BR[,laDim],
                            threshold = 2,
                            font.size = 5,
                            #color4bar = gplots::col2hex(col4J.ibm),
                            main = paste0(
                              'MCA on the IBM-NoAttrition data Set: Bootstrap ratio ',laDim),
                            ylab = 'Bootstrap ratios'
)
print(ba002.BR2)
laDim = 3
ba002.BR3 <- PrettyBarPlot2(BR[,laDim],
                            threshold = 2,
                            font.size = 5,
                            main = paste0(
                              'MCA on the IBM-NoAttrition data Set: Bootstrap ratio ',laDim),
                            ylab = 'Bootstrap ratios'
)
print(ba002.BR3)