# extract_features.r - part of TF2
# Purpose: Take appropriately formatted (what is that?) DNase-1 signal and 'extract features' (binary). 0 means 'missing data', 1 'no', 2 'yes'.
# Warning: parallelising this means the peaks might (requires testing) get all messed up, order-wise, so you need to sort-bed on this afterwards! Hopefully this doesn't negate the speed gain from parallelisation.
# Possible solution: mclapply returns the value for each peak, then write this all to the files...

options(warn=-1)
# missingness threshold: what frac of 0s in the signal counts as missing?
THRE<-0.2

# above average signal?
get_feature1 <- function(signal_data,peak_mean){
    col_means <- colMeans(signal_data)
    f1<-ifelse(col_means>peak_mean,2,1)
    f1[is.na(f1)]<-0
    return(f1)
}

get_f2_and_f3 <- function(signal_data){
    win_size <- nrow(signal_data)
    f2<-vector("integer")
    f3<-vector("integer")
    # centred
    x <- seq(win_size)-ceiling(win_size/2)
    for (loc in 1:ncol(signal_data)){
        if (mean(signal_data[,loc]==0)>THRE){
            # missing data
            increasing<-0
            quadratic<-0
        } else{
            linear <- lm(signal_data[,loc] ~ x)
            increasing <- ifelse(linear$coefficients["x"]>1/win_size,2,1)
            quad <- lm(signal_data[,loc] ~ x^2)
            # note presence of another arbitrary threshold
            quadratic <- ifelse(abs(quad$coefficients["x"])>0.3,2,1)
        }
        f2<-c(f2,increasing)
        f3<-c(f3,quadratic)
    }
    return(list("f2"=f2,"f3"=f3))
}

get_peak_features <- function(peak,peaklist,signal,feature1,feature2,feature3){
    hor_str <- peaklist[peak,1]
    if (peak%%1000==0){
        cat("Peak",peak,"\n")
        cat(hor_str,"\n")
    }
    # this is just string formatting
    broken_hor_str <- unlist(strsplit(hor_str,":"))
    peak_range <- unlist(strsplit(broken_hor_str[2],"-"))
    peak_start <- as.integer(peak_range[1])
    peak_end <- as.integer(peak_range[2])
    peak_length <- diff(c(peak_start,peak_end))-1
    buff <- matrix(scan(signal,sep="\t",what=character(),nlines=peak_length,quiet=TRUE),nrow=peak_length,byrow=T)
    peak_mean <- mean(as.numeric(buff[,5]))
    # signal data is now actually columns for locations and rows for the values...
    signal_data<- apply(buff[,5:ncol(buff)],1,as.numeric)
    f1<-get_feature1(signal_data,peak_mean)
    f2_and_f3<-get_f2_and_f3(signal_data)
    chro<-broken_hor_str[1]
    f2<-f2_and_f3$"f2"
    f3<-f2_and_f3$"f3"
    cat(chro,"\t",peak_start,"\t",peak_end,"\t",f1,"\n",file=feature1)
    cat(chro,"\t",peak_start,"\t",peak_end,"\t",f2,"\n",file=feature2)
    cat(chro,"\t",peak_start,"\t",peak_end,"\t",f3,"\n",file=feature3)
}

# --- Main bit! --- #
#
signal<-file("dnase_signal_final.bed.gz",open="r")
feature1<-file("feature1.bed",open="w")
feature2<-file("feature2.bed",open="w")
feature3<-file("feature3.bed",open="w")
peaklist<-read.table("k562_peak_list",as.is=TRUE)
N_PEAKS<-nrow(peaklist)
# i can already feel the race conditions
mclapply(1:N_PEAKS,get_peak_features,peaklist,signal,feature1,feature2,feature3)


# 3. faza: Vizualizacija podatkov

#OPOMBA: Kjer je #======== je graf tudi v poročilu

#dež za vse
g1 = ggplot(tabela1%>%filter(leto == "2010")) + aes(x = mesec_c, y = padavine) +
  geom_col(position = "dodge",fill = "dark blue") +
  facet_wrap(. ~ naselje, ncol = 3)   + theme_classic() +
  labs(
    x = "Mesec",
    y = "Mesečne padavine[mm/m^2]",
    title = "Merjenja 20-ih meteoroloških postaj v letu 2001"
  )+
  scale_x_continuous("Mesec",breaks = 1:12)

##temperature za vse
g2 = ggplot(tabela1%>%filter(leto == "2001")) + aes(x = mesec_c, y = temperature,group = 1 ) + geom_line(position = "dodge") +
  facet_wrap(. ~ naselje, ncol = 3)+ theme_classic() +
  labs(
    x = "Mesec",
    y = "Povprečna dnevna temperatura[°C]",
    title = "Merjenja 20-ih meteoroloških postaj v letu 2001"
  )

#Kako grejo čez leta padavine LETNO , Ali naj uporabim ????
g3 =ggplot(tabela3%>%group_by(naselje)) + aes(x = leto, y = avg_p) + geom_line() +
  facet_wrap(. ~ naselje, ncol = 3) + theme_classic()

#identično za čez čas temperature LETNO
g4 = ggplot(tabela3%>%group_by(naselje)) + aes(x = leto, y = avg_t) + geom_line(color="red") +
  facet_wrap(. ~ naselje, ncol = 3) + theme_classic()

#razsevni, kako so temperature letne glede na nmv
#OP.: Identičen je pri analizi narisan
g7 = ggplot(tabela3) + aes(x=nmv , y = avg_t)+
  geom_point() + stat_smooth(method = lm)

#razsevni, kako so padavine letne glede na nmv
#OP.: Identičen je pri analizi narisan
g8 = ggplot(tabela3) + aes(x=nmv , y = avg_p)+
  geom_point() + stat_smooth(method = lm)

#====gostota poseljenosti od nmv ====
g9 = ggplot(tabela3) + aes(x=nmv , y = avg_preb,color=naselje)+
  geom_point(size = 2.5) +
  labs(
    x = "Nadmorska višina[m]",
    y = "Gostota poseljenosti [prebivalci/km^2]",
    title = "Gostota poseljenosti",
    color = ""
  ) + theme(legend.position = "none")
#==========================================

#Kako je gostota poseljenosti od temperatur, je tudi pri analizi
g10 = ggplot(tabela3[tabela3$naselje != "Kredarica",]) + aes(x=avg_t , y = avg_preb)+
  geom_point() + stat_smooth(method = lm)

#Kako je gostota poseljenosti od padavin, je tudi pri analizi
g11 = ggplot(tabela3[tabela3$naselje != "Kredarica",]) + aes(x=avg_p , y = avg_preb)+
  geom_point() + stat_smooth(method = lm)

#===================================
SLO <- map_data("world") %>% filter(region=="Slovenia")
data = tabela3 %>%filter(leto=="2010")
data2 = data[-c(17,18),] #izvzel NA
data2 = data2 %>% filter(naselje != "Kredarica") #Izvzel kredarico da lahko uporabim trans = log
g13 = ggplot() +
  geom_polygon(data = SLO, aes(x=long, y = lat, group = group), fill="grey", alpha=0.3) +
  geom_point( data=data2, aes(x=lon, y=lat, size=avg_p,color=nmv)) +
  scale_size_continuous(range=c(1,12)) +
  scale_color_viridis(trans="identity",option = "C") +
  theme_void() + ylim(45,47) + coord_map()  +
  geom_text(
    data = data2,
    mapping = aes(x = lon , y = lat+0.09, label = naselje),
    size = 2.5
  ) +
  labs(
    title = "Nadmorske višine ter povprečne \nmesečne padavine meteoroloških postaj",
    colour = "Nadmorska višina[m]",
    size = "Povprečne mesečne \npadavine[mm/m^2]"
  )
#===============================================
data3 = data[-17,]
data3 = data3 %>% filter(naselje != "Kredarica")
g14 = ggplot() +
  geom_polygon(data = SLO, aes(x=long, y = lat, group = group), fill="grey", alpha=0.3) +
  geom_point( data=data3, aes(x=lon, y=lat, size=avg_t,color=nmv)) +
  scale_size_continuous(range=c(1,11)) +
  scale_color_viridis(trans="identity",option = "C") +
  theme_void() + ylim(45,47) + coord_map()  +
  geom_text(
    data = data3,
    mapping = aes(x = lon , y = lat+0.12, label = naselje),
    size = 2.5
  ) +
  labs(
    title = "Nadmorske višine ter povprečne dnevne \ntemperature meteoroloških postaj",
    colour = "Nadmorska višina[m]",
    size = "Povprečne dnvene \ntemperature[°C]"
  )
#===============================================

#Kako gre gostota prebivalstva čez leta, brezveze
g15 = ggplot(tabela2%>%group_by(naselje)) + aes(x=datum, y=gostota,group = 1)  +
  geom_line() + facet_wrap(.~ naselje, ncol = 3)

#spremembe tamperatur tekom let
gg =  ggplot() + layer(
    data = tabela3%>%group_by(naselje),
    mapping = aes(x = leto, y = avg_p),
    geom = "line",
    stat = "identity",
    position = "identity",
  ) +   facet_wrap(.~ naselje ,ncol = 3)

#temperatur za vse po vseh mesecih iz tabele 1
g5 = ggplot(tabela1) + aes(x = datum_c , y = temperature, group = 1) +
  geom_line() +facet_wrap(. ~ naselje, ncol = 3)

#dež za vse po vseh mesecih iz tbele 1
g6 = ggplot(tabela1) + aes(x = datum_c , y = padavine) +
  geom_line() + facet_wrap(. ~ naselje, ncol = 3)

#==========================
ylim.prim <- c(0, 100)
ylim.sec <- c(0, 5)
b <- diff(ylim.prim)/diff(ylim.sec)
a <- ylim.prim[1] - b*ylim.sec[1]
#======================
G1 = ggplot(tabela1%>%filter(leto == "2010")%>%
              filter(naselje!= "Rogaška Slatina")%>%filter(naselje != "Slap pri Vipavi" ),
            aes(mesec_c, padavine)) +
  geom_col(fill = "dark blue") +
  geom_line(aes(y = a + temperature*b), color = "red") +
  scale_y_continuous("Padavine v mesecu[mm/m^2]", sec.axis = sec_axis(~ (. - a)/b, name = "Temperature[°C]"))+
  scale_x_continuous("Mesec",breaks = 1:12) +
  ggtitle("Padavine in temperature za leto 2010") + facet_wrap(.~naselje , ncol = 4)+
  facet_wrap(. ~ naselje, ncol = 4)  + theme_bw()
#=====================


print(R.version.string)

# COMMAND ----------

path="weight_data.csv"
print(paste("Reading file from",path))

routes<-read.csv(path, header=TRUE)

# The predictor vector (height).
x <- routes$height
# The response vector (weight).
y <- routes$weight
# Apply the lm() function.
model <- lm(y~x)

# COMMAND ----------

routes

# COMMAND ----------

# Make Predictions
df_test_heights <- data.frame(x = as.numeric(c(115,20)))
result <-  predict(model,df_test_heights)
print(result)

# COMMAND ----------

# Save the model to blob storage
model_path="model.rds"
saveRDS(model, model_path)

# COMMAND ----------

# View model details
print(model)

# COMMAND ----------

print('Completed')


# Libraries
library(raster)
library(maptools)

# Params
directory = 'data/geo'
map_crs = '+proj=longlat +datum=WGS84'

# Initialize
data(wrld_simpl)

################ Reading different file types ################

# Read geotif
file <- paste0(directory, '/0_manual/anthropogenic_biomes/anthromes-v2-2000-global-geotif/a2000_global.tif')
x1 <- raster::raster(file)

file <- paste0(directory, '/0_manual/spam/dataverse_files/spam2010v1r0_global_harv_area.geotiff/spam2010v1r0_global_harvested-area_acof_a.tif')
x5 <- raster::raster(file)
stack(x1, x5)

# Read dat
file <- paste0(directory, '/0_manual/soil_param/ISRIC_W_GRID_546/ISRIC_W_GRID_546/data/wise_awc.dat')
x3 <- raster::raster(file)
raster::projection(x3) <- map_crs
x3 <- raster::resample(x3, x1, method='ngb')
stack(x1,x3)
plot(x3)

# Read asc
file_dir <- paste0(directory, '/0_manual/soil_param2/ISLSCP_SOILS_1DEG_1004/ISLSCP_SOILS_1DEG_1004/data')
files <- list.files(file_dir, pattern="asc", full.names=TRUE)
x4 <- raster::raster(files[1])
raster::projection(x4) <- map_crs
x4 <- raster::resample(x4, x1, method='ngb')
stack(x1, x4)
plot(x4)

# Reproject raster
# raster::reprojectRaster


data = read.csv("random_search_bandit.csv")
attach(data)
av1 = aov(R~population*mutation*elitism*alpha*exploration*creation)
av2 = aov(R~population*mutation*elitism*repetitions*crossover_rate)
summary(av1)
summary(av2)
detach(data)


# -----------------------
# obtain a point estimate of maturity from the data provided
  est.size.at.maturity = function(d,sex) {

    # recode maturity: 2 is immature -> 0
    imm = which(d$mat==2)
    d$mat[imm] = 0

    i = which(is.finite(d$mat))

    outputvector = NULL

    if (length(i) > 20) {
      d = d[i,]

    #  d$surfacearea = d$surfacearea / min(d$surfacearea[d$surfacearea>0] )
      dummy = d[1,]
    #  dummy$surfacearea = floor(length(i)/10)
      dmat = dimm = dummy
      dmat$mat = 1
      dimm$mat = 0
      if (sex==male) {
        dimm$cw = 30
        dmat$cw = 150
      } else {
        dimm$cw = 30
        dmat$cw = 80
      }

      d = rbind(d, dmat, dmat, dmat, dimm, dimm, dimm, dimm)

      r =  glm (mat ~ cw, data=d, family=binomial(link="logit") )
      res = coef(summary(r))
#      res2 = confint(r)
#      fin = cbind(res[,c("Estimate","Std. Error")],res2)
#      colnames(fin) = c("Estimate","Std. Error", colnames(res2))
      cw50 = dose.LD50(r,lambda=c(1,NA)) # lambda is a vector of model coef, with NA for inverse prediction variable.
      names(cw50) = c("cw50", "cw50lower", "cw50upper")
      olist = c("Estimate","Std. Error")

      r1 = res[1,olist] ; names(r1) = c("a0", "a0.se" )
      r2 = res[2,olist] ; names(r2) = c("a1", "a1.se" )
      r3 = c(length(i), r$deviance, r$aic); names(r3)=c("n", "deviance", "aic")
      r4 = c(floor(r$converged)); names(r4)="converged"

      outputvector = c( r1, r2, r3, r4, cw50)

    }
    return(outputvector)
  }


base::library('mlbench')

load <- function (train_ratio=1.0, shuffle=FALSE) {
    utils::data('BostonHousing')
    BostonHousing$chas <- base::as.numeric(BostonHousing$chas)
    if (shuffle) {
        indices <- base::sample(base::nrow(BostonHousing))
        BostonHousing <- BostonHousing[indices, ]
    }
    width = base::ncol(BostonHousing)
    height = base::nrow(BostonHousing)
    medium = base::floor(train_ratio*height)
    base::return(list(
        X_train=BostonHousing[1:medium, 1:(width-1)],
        X_test=BostonHousing[(medium+1):height, 1:(width-1)],
        y_train=BostonHousing[1:medium, width],
        y_test=BostonHousing[(medium+1):height, width]
    ))
}


### compute turning angle

message ("start straightness.r")

plot_title = "Straightness Histogram (Groups)"
plot_title2 = "Straightness Histogram (Individuals)"

straight_table = data.frame()
median_angle = c()
median_meander = c()

#compute straightness for each individum
for (i in c(1:nrow(id_table))) {
	straightnessres =c.straightness(traj[id(traj)==id_table$id[i]])
	angle = straightnessres$angle
	meander =straightnessres$meander
	#hist(abs(meander), main = id_table$id[i])
	median_angle = c(median_angle,median(abs(angle)))
	median_meander = c(median_meander,quantile(abs(meander), probs =0.5, na.rm=TRUE))
	id = rep(id_table$id[i],length(angle))
	group = rep(id_table$group[i],length(angle))
	straight_table = rbind(straight_table,data.frame(angle,meander,id,group))
}
#straight_table$angle = straight_table$angle/pi*180
#straight_table$meander = abs(straight_table$meander/pi*180)
#straight_mtable=create.mean.table (straight_table,group_ids,1:2)

#straight_table_2=data.frame(median_angle,median_meander,id=id_table$id,group=id_table$group)

f_table = data.frame(f_table,turning_angle=median_angle,meander=median_meander)

f_table_positive = data.frame(f_table_positive,turning_angle=median_angle,meander=median_meander)
#mean_table = create.mean.table(straight_table_2,group_ids,data_cols=1:2)

message("starting plots straightness")
### create plots
# M= max(mean_table$means$median_angle)+ max(mean_table$ses$median_angle)*1.3
# mybarplot(mean_table$means$median_angle,mean_table$ses$median_angle,rownames(mean_table$means),
	# main="Mean of median of turning angle",ylab="Angle [degrees]", ylim= c(0,M))

# M= max(mean_table$means$median_meander)+ max(mean_table$ses$median_meander)*1.3
# mybarplot(mean_table$means$median_meander,mean_table$ses$median_meander,rownames(mean_table$means),
	# main="Mean of median of the meander",ylab="meander [degrees*s/mm]", ylim= c(0,M))
#
#if (g_bin_size==0)
#	{g_bin_size = 0.5}
#v = straight_table$meander
#bins = seq(min(v[!is.na(v)])-g_bin_size,max(v[!is.na(v)])+g_bin_size,g_bin_size)
#
###plot histograms
##hplot1 = histogram(~ meander | group, data=straight_table, breaks = bins, type="percent",col=0,ylab="percent", xlab="relative angle [degree]", layout=c(2,2), polot = FALSE)
###hplot2 = histogram(~ angle | group, data=straight_table, scales=list(x = list(log = "e")),breaks = bins, type="percent",col=0,ylab="percent", xlab="relative angle [degree]", layout=c(2,2))
###hplot2 = histogram(~ angle | id ,data=straight_table, breaks = bins, type="percent",col=0,ylab="percent", xlab="relative angle [degree]", layout=c(3,3))
##print(hplot1, xlim=c(0,90))
###print(hplot2


filterData <- function (type, raw) {
    res <- array('', dim=c(nrow(raw),ncol(raw)))
    idx <- 1;

    for (i in 1:nrow(raw)) {
        if (raw[i,3]==type) {
            for (j in 1:ncol(raw)) {
                res[idx,j] <- toString(raw[i,j])
            }
            idx <- idx + 1
        }
    }

    return(res[1:idx-1,])
}

nodes <- as.matrix(read.csv('nodes.list', sep=',', header=FALSE), quote=FALSE)
#print(nodes)

n <- length(nodes)
nodesMap <- new.env(hash=T, parent=emptyenv())
for(i in 1:n) {
  nodesMap[[nodes[i]]] <- i
}
#print(ls(nodesMap))

raw <- filterData('latency', read.csv('data.csv', sep='\t', header=FALSE))
data <- as.matrix(raw, quote=FALSE)
#print(data)

RTT <- matrix(nrow=n, ncol=n)
rownames(RTT) <- nodes[,1]
colnames(RTT) <- nodes[,1]

Latency <- matrix(nrow=n, ncol=n)
rownames(Latency) <- nodes[,1]
colnames(Latency) <- nodes[,1]

for(i in 1:nrow(data)) {
    a <- nodesMap[[data[i,1]]]
    b <- nodesMap[[data[i,4]]]
    Lab <- as.numeric(data[i,10])
    RTTab <- as.numeric(data[i,15])

    if (!is.null(a) && !is.null(b) && !is.null(Lab) && !is.null(RTTab)) {
        Latency[a,b] = Lab
        RTT[a,b] = RTTab
    }
}

print(round(RTT, digits=2))
print(round(Latency, digits=2))


rm(list = ls())

require(magrittr)

# set the wd
setwd("C:/Users/gbal/Desktop/r.training.mnhn")

salmon.data <-
  read.table(
    file = '2.data/2.salmon/salmon.data.raw.txt',
    header = TRUE,
    sep = ',',
    dec = '.'
  )

write.table(x = salmon.data,
            file = 'saumon.2.txt',
            sep = ',', dec = '.',
            row.names = FALSE)

salmon.data$wild <- salmon.data$wild == 1
salmon.data[ , c("country", "sex", 'river')] <-
  sapply(salmon.data[ , c("country", "sex", 'river')], FUN =
           function(x) as.factor(x), simplify = FALSE)
head(salmon.data)
summary(salmon.data)
salmon.data$river

salmon.data$weight[salmon.data$weight > 50 & !is.na(salmon.data$weight)] <-
  salmon.data$weight[salmon.data$weight > 50 & !is.na(salmon.data$weight)] / 1000

salmon.data$length[salmon.data$length < 20 & !is.na(salmon.data$lenght)] <-
  salmon.data$length[salmon.data$length < 20 & !is.na(salmon.data$length)] * 2.54

which(salmon.data$length < 20 & !is.na(salmon.data$lenght))

# exercice graph 1 ----

plot(x = salmon.data$length[salmon.data$river == 'moy' &
                              salmon.data$sea.age == 1],
     y = salmon.data$weight[salmon.data$river == 'moy' &
                              salmon.data$sea.age == 1],
     ylab = 'Weight', xlab = 'Length', pch = '.')

hist(salmon.data$weight[salmon.data$country == 'ie'], main = 'Weight')

pdf('mes.saumons.pdf', useDingbats = FALSE)
boxplot(salmon.data$weight ~ salmon.data$year, outline = FALSE)
boxplot(weight ~ year, data = salmon.data, outline = FALSE)
dev.off()
dir()

barplot(table(salmon.data$country, salmon.data$year), ylab = 'Effectif')

matplot(table(salmon.data$year, salmon.data$river),
        type = 'b', lwd = 2)

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

plot(x = salmon.data$weight,
     y = salmon.data$length,
     pch = '.', ylim = c(60, 100),
     col = salmon.data$river)

legend(x = 'right',
       fill = salmon.data$river,
       legend = levels(salmon.data$river))

mtext(side = 3, line = 3, 'Titre', col = "red")


#Jenny Smith

#3/5/18

#purpose: function for volcano plots and MA plots

volcano_plot <- function(twoGroups_DEGs.res, cut.off=2.5, label.offset=0.5){

  library(limma)
  library(tibble)
  library(ggplot2)
  library(ggrepel)

  #Only prints out - cannot be saved
  # vplot1 <- volcanoplot(twoGroups_DEGs.res$DE$eBayesFit,
  #             highlight = 5,
  #             names=rownames(twoGroups_DEGs.res$DE$eBayesFit),
  #             pch=16, cex=1.75)

  df <- data.frame(logFC=twoGroups_DEGs.res$DE$eBayesFit$coefficients[,1],
                   pValue=twoGroups_DEGs.res$DE$eBayesFit$p.value[,1],
                   FDR=p.adjust(twoGroups_DEGs.res$DE$eBayesFit$p.value[,1], method="BH"),
                   MeanExpression=twoGroups_DEGs.res$DE$eBayesFit$Amean) %>%
      rownames_to_column("Gene") %>%
      mutate(Neg.Log10.P= -log10(pValue),
             Neg.Log10.FDR= -log10(FDR),
             DEGs.Groups=case_when(
                  logFC > 1.0 & FDR < 0.05 ~ "FC Greater than 2",
                  logFC < -1.0 & FDR < 0.05 ~ "FC Less than 2",
                  TRUE ~ "Not Significant FC"))

  #Select differentially expressed genes to highlight in the plot.
  idx <- which(abs(df$logFC) > cut.off & df$FDR < 0.05)

  vplot2 <- ggplot(df, aes(x=logFC, y=Neg.Log10.FDR)) +
    geom_point(data = filter(df, DEGs.Groups == "Not Significant FC"),
               mapping = aes(x=logFC, y=Neg.Log10.FDR, color=DEGs.Groups), alpha=0.65)  +

    geom_point(data= filter(df, grepl("2", DEGs.Groups)),
               mapping = aes(x=logFC, y=Neg.Log10.FDR, color=DEGs.Groups)) +

    geom_vline(xintercept=c(-1,1)) +
    geom_hline(yintercept = -log10(0.05)) +

    scale_color_manual(values=c("FC Greater than 2"="red",
                                "FC Less than 2"="blue",
                                "Not Significant FC"="lightgrey")) +

    theme(plot.title = element_text(hjust = 0.5, size = 20),
          panel.background = element_rect(fill="white"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.border = element_rect(color = "black", fill=NA),
          axis.text = element_text(color = "black"),
          axis.text.x = element_text(angle = 0,hjust=0.5,vjust = 0.5, size = 26),
          axis.text.y = element_text(size = 25),
          axis.title = element_text(size = 30),
          plot.margin = margin(2,2,2,2, unit = "mm")) +

    geom_text_repel(aes(x=logFC, y=Neg.Log10.FDR, label=Gene),
                    size=3.5,
                    data=df[idx, ])

  res <- list("gg.volcano"=vplot2, "data"=df)
  return(res)

}

MA_plot <- function(twoGroups_DEGs.res, cut.off=2.5, label.offset=0.5){

  df <- data.frame(logFC=twoGroups_DEGs.res$DE$eBayesFit$coefficients[,1],
                   pValue=twoGroups_DEGs.res$DE$eBayesFit$p.value[,1],
                   FDR=p.adjust(twoGroups_DEGs.res$DE$eBayesFit$p.value[,1], method="BH"),
                   MeanExpression=DS.DE$DE$eBayesFit$Amean) %>%
    rownames_to_column("Gene") %>%
    mutate(Neg.Log10.P= -log10(pValue),
           DEGs.Groups=case_when(
             logFC > 1.0 & pValue < 0.05 ~ "FC Greater than 2",
             logFC < -1.0 & pValue < 0.05 ~ "FC Less than 2",
             TRUE ~ "Not Significant FC"))

    MAplot <- ggplot(df, aes(x=MeanExpression, y=logFC, color=DEGs.Groups)) +

      geom_point(data = filter(df, DEGs.Groups == "Not Significant FC"),
                 mapping = aes(x=MeanExpression, y=logFC, color=DEGs.Groups), alpha=0.65)  +

      geom_point(data= filter(df, grepl("2", DEGs.Groups)),
                 mapping = aes(x=MeanExpression, y=logFC, color=DEGs.Groups)) +

      scale_color_manual(values=c("FC Greater than 2"="red",
                                  "FC Less than 2"="blue",
                                  "Not Significant FC"="lightgrey")) +

      theme(plot.title = element_text(hjust = 0.5, size = 20),
            panel.background = element_rect(fill="white"),
            panel.grid.major = element_blank(),
            panel.grid.minor = element_blank(),
            panel.border = element_rect(color = "black", fill=NA),
            axis.text = element_text(color = "black"),
            axis.text.x = element_text(angle = 0,hjust=0.5,vjust = 0.5, size = 26),
            axis.text.y = element_text(size = 25),
            axis.title = element_text(size = 30),
            plot.margin = margin(2,2,2,2, unit = "mm"))

    return(MAplot)
}


#devtools::test("asremlPlus")
context("model_selection3")
asr3.lib <- "D:\\Analyses\\R oldpkg"

cat("#### Test for parallel processing with asreml3\n")
test_that("parallel_asreml3", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asremlPlus)
  library(asreml, lib.loc = asr3.lib)
  library(parallel)
  library(foreach)
  library(doParallel)
  ### load a data set
  data(Wheat.dat)

  #'## Analyze thechick pea data multiple times using lapply
  n <- 100

  ## Testing of parallel processing
  ### Analyze the chick pea data set n times in parallel
  (ncores <- parallel::detectCores())
  (cl <- makeCluster(ncores))
  registerDoParallel(cl)
  fits <- foreach (i = 1:n, .packages = c("asreml","asremlPlus"))  %dopar%
    {
      current.asr <- asreml(yield ~ Rep + Variety,
                            random = ~ Row + units,
                            residual = ~ ar1(Row):ar1(Column),
                            data=Wheat.dat)
    }
  stopCluster(cl)
})

cat("#### Test for simulate.asreml with asreml3\n")
test_that("simulate_asreml3", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asremlPlus)
  library(asreml, lib.loc = asr3.lib)

  data(Wheat.dat)

  # Fit initial model
  current.asr <- asreml(yield ~ Rep + Variety,
                        random = ~ Row + units,
                        rcov = ~ ar1(Row):ar1(Column),
                        data=Wheat.dat, control= asreml.control(aom=TRUE))
  summary(current.asr)

  s2 <- current.asr$sigma2
  gamma.Row <- current.asr$gammas[1]
  gamma.unit <- current.asr$gammas[2]
  rho.r <- current.asr$gammas[4]
  rho.c <- current.asr$gammas[5]
  row.ar1 <- mat.ar1(order=10, rho=rho.r)
  col.ar1 <- mat.ar1(order=15, rho=rho.c)
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    gamma.unit * diag(1, nrow=150, ncol=150) +
    mat.dirprod(row.ar1, col.ar1)
  V <- s2*V
  testthat::expect_equal(nrow(V), 150)
  testthat::expect_equal(ncol(V), 150)

  #Produce simulated and observed residuals
  resid <- simulate(current.asr, V=V, which="resid", nsim = 50)
  testthat::expect_equal(length(resid), 2)
  testthat::expect_equal(nrow(resid$observed), 150)
  testthat::expect_equal(ncol(resid$observed), 7)
  testthat::expect_equal(nrow(resid$residuals), 150)
  testthat::expect_equal(ncol(resid$residuals), 50)
  resid$residuals <- cbind(resid$observed[c("Row","Column")],
                           resid$residuals)
  #Plot variogram
  vario <- asreml.variogram(resid$observed[c("Row","Column","residuals")])
  testthat::expect_equal(nrow(vario), 150)
  testthat::expect_equal(ncol(vario), 4)
  lattice::wireframe(gamma ~ x*y, data=vario[1:3],
                     xlab="Row differences", ylab="Column differences", zlab="")
  #Plot variofaces
  resid$residuals <- cbind(resid$observed[c("Row","Column")],
                           resid$residuals)
  plotVariofaces(data=resid$observed[c("Row","Column","residuals")],
                 residuals=resid$residuals,
                 restype="Standardized conditional residuals")

  faces <- variofaces(current.asr, V=V, aom=TRUE, units="ignore", nsim = 50)
  testthat::expect_equal(nrow(faces$face1), 10)
  testthat::expect_equal(ncol(faces$face1), 5)
  testthat::expect_equal(nrow(faces$face2), 15)
  testthat::expect_equal(ncol(faces$face2), 5)
  plot.asrVariogram(variogram.asreml(current.asr))

})


#test_omx_rev2.r

#This script has example code for a revised R api (omx_rev2.R)

#Load the rhdf5 library
library( rhdf5 )

#Create an OMX file to store 1000  x  1000 matrix
createFileOMX( "test.omx", 2000, 2000 )

#Make a matrix
OD1 <- matrix( round( runif( 2e6, 0, 100 ) ), nrow=2000, ncol=2000 )
PA1 <- matrix( round( runif( 2e6, 0, 100 ) ), nrow=2000, ncol=2000 )

#Write the matrices
writeMatrixOMX( "test.omx", OD1, "OD1", Description="Scenario 1 Origin-Destination Matrix" )
writeMatrixOMX( "test.omx", PA1, "PA1", Description="Scenario 1 Production-Attraction Matrix" )
rm( OD1, PA1 )

#Make some lookups
EI <- c( rep( "E", 50 ), rep( "I", 1950 ) )
Districts <- c( round( runif( 50, 1, 5 ) ), round( runif( 1950, 3, 40 ) ) )

#Write the lookups
writeLookupOMX( "test.omx", EI, "EI", LookupDim=NULL, Replace=FALSE, Description="External and internal zones" )
writeLookupOMX( "test.omx", Districts, "Districts", LookupDim=NULL, Replace=FALSE, Description="Districts" )
rm( EI, Districts )

#List the contents of the file including attributes
listOMX( "test.omx" )

#Extract the EE portion of matrix OD1
EILookup <- readLookupOMX( "test.omx", "EI" )
EE.OD <- readMatrixOMX( "test.omx", "OD1", RowIndex=which( EILookup$Lookup == "E" ), ColIndex=which( EILookup$Lookup == "E" ) )


print(0)
print(1)
a <- 1
b <- a + a
print(a)
print(b)
while (a < 1000000){
    a <- a + b
    b <- a + b
    print(a)
    print(b)
}


# 4. faza: Napredna analiza podatkov

#RAZVRŠČANJE V SKUPINE

#funkcije iz predavanj in vaj, ki sem jih uporabila v nadaljevanju:
hc.kolena = function(dendrogram, od = 1, do = NULL, eps = 0.5) {
  n = length(dendrogram$height) + 1  # število primerov in nastavitev parametra do
  if (is.null(do)) {
    do = n - 1
  }
  k.visina = tibble(
    k = as.ordered(od:do),
    visina = dendrogram$height[do:od]) %>%
    mutate(dvisina = visina - lag(visina)) %>%         # sprememba višine
    mutate(               # ali se je intenziteta spremembe dovolj spremenila?
      koleno = lead(dvisina) - dvisina > eps)
  k.visina
}

# iz tabele k.visina vrne seznam vrednosti k, pri katerih opazujemo koleno
hc.kolena.k = function(k.visina) {
  k.visina %>%
    filter(koleno) %>%
    dplyr::select(k) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

# narišemo diagram višin združevanja
diagram.kolena = function(k.visina) {
  k.visina %>% ggplot() +
    geom_point(
      mapping = aes(x = k, y = visina),
      color = "red") +
    geom_line(
      mapping = aes(x = as.integer(k), y = visina),
      color = "red") +
    geom_point(
      data = k.visina %>% filter(koleno),
      mapping = aes(x = k, y = visina),
      color = "blue", size = 2) +
    ggtitle(paste("Kolena:", paste(hc.kolena.k(k.visina), collapse = ", "))) +
    xlab("število skupin (k)") + ylab("razdalja pri združevanju skupin") +
    theme_classic()
}

diagram.skupine = function(podatki, oznake, skupine, k) {
  podatki = podatki %>%
    bind_cols(skupine) %>%
    rename(skupina = ...4)

  d = podatki %>%
    ggplot(
      mapping = aes(
        x = x, y = y, color = skupina
      )
    ) +
    geom_point() +
    geom_label(label = oznake, size = 2) +
    scale_color_hue() +
    theme_classic()

  for (i in 1:k) {
    d = d + geom_encircle(
      data = podatki %>%
        filter(skupina == i)
    )
  }
  d
}

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

  razdalje = dist(podatki)

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

  k.obrisi
}

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

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

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

#________________________________________________________________________________
#uporabila bom podatke tabela2
tabela.skupine1.1 <- tabela2 %>%
  dplyr::select(1, 2, 6) %>%
  filter(regija != "SLOVENIJA") %>%
  group_by(regija, solsko.leto) %>%
  summarise(promil = sum(delez.promil))

tabela.skupine1.2 <- tabela.skupine1.1%>%
  pivot_wider(
    names_from = solsko.leto,
    values_from = promil
  )

#wardove razdalje:
regije <- tabela.skupine1.2[, 1] %>% unlist()
razdalje <- tabela.skupine1.2[, -1] %>% dist()
dendrogram <- razdalje %>% hclust(method = "ward.D")

#tabela, za risanje skupin
regije.x.y <- as.tibble(razdalje %>% cmdscale(k = 2)) %>%
  bind_cols(regije) %>%
  dplyr::select(regija = ...3, x = V1, y = V2)

#DENDROGRAM
#plot(dendrogram, labels = regije, ylab = "višina", main = NULL)

#HIERARHIČNO RAZVRŠČANJE V SKUPINE
#nariše graf in obarva kolena modro
graf.kolena <- dendrogram %>% hc.kolena() %>% diagram.kolena() #dobila sem dva oprimalna k: 2 in 3
#za k=2:
skupine.2 <- dendrogram %>%
  cutree(k = 2) %>%
  as.ordered()
diagram.skupine(regije.x.y, regije.x.y$regija, skupine.2, 2)
#za k=3:
skupine.3 <- dendrogram %>%
  cutree(k = 3) %>%
  as.ordered()
diagram.skupine(regije.x.y, regije.x.y$regija, skupine.3, 3)

#METODA K-TIH VODITELJEV:
#za r.km:
r.km <- tabela.skupine1.2[, -1] %>% obrisi(hc = FALSE)
opt.st.skupin.r.km <- obrisi.k(r.km)     #optimaleno k=2
diagram.obrisi(r.km)

set.seed(123)
skupine <- tabela.skupine1.2[, -1] %>%
  kmeans(centers = 2) %>%
  getElement("cluster") %>%
  as.ordered
#narišem graf in obkroži skupine:
diagram.skupine(regije.x.y, regije.x.y$regija, skupine, opt.st.skupin.r.km)

#za r.hc:
r.hc <- tabela.skupine1.2[, -1] %>% obrisi(hc = TRUE)
opt.st.skupin.r.hc <- obrisi.k(r.hc)     #optimaleno k=2
diagram.obrisi(r.hc)

skupine <- tabela.skupine1.2[, -1] %>%
  dist() %>%
  hclust(method = "ward.D") %>%
  cutree(k = 2) %>%
  as.ordered()
#narišemo graf in obkroži skupine:
diagram.skupine(regije.x.y, regije.x.y$regija, skupine, opt.st.skupin.r.hc)

#funkcija, ki nariše graf za optimalno število kolen glede na nacin dolocanja
narisi <- function(nacin){
  if(nacin == "Hierarhično razvrščanje"){
    graf.kolena <- dendrogram %>% hc.kolena() %>% diagram.kolena()
    graf.kolena
  }else {
    r.km <- tabela.skupine1.2[, -1] %>% obrisi(hc = FALSE)
    diagram.obrisi(r.km)
  }
}

narisi("Hierarhično razvrščanje")
narisi("Metoda k-tih voditeljev")

#zemljevid za razvrščanje po skupinah z metodo HAC
source("lib/uvozi.zemljevid.r")
zemljevid <- uvozi.zemljevid("http://kt.ijs.si/~ljupco/lectures/appr/zemljevidi/si/gadm36_SVN_shp.zip",
                             "gadm36_SVN_1", mapa = "zemljevidi", encoding="UTF-8")

zemljevid <- zemljevid %>%
  spTransform(CRS("+proj=longlat +datum=WGS84")) # pretvorimo v ustrezen format

loc <- locale(encoding="UTF-8")
for (col in names(zemljevid)) {
  if (is.character(zemljevid[[col]])) {
    zemljevid[[col]] <- zemljevid[[col]] %>%
      parse_character(locale=loc)
  }
}

zemljevid@data
zemljevid.regije <- zemljevid
names(zemljevid.regije)
zemljevid.regije$NAME_1

zemljevid.regije$NAME_1 <- factor(zemljevid.regije$NAME_1)

lvls <- levels(zemljevid.regije$NAME_1)

#funkcija, ki nariše zemljevid glede na število izbranih skupin
zemljevid <- function(k){
  skupine.k <- dendrogram %>%
    cutree(k = k) %>%
    as.ordered()

  podatki.k <- regije.x.y %>%
    bind_cols(skupine.k) %>%
    rename(skupina = ...4) %>%
    dplyr::select(1, 4)

  podatki.k$regija <- str_replace_all(
    podatki.k$regija,
    c("Primorsko-notranjska" = "Notranjsko-kraška", "Posavska"= "Spodnjeposavska")
  )

  # spremenim imena regij, da se ujemajo z zemljevidom, kratice spremenim nazaj v dolga imena
  imena.regij.nazaj = tibble(
    regija = c("Gorenjska", "Goriška", "Jugovzhodna Slovenija", "Koroška",
               "Obalno-kraška", "Osrednjeslovenska", "Podravska", "Pomurska",
               "Spodnjeposavska", "Notranjsko-kraška", "Savinjska","Zasavska",
               "SLOVENIJA"),
    oznaka = c(
      "kr", "ng", "nm", "sg", "kp", "lj", "mb", "ms", "kk", "po", "ce", "za", "slo")
  )

  tmap_mode("plot")
  zemljevid1 <- merge(
    x = podatki.k,
    y = imena.regij.nazaj,
    by = "regija", all.x = TRUE
  ) %>%
    dplyr::select(regija, skupina)

  zemljevid1 <- merge(zemljevid.regije,
                      zemljevid1,
                      by.x = "NAME_1",
                      by.y = "regija")

  zem <- tm_shape(zemljevid1) +
    tm_polygons(
      "skupina" ,
      style = "pretty",
      palette="Blues",
      title="Skupina:"
    ) +
    tm_layout(
      "",
      legend.title.size=1,
      legend.text.size = 0.8,
      legend.position = c("right","bottom"),
      legend.bg.color = "white",
      legend.bg.alpha = 1) +
    tm_text("NAME_1", size = 4/5)

  zem

}

#narišem zemljevid za k=2:
zem2 <- zemljevid(2)

#narišem zemljevid za k=3:
zem3 <- zemljevid(3)

#_______________________________________________________________________________
#NAPOVEDNI MODELI
#Linearna regresija
preurejena.4 <- tabela4 %>%
  dplyr::select(2, 4, 5) %>%
  group_by(vrsta.izobrazevanja, solsko.leto) %>%
  summarise(stevilo.diplomantov = sum(stevilo.diplomantov))

tabela.podatki <- tabela3 %>%
  dplyr::select(1, 5, 6) %>%
  group_by(vrsta.izobrazevanja, solsko.leto) %>%
  summarise(stevilo.vpisanih = sum(stevilo.vpisanih)) %>%
  left_join(preurejena.4, by = c("vrsta.izobrazevanja" = "vrsta.izobrazevanja",
                            "solsko.leto" = "solsko.leto")
            ) %>%
  filter(solsko.leto != "2020/21", solsko.leto != "2009/10", solsko.leto != "2010/11")

gg <- ggplot(tabela.podatki, aes(x=stevilo.vpisanih, y=stevilo.diplomantov)) + geom_point()

stevilo.diplomantov ~ stevilo.vpisanih
stevilo.diplomantov ~ stevilo.vpisanih + I(stevilo.vpisanih^2)

podatki <- tabela.podatki
n <- nrow(podatki)
r <- sample(1:n)
formula <- stevilo.diplomantov ~ stevilo.vpisanih

k <- 5
set.seed(123)
razrez <- cut(1:n, k, labels = FALSE)
razbitje <- split(r, razrez)

pp.napovedi <- rep(0, n)
for (i in 1:length(razbitje)){
  train.data <- podatki [-razbitje[[i]], ]           #učni podatki
  test.data <- podatki[razbitje[[i]], ]              #testni podatki
  model <- lm(data = train.data, formula = formula)  #naučimo model
  napovedi <- predict(model, newdata = test.data)    #napovemo za testne podatke
  pp.napovedi[razbitje[[i]]] <- napovedi
}

pp.napovedi

#izračunamo kvadratno napako -MSE
MSE <- mean((pp.napovedi - podatki$stevilo.diplomantov)^2)

gg <- gg +
  geom_smooth(method = "lm",
              formula = y ~ x,
              se = TRUE,
              fullrange = TRUE,
              color = "green") +
  theme_classic() +
  theme(
    plot.title = element_text(hjust = 0.5) #naslov na sredini
  ) +
  labs(
    x = "Število vpisanih",
    y = "Število diplomantov",
    title = "LINEARNA REGRESIJA"
  )


fn.ge = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_ge_matrix_gene_sle_lowDA.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.si = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_sample_info_2_sle_lowDA.txt")
info = fread(fn.si, data.table=F)

# stability calculation
ss = matrix(NA,nrow(dat), 2, dimnames=list(rownames(dat),c("ISV","WSV")))
pv = rep(NA,nrow(dat))
names(pv) = rownames(dat)
for (i in 1:nrow(dat)) {
  tmp = info %>%
  dplyr::select(SUBJECT) %>%
  mutate(value=dat[i, ])
  fit = aov(value~SUBJECT, data=tmp)
  ss[i,] = summary(fit)[[1]]["Sum Sq"][[1]]
  pv[i] = summary(fit)[[1]]["Pr(>F)"][[1]][1]
}

pv.bh = p.adjust(pv, "BH")
pv.bonf = p.adjust(pv, "bonferroni")
ssn = ss / rowSums(ss)

fn.ssn = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_genes_stability.txt")

ssn %>% as.data.frame() %>% tibble::rownames_to_column("gene") %>%
  mutate(pv = pv, pv.BH=pv.bh, pv.Bonf=pv.bonf) %>%
  fwrite(fn.ssn, sep="\t", col.names=T, row.names=F, quote=F)


#Tests and Explanations

#Function Library
try(setwd("~/Shared Files/DPM/Latest"))
source(file="ConsensusMechanism.r")

#Declare List
Scenarios <- vector("list")
SLabels <- vector("list")

#[1] Design Case
SLabels$Base <- "Basic Case - 14/24 [58%] Honest"

M1 <-  rbind(
    c(1,1,0,0),
    c(1,0,0,0),
    c(1,1,0,0),
    c(1,1,1,0),
    c(0,0,1,1),
    c(0,0,1,1))

row.names(M1) <- c("True", "Confused 1", "True", "Confused 2", "Liar", "Liar")
colnames(M1) <- c("C1.1","C2.1","C3.0","C4.0")

Scenarios$Base <- M1
#

# [2] Reversed Matrix
SLabels$Reversed <- "Basic Case - 14/24 [58%] Honest, reversed wording"
M2 <- ReverseMatrix(M1)
Scenarios$Reversed <- M2
#

# [3] Deviance: Deranged Nonconformist
SLabels$Deviance <- "Punishment from Deviating from Stable"

M3 <- rbind(M1[c(1,3),],
            M1[c(1,3),],
            "Liar"=c(0,0,1,1))

Scenarios$Deviance <- M3
#

# [4] Coalitional Deviance: Using a group to game the system.
SLabels$CoalitionalDeviance <- "Targeting Contract (#3) with <50% Conspirators (including 1 AntiTruth Diver)"
SLabels$CoalitionalDeviance2 <- "Targeting Contract (#3) with <50% Conspirators (including 1 AntiTeam Diver)"

 M4b <- rbind("True"=c(1,1,0,0),
              "True"=c(1,1,0,0),
              "True"=c(1,1,0,0),
              "True"=c(1,1,0,0),
              "True"=c(1,1,0,0),
              "True"=c(1,1,0,0),
              "Diver"=c(0,0,1,1), #Diver
              "Liar"=c(1,1,1,0),
              "Liar"=c(1,1,1,0),
              "Liar"=c(1,1,1,0), #4 conspirators
              "Liar"=c(1,1,1,0)) # + 1 Diver     = 5 <6

M4c <- M4b
M4c["Diver",3] <- 0 #Diver negatively correlated with his team

M4d <- rbind(M4c,"FailSafe"=c(.5,.5,.5,.5))

Scenarios$CoalitionalDeviance  <- M4b
Scenarios$CoalitionalDeviance2  <- M4c
#

# [5] Clueless: Passing on a Contract - "I have no idea"
SLabels$CluelessControl <- c("Having no idea - 'passing' on a contract [control]")
SLabels$CluelessTest <- c("Having no idea - 'passing' on a contract [test]")

M3a <- rbind(M1[1,],M1[1,],M1[1,],M1[1,],M1[1,],M1[1,],M1[1,]) #bigger reference case
row.names(M3a) <- rep("True",nrow(M3a))

M3m <- M3a
M3m[2,2] <- NA

Scenarios$CluelessControl <- M3a
Scenarios$CluelessTest <- M3m
#

# [6] Inchoerence
SLabels$Incoherence <- c("Punishing Incoherence - I KNOW that this contract is spam/nonsense")
SLabels$Incoherence2 <- c("Punishing Incoherence - I KNOW that this contract is spam/nonsense [2]")

M6 <- M3a
M6[-3,2]  <- .5 #Incoherent

M6b <- M6
M6b[7,2]  <- 0 #Incentive examination

Scenarios$Inchoherence <- M6
Scenarios$Inchoherence2 <- M6b
#

# [7] Unanimous: Perfect Consensus Bug
SLabels$Unanimous <- c("Having everyone agree perfectly (desireable) crashes PCA")

PerCon <- rbind(M1[1,], M1[1,], M1[1,], M1[1,])

Scenarios$PerCon <- PerCon
#

# [8] Contract Gaming
SLabels$Gaming <- c("Gaming the Contracts")

M9 <- cbind(M1,"C0.5"=.5,"C0.5"=.5,"C0.5"=.5,"C0.5"=.5,"C0.5"=.5,"C0.5"=.5,"C0.5"=.5,"C0.5"=.5)
M9[5:6,5:12] <- c(0,1,1,0)
M9 <- rbind(M9,M9,M9,M9)

Scenarios$Gaming <- M9
#

# [9] Handling Missing Values
SLabels$Missing1 <- c("A minority of players give missing values to 1 contract")
SLabels$Missing2 <- c("A majority of players give missing values to a minority of their contracts")
SLabels$Missing3 <- c("All players give missing values to a minority of their contracts")
SLabels$Missing4 <- c("Some players give missing values to a majority of their contracts")
SLabels$Missing5 <- c("All players give missing values to a majority of their contracts")

M10a <- cbind(M1,"C0"=c(0,NA,0,NA,1,1))

M10b <- cbind(M10a, "C1"=c(1,1,1,NA,0,0), "C1"=c(NA,NA,NA,0,1,1))
M10b <- rbind(M10b,M10b)

M10c <- M10b
M10c[5,1] <- NA ; M10c[6,2] <- NA ; M10c[11,1] <- NA ; M10c[12,2] <- NA ;

M10d <- M10b[-11:-12,]
M10d[5,3:6] <- NA ; M10d[6,1:4] <- NA ;
M10d[7:8,1:2] <- NA ; M10d[2,2:3] <- NA;

M10e <- rbind(M1,M1)
M10e <- cbind(M10e[,1],M10e,M10e)

M10e[1,1:5] <- NA
M10e[2,2:6] <- NA
M10e[3,3:7] <- NA
M10e[4,4:8] <- NA
M10e[5,5:9] <- NA
M10e[6,c(6:9,1)] <- NA
M10e[7,c(7:9,1:2)] <- NA
M10e[8,c(8:9,1:3)] <- NA
M10e[9,c(9,1:4)] <- NA
M10e[10,1:5] <- NA
M10e[11,2:6] <- NA
M10e[12,3:7] <- NA

Scenarios$Missing1 <- M10a
Scenarios$Missing2 <- M10b
Scenarios$Missing3 <- M10c
Scenarios$Missing4 <- M10d
Scenarios$Missing5 <- M10e
#

# [10] Riven Judgements
SLabels$Riven <- "Separate but equal subgroups, and their recombination. [1]"
SLabels$Riven2 <- "Separate but equal subgroups, and their recombination. [2]"

Mg <- rbind( cbind(M1,   M1*NA, M1*NA),
             cbind(M1*NA,M1,    M1*NA),
             cbind(M1*NA,M1*NA, M1))

Mg2 <- Mg
Mg2[7,1] <- 1

Scenarios$Riven <- Mg
Scenarios$Riven2 <- Mg2
#

### * Test Results and Commentary * ###

Factory(Scenarios$Base)
CompareIncentives(Scenarios$Base)
#Good.
Chain(X=Scenarios$Base)
#Very good. Conforms quickly to a correct prediction.
#I'm thinking one block per day, assuming we smooth difficulty correctly.

Factory(Scenarios$Reversed)
all.equal(Factory(Scenarios$Reversed)$Agents,Factory(Scenarios$Base)$Agents) #TRUE
#Identical incentive structure, despite reversed inputs and outputs.
#Good.

Factory(Scenarios$Deviance)
#Biggest Deviator gets CRUSHED to zero. High-Stakes!
#Good.

Factory(Scenarios$CoalitionalDeviance)
#Success: An attempted <51% attack which failed.

Factory(Scenarios$CoalitionalDeviance2)
# Oh, no: A Sucessful <51% attack 'Friendly Fire' ...will have to address this.

  #Pre-Analytics
  CompareIncentives(X=Scenarios$CoalitionalDeviance2)

  row.names( Scenarios$CoalitionalDeviance2 )[7] <- "Liar"
  CompareIncentives(X=Scenarios$CoalitionalDeviance2)

  # [1] Success: 'Symmetric Friendly Fire'  (ie Team truth forms a coalition of their own)
  Scenarios$CoalitionalDeviance3 <- Scenarios$CoalitionalDeviance2
  Scenarios$CoalitionalDeviance3[6,] <- c(0,0,1,1)

  CompareIncentives(X=Scenarios$CoalitionalDeviance3)
  Chain(Scenarios$CoalitionalDeviance3,N=100)
  #Team 'True' wins via symmetry-exploitation

  # [2] Success: 'Cold Feet 1' (a single player abandons the coalition)
  Scenarios$CoalitionalDeviance4 <- Scenarios$CoalitionalDeviance2
  Scenarios$CoalitionalDeviance4[8,] <- c(1,1,0,0)

  CompareIncentives(X=Scenarios$CoalitionalDeviance4)
  Ss <- Chain(Scenarios$CoalitionalDeviance4,N=70)[[70]]$Agents
  Ss <- data.frame(NewRep=as.numeric(Ss[,"NewRep"]),Group=row.names(Ss))
  aggregate(.~Group,data=Ss, FUN=sum)

  Scenarios$CoalitionalDeviance5 <- Scenarios$CoalitionalDeviance2
  Scenarios$CoalitionalDeviance5[8,] <- c(1,1,0,0)
  Scenarios$CoalitionalDeviance5[9,] <- c(1,1,0,0)

  CompareIncentives(X=Scenarios$CoalitionalDeviance5)
  Ss <- Chain(Scenarios$CoalitionalDeviance5,N=50)[[50]]$Agents
  Ss <- data.frame(NewRep=as.numeric(Ss[,"NewRep"]),Group=row.names(Ss))
  aggregate(.~Group,data=Ss, FUN=sum)
  #Notice after 50 rounds, the devil [=King of Liars] has actually become the two bottommost liars, as they represent the most significant source of confusion.
  #Team 'True' wins via stoicism

  #[3] Recursive Friendly Fire - a sub-coalition forms to defect, but a sub-coalition of this coalition forms to defect again.
  Scenarios$CoalitionalDeviance6 <- rbind(c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1), #10
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1),
                                          c(1,1,0,0,1), #15 (60%)

                                          #Coalition 1, backstabbing Truth to game contract 3
                                          c(0,0,0,1,0), #1 - Friendly Fire
                                          c(1,1,1,0,1),
                                          c(1,1,1,0,1),
                                          c(1,1,1,0,1),
                                          c(1,1,1,0,1),
                                          c(1,1,1,0,1), #6 (24%)

                                          #Coalition 2, 'backstabbing' Coalition 1 to game contract 4
                                          c(0,0,1,0,0), #1 - Friendly Fire
                                          c(1,1,0,1,1),
                                          c(1,1,0,1,1),
                                          c(1,1,0,1,1)) #4 (16%)

  row.names(Scenarios$CoalitionalDeviance6) <- c(rep('Truth',15),rep('Lie 1',6),rep('Lie 2',4))
  Factory(Scenarios$CoalitionalDeviance6)
  CompareIncentives(Scenarios$CoalitionalDeviance6)
  #fantastic sucess...Lie 2 loses less

  #clearly, the Nash Equilibrium
  Scenarios$CoalitionalDeviance7 <- Scenarios$CoalitionalDeviance6[1:21,]
  Scenarios$CoalitionalDeviance7 <- rbind(Scenarios$CoalitionalDeviance7, rbind(
                                                                              'Truth 2'=c(1,1,0,0,1),
                                                                              'Truth 2'=c(1,1,0,0,1),
                                                                              'Truth 2'=c(1,1,0,0,1),
                                                                              'Truth 2'=c(1,1,0,0,1)))
  Factory(Scenarios$CoalitionalDeviance7)
  CompareIncentives(Scenarios$CoalitionalDeviance7)

  # [4] Passive - Sideways expansion by 2 contracts
  Scenarios$CoalitionalDeviance8 <- cbind(Scenarios$CoalitionalDeviance2,Scenarios$CoalitionalDeviance2[,1:2])
  Factory(Scenarios$CoalitionalDeviance8)
  CompareIncentives(Scenarios$CoalitionalDeviance8)
  #Success, larger number of contracts makes this attack improbable.

  Scenarios$CoalitionalDeviance9 <- cbind(Scenarios$CoalitionalDeviance2,
                                          Scenarios$CoalitionalDeviance2,
                                          Scenarios$CoalitionalDeviance2,
                                          Scenarios$CoalitionalDeviance2[,-3])
  Factory(Scenarios$CoalitionalDeviance9)
  CompareIncentives(Scenarios$CoalitionalDeviance9)
  #The attack must expand proportionally.

Factory(Scenarios$CluelessControl)
Factory(Scenarios$CluelessTest)
#Finding: 2 falls from tie at 5th .11 to a tie at 7th with .07; no impact on other results: success.

#Note: Must be a discrete set of options: c(1,0,NA,.5)    ---- !!! by extention, Catch must be implemented in FillNA. Indeed, in this example our lazy character is punished twice.
#otherwise there will likely be pragmatic individuals who rationally deviate to answers like ~.85 or ~.92 or some nonsense. [obviously]

Factory(Scenarios$Inchoherence)
Factory(Scenarios$Inchoherence2)
#interesting behavior, but incentive compatible, particularly given low Schelling Salience
#incentive to switch to the consensus .5

Factory(Scenarios$PerCon)
#No problems.

Factory(Scenarios$Gaming)
CompareIncentives(Scenarios$Gaming)
#more or less what i expected

Factory(Scenarios$Missing1)
Factory(Scenarios$Missing2)
Factory(Scenarios$Missing3)
Factory(Scenarios$Missing4)
Factory(Scenarios$Missing5)
#Works

Factory(Scenarios$Riven)
Factory(Scenarios$Riven2)
#

# !!! Must FillNa with .5 FIRST, then average in, to prevent monopoly voting on brand-new contracts. (Actually, if it will eventually be ruled .5).

#Voting Across Time
#Later Votes should count more
#! ...simple change = ConoutFinal becomes exponentially smoothed result of previous chains.
#! require X number of chains (blocks) before the outcome is officially determined (two weeks?)

# Will need:
# 1] Percent Voted
# 2] Time Dimension of blocks.

#
# Possible solutions:
#   1 - sequential filling of NAs (sequential removal of columns) - pre-processing replace with average?
#   2 - what about the 'expert factor' idea? what happened to that?
#   3 - Completely replace FillNa with Reputations (lots of positives here)

#TO-DO
#Cascading reputation .6,.5,.3.,2., etc =   dexp(nrow(Mg))

#Mysterious behavior - loading only on first factor
#solutions
# 1- ignore. incentives will encourage filling out of contracts on 'obvious' events
# 2 - use later factors. Unknown what behavior could result from this

# [ Additive Reputation ] Is reputation completely additive? - Yes, now.

Mar1 <- M1
r1 <- rep(1/6,6)

Mar2 <- M1[-6,]
r2 <- c(1/6, 1/6, 1/6, 1/6, 2/6)

Mar3 <- M1[c(1,2,4,5),]
r3 <- c( 2/6, 1/6, 1/6, 2/6)

Mar4 <- M1[c(1,2,4,5,6),]
r4 <- c( 2/6, 1/6, 1/6, 1/6, 1/6)

Factory(Mar1,Rep=r1)$Agents
Factory(Mar2,Rep=r2)$Agents
Factory(Mar3,Rep=r3)$Agents
Factory(Mar4,Rep=r4)$Agents

#Is reputation additive? Yes (excluding NA-born effects, we could correct with Rep/mean(Rep) but NA is not part of equilibrium so it shouldnt matter).

Factory(Mg)$Agents[,c("OldRep","ThisRep","SmoothRep")]
Factory(Mg2)$Agents[,c("OldRep","ThisRep","SmoothRep")]
#True 1 of group 2 skyrockets ahead, as desired.

#upon reflection, I dont think this 'problem' is particularly bad.

# [ Scaling - What are the computational limits (on a normal machine)?]
#Many improvements can be made, of course.

TestLimit <- function(n1,n2,AddNa=1) {
  M_huge <- matrix(round(runif(n1*n2)),n1,n2)
  if(AddNa==1) M_huge[sample(1:(n1*n2),size=(n1*n2)/3)] <- NA
  print(Factory(M_huge))
}

system.time(print("1"))
system.time(TestLimit(100,10))
system.time(TestLimit(1000,100))
# user  system elapsed
# 0.66    0.00    0.65

# system.time(TestLimit(10000,1000))
# user  system elapsed
# 135.03    0.67  135.84

# system.time(TestLimit(100000,100))
# user  system elapsed
# 86.28    0.13   86.42

# system.time(TestLimit(100000,10))
# user  system elapsed
# 5.66    0.03    5.66
# registerDoParallel(cores=4)

# Ten million - 10,000,000. That's pretty big
#
# system.time(TestLimit(5000,500))
# user  system elapsed
# 13.53    0.02   13.52

#Solutions

# [1] - cap the number of rows
  # in its current state, it is basically unlimited - unrealistic
  # the first 100,000 votes are probably decentralized enough ...how low should this number go? (can be a f[ncol(Vmatrix)])
  # given that reputation is fully additive, this would discourage the spreading of reputations
  # this would also solve the "dust bust" question (ie suck up any accounts with tiny dust amounts of reputation)
  # can add the slow retarget to make this grow over the next thousand years (every 4 years?)

#after simply listing the specifics of this solution I realize it is the best candidate

#Steps

# [1] [CANCEL - BAD IDEA] Reward later factors (Comp.2, 3)? Seems risky...lets square the loadings or something to truly emphasize the first factor.
# [2] [DONE] Build R (reward matrix) as a proportion.
# [3] [DONE] What if the guy has no idea? NAs
# [4] [DONE] Fix 'perfect consensus' bug.
# [5] Reward function: a% of current reserve pool? [yes], payouts over time ? [this is whats happening, not finished yet]
# [6] Scale Cost By Funds availiable [????]
# [7] Add payment functionality (pay-per-vote)
# [8] Functionality for new arrivals..old contracts missing data.
# [9] [DONE] Remove incentive to create contracts where consensus is @.5 !
# [10.a] [DONE] Univariate fill missing data in an incentive-consistent way.
# [10.b] [part-DONE] Multivariate fill missing data (recursive? bootstrapped?) [chose simultaneous prediction, and ignore]
# [10.c  - FillNa should faithfully reproduce .5s]

# [adding a NA to a contract can wipe out the validations there, ONLY when filling NA, - fix by using exponential smoothing to calc Rewards] [Fixed!]
# [11] Ask - Ask people the outcomes of contracts...how to maximize (contract reward? d(Cr)?)

#

# [20 - Discourage "Obvious Outcome" Contracts by fee for open interest (more disagreement)]

###

# Ask <- function(M, p=.2, epsilon=.001) {
#
#   #M is the target matrix, r the random variable assigned to a player
#   #p is the weight given to NAs versus disputed outcomes
#   #epsilon is the weight given to otherwise weightless contracts.
#
#   Weight1 <- GetWeight( (Factory(M)[[2]][nrow(M)+4,]) + epsilon)  #Na Weight
#   Weight2 <- Factory(M)[[2]][nrow(M)+2,]                          #Contract Reward weight
#   Weight2 <- GetWeight( ((.25)-(Weight2-.5)^2) + epsilon)         #Transformation to find low-weighted
#
#   WeightC <- p*Weight1 + (1-p)*Weight2
#   ConCol <- sample(1:ncol(M),1,prob=WeightC)
#
#   #print(WeightC)
#
#   return(ConCol)
# }
#
# Ask(M1)

# temp <- unlist(lapply(1:100,FUN=function(x) Ask(M10a)))
# hist(temp)

#see Governance
# # [12] Create a New contract...it should cost(?)
# NewContract <- function(M) { #This is going to rely on a time dimension I havent implemented yet
# }
#
# OpenInterest <- function(M,c) {
#
# }

# [11] [Done] Ask
# [12] NewContract
# [13] Open Interest - Two disagreeing parties each pay Ai (i in 1,2 ; Sum(A)=1) to mint two new coins -- eventually redeemable for 0 and 1-FEEepsilon .

# [14] Subsidized Events - Principals paying Agents to influence the outcome of contracts.

# [14a] A market for an event will allow it's occurance to be noted by the Factory after it's occurance.
# [14b] Partition a 'Verification Space' (private information known only to the agent: date, time, colour, etc).
# [14c] Allow private bets within the Verification Space - possibly a second set of Colored Coins "specical coin".
# [14d] At EoC, people collect proportional to their holdings of insider-information coins.
# [14e] Assurance contracts to allow anyone to fund a 'club good' event.

#Plot
PlotJ(M1)


# Assignment 1
# Problem 2

# CLEAR WORK DIRECTORY
rm(list=ls())
setwd("C:/Users/Paras Garg/Documents/R/FE Assignments")

# INSTALLING AND USING PACKAGES
install.packages('doBy')
install.packages('ggplot2')
install.packages('plyr')
library('doBy')
library('ggplot2')
library('plyr')

### LOADING DATASETS
day_1 <- data.frame(read.csv("nyt1.csv"))
day_2 <- data.frame(read.csv("nyt2.csv"))
day_3 <- data.frame(read.csv("nyt3.csv"))

### FUNCTIONS
  # CREATE NEW AGE_GROUP VARIABLE
  age_var <- function (df) {
    df$Age_Group[df$Age < 20] <- '<20'
    df$Age_Group[df$Age >= 20 & df$Age < 30] <- '20-29'
    df$Age_Group[df$Age >= 30 & df$Age < 40] <- '30-39'
    df$Age_Group[df$Age >= 40 & df$Age < 50] <- '40-49'
    df$Age_Group[df$Age >= 50 & df$Age < 60] <- '50-59'
    df$Age_Group[df$Age >= 60 & df$Age < 70] <- '60-69'
    df$Age_Group[df$Age >= 70] <- '70+'

    #df$Age_Group <- cut(df$Age, c(-Inf,0,20,30,40,50,60,70,Inf), include.lowest = FALSE)
    return (df)
  }

  data_prep <- function (df) {
    df$Gender[df$Gender == 1] <- "Male"
    df$Gender[df$Gender == 0] <- "Female"
    df$Signed_In[df$Signed_In == 1] <- "Signed In"
    df$Signed_In[df$Signed_In == 0] <- "Not Signed In"
    return(df)
  }

  imp <- function(df, day) {
    ggplot(df, aes(x=Impressions, color=Age_Group)) + geom_density() +
      xlab("Impressions") + labs(color="Age") + ggtitle(paste(day, "Impressions", sep=": "))
  }

  ctr <- function(df, day, ref) {
    if (ref == "Imp") {
      ref <- "(Impressions > 0)"
    } else if (ref == "Clks") {
      ref <- "(Clicks > 0)"
    }

    ggplot(df, aes(x=Clicks/Impressions, color=Age_Group)) + geom_density() +
      xlab("Click-through-rate (CTR)") + labs(color="Age") +
      ggtitle(paste(day, "CTR", ref, sep=" : "))
  }

  click_var <- function (df) {
    df$Clicks_Cat <- cut(df$Clicks, c(-Inf,0,1,2,3,4,Inf), include.lowest = FALSE)
    return (df)
  }

  group_stats <- function(x) {
    c(length(x), min(x), max(x), mean(x))
  }

### Data Preparation
day_1 <- data_prep(age_var(day_1))
day_2 <- data_prep(age_var(day_2))
day_3 <- data_prep(age_var(day_3))

### ANALYSIS
#Impression
imp(day_1, "Day 1")
imp(day_2, "Day 2")
imp(day_2, "Day 3")

# Click Through Rate
ctr(subset(day_1, Impressions > 0), "Day 1", "Imp")
ctr(subset(day_2, Impressions > 0), "Day 2", "Imp")
ctr(subset(day_3, Impressions > 0), "Day 3", "Imp")

ctr(subset(day_1, Clicks > 0), "Day 1", "Clks")
ctr(subset(day_2, Clicks > 0), "Day 2", "Clks")
ctr(subset(day_3, Clicks > 0), "Day 3", "Clks")

# Impressions across Age Group
age_imp_boxplot <- function (df, day) {
  ggplot(df, aes(x = Age_Group, y = Impressions, fill=Age_Group)) +
    geom_boxplot() +
    xlab("Age Group") + guides(fill=FALSE) +
    ggtitle(paste(day, "Impressions Across Age Groups", sep=": "))
}

age_imp_hist <- function (df, day) {
  ggplot(df, aes(x = Impressions, fill = Age_Group)) +
    geom_histogram(bins = 15) + ggtitle(paste(day, "Impressions Across Age Groups", sep=": "))
}

age_imp_boxplot(day_1, "Day 1")
age_imp_boxplot(day_2, "Day 2")
age_imp_boxplot(day_3, "Day 3")

age_imp_hist(day_1, "Day 1")
age_imp_hist(day_2, "Day 2")
age_imp_hist(day_3, "Day 3")

# Click Through Rate across Age Group
age_ctr_boxplot <- function (df, day) {
  ggplot(df, aes(x = Age_Group, y = Clicks/Impressions, fill=Age_Group)) +
    geom_boxplot() +
    xlab("Age Group") + guides(fill=FALSE) +
    theme(plot.title = element_text(size=10)) +
    ggtitle(paste(day, "CTR Across Age Groups", sep=": "))
}

age_ctr_hist <- function (df, day) {
  ggplot(df, aes(x = Clicks/Impressions, fill = Age_Group)) +
    theme(plot.title = element_text(size=10)) +
    geom_histogram(bins = 15) + ggtitle(paste(day, "CTR Across Age Groups", sep=": "))
}

age_ctr_boxplot(subset(day_1, Clicks > 0 & Impressions > 0), "Day 1")
age_ctr_boxplot(subset(day_2, Clicks > 0 & Impressions > 0), "Day 2")
age_ctr_boxplot(subset(day_3, Clicks > 0 & Impressions > 0), "Day 3")

age_ctr_hist(subset(day_1, Clicks > 0 & Impressions > 0), "Day 1")
age_ctr_hist(subset(day_2, Clicks > 0 & Impressions > 0), "Day 2")
age_ctr_hist(subset(day_3, Clicks > 0 & Impressions > 0), "Day 3")

### Comparisons across user segments/demographics
# Male v/s Female
male_vs_female <- function (df, age_grp, day) {
  df <- subset(df, Age_Group == age_grp)

  ggplot(df, aes(x = Gender, y = ..count..)) +
    geom_bar(aes(colour = "black", fill = Gender)) +
    geom_text(stat='count', aes(label=..count..),vjust=2) +
    xlab("Gender") +
    ggtitle(paste(day, "Age Group (<20 Age)", sep = " : "))
}

male_vs_female(day_1, "<20", "Day 1")
male_vs_female(day_2, "<20", "Day 2")
male_vs_female(day_3, "<20", "Day 3")

# SignedIn v/s Not SignedIn
loggedin_vs_not <- function (df, day) {
  ggplot(df, aes(x = Signed_In, y = ..count../1000)) +
    geom_bar(aes(colour = "black", fill = Signed_In)) +
    geom_text(stat='count', aes(label=..count..), vjust=2) +
    ylab("Total (in thousands)") +
    xlab("Day 1: Logged In Stats") +
    ggtitle(paste(day, "Signed In Status", sep = " : "))
}

loggedin_vs_not(day_1, "Day 1")
loggedin_vs_not(day_2, "Day 2")
loggedin_vs_not(day_3, "Day 3")

# Clicked v/s not clicked
clicked_vs_not <- function (df, day) {
  df$Have_Clicked[df$Clicks > 0] <- "Clicked"
  df$Have_Clicked[df$Clicks == 0] <- "Not Clicked"

  ggplot(df, aes(x = Have_Clicked, y = ..count../1000)) +
    geom_bar(aes(colour = "black", fill = Have_Clicked)) +
    geom_text(stat='count', aes(label=..count..),vjust=1.5) +
    ylab("Total (in thousands)") +
    xlab("Clicks") +
    ggtitle(paste(day, "Clicks Status", sep = " : "))
}

clicked_vs_not(day_1, "Day 1")
clicked_vs_not(day_2, "Day 2")
clicked_vs_not(day_3, "Day 3")

### METRICS AND DISTRIBUTION ANALYSIS
# Impression across age groups
ggplot(day_1,aes(x=Age_Group, y=Impressions, fill=Age_Group)) +
  geom_boxplot() + xlab("Age Grpups") + guides(fill=FALSE) +
  ggtitle("Day 1: Impressions accross Age Group")

ggplot(day_2,aes(x=Age_Group, y=Impressions, fill=Age_Group)) +
  geom_boxplot() + xlab("Age Grpups") + guides(fill=FALSE) +
  ggtitle("Day 2: Impressions accross Age Group")

ggplot(day_3,aes(x=Age_Group, y=Impressions, fill=Age_Group)) +
  geom_boxplot() + xlab("Age Grpups") + guides(fill=FALSE) +
  ggtitle("Day 3: Impressions accross Age Group")

# Number of Impressions across Age Groups
ggplot(day_1, aes(x=Impressions, y = ..count../1000, fill=Age_Group)) +
  ylab("Total (in thousands)") +
  geom_histogram(bins = 15) + ggtitle("Day 1: Number of Impressions")

ggplot(day_2, aes(x=Impressions, y = ..count../1000, fill=Age_Group)) +
  ylab("Total (in thousands)") +
  geom_histogram(bins = 15) + ggtitle("Day 2: Number of Impressions")

ggplot(day_3, aes(x=Impressions, y = ..count../1000, fill=Age_Group)) +
  ylab("Total (in thousands)") +
  geom_histogram(bins = 15) + ggtitle("Day 3: Number of Impressions")

# Number of Impressions across Gender
ggplot(day_1, aes(x=Impressions,  fill=Gender, colour=Gender)) +
  geom_bar() +
  xlab("Impressions") + ggtitle("Day 1: Impressions across Gender")

ggplot(day_2, aes(x=Impressions,  fill=Gender, colour=Gender)) +
  geom_bar() +
  xlab("Impressions") + ggtitle("Day 2: Impressions across Gender")

ggplot(day_3, aes(x=Impressions,  fill=Gender, colour=Gender)) +
  geom_bar() +
  xlab("Impressions") + ggtitle("Day 3: Impressions across Gender")

# Distribution of Clicks across Gender
ggplot(subset(day_1, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Gender)) + geom_bar() +
  ggtitle("Day 1: Clicks across Gender")

ggplot(subset(day_2, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Gender)) + geom_bar() +
  ggtitle("Day 2: Clicks across Gender")

ggplot(subset(day_3, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Gender)) + geom_bar() +
  ggtitle("Day 3: Clicks across Gender")

# Distribution of Clicks across Age Groups
ggplot(subset(day_1, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Age_Group)) + geom_bar() +
  ggtitle("Day 1: Clicks across Age Groups")

ggplot(subset(day_2, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Age_Group)) + geom_bar() +
  ggtitle("Day 2: Clicks across Age Groups")

ggplot(subset(day_3, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Age_Group)) + geom_bar() +
  ggtitle("Day 3: Clicks across Age Groups")

# Distribution of Clicks across signed in status
ggplot(subset(day_1, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Signed_In)) + geom_bar() +
  ggtitle("Day 1: Clicks across User SignedIn Status")

ggplot(subset(day_3, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Signed_In)) + geom_bar() +
  ggtitle("Day 2: Clicks across User SignedIn Status")

ggplot(subset(day_3, Impressions > 0 & Clicks > 0), aes(x=Clicks, fill=Signed_In)) + geom_bar() +
  ggtitle("Day 3: Clicks across User SignedIn Status")

FE 582 - Foundation of Financial Data Science/Assignments/Assignment 1/Problem_2.r