###############################################################################
# 01-generating-images.r
###############################################################################

setwd("~/Dropbox/PAPERS/textasdata")
library(topicmodels)
library(reshape)
load("data_out/lda_results-twokenizer.Rdata")

###############################################################################
### A) Computing top 10 words for each topic
###############################################################################

K <- 100
num.words <- 15
normalized.topics <- exp(lda.fit@beta) / rowSums(exp(lda.fit@beta))

calculate.specificity <- function(mod) {
  if(!inherits(mod,"LDA") & !inherits(mod,"CTM") ) stop("mod object must inherit from LDA or CTM")
  terms <- posterior(mod)$terms
  topics <- posterior(mod)$topics
  Nwords<-ncol(terms)
  Ntopics<-ncol(topics)
  Ndocs<-nrow(topics)
  ptopic <- apply(topics,2,sum)/Ndocs
  pwords <- apply(terms,2,function(x) sum(x*ptopic))
  numer <- terms*ptopic
  denom  <- matrix(pwords,nrow=Ntopics,ncol=Nwords,byrow=TRUE)
  return(numer/denom)
}

normalized.words <- calculate.specificity(lda.fit)

scores <- apply(normalized.topics, 2, function(x)
    x * ( log(x + 1e-05) - sum(log(x + 1e-05))/length(x)) )
colnames(scores) <- lda.fit@terms
words <- apply(scores, 1, function(x)
        colnames(scores)[order(x, decreasing = TRUE)[1:num.words]])
f.scores <- apply(scores, 1, function(x)
        x[order(x, decreasing = TRUE)[1:num.words]])
n.topics <- rep(seq(1, K, 1), each=num.words)
info.df <- data.frame(
    topic = n.topics,
    word = c(words),
    score = c(f.scores),
    stringsAsFactors=F)

info.df$specificity <- NA
for (i in 1:length(info.df$topic)){
    info.df$specificity[i] <- normalized.words[info.df$topic[i], which(colnames(scores) %in% info.df$word[i])]
}
info.df$topic <- paste0("Topic ", info.df$topic)
info.df$topic <- factor(info.df$topic, levels=paste0("Topic ", 1:K))
info.df$order <- factor(order.topics <- rep(seq(1, num.words, 1), times=K), levels=as.character(15:1))

# generating figures

library(ggplot2)
library(gtable)
library(gridExtra)
library(scales)
library(ggdendro)
library(ggthemes)

for (k in 1:K){

	cat(k, '\n')

	df <- info.df[info.df$topic==paste0('Topic ', k),]

	p <- ggplot(data=df,
		aes(y=order, x=specificity, label=word))
	pq <- p + geom_text(aes(size=score), hjust=1) +
    	scale_size_continuous(range=c(3,5)) +
    	scale_y_discrete("Top 10 scoring words for each topic",
        	expand=c(0.03, 0.1)) +
    	scale_x_continuous("Specificity of word to each topic",
        	limit=c(min(df$specificity)-.75, 1)) +
    	theme_bw() +
    	theme(axis.line = element_blank(),
    	panel.grid.major = element_blank(),
    	panel.grid.minor = element_blank(),
    	panel.border = element_blank(),
    	panel.background = element_blank(),
    	axis.text = element_blank(),
    	axis.ticks = element_blank(),
    	axis.title.y = element_text(size = rel(.6)),
    	axis.title.x = element_text(size = rel(.6)),
    	legend.position = "none") +
    	geom_vline(xintercept = min(df$specificity)-.75, color="grey80", linetype=7) +
    	geom_hline(yintercept = 0.5, color="grey80", linetype=7)

	pq

	ggsave(pq, file=paste0("05-dashboard/files/img/words-plot-", k, '.png'), height=3.5, width=3)

}

###############################################################################
### B) Computing time series for each topic
###############################################################################

## getting list of dates
fls <- list.files('data_out/tweets/text')
dates <- substr(fls, 1, 10)
dates <- gsub('_', '-', dates)
party <- substr(fls, 12, 14)
chamber <- gsub('.*_(.*)\\.txt','\\1',fls)

## computing differences across parties
time.series <- t(lda.fit@gamma)
df <- data.frame(chamber = rep(chamber, each=100),
    date = rep(as.Date(dates), each=100),
    party = rep(party, each=100),
    topic = rep(1:100, 2920), prop=c(time.series),
    stringsAsFactors=F)

## media data
#nyt <- read.csv("data_out/nytimes-dataset-filtered.csv", stringsAsFactors=F)
# load("data_out/lda-nyt-results.Rdata")
# nyt <- data.frame(
#   date = nyt$date,
#   topic = apply(results$topic, 1, which.max),
#   count = 1,
#   stringsAsFactors=F)
# agg <- aggregate(nyt$count, by=list(date=nyt$date, topic=nyt$topic), sum)
# names(agg)[3] <- 'count'
# lng <- aggregate(nyt$count, by=list(date=nyt$date), sum)
# names(lng)[2] <- 'sum'
# agg <- merge(agg, lng, all.x=TRUE)
# agg$prop <- agg$count / agg$sum
# agg$date <- as.Date(agg$date)

# load("data_out/lda-nyt-agg-results.Rdata")
# dd <- seq(as.Date("2013-01-01"), as.Date("2014-12-31"), by="day")
# nyt <- data.frame(
#   topic = rep(1:100, each=730),
#   date = rep(dd, 100),
#   prop = c(results$topics),
#   stringsAsFactors=F)

load("data_out/lda-media-results.Rdata")
dd <- seq(as.Date("2013-01-01"), as.Date("2014-12-30"), by="day")
media <- data.frame(
  topic = rep(1:100, each=729),
  date = rep(dd, 100),
  prop = c(results$topics),
  stringsAsFactors=F)

## public
users <- scan("data_out/matrix/users-list.txt", what='character')
load("data_out/lda-public-results.Rdata")
dd <- substr(users[grep('_public', users)], 1, 10)
pub <- data.frame(
  date = rep(as.Date(dd), K),
  topic = rep(1:K, each=nrow(results$topics)),
  prop = c(results$topics), stringsAsFactors=F)

# public (democrats)
dd <- substr(users[grep('_democr', users)], 1, 10)
load("data_out/lda-dems-results.Rdata")
dem <- data.frame(
  date = rep(as.Date(dd), K),
  topic = rep(1:K, each=nrow(results$topics)),
  prop = c(results$topics), stringsAsFactors=F)

# public (republicans)
dd <- substr(users[grep('_repub', users)], 1, 10)
load("data_out/lda-reps-results.Rdata")
rep <- data.frame(
  date = rep(as.Date(dd), K),
  topic = rep(1:K, each=nrow(results$topics)),
  prop = c(results$topics), stringsAsFactors=F)

# random users
dd <- seq(as.Date("2013-01-01"), as.Date("2014-12-31"), by="day")
load("data_out/random-users-results.Rdata")
rnd <- data.frame(
  date = rep(as.Date(dd), K),
  topic = rep(1:K, each=nrow(results$topics)),
  prop = c(results$topics), stringsAsFactors=F)

## random uses

for (k in 1:K){

  # parties
	sbs <- df[df$topic==k,]
	sbs <- aggregate(sbs$prop, by=list(date=sbs$date, party=sbs$party), FUN=mean)
	# media
  mm <- merge(data.frame(date=unique(sbs$date), stringsAsFactors=F),
    media[media$topic==k, c("date", "prop")], all.x=TRUE)
  mm$prop[is.na(mm$prop)] <- 0

  # public
  pp <- merge(data.frame(date=unique(sbs$date), stringsAsFactors=F),
    pub[pub$topic==k, c("date", "prop")], all.x=TRUE)
  pp$prop[is.na(pp$prop)] <- 0
  dd <- merge(data.frame(date=unique(sbs$date), stringsAsFactors=F),
    dem[dem$topic==k, c("date", "prop")], all.x=TRUE)
  dd$prop[is.na(dd$prop)] <- 0
  rr <- merge(data.frame(date=unique(sbs$date), stringsAsFactors=F),
    rep[rep$topic==k, c("date", "prop")], all.x=TRUE)
  rr$prop[is.na(rr$prop)] <- 0

  ## random users
  rnn <- merge(data.frame(date=unique(sbs$date), stringsAsFactors=F),
    rnd[rnd$topic==k, c("date", "prop")], all.x=TRUE)
  rnn$prop[is.na(rnn$prop)] <- 0

  sbs <- data.frame(
		date = unique(sbs$date),
		Democrats = round(sbs$x[sbs$party=="dem"], 3),
		Republicans = round(sbs$x[sbs$party=="rep"], 3),
    Media = round(mm$prop, 3),
    Public = round(pp$prop, 3),
    Democratic_Supporters = round(dd$prop, 3),
    Republican_Supporters = round(rr$prop, 3),
    Random_Users= round(rnn$prop, 3))

	write.csv(sbs, file=paste0("05-dashboard/files/data/ts-", k, '.csv'),
		row.names=FALSE, quote=FALSE)

}

###############################################################################
### C) Computing quantities of interest
###############################################################################

qois <- data.frame(
  topic = 1:K,
  prop = NA,
  prop_sen_dems = NA,
  prop_sen_reps = NA,
  prop_house_dems = NA,
  prop_house_reps = NA,
  media = NA,
  public = NA,
  republicans = NA,
  democrats = NA,
  random = NA)

# topic proportions
load("data_out/lda_results-twokenizer.Rdata")
qois$prop <- apply(lda.fit@gamma, 2, mean)*100

# by party and chamber
df <- data.frame(chamber = rep(chamber, each=100),
    date = rep(as.Date(dates), each=100),
    party = rep(party, each=100),
    topic = rep(1:100, 2920), prop=c(time.series),
    stringsAsFactors=F)
agg <- aggregate(df$prop, by=list(topic=df$topic, party=df$party, chamber=df$chamber), FUN=mean)

qois$prop_sen_dems <- agg$x[agg$party=="dem" & agg$chamber=="senate"]*100
qois$prop_sen_reps <- agg$x[agg$party=="rep" & agg$chamber=="senate"]*100
qois$prop_house_dems <- agg$x[agg$party=="dem" & agg$chamber=="house"]*100
qois$prop_house_reps <- agg$x[agg$party=="rep" & agg$chamber=="house"]*100

# media
# nyt <- read.csv("data_out/nytimes-dataset-filtered.csv", stringsAsFactors=F)
# load("data_out/lda-nyt-results.Rdata")
# nyt <- data.frame(
#   date = nyt$date,
#   topic = apply(results$topic, 1, which.max),
#   stringsAsFactors=F)
# tab <- prop.table(table(nyt$topic))
# qois$media <- as.numeric(tab)*100
load("data_out/lda-media-results.Rdata")
qois$media <- sapply(1:K, function(x) mean(results$topics[,x]))*100

# public
load("data_out/lda-public-results.Rdata")
qois$public <- sapply(1:K, function(x) mean(results$topics[,x]))*100
load("data_out/lda-dems-results.Rdata")
qois$democrats <- sapply(1:K, function(x) mean(results$topics[,x]))*100
load("data_out/lda-reps-results.Rdata")
qois$republicans <- sapply(1:K, function(x) mean(results$topics[,x]))*100
load("data_out/random-users-results.Rdata")
qois$random <- sapply(1:K, function(x) mean(results$topics[,x]))*100

# sanity check
plot(qois$prop, qois$media)
plot(qois$prop_sen_dems, qois$prop_house_dems)

cor(qois)

# saving to disk
save(qois, file="05-dashboard/qois.rdata")

# top scoring MCs for each topic

###############################################################################
### D) Representative tweets
###############################################################################

library(slam)
library(Matrix)
library(tm)

ind <- scan("data_out/matrix/rs-dtm-indices.txt")
pointers <- scan("data_out/matrix/rs-dtm-pointers.txt")
values <- scan("data_out/matrix/rs-dtm-values.txt")
words <- scan("data_out/matrix/congress-words.txt", what="character", sep="\n")
tweets <- read.csv("data_out/tweets/tweets-random-sample.csv", stringsAsFactors=F, colClasses="character")

X <- sparseMatrix(j=ind, p=pointers, x=values,
  dims=c(nrow(tweets), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

# deleting empty rows
todelete <- which(rowSums(X)==0)
X <- X[-todelete,]
tweets <- tweets[-todelete,]

load('data_out/lda-rs-results.Rdata')

# deleting duplicated tweets
duplicated <- which(duplicated(tweets$text))
tweets <- tweets[-duplicated,]
results$topics <- results$topics[-duplicated,]

# deleting weird tweets
todelete <- grep('xss', tweets$text)
tweets <- tweets[-todelete,]
results$topics <- results$topics[-todelete,]

K <- 100
rs <- list()

for (k in 1:K){
  choices <- tail(order(results$topics[,k]),n=6)
  rs[[k]] <- tweets[choices,]
  rs[[k]]$topic <- k
}
rs <- do.call(rbind, rs)

# function to display embedded tweet
tw.embed <- function(text, name, screen_name, id_str, created_at, dt, js=FALSE){
    txt <- paste0('

',
        text, '
 ', name, " (@", screen_name,
        ") ",
        dt, '
')
    if (js){
        txt <- paste0(txt,
            ' ')
    }
    return(txt)
}

# preparing embed
rs$embed <- NA
for (i in 1:nrow(rs)){

  rs$embed[i] <- tw.embed(rs$text[i], rs$screen_name[i], rs$screen_name[i], rs$id_str[i],
    "", "")

}

save(rs, file="05-dashboard/rs-tweets.rdata")

###############################################################################
### D) Representative media tweets
###############################################################################

library(slam)
library(Matrix)
library(tm)

ind <- scan("data_out/matrix/media-rs-dtm-indices.txt")
pointers <- scan("data_out/matrix/media-rs-dtm-pointers.txt")
values <- scan("data_out/matrix/media-rs-dtm-values.txt")
words <- scan("data_out/matrix/congress-words.txt", what="character", sep="\n")
tweets <- read.csv("data_out/tweets/media-tweets-random-sample.csv", stringsAsFactors=F, colClasses="character")

X <- sparseMatrix(j=ind, p=pointers, x=values,
  dims=c(nrow(tweets), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

# deleting empty rows
todelete <- which(rowSums(X)==0)
X <- X[-todelete,]
tweets <- tweets[-todelete,]

load('data_out/lda-media-rs-results.Rdata')

# deleting duplicated tweets
duplicated <- which(duplicated(tweets$text))
tweets <- tweets[-duplicated,]
results$topics <- results$topics[-duplicated,]

# deleting weird tweets
todelete <- grep('xss', tweets$text)
tweets <- tweets[-todelete,]
results$topics <- results$topics[-todelete,]

K <- 100
rs <- list()

for (k in 1:K){
  choices <- tail(order(results$topics[,k]),n=6)
  rs[[k]] <- tweets[choices,]
  rs[[k]]$topic <- k
}
rs <- do.call(rbind, rs)

# function to display embedded tweet
tw.embed <- function(text, name, screen_name, id_str, created_at, dt, js=FALSE){
    txt <- paste0('

',
        text, '
 ', name, " (@", screen_name,
        ") ",
        dt, '
')
    if (js){
        txt <- paste0(txt,
            ' ')
    }
    return(txt)
}

# preparing embed
rs$embed <- NA
for (i in 1:nrow(rs)){

  rs$embed[i] <- tw.embed(rs$text[i], rs$screen_name[i], rs$screen_name[i], rs$id_str[i],
    "", "")

}

media_rs <- rs
save(media_rs, file="05-dashboard/media-rs-tweets.rdata")

# ###############################################################################
# ### E) Representative articles
# ###############################################################################

# nyt <- read.csv("data_out/nytimes-dataset-filtered.csv", stringsAsFactors=F)
# hl <- read.csv("data_out/nyt-headlines.csv", stringsAsFactors=F)
# nyt <- merge(nyt, hl, all.x=TRUE, sort=FALSE)
# load("data_out/lda-nyt-results.Rdata")

# K <- 100
# nytrs <- list()

# for (k in 1:K){
#   choices <- tail(order(results$topics[,k]),n=5)
#   nytrs[[k]] <- nyt[choices,]
#   nytrs[[k]]$url <- paste0(
#     '
[', nytrs[[k]]$date, '] ', toupper(nytrs[[k]]$headline),
#     '. ',  nytrs[[k]]$abstract, '
\n')
#   nytrs[[k]]$topic <- k
# }
# nytrs <- do.call(rbind, nytrs)

# save(nytrs, file="05-dashboard/rs-nyt.rdata")

###############################################################################
### F) MCs using each topic the most
###############################################################################

load('data_out/lda-mcs-results.Rdata')
mcs <- scan("data_out/matrix/mcs-list.txt", what='character')

K <- 100
topmcs <- list()

for (k in 1:K){
  choices <- tail(order(results$topics[,k]),n=5)
  topmcs[[k]] <- data.frame(screenName = mcs[choices], stringsAsFactors=F)
  topmcs[[k]]$topic <- k
}

topmcs <- do.call(rbind, topmcs)
topmcs$order <- 1:nrow(topmcs)
mcs <- read.csv("data_out/congress_data.csv", stringsAsFactors=F)

topmcs <- merge(topmcs,
  mcs[,c("screenName", "party", "state")], all.x=TRUE, sort=FALSE)

topmcs <- topmcs[order(topmcs$order),]
topmcs$text <- paste0(
  ' @', topmcs$screenName, ' (',
    topmcs$party, '-', topmcs$state, ')')

save(topmcs, file="05-dashboard/top-mcs.rdata")


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet()

## ----eval=FALSE---------------------------------------------------------------
## a <- aregImpute(~ age + sex + bp + death +
##                 heart.attack.before.death,
##                 data=mydata, n.impute=5)
## f <- fit.mult.impute(death ~ rcs(age,3) + sex +
##                      rcs(bp,5), lrm, a, data=mydata)

## ----eval=FALSE---------------------------------------------------------------
## support <- transform(support,
##                      totcst = ifelse(is.na(totcst),
##                        (expression_in_charges), totcst))


###### ASSIGNMENT 1 ######
###### QUESTION 1 ######

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

### INSTALLING AND INCLUING PACKAGES
install.packages('gdata')
install.packages('ggplot2')
install.packages('plyr')
library('gdata')
library('ggplot2')
library('plyr')
library("doBy")

### LOADING DATASETS
bronx <- read.xls("rollingsales_bronx.xls", perl = "C:\\Perl64\\bin\\perl.exe", pattern="BOROUGH")
brooklyn <- read.xls("rollingsales_brooklyn.xls", perl = "C:\\Perl64\\bin\\perl.exe", pattern="BOROUGH")
manhattan <- read.xls("rollingsales_manhattan.xls", perl = "C:\\Perl64\\bin\\perl.exe", pattern="BOROUGH")
queens <- read.xls("rollingsales_queens.xls", perl = "C:\\Perl64\\bin\\perl.exe", pattern="BOROUGH")
staten <- read.xls("rollingsales_statenisland.xls", perl = "C:\\Perl64\\bin\\perl.exe", pattern="BOROUGH")

### DATA FORMATTING FUNCTION
format_data <- function (df) {
  df$GROSS.SQUARE.FEET.N <- as.numeric((gsub("[^[:digit:]]","", df$GROSS.SQUARE.FEET)))
  df$LAND.SQUARE.FEET.N <- as.numeric((gsub("[^[:digit:]]","", df$LAND.SQUARE.FEET)))
  df$SALE.PRICE.N <- as.numeric(gsub("[^[:digit:]]","",df$SALE.PRICE))

  df$SALE.DATE <- as.Date(df$SALE.DATE)
  df$YEAR.BUILT <- as.numeric(as.character(df$YEAR.BUILT))

  return (df)
}

### DATA CLEANING FUNCTION
clean_data <- function (df) {
  #Removing NA values
  df <- df[!is.na(df$GROSS.SQUARE.FEET.N), ]
  df <- df[!is.na(df$LAND.SQUARE.FEET.N), ]
  df <- df[!is.na(df$SALE.PRICE.N), ]

  #Removing outliners
  df$SALE.PRICE.LOG <- log(df$SALE.PRICE.N)
  df <- df[df$SALE.PRICE.LOG > 5, ]

  #Categorize sales buildings
  family_category <- grepl("FAMILY", df$BUILDING.CLASS.CATEGORY) * 1
  condos_category <- grepl("CONDOS", df$BUILDING.CLASS.CATEGORY) * 2
  coops_category <- grepl("COOPS", df$BUILDING.CLASS.CATEGORY) * 3

  category <- as.character(family_category + condos_category + coops_category)
  category[category == "1"] <- "FAMILY"
  category[category == "2"] <- "CONDOS"
  category[category == "3"] <- "COOPS"
  category[category == "0"] <- "OTHERS"

  df$BUILDING.CLASS.CATEGORY.N <- factor(category)

  return (df)
}

### DATA FRAMES FORMATTING AND CLEANING
bronxDf <- clean_data(format_data(bronx))
brooklynDf <- clean_data(format_data(brooklyn))
manhattanDf <- clean_data(format_data(manhattan))
queensDf <- clean_data(format_data(queens))
statenDf <- clean_data(format_data(staten))

### ANALYSIS ACROSS BOROUGHS
  # Borough vs Sale Price for particular Building Class
  borough_sp <- function (class) {
      outliers <- bronxDf$SALE.PRICE.LOG[bronxDf$BUILDING.CLASS.CATEGORY.N == class]
      borough_1 <- data.frame(BOROUGH = rep("Bronx", length(outliers)), SALE.PRICE.LOG = outliers)

      outliers <- brooklynDf$SALE.PRICE.LOG[brooklynDf$BUILDING.CLASS.CATEGORY.N == class]
      borough_2 <- data.frame(BOROUGH = rep("Brooklyn", length(outliers)), SALE.PRICE.LOG = outliers)

      outliers <- manhattanDf$SALE.PRICE.LOG[manhattanDf$BUILDING.CLASS.CATEGORY.N == class]
      borough_3 <- data.frame(BOROUGH = rep("Manhattan", length(outliers)), SALE.PRICE.LOG = outliers)

      outliers <- queensDf$SALE.PRICE.LOG[queensDf$BUILDING.CLASS.CATEGORY.N == class]
      borough_4 <- data.frame(BOROUGH = rep("Queens", length(outliers)), SALE.PRICE.LOG = outliers)

      outliers <- statenDf$SALE.PRICE.LOG[statenDf$BUILDING.CLASS.CATEGORY.N == class]
      borough_5 <- data.frame(BOROUGH = rep("Staten Island", length(outliers)), SALE.PRICE.LOG = outliers)

      finalDf <- rbind(borough_1, borough_2, borough_3, borough_4, borough_5)
      ggplot(finalDf, aes(x=BOROUGH, y=SALE.PRICE.LOG, fill=BOROUGH, colour=BOROUGH, group=BOROUGH)) +
        geom_boxplot() +
        ggtitle(class)
  }

  borough_sp("FAMILY")
  borough_sp("CONDOS")
  borough_sp("COOPS")
  borough_sp("OTHERS")

  # Building Class vs Sale Price for particular Borough
  building_sp <- function (df, borough) {
    BUILDING.CLASS <- df$BUILDING.CLASS.CATEGORY.N
    SALE.PRICE.LOG <- df$SALE.PRICE.LOG

    ggplot(df, aes(x=BUILDING.CLASS, y=SALE.PRICE.LOG, fill=BUILDING.CLASS, colour=BUILDING.CLASS, group=BUILDING.CLASS)) +
      geom_boxplot() +
      ggtitle(borough)
  }

  building_sp(bronxDf, "BRONX")
  building_sp(brooklynDf, "BROOKLYN")
  building_sp(manhattanDf, "MANHATTAN")
  building_sp(queensDf, "QUEENS")
  building_sp(statenDf, "STATEN ISLAND")

  # Sale Price vs Gross Square feet for particular Borough
  gross_sp <- function (df, borough) {
    SALE.PRICE.LOG <- df$SALE.PRICE.LOG
    GROSS.SQFT.LOG <- log(df$GROSS.SQUARE.FEET.N)
    BUILDING.CLASS <- df$BUILDING.CLASS.CATEGORY.N

    ggplot(df, aes(x=SALE.PRICE.LOG, y=GROSS.SQFT.LOG, fill=BUILDING.CLASS, colour=BUILDING.CLASS)) +
      geom_point() +
      ggtitle(borough)
  }

  gross_sp(bronxDf, "BRONX")
  gross_sp(brooklynDf, "BROOKLYN")
  gross_sp(manhattanDf, "MANHATTAN")
  gross_sp(queensDf, "QUEENS")
  gross_sp(statenDf, "STATEN ISLAND")

  # Sale Price vs Frequency for particular Borough
  sp_freq <- function (df, borough) {
    par(mfrow=c(2,2))
    hist(log(df[df$BUILDING.CLASS.CATEGORY.N=="FAMILY",]$SALE.PRICE.N),
         col="#8daeb4", main="Family Homes", xlab= "SALE.PRICE.LOG",
         cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    hist(log(df[df$BUILDING.CLASS.CATEGORY.N=="CONDOS",]$SALE.PRICE.N),
         col="#0d447a", main="CONDOS", xlab= "SALE.PRICE.LOG",
         cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    hist(log(df[df$BUILDING.CLASS.CATEGORY.N=="COOPS",]$SALE.PRICE.N),
         col="#ffbe4c", main="COOPS", xlab= "SALE.PRICE.LOG",
         cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    hist(log(df[df$BUILDING.CLASS.CATEGORY.N=="OTHERS",]$SALE.PRICE.N),
         col="#fddf5f", main="Others", xlab= "SALE.PRICE.LOG",
         cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    title(main = borough, outer = TRUE, cex.main=1.0, line=-1)
  }

  sp_freq(bronxDf, "BRONX")
  sp_freq(brooklynDf, "BROOKLYN")
  sp_freq(manhattanDf, "MANHATTAN")
  sp_freq(queensDf, "QUEENS")
  sp_freq(statenDf, "STATEN ISLAND")

  ## Summary
  summary_stats <- function(df, borough) {
    summaryBy(data = df, SALE.PRICE.N + GROSS.SQUARE.FEET.N ~ BUILDING.CLASS.CATEGORY.N,
              FUN = c(length, mean, median),
              fun.names = c("Total no.", "Mean", "Median"),
              var.names = c(borough))
  }

  summary_stats(bronxDf, "Bronx")
  summary_stats(brooklynDf, "Brooklyn")
  summary_stats(manhattanDf, "Manhattan")
  summary_stats(queensDf, "Queens")
  summary_stats(statenDf, "Staten Island")

### ANALYSIS ACROSS TIME
  # DAY AND MONTH FETCHER FUNCTION
  day_month <- function (df) {
    df$DAY <- format(df$SALE.DATE, "%A")
    df$DAY <- factor(df$DAY, levels = c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday"))

    df$MONTH <- format(df$SALE.DATE, "%B")
    df$MONTH <- factor(df$MONTH, levels = c("January", "February", "March", "April", "May", "June", "July",
                                            "August", "September", "October", "November", "December"))
    return(df)
  }

  bronxTime <- day_month(bronxDf)
  brooklynTime <- day_month(brooklynDf)
  manhattanTime <- day_month(manhattanDf)
  queensTime <- day_month(queensDf)
  statenTime <- day_month(statenDf)

  # Total sale of Building Class in Months
  monthly_sale <- function (class) {
    filter <- bronxTime$SALE.PRICE.LOG[bronxTime$BUILDING.CLASS.CATEGORY.N == class]
    month <- bronxTime$MONTH[bronxTime$BUILDING.CLASS.CATEGORY.N == class]
    borough_1 <- data.frame(BOROUGH = rep("Bronx", length(filter)), SALE.PRICE.LOG = filter, MONTH=month)

    filter <- brooklynTime$SALE.PRICE.LOG[brooklynTime$BUILDING.CLASS.CATEGORY.N == class]
    month <- brooklynTime$MONTH[brooklynTime$BUILDING.CLASS.CATEGORY.N == class]
    borough_2 <- data.frame(BOROUGH = rep("Brooklyn", length(filter)), SALE.PRICE.LOG = filter, MONTH=month)

    filter <- manhattanTime$SALE.PRICE.LOG[manhattanTime$BUILDING.CLASS.CATEGORY.N == class]
    month <- manhattanTime$MONTH[manhattanTime$BUILDING.CLASS.CATEGORY.N == class]
    borough_3 <- data.frame(BOROUGH = rep("Manhattan", length(filter)), SALE.PRICE.LOG = filter, MONTH=month)

    filter <- queensTime$SALE.PRICE.LOG[queensTime$BUILDING.CLASS.CATEGORY.N == class]
    month <- queensTime$MONTH[queensTime$BUILDING.CLASS.CATEGORY.N == class]
    borough_4 <- data.frame(BOROUGH = rep("Queens", length(filter)), SALE.PRICE.LOG = filter, MONTH=month)

    filter <- statenTime$SALE.PRICE.LOG[statenTime$BUILDING.CLASS.CATEGORY.N == class]
    month <- statenTime$MONTH[statenTime$BUILDING.CLASS.CATEGORY.N == class]
    borough_5 <- data.frame(BOROUGH = rep("Staten Island", length(filter)), SALE.PRICE.LOG = filter, MONTH=month)

    finalDf <- rbind(borough_1, borough_2, borough_3, borough_4, borough_5)
    ggplot(finalDf, aes(x=MONTH, y=SALE.PRICE.LOG, fill=MONTH, colour=MONTH, group=MONTH)) +
      theme(axis.text.x=element_text(angle = 90, vjust = 0.5)) +
      geom_boxplot() +
      ggtitle(class)
  }

  monthly_sale("FAMILY")
  monthly_sale("CONDOS")
  monthly_sale("COOPS")
  monthly_sale("OTHERS")

  # Number of sale of Building Class by Month for particular Borough
  building_sale_month <- function (df, class, borough) {

    SALE.PRICE.LOG <- df$SALE.PRICE.LOG[df$BUILDING.CLASS.CATEGORY.N == class]
    ggplot(df, aes(x=MONTH, y=SALE.PRICE.LOG, fill=MONTH, colour=MONTH, group=MONTH)) +
      geom_boxplot() +
      theme(axis.text.x=element_text(angle = 90, vjust = 0.5)) +
      xlab(borough) +
      ggtitle(class)
  }

  building_sale_month(bronxTime, "FAMILY", "Bronx")
  building_sale_month(bronxTime, "CONDOS", "Bronx")
  building_sale_month(bronxTime, "COOPS", "Bronx")
  building_sale_month(bronxTime, "OTHERS", "Bronx")

  building_sale_month(brooklynTime, "FAMILY", "Brooklyn")
  building_sale_month(brooklynTime, "CONDOS", "Brooklyn")
  building_sale_month(brooklynTime, "COOPS", "Brooklyn")
  building_sale_month(brooklynTime, "OTHERS", "Brooklyn")

  building_sale_month(manhattanTime, "FAMILY", "Manhattan")
  building_sale_month(manhattanTime, "CONDOS", "Manhattan")
  building_sale_month(manhattanTime, "COOPS", "Manhattan")
  building_sale_month(manhattanTime, "OTHERS", "Manhattan")

  building_sale_month(queensTime, "FAMILY", "Queens")
  building_sale_month(queensTime, "CONDOS", "Queens")
  building_sale_month(queensTime, "COOPS", "Queens")
  building_sale_month(queensTime, "OTHERS", "Queens")

  building_sale_month(statenTime, "FAMILY", "Staten Island")
  building_sale_month(statenTime, "CONDOS", "Staten Island")
  building_sale_month(statenTime, "COOPS", "Staten Island")
  building_sale_month(statenTime, "OTHERS", "Staten Island")

  # Sale Price vs Gross Square feet for particular Borough
  gross_sp_time <- function (df, borough) {
    SALE.PRICE.LOG <- df$SALE.PRICE.LOG
    GROSS.SQFT.LOG <- log(df$GROSS.SQUARE.FEET.N)
    MONTH <- df$MONTH

    ggplot(df, aes(x=SALE.PRICE.LOG, y=GROSS.SQFT.LOG, fill=MONTH, colour=MONTH, group=MONTH)) +
      geom_point() +
      ggtitle(borough)
  }

  gross_sp_time(bronxTime, "Bronx")
  gross_sp_time(brooklynTime, "Brooklyn")
  gross_sp_time(manhattanTime, "Manhattan")
  gross_sp_time(queensTime, "Queens")
  gross_sp_time(statenTime, "Staten Island")

  # Sale Price vs Frequency for particular Borough
  sp_freq_time <- function (df, borough) {
    hist(log(df[(df$MONTH=="January" | df$MONTH=="Fabruary" | df$MONTH=="March"),]$SALE.PRICE.N),
         col="#8daeb4", main="QUATER 1", xlab= "SALE.PRICE.LOG",
         cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    hist(log(df[(df$MONTH=="April" | df$MONTH=="May" | df$MONTH=="June"),]$SALE.PRICE.N),
         col="#8daeb4", main="QUATER 2", xlab= "SALE.PRICE.LOG",
        cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    hist(log(df[(df$MONTH=="July" | df$MONTH=="August" | df$MONTH=="September"),]$SALE.PRICE.N),
         col="#8daeb4", main="QUATER 3", xlab= "SALE.PRICE.LOG",
         cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    hist(log(df[(df$MONTH=="October" | df$MONTH=="November" | df$MONTH=="December"),]$SALE.PRICE.N),
         col="#8daeb4", main="QUATER 4", xlab= "SALE.PRICE.LOG",
         cex.lab=0.75, cex.main=0.75, cex.axis=0.75)
    title(main = borough, outer = TRUE, cex.main=1.0, line=-1)
  }

  sp_freq_time(bronxTime, "Bronx")
  sp_freq_time(brooklynTime, "Brooklyn")
  sp_freq_time(manhattanTime, "Manhattan")
  sp_freq_time(queensTime, "Queens")
  sp_freq_time(statenTime, "Staten Island")

  ## SUMMARY
  #Summary of the sale prices & gross square feet acrross borough and time
  summary_time_stats <- function(df, borough) {
    summaryBy(data = df, SALE.PRICE.N + GROSS.SQUARE.FEET.N ~ MONTH,
              FUN = c(length, mean, median),
              fun.names = c("Total no.", "Mean", "Median"),
              var.names = c(borough))
  }

  summary_time_stats(bronxTime, "Bronx")
  summary_time_stats(brooklynTime, "Brooklyn")
  summary_time_stats(manhattanTime, "Manhattan")
  summary_time_stats(queensTime, "Queens")
  summary_time_stats(statenTime, "Staten Island")

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


library(clinfun)
source(file.path(PROJECT_DIR, "R/functions/get_score.r"))
source(file.path(PROJECT_DIR, "R/functions/load_sig.r"))
source(file.path(PROJECT_DIR, "R/functions/gg_color_hue.r"))

# load CD38 signature genes
fn.cd38.cor = file.path(PROJECT_DIR, "generated_data", "CHI", "robust_corr_genes.txt")
gene.sig = load_sig(fn.cd38.cor, "cor.mean.sd.ratio", ntop=10)

# load gene expression data
fn.ge = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_GE_matrix_gene.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", "CHI", "CHI_sample_info_2_CD38hi.txt")
info = fread(fn.si, data.table=F)
info = info %>% mutate(Response = factor(Response, levels=c("low","middle","high")))

sexclr = gg_color_hue(2) %>% setNames(c("F","M"))

for(sex in c("F","M")) {

df = data.frame()
df.text = data.frame()

for (tp in c(0,-7,70)) {
  si = with(info, time == tp & gender==sex)# & !is.na(CD38hi))
  sum(si)
  tdat = dat[,si]
  tinfo = info[si,]

  day.pt = case_when(
    tp == 0 ~ "Baseline 1 (day 0)",
    tp == -7 ~ "Baseline 2 (day -7)",
    tp == 70 ~ "Baseline 3 (day 70)"
  )

  gi = toupper(rownames(tdat)) %in% toupper(gene.sig)
  sum(gi)

  ihl = tinfo$Response %in% c("low","middle","high")
  X = get_score(tdat[gi,])[ihl]
  Y = tinfo$Response[ihl]

  j.pv = jonckheere.test(X, as.numeric(Y), alternative = "inc")$p.value

  df.text = rbind(df.text,
                  data.frame(day.label = day.pt,
                             label.j.pv=sprintf("p = %.2g",j.pv)))

  tmp = data.frame(day = paste0("day ", tp), day.label=day.pt, subject=tinfo$subject[ihl], score=X, Response=factor(Y))
  df = rbind(df, tmp)
}

df.text$x = rep(0.25, 3)
df.text$y = rep(0.1, 3)

df = df %>%
  mutate(day.label = factor(day.label))

# Generate boxplots
ggplot(df, aes(x=Response, y=score)) +
  geom_boxplot(aes(alpha=day.label), fill=sexclr[[sex]], outlier.colour = NA) +
  geom_dotplot(binaxis = "y", stackdir = "center", aes(fill=Response)) +
  facet_wrap(~day.label, nrow=1) +
  scale_fill_manual(values=c("white", "grey50", "black"), name="Response",
                    breaks=c(0,1,2), labels=c("low","middle","high")) +
  scale_alpha_manual(values=c(0.5,0.2,0.8)) +
  geom_text(data = df.text, aes(label=label.j.pv), x=1.5, y=Inf,vjust=1.1, hjust=0.5, size=4, inherit.aes = F) +
  xlab("Response") + ylab("TGSig score") +
  coord_cartesian(xlim=c(0.8, 3.2)) +
  theme_bw() + theme(legend.position="none") +
  theme(panel.border = element_blank(), strip.background = element_blank(),
        strip.text.x = element_text(size=12),
        panel.spacing = unit(0,"mm"), panel.grid.major.x = element_blank(),
        axis.ticks = element_blank())
fn.fig = file.path(PROJECT_DIR, "figure_generation", glue::glue("TGSig_vs_response_{sex}.only"))
ggsave(paste0(fn.fig, ".png"), w=7,h=4)
ggsave(paste0(fn.fig, ".pdf"), w=7,h=4)

}


#TIC TAC TOE GAME
library(tictactoe)

ttt(ttt_human(name="GIUSEPPE"), ttt_random())

player1<- ttt_ai()
player2<- ttt_ai()
SimulatedGame <- ttt_simulate(player1, player2, N = 100)

str(SimulatedGame)

prop.table(table(SimulatedGame))

player3<- ttt_ai()
player4<- ttt_ai()

TrainPlayer4 <- ttt_qlearn(player4, N = 500, verbose = FALSE)

SimulatedGameQLearn <- ttt_simulate(player3, player4, N = 100)

prop.table(table(SimulatedGameQLearn))


####################################################################
## Helper functions and algorithms for analysis of data shown in "The immune contexture of hepatocellular carcinoma predicts clinical outcome"
## V 1.0
## (c) Moritz Hess 2018

#####################################################################
score.universal <- function(Genes,mat,thres="median",direction="both",addone=TRUE)
{
    ## Computes a score for each sample (individual) based on the expression of selected genes and their association with survival. The higher the score, the longer is the expected survival.
    ## "Genes" is a Named Vector, indicating the gene names and the ratio of the proportional hazard: 1 = increasing hazard probability with increasing expression, -1 = decreasing hazard probability with increasing expression.
    ## "mat" is an expression matrix (rows=genes,columns=samples); approximately normally distributed eg. log transformed
    ## "score" is the returned score per individual

    GeneNames <- names(Genes)
    genesdir <- Genes
    mat <- t(scale(t(mat)))
    .i <- intersect(GeneNames,rownames(mat))
    mat <- mat[.i,]

    score <- rep(0,ncol(mat))
    for (i in .i)

    {

        .med <- median(mat[i,])
        .med <- rep(.med,4)
        if (thres !="median")
        {
            .med <- quantile(mat[i,])
        }

        if (sign(genesdir[i]) ==1)
        {
            score.log <- mat[i,]< .med[2]

        }
        else if (sign(genesdir[i]) ==-1)
        {
            score.log <- mat[i,]> .med[4]

        }
        increaseby <- 1
        if (!addone)
        {
            increaseby <- genesdir[i]
        }
        score[score.log] <- score[score.log] + abs(increaseby)
        if (direction=="both")
        {
            score[!score.log] <- score[score.log] - abs(increaseby)
        }
    }
    score
}

permcelltest <- function(unip,n,externaluniverse=NULL)
{
    ## Computes the probability of an average z-score of a gene set.
    ## "unip" is a named list containing z-scores from e.g. a cox model. Each list entry is a named vector containing the z-scores of a gene set. Gene sets have to be mutually exclusive. "n" determines the number of conducted simulations to retrieve the empirical null distribution of observing a particular average z-score per gene-set. In each simulation (S_i), for each gene set, a random number of genes (z-scores) of equal size as the gene set are sampled from all available z-scores (across all gene sets) and average z-scores are computed per gene-set. The number of simulated average absolute z-scores, exceeding the absolute value of the empirical averaged z-score per gene-set is the p-value for the respective z-score.
    gene.universe <- unlist(unip)
    if (!is.null(externaluniverse))
    {
        gene.universe = externaluniverse
    }

    unip.length <- sapply(unip,length)
    nrep <- n
    .bg <- lapply(unip.length, function(x) sapply(1:nrep,function(y) mean(sample(gene.universe,x))))
    .obs <- sapply(unip, function(x) mean(x))
    .obs.p.r <- sapply(names(.obs), function(x) length(which(.bg[[x]] >.obs[[x]]))/nrep)
    .obs.p.l <- sapply(names(.obs), function(x) length(which(.bg[[x]] <.obs[[x]]))/nrep)
    .obs.p <- apply(cbind(.obs.p.r,.obs.p.l),1,min)
    return (.obs.p)
}

plotzscoreenrich <- function(unip,enrichp,fdrthres=0.05)
{
    ## Plots the distribution of z-scores per gene-set ("unip") and the p-values from "permcelltest" ("enrichp").
    xx <- unip
    xx <- lapply(xx,function(x) x * -1)
    xx.v <- enrichp[names(unip)]
    xx.vp <- p.adjust(xx.v,method="bonferroni")
    xx.vp <- sapply(xx.vp, function(x) ifelse(x<fdrthres,yes="*", no=""))
    xx.v <- sapply(xx.v, function(x) sprintf("%.4f",x))
    # pdf(sprintf('%s.pdf',fnamesuffix))
    .min <- min(unlist(xx))
    .max <- max(unlist(xx))
    plot(NA,xlim=c(.min,.max),ylim=c(0.5,length(xx)+0.5),ylab='',xlab= ' - Beta/SE(Beta),  Cox proportional hazards model ',axes=FALSE)
    axis(1)
    mtext('Immune Cell Type',2,3)
    box <- boxplot(xx,horizontal = TRUE,add=TRUE,axes=FALSE,border='black',outline=FALSE)#,boxwex=0.7)
    parc <- par()
    .min <- parc$usr[1]
    .max <- parc$usr[2]
    avg. <- sapply(xx,mean)
    .name.pos <- ifelse(avg. > 0, yes =4,no=2)
    .digit.side <- ifelse(avg. > 0, yes =2,no=4)
    .number.pos <- ifelse(avg. > 0, yes=5,no=1)
    .number.pos. <- c()
    for (i in 1:length(.number.pos))
    {
        .number.pos. <- c(.number.pos.,box$stats[.number.pos[i],i])
    }
    text(y=1:length(xx),x=.number.pos.,pos=.name.pos,labels=names(xx),col='grey')
    .number.pos <- ifelse(avg. > 0, yes=1,no=5)
    .number.pos. <- c()
    for (i in 1:length(.number.pos))
    {
        .number.pos. <- c(.number.pos.,box$stats[.number.pos[i],i])
    }
    .lab <- apply(cbind(box$n,xx.v[box$names],xx.vp[box$names]),1,paste,collapse=" | ")
    text(y=(1:length(xx))+0.25,x=.number.pos.,labels=.lab,pos=.digit.side,cex=0.7,col='grey')
    par(xpd=FALSE)
    abline(v=0)

    # dev.off()
}

###########################
## Convenience Functions ##
###########################
unicoxexpression <- function(mat,survtable,formula)
{
    require(survival)
    cox.univariate.results <- list()
    for (id in rownames(mat))
    {
        cur.df <- data.frame(Expression = as.numeric(mat[id,]),survtable)

        Mod <- coxph(formula,data=cur.df)
        cox.univariate.results[[id]] <- Mod
    }
    cox.univariate.results
}

cellcox <- function(immunelist,mainmat,cox.table,Formula)
{

    cox.univariate.results <- list()
    system.time(

        for ( cell.type in names(immunelist))
        {
            cell.type.ids <- immunelist[[cell.type]]
            mat <- mainmat[cell.type.ids,]
            celltyperesults <- unicoxexpression(mat=mat,survtable = cox.table,formula=Formula)
            cox.univariate.results[[cell.type]] <- celltyperesults
        }
    )
    return(cox.univariate.results)
}

Limma.Pipe <- function(Counts,Model,Block=Replicate,Voom=FALSE, Random=FALSE,Correlation=0){
    library(limma)
    library(edgeR)

    {
        if ( Voom )
            {

                nf <- calcNormFactors(Counts)
                Self.nointeract <- voom(Counts,Model,lib.size = colSums(Counts)*nf,plot=TRUE)
            }
        else
            {
                Self.nointeract <- Counts
            }
    }
    {
        if ( Random )
            {
                corfit <- duplicateCorrelation(Self.nointeract, ndups=1, block = Block)
            }
        else
            {
                corfit <- list(consensus.correlation=Correlation)
            }
    }
    Self.nointeract.fit <- lmFit(Self.nointeract,Model,correlation = corfit$consensus.correlation,block=Block)
    Self.nointeract.fit <- eBayes(Self.nointeract.fit)
    Output <- list(Transformed = Self.nointeract, Model = Self.nointeract.fit, Correlation = corfit)
    return(Output)
}


library(rgdal)
library(ggplot2)
#shape file
sh <- readOGR("/tmp/shapes/CA_State_TIGER2016.shp")
#sh_df <- fortify(sh)
points <- data.frame(lat=c(37), long = c(-120))
coordinates(points) <-~long+lat
proj4string(points)<-CRS("+proj=longlat +datum=NAD83")
points <- spTransform(points, CRS(proj4string(sh)))
identical(proj4string(sh), proj4string(points))
points <- data.frame(points)
map<-ggplot() + geom_polygon(data = sh, aes(x=long, y=lat, group = group)) + geom_point(data= points, aes(x=long, y = lat), color="red")
ggsave('file.png', plot=map)


#' Unit Testing script for NMF package: NMFfit objects
#'
#' @author Renaud Gaujoux
#' @creation 22 April 2009

# make the internal functions/objects visible
if( isNamespaceLoaded('NMF') ){
	NMFfitX <- NMF:::NMFfitX
}

.TestSeed <- 123456

.testData <- function(n=20, r=3, m=10, ...){
	syntheticNMF(n, r, m, ...)
}

#' Unit test for the number of iterations
test.niter <- function(){

	# set random seed
	set.seed(.TestSeed)
	# generate random target matrix
	r <- 3; V <- .testData(r=r)

	# fit an iterative model
	res <- nmf(V,r)
	checkTrue(!is.null(niter(res)), "The number of iterations is set by the default -- iterative -- algorithm")
	# fit with SNMF/R(L)
	res <- nmf(V,r, method='snmf/r')
	checkTrue(!is.null(niter(res)), "The number of iterations is set by the SNMF/R algorithms")
	res <- nmf(V,r, method='snmf/l')
	checkTrue(!is.null(niter(res)), "The number of iterations is set by the SNMF/R algorithms")

	# fix number of iterations
	res <- nmf(V, r, .stop=function(strat, i, target, data, ...) if(i>=10) TRUE else FALSE)
	checkEquals(niter(res), 10, "The number of iterations is correctly set in the case of a fixed number of iterations .stop function")

}

test.isNMFfit <- function(){

	# set random seed
	set.seed(.TestSeed)
	# generate random target matrix
	r <- 3; V <- .testData(r=r)

	# single run
	res <- nmf(V, 2)
	checkTrue(isNMFfit(res), "isNMFfit returns TRUE on the result of a single run")

	# multiple runs - keeping single fit
	resm <- nmf(V, 2, nrun=3)
	checkTrue(isNMFfit(resm), "isNMFfit returns TRUE on the result of a multiple runs - keep best")

	# multiple runs - keeping all fits
	resM <- nmf(V, 2, nrun=3, .opt='k')
	checkTrue(isNMFfit(resM), "isNMFfit returns TRUE on the result of a multiple runs - keep best")

	# with a list of results
	checkEquals(isNMFfit(list(res, resm, resM)), rep(TRUE, 3), "isNMFfit returns [TRUE TRUE TRUE] on a list of 3 NMF results")
	checkEquals(isNMFfit(list(res, resm, resM, 'not a result')), c(rep(TRUE, 3), FALSE), "isNMFfit returns [TRUE TRUE TRUE FALSE] on a list of 3 NMF results + 1 not result")
	checkEquals(isNMFfit(list(res, resm, resM), recursive=FALSE), FALSE, "isNMFfit returns FALSE on a list of 3 NMF results when 'recursive=FALSE'")

}

#' Unit test for function nmf.equal
test.nmf.equal <- function(){

	check.nmf.equal <- function(type=c('NMF', 'NMFfit', 'NMFfitX1', 'NMFfitXn')){

		n <- 100; r <- 3; m <- 20

		# create an NMF model
		set.seed(123)
		V <- rmatrix(n, m)
		resM <- nmf(V, 3)
		resM <- NMFfitX(list(resM))

		## utility functions
		create.type <- function(type, obj){
			a <- if( type=='NMF' )
				fit(obj)
			else if( type=='NMFfit' )
				minfit(obj)
			else if( type=='NMFfitX1' )
				NMFfitX(obj, .merge=TRUE)
			else
				obj

			if( type != 'NMF' ){
				#print(class(a))
				stopifnot( class(a) == type )
			}
			a
		}

		add.diff <- function(obj, addon){
			basis(fit(obj[[1]])) <- basis(fit(obj[[1]])) + rmatrix(basis(fit(obj[[1]])), max=addon)
			obj
		}
		##

		a <- create.type(type, resM)
		sapply(c('NMF', 'NMFfit', 'NMFfitX1', 'NMFfitXn'), function(type2){

				b <- create.type(type2, resM)

				type.pair <- paste(type, "x", type2)
				# on same object
				checkTrue( nmf.equal(a, a), paste(type.pair, "- Default: returns TRUE on same object"))
				checkTrue( nmf.equal(a, a, identical=TRUE), paste(type.pair, "- With identical=TRUE: returns TRUE on same object"))
				checkTrue( nmf.equal(a, a, identical=FALSE), paste(type.pair, "- With identical=FALSE: returns TRUE on same object"))
				checkTrue( nmf.equal(a, a, identical=FALSE, tol=0), paste(type.pair, "- With identical=FALSE, tol=0: returns TRUE on same object"))
				checkTrue( nmf.equal(a, a, tol=0), paste(type.pair, "- With only argument tol=0: returns TRUE on same object"))

				# on almost same object
				b <- add.diff(resM, .Machine$double.eps ^ 0.6)
				b <- create.type(type2, b)

				checkTrue( !nmf.equal(a, b), paste(type.pair, "- Default: returns FALSE on almost same object"))
				checkTrue( !nmf.equal(a, b, identical=TRUE), paste(type.pair, "- With identical=TRUE: returns FALSE on almost same object"))
				checkTrue( nmf.equal(a, b, identical=FALSE), paste(type.pair, "- With identical=FALSE: returns TRUE on almost same object"))
				checkTrue( nmf.equal(a, b, identical=FALSE, tol=10^-4)
						, paste(type.pair, "- With identical=FALSE, tol > difference: returns TRUE on almost same object"))
				checkTrue( nmf.equal(a, b, tol=10^-4)
						, paste(type.pair, "- With only argument tol > difference: returns TRUE on almost same object"))
				checkTrue( !isTRUE(nmf.equal(a, b, identical=FALSE, tolerance= .Machine$double.eps * 2))
						, paste(type.pair, "- With identical=FALSE, tol < difference: returns FALSE on almost same object"))
				checkTrue( !isTRUE(nmf.equal(a, b, tolerance= .Machine$double.eps * 2))
						, paste(type.pair, "- With only argument tol < difference: returns FALSE on almost same object"))

				# on very different object
				b <- add.diff(resM, 10)
				b <- create.type(type2, b)

				checkTrue( !nmf.equal(a, b), paste(type.pair, "- Default: returns FALSE on very different object"))
				checkTrue( !nmf.equal(a, b, identical=TRUE), paste(type.pair, "- With identical=TRUE: returns FALSE on very different object"))
				checkTrue( !isTRUE(nmf.equal(a, b, identical=FALSE)), paste(type.pair, "- With identical=FALSE: returns FALSE on very different object"))
				checkTrue( nmf.equal(a, b, identical=FALSE, tol=11)
						, paste(type.pair, "- With identical=FALSE, tol > difference: returns TRUE on very different object"))
				checkTrue( nmf.equal(a, b, tol=11)
						, paste(type.pair, "- With only argument tol > difference: returns TRUE on very different object"))
				checkTrue( !isTRUE(nmf.equal(a, b, identical=FALSE, tol=0.5))
						, paste(type.pair, "- With identical=FALSE, tol < difference: returns FALSE on very different object"))
				checkTrue( !isTRUE(nmf.equal(a, b, tol=0.5))
						, paste(type.pair, "- With only argument tol < difference: returns FALSE on very different object"))
		})

	}

	sapply(c('NMF', 'NMFfit', 'NMFfitX1', 'NMFfitXn'), check.nmf.equal)

}

test.deviance <- function(){

}


library(ggplot2)
library(dplyr)

gaps <- read.table("bronze_gap_1mbp_bins.tsv",header=T,sep="\t")

ggplot(gaps %>% mutate(bin.count=1)
	    %>% group_by(Chr)
	    %>% mutate(bin.pos = cumsum(bin.count) - 0.5*bin.count),
	    aes(x=Chr, y=bin.count, fill=N_Perc)) +
	    coord_flip() +
	    theme_bw() +
	    geom_bar(stat="identity") +
	    scale_x_discrete(limits=c("Ha17","Ha16","Ha15","Ha14","Ha13","Ha12",
	    "Ha11","Ha10","Ha9","Ha8","Ha7","Ha6","Ha5","Ha4","Ha3","Ha2","Ha1")) +
	    scale_fill_gradient("Percent gaps", low = "white", high = "black",
	    limits=c(0,max(gaps$N_Perc))) +
	    xlab("Chromosome") +
	    ylab("1Mbp bins") +
	    theme(axis.line = element_blank(),
	    panel.grid.major = element_blank(),
	    panel.grid.minor = element_blank(),
	    panel.border = element_blank(),
	    panel.background = element_blank())


# diagnosis-per-patient-count

# count number of unique diagnoses per patient

library(tidyverse) #for packages dplyr

# create a small example dataframe
df1 <- data_frame( patient = c(1,1,1,2,2,2,3,3,3),
                   diagnosis = c('a','b','c','d','d','e','f','f','f'))

# count diagnoses per patient using dplyr
# key part is 'group_by()'
df2 <- df1 %>%
  group_by(patient) %>%
  summarize(n_diagnoses = length(unique(diagnosis)))

df2
#         patient n_diagnoses
# 1       1           3
# 2       2           2
# 3       3           1


BNP_DIR = "/Users/jtobin/projects/bnp"
DP_SRC  = paste(BNP_DIR, "dirichlet-process/src/dp.r", sep = "/")

source(DP_SRC)

# FIXME (jtobin): this may not be correct
hdp = function(n, a, h, n1, n2, a1, a2) {
  g0 = dp(n, a, h)
  h0 = function() { sample(g0[[1]], size = 1) }
  g1 = dp(n1, a1, h0)
  g2 = dp(n1, a1, h0)
  h1 = function() { sample(g1[[1]], size = 1) }
  h2 = function() { sample(g2[[1]], size = 1) }
  list(dp(n2, a2, h1), dp(n2, a2, h2))
  }


# DESeq
pasillaCountTable = read.table(“file.txt”, header = TRUE, row.names = 1)
pasillaDesign = data.frame(row.names = colnames(pasillaCountTable),
                           condition = c("untreated", "untreated", "treated", "treated", "treated"),
                           libType = c("paired-end", "paired-end", "paired-end", "paired-end", "paired-end"))
pairedSamples = pasillaDesign$libType == "paired-end"
countTable = pasillaCountTable[, pairedSamples]
condition = pasillaDesign$condition[pairedSamples]
condition = factor(c("untreated", "untreated", "treated", "treated", "treated"))
cds = newCountDataSet(countTable, condition)
cds = estimateSizeFactors(cds)
cds = estimateDispersions(cds)
res = nbinomTest(cds, "untreated", "treated")
write.csv(res, file = "file_deseq_results.csv")


library(readxl)
library(rpart)
sdf=read_excel("M-LC.csv")
sdf
vilist=NULL
for(r in 1:T)#(480,T=10000;240,T=6000;120,T=2000)
{
    selrows=sample(1:nrow(sdf),nrow(sdf),replace=T)
    selcols=c("Species",sample(setdiff(colnames(sdf),"Species"),15))
    trainset=sdf[selrows,selcols]
    oobset=sdf[setdiff(1:nrow(sdf),selrows),selcols]
    t0=rpart(Species~.,data=trainset)
    oobset$pred=predict(t0,oobset,type="class")
    oob=1-sum(diag(table(oobset$Species,oobset$pred)))/nrow(oobset)
    oobset$pred=NULL
    var=setdiff(selcols,"Species")
    decreaseAccuracy=NULL
    for(ivar in var)
    {
        oobset_sl=oobset
        eval(parse(text=paste("oobset_sl$",ivar,"=sample(oobset_sl$",ivar,
                              ",nrow(oobset_sl))",sep="")))
        oobset_sl$pred=predict(t0,oobset_sl,type="class")
        oob_sl=1-sum(diag(table(oobset_sl$Species,
                                oobset_sl$pred)))/nrow(oobset_sl)
         decreaseAccuracy=c(decreaseAccuracy,(oob_sl-oob))
    }

    names(decreaseAccuracy)=var
    vilist=c(vilist,decreaseAccuracy)
}

d0=data.frame(var=names(vilist),val=vilist,stringsAsFactors=F)
out_avg=aggregate.data.frame(d0$val,by=list(d0$var),mean)
out_sd=aggregate.data.frame(d0$val,by=list(d0$var),sd)
MeanDecreaseAccuracy.scale=out_avg[,2]/out_sd[,2]
names(MeanDecreaseAccuracy.scale)=out_sd[,1]
write.table(MeanDecreaseAccuracy.scale,file="significance(lr_i).txt",col.names=T,quote=T)


#' sum
#'
#' Sums any combination of float/numeric vector(s)/matri[x|ces].
#'
#' @details
#' If there are any elements in \code{...}, all elements in the list will first
#' be summed in their native precision, then converted to double precision so
#' they can be combined with \code{base::sum()}.  The final result will be cast
#' to single precision if \code{...} contains only integer and/or float objects.
#' Otherwise, the return will be double precision.
#'
#' @param x
#' A float matrix.
#' @param ...
#' Additional elements (numeric/float vectors/matrices) to sum.
#' @param na.rm
#' should NA's be removed?
#'
#' @return
#' A single value.
#'
#' @examples
#' library(float)
#' x = flrunif(10, 3)
#'
#' sum(x)
#' sum(x, 1)
#'
#' @useDynLib float R_sum_spm
#' @name sum
#' @rdname sum
NULL

sum_float32_ = function(x, na.rm)
{
  ret = .Call(R_sum_spm, DATA(x), na.rm)
  float32(ret)
}

summer = function(x, na.rm)
{
  if (is.float(x))
    dbl(sum_float32_(x, na.rm=na.rm))
  else
    sum(x, na.rm=na.rm)
}

sum_float32 = function(x, ..., na.rm=FALSE)
{
  additional = list(...)
  xsum = sum_float32_(x, na.rm=na.rm)

  if (length(additional) > 0)
  {
    additional_sum = base::sum(sapply(additional, summer, na.rm=na.rm))
    if (any(sapply(additional, is.double)))
      dbl(xsum) + additional_sum
    else
      xsum + fl(additional_sum)
  }
  else
    xsum
}

#' @rdname sum
#' @export
setMethod("sum", signature(x="float32"), sum_float32)


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(cowplot))
suppressPackageStartupMessages(library(RColorBrewer))
suppressPackageStartupMessages(library(svglite))

# Load helper functions
source(file.path("scripts", "util.R"))

fig_extensions <- c('.png', '.pdf', '.svg')

# Create theme
correlation_theme <- theme(axis.text.x = element_text(angle = 90, size = 5),
                           plot.title = element_text(hjust = 0.5),
                           legend.text = element_text(size = 8),
                           legend.key.size = unit(0.7, 'lines'))

file <- file.path("results", "TCGA_sample_correlation_phenotype.tsv.gz")
tcga_full_df <- readr::read_tsv(file,
                                col_types = readr::cols(
                                    .default = readr::col_character(),
                                    correlation = readr::col_double(),
                                    seed = readr::col_integer(),
                                    num_comp = readr::col_integer()
                                )
                               )

print(dim(tcga_full_df))

head(tcga_full_df)

tcga_subset_df <- subset_correlations(df = tcga_full_df,
                                      cor_type = "pearson",
                                      data_type = "testing",
                                      signal_type = "signal")

print(dim(tcga_subset_df))

head(tcga_subset_df)

tcga_full_corr_gg <- plot_correlation_summary(df = tcga_subset_df)
tcga_full_corr_gg

select_cancer_types <- c("BRCA", "COAD", "LGG", "PCPG", "LAML")
mean_cor_palette <- colorRampPalette(rev(brewer.pal(9, "YlGn")))

file <- file.path("results", "TCGA_sample_correlation_phenotype_summary.tsv.gz")
tcga_summary_df <- readr::read_tsv(file,
                                   col_types = readr::cols(
                                       .default = readr::col_character(),
                                       num_comp = readr::col_integer(),
                                       mean_cor = readr::col_double(),
                                       var_cor = readr::col_double()
                                   )
                                  )

head(tcga_summary_df)

tcga_subset_summary_df <- process_summary_df(summary_df = tcga_summary_df,
                                             select_sample_types = select_cancer_types,
                                             cor_type = 'pearson',
                                             data_type = 'testing',
                                             signal_type = 'signal')

tcga_select_cancertype_gg <- plot_subset_summary(tcga_subset_summary_df, palette = mean_cor_palette)
tcga_select_cancertype_gg

tcga_capacity_gain_df <- process_capacity(tcga_summary_df, select_cancer_types)
tcga_select_cancertype_capactity_gain_gg <- plot_capacity_difference(tcga_capacity_gain_df)

tcga_select_cancertype_capactity_gain_gg

select_tissues <- c("Liver", "Pancreas", "Blood")

file <- file.path("results", "GTEX_sample_correlation_phenotype_summary.tsv.gz")
gtex_summary_df <- readr::read_tsv(file,
                                   col_types = readr::cols(
                                       .default = readr::col_character(),
                                       num_comp = readr::col_integer(),
                                       mean_cor = readr::col_double(),
                                       var_cor = readr::col_double()
                                   )
                                  )

head(gtex_summary_df)

gtex_capacity_gain_df <- process_capacity(gtex_summary_df, select_tissues)
gtex_select_tissuetype_capactity_gain_gg <- plot_capacity_difference(gtex_capacity_gain_df)

gtex_select_tissuetype_capactity_gain_gg

alg_legend <- cowplot::get_legend(gtex_select_tissuetype_capactity_gain_gg)
cor_legend <- cowplot::get_legend(tcga_select_cancertype_gg)

legend <- (
    cowplot::plot_grid(
        cor_legend,
        alg_legend,
        nrow = 2
    )
)

main_plot <- (
    cowplot::plot_grid(
        tcga_full_corr_gg + theme(legend.position = 'none'),
        tcga_select_cancertype_gg + theme(legend.position = "none"),
        tcga_select_cancertype_capactity_gain_gg + theme(legend.position = 'none'),
        gtex_select_tissuetype_capactity_gain_gg + theme(legend.position = 'none'),
        labels = c("a", "b", "c", "d"),
        ncol = 2,
        nrow = 2
    )
)

main_plot = cowplot::plot_grid(main_plot, legend, rel_widths = c(1, 0.15), ncol = 2)
main_plot

for(extension in fig_extensions) {
    sup_file <- paste0("correlation_summary", extension)
    sup_file <- file.path("figures", sup_file)
    cowplot::save_plot(filename = sup_file,
                       plot = main_plot,
                       base_height = 150,
                       base_width = 170,
                       unit = "mm",
                       dpi = 500)
}

file <- file.path("results", "GTEX_sample_correlation_phenotype.tsv.gz")
gtex_full_df <- readr::read_tsv(file,
                                col_types = readr::cols(
                                    .default = readr::col_character(),
                                    correlation = readr::col_double(),
                                    seed = readr::col_integer(),
                                    num_comp = readr::col_integer()
                                )
                               )

print(dim(gtex_full_df))

head(gtex_full_df)

gtex_subset_df <- subset_correlations(df = gtex_full_df,
                                      cor_type = "pearson",
                                      data_type = "testing",
                                      signal_type = "signal")

gtex_subset_shuffled_df <- subset_correlations(df = gtex_full_df,
                                               cor_type = "pearson",
                                               data_type = "testing",
                                               signal_type = "shuffled")

gtex_full_corr_gg <- plot_correlation_summary(df = gtex_subset_df,
                                              ylimits = c(-0.15, 1))
gtex_full_corr_shuffled_gg <- plot_correlation_summary(df = gtex_subset_shuffled_df,
                                                       ylimits = c(-0.01, 0.15))

gtex_full_cor_gg <- cowplot::plot_grid(
    gtex_full_corr_gg +
        theme(legend.position = 'none') +
        ylab('Real Data\nSample Correlations') +
        ggtitle('GTEX') +
        xlab(''),
    gtex_full_corr_shuffled_gg +
        theme(legend.position = "none") +
        ylab('Shuffled Data\nSample Correlations'),
    labels = c("", ""),
    ncol = 1,
    nrow = 2
)

gtex_full_cor_gg

file <- file.path("results", "TARGET_sample_correlation_phenotype.tsv.gz")
target_full_df <- readr::read_tsv(file,
                                  col_types = readr::cols(
                                      .default = readr::col_character(),
                                      correlation = readr::col_double(),
                                      seed = readr::col_integer(),
                                      num_comp = readr::col_integer()
                                  )
                                 )

print(dim(target_full_df))

head(target_full_df)

target_subset_df <- subset_correlations(df = target_full_df,
                                        cor_type = "pearson",
                                        data_type = "testing",
                                        signal_type = "signal")

target_subset_shuffled_df <- subset_correlations(df = target_full_df,
                                                 cor_type = "pearson",
                                                 data_type = "testing",
                                                 signal_type = "shuffled")

target_full_corr_gg <- plot_correlation_summary(df = target_subset_df,
                                               ylimits = c(-0.15, 1))
target_full_corr_shuffled_gg <- plot_correlation_summary(df = target_subset_shuffled_df,
                                                         ylimits =  c(-0.01, 0.15))

target_full_cor_gg <- cowplot::plot_grid(
    target_full_corr_gg +
        theme(legend.position = 'none') +
        ylab('') +
        xlab('') +
        ggtitle('TARGET'),
    target_full_corr_shuffled_gg +
        theme(legend.position = "none") +
        ylab(''),
    labels = c("", ""),
    ncol = 1,
    nrow = 2
)

target_full_cor_gg

tcga_shuffled_subset_df <- subset_correlations(
    df = tcga_full_df,
    cor_type = "pearson",
    data_type = "testing",
    signal_type = "shuffled"
    )

print(dim(tcga_shuffled_subset_df))

head(tcga_shuffled_subset_df)

tcga_full_corr_shuffled_gg <- plot_correlation_summary(df = tcga_shuffled_subset_df,
                                                       ylimits = c(-0.03, 0.09))
tcga_full_corr_shuffled_gg

tcga_subset_shuffled_summary_df <-
    process_summary_df(summary_df = tcga_summary_df,
                       select_sample_types = select_cancer_types,
                       cor_type = 'pearson',
                       data_type = 'testing',
                       signal_type = 'shuffled')

tcga_select_shuffled_cancertype_gg <-
    plot_subset_summary(tcga_subset_shuffled_summary_df,
                        palette = mean_cor_palette)
tcga_select_shuffled_cancertype_gg

alg_legend <- cowplot::get_legend(tcga_full_corr_shuffled_gg)
cor_legend <- cowplot::get_legend(tcga_select_shuffled_cancertype_gg)

legend <- (
    cowplot::plot_grid(
        alg_legend,
        cor_legend,
        nrow = 2
    )
)

main_plot <- (
    cowplot::plot_grid(
        gtex_full_cor_gg,
        target_full_cor_gg,
        tcga_full_corr_shuffled_gg +
            theme(legend.position = 'none') +
            ggtitle('TCGA') +
            ylab('Shuffled Data\nSample Correlations'),
        tcga_select_shuffled_cancertype_gg +
            theme(legend.position = "none") +
            ggtitle('TCGA'),
        labels = c("a", "b", "c", "d"),
        ncol = 2,
        nrow = 2,
        rel_heights = c(1.1, 0.9)
    )
)

main_plot = cowplot::plot_grid(main_plot,
                               legend,
                               rel_widths = c(1, 0.15),
                               ncol = 2)
main_plot

for(extension in fig_extensions) {
    sup_file <- paste0("supplemental_correlation_summary", extension)
    sup_file <- file.path("figures", sup_file)
    cowplot::save_plot(filename = sup_file,
                       plot = main_plot,
                       base_height = 150,
                       base_width = 170,
                       unit = "mm",
                       dpi = 500)
}


#===============================================================
# Do polarization analysis by day, using the combined retweets
# and estimates dataset. Collect and plot various metrics of
# polarization over time.
#
# Assumptions
#  - data stored in retweet_estimates/rt_est_[date].Rdata
#  - output folder plots/ exists
#===============================================================

library(ggplot2)
files <- list.files("retweet_estimates/", full.names = TRUE)
dates <- list.files("retweet_estimates/")

for (i in 1 : length(dates)) {
    dates[i] <- substr(dates[i], 8, 17)
    # dates[i,] <- strptime(dates[i,], "%Y_%m_%d")
}

#===============================================================
# COMPUTE POLARIZATION INDEX
# For each day, compute different measures of political
# polarization.
#===============================================================

pol1.days <- c()
pol2.days <- c()
pol3.days <- c()

for (i in 1 : length(files)) {
    load(files[i])  # loads dataframe called retweets

    # 1. Do the retweeter and original Twitter user share the same ideology?
    #    We can check if the product is positive; then they're the same.
    pol1 <- mean(retweets$ideology_retweeter * retweets$ideology_retweeted > 0)
    pol1.days <- rbind(pol1.days, pol1)

    # 2. How often were the two authors within 1 point of each other (1 SD)?
    pol2 <- mean(abs(retweets$ideology_retweeter - retweets$ideology_retweeted) < 1)
    pol2.days <- rbind(pol2.days, pol2)

    # 3. Average polarization of information that is retweeted (from paper)?
    pol3 <- mean(abs(retweets$ideology_retweeted))
    pol3.days <- rbind(pol3.days, pol3)

}

#===============================================================
# PLOT POLARIZATION INDEXES
# For each measure of polarization, plot it and save the result.
#===============================================================

df1 <- data.frame(pol1 = pol1.days, day = c(1:19))
plt <- ggplot(df1, aes(x=day, y=pol1)) + geom_point() + geom_smooth() +
       labs(x="Date", y="Proportion of Pairs",
            title="Proportion of pairs with same-direction ideology") +
       scale_x_continuous(labels = c("May 10", "May 20", "May 29"), breaks = c(1, 10, 19))
ggsave(filename = "plots/polarize1.png", plot = plt, width=6, height=4)

df2 <- data.frame(pol2 = pol2.days, day = c(1:19))
plt <- ggplot(df2, aes(x=day, y=pol2)) + geom_point() + geom_smooth() +
       labs(x="Date", y="Proportion of Pairs",
            title="Proportion of pairs within 1 standard deviation of each other") +
       scale_x_continuous(labels = c("May 10", "May 20", "May 29"), breaks = c(1, 10, 19))
ggsave(filename = "plots/polarize2.png", plot = plt, width=6, height=4)

df3 <- data.frame(pol3 = pol3.days, day = c(1:19))
plt <- ggplot(df3, aes(x=day, y=pol3)) + geom_point() + geom_smooth() +
       labs(x="Date", y="Polarization Measure",
            title="Average polarization of retweeted information") +
       scale_x_continuous(labels = c("May 10", "May 20", "May 29"), breaks = c(1, 10, 19)) +
       scale_y_continuous(breaks = seq(1.0, 1.3, by=0.05))
ggsave(filename = "plots/polarize3.png", plot = plt, width=6, height=4)


deps <- list(
"des_system_lib" = c("std", "synopsys", "std_cell_lib", "des_system_lib", "dw02", "dw01", "ramlib", "ieee"),
"dw01" = c("ieee", "dw01", "dware", "gtech", "dw04"),
"dw02" = c("ieee", "dw02", "dware"),
"dw03" = c("std", "synopsys", "dware", "dw03", "dw02", "dw01", "ieee", "gtech"),
"dw04" = c("dw04", "ieee", "dw01", "dware", "gtech"),
"dw05" = c("dw05", "ieee", "dware"),
"dw06" = c("dw06", "ieee", "dware"),
"dw07" = c("ieee", "dware"),
"dware" = c("ieee", "dware"),
"gtech" = c("ieee", "gtech"),
"ramlib" = c("std", "ieee"),
"std_cell_lib" = c("ieee", "std_cell_lib"),
"synopsys" = c())


#! /usr/local/bin/RScript

library(data.table)
library(ggplot2)
library(ggthemes)

# Set working directories
setwd("~/bu/Desktop/MCMonitor")
figures.dir = "~/bu/Desktop/MCMonitor/Plots/"

# Read data
dd = data.table(read.delim("./Plots_data/time_evolution.csv.gz",
                           sep=","))
dd[, item_distribution := as.character(item_distribution)]
dd[, graph := as.character(graph)]

max_time = max(dd$t)+1

# Time evolution plot
p = ggplot(data=dd, aes(x=t, y=objective_value))
p = p + stat_summary(aes(y=objective_value, color=item_distribution, group=item_distribution), geom="line", fun.y=mean)
p = p + scale_x_continuous(name="Time", breaks=seq(0,max_time,1))
p = p + scale_y_continuous(name="Baseline Objective")
p = p + facet_grid(graph~item_distribution)
p = p + theme_bw()
p = p + theme(strip.background = element_blank())
p
ggsave(paste0(figures.dir, "time_evolution.pdf"), w=16, h=16)


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     14.10.2019
#modificado: 05.11.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")

## 1. filter()
library("nycflights13")
?flights

#table
print(flights)
dim(flights)

#filter 1
jan1 <- flights %>%
  filter(month==1,day==1)
print(jan1)
dim(jan1)

#filter 2
#nov_dec <- flights %>%
#  filter(month==11 | month==12)
nov_dec <- flights %>%
  filter(month %in% c(11,12))
print(nov_dec)
dim(nov_dec)

#filter 3
#no_late <- flights %>%
#  filter(!(arr_delay > 120 | dep_delay > 120))
no_late <- flights %>%
  filter(arr_delay <= 120 & dep_delay <= 120)
print(no_late)
dim(no_late)

## 2. arrange()
library("nycflights13")
?flights

#table
print(flights)

#arrange 1
ord_date <- flights %>%
  arrange(year,month,day)
print(ord_date)
all.equal(flights,ord_date)

#arrange 2
ord_arr_delay <- flights %>%
  arrange(desc(arr_delay))
print(ord_arr_delay)

## 3. select()
library("nycflights13")
?flights

#table
print(flights)

#select 1
flights %>%
  select(year,month,day)

#select 2
flights %>%
  select(year:day)

#select 3
flights %>%
  select(-(year:day))

#select 4
flights %>%
  select(contains("arr"))
#flights[,grep("arr",colnames(flights))]

#select 4
flights %>%
  select(time_hour,air_time,everything())

#rename 1
flights %>%
  rename(tail_num=tailnum)
#flights_temp <- flights
#colnames(flights_temp) <- sub("tailnum","tail_num",colnames(flights_temp))
#flights_temp

## 4. mutate()
library("nycflights13")
?flights

#table
flights_sml <- flights %>%
  select(year:day,ends_with("delay"),distance,air_time)
print(flights_sml)

#mutate 1
flights_sml %>%
  mutate(gain = arr_delay - dep_delay,
                speed = distance/air_time*60)

#mutate 2
flights_sml %>%
  mutate(gain = arr_delay - dep_delay,
         hours = air_time/60,
         gain_per_hour = gain/hours)

#transmute 1
flights_sml %>%
  transmute(gain=arr_delay - dep_delay,
            hours = air_time/60,
            gain_per_hour = gain/hours)

## 5. summarize()
library("nycflights13")
?flights

#table
print(flights)

#summarize 1
flights %>%
  summarize(delay = mean(dep_delay,na.rm=TRUE))

#summarize 2
flights %>%
  group_by(dest) %>%
  summarize(count = n(),
            dist = mean(distance,na.rm=TRUE),
            delay = mean(dep_delay,na.rm=TRUE)) %>%
  filter(count > 20,dest != "HNL")

#summarize 3
delay <- group_by(.data=flights,dest)
delay <- summarize(.data=by_dest,count = n(),
                                 dist = mean(distance,na.rm=TRUE),
                                 delay = mean(dep_delay,na.rm=TRUE))
delay <- filter(.data=delay,count > 20,dest != "HNL")
print(delay)

## 6. group_by()
library("nycflights13")
?flights

#table
print(flights)

#group 1
flights %>%
  group_by(year) %>%
  summarize(nflights = n())

#group 2
daily <- flights %>%
  group_by(year,month,day)
print(daily)
per_day <- daily %>%
  summarize(nflights = n())
print(per_day)
per_month <- per_day %>%
  summarize(nflights = sum(nflights))
print(per_month)
per_year <- per_month %>%
  summarize(nflights = sum(nflights))
print(per_year)

#ungroup 1
daily %>%
  ungroup() %>%
  summarize(nflights = n())


library(methods)
library(stats4)
library(splines)
library(VGAM)

args=commandArgs(T)
delta <- 0.1
bound <- 64000000
size <- 33000
x <- rzipf(size,bound,delta)
x <- sort(x)
for( i in 1:size)
        cat((x[i]-1),"\n")


#!/usr/bin/Rscript
#
# ARIMA Method for Retail Forecasting Benchmark - OrangeJuice_Pt_3Weeks_Weekly
#
# Note that we first select the best ARIMA model for each time series using Auto ARIMA in
# model_selection.r script. Then, we simply train the best ARIMA model in this script to
# exclude the model selection time and achieve a fair comparison with other methods.
#
# This script can be executed with the following command from TSPerf directory
#                Rscript <submission dir>/train_score.r -seed <seed value>
# where <seed value> is a random seed value from 1 to 5 (here since the forecast method
# is deterministic, this value will be simply used as a suffix of the output file name).

# Import packages
library(optparse)
library(dplyr)
library(tidyr)
library(forecast)

# Define parameters
NUM_ROUNDS <- 12
TRAIN_START_WEEK <- 40
TRAIN_END_WEEK_LIST <- seq(135, 157, 2)
TEST_START_WEEK_LIST <- seq(137, 159, 2)
TEST_END_WEEK_LIST <- seq(138, 160, 2)

# Parse input argument
option_list <- list(
  make_option(c('-s', '--seed'), type='integer', default=NULL,
              help='random seed value from 1 to 5', metavar='integer')
)
opt_parser <- OptionParser(option_list=option_list)
opt <- parse_args(opt_parser)

# Paths of the training data and submission folder
DATA_DIR <- './retail_sales/OrangeJuice_Pt_3Weeks_Weekly/data'
TRAIN_DIR <- file.path(DATA_DIR, 'train')
SUBMISSION_DIR <- file.path(dirname(DATA_DIR), 'submissions', 'ARIMA')

# Generate submission file name
if (is.null(opt$seed)){
  output_file_name <- file.path(SUBMISSION_DIR, 'submission.csv')
  print('Random seed is not specified. Output file name will be submission.csv.')
} else{
  output_file_name <- file.path(SUBMISSION_DIR, paste0('submission_seed_', as.character(opt$seed), '.csv'))
  print(paste0('Random seed is specified. Output file name will be submission_seed_',
        as.character(opt$seed) , '.csv.'))
}

#### Implement ARIMA model for every store-brand ####
print('Using ARIMA Method')
pred_arima_all <- list()

# Load hyperparameters
hparams <- read.csv(file.path(SUBMISSION_DIR, 'hparams.csv'))

apply_arima_method <- function(train_sub, r) {
  # Trains ARIMA model to forecast sales of each store-brand in a certain round.
  #
  # Args:
  #   train_sub (Dataframe): Training data of a certain store-brand
  #   r (Integer): Index of the forecast round
  #
  # Returns:
  #   pred_arima_df (Dataframe): Predicted sales of the current store-brand
  cur_store <- train_sub$store[1]
  cur_brand <- train_sub$brand[1]
  train_ts <- ts(train_sub[c('logmove')], frequency = 52)
  # Retrieve the best ARIMA model selected before
  arima_order <- hparams[which(hparams$store==cur_store &
                               hparams$brand==cur_brand), ]
  fit_arima <- Arima(y=train_ts, order=unlist(arima_order[c('p','d','q')], use.names=FALSE))
  pred_arima <- forecast(fit_arima, h=pred_horizon)
  pred_arima_df <- data.frame(round = rep(r, pred_steps),
                              store = rep(cur_store, pred_steps),
                              brand = rep(cur_brand, pred_steps),
                              week = pred_weeks,
                              weeks_ahead = pred_weeks_ahead,
                              prediction = round(exp(pred_arima$mean[2:pred_horizon])))
}

for (r in 1:NUM_ROUNDS) {
  print(paste0('---- Round ', r, ' ----'))
  pred_horizon <- TEST_END_WEEK_LIST[r] - TRAIN_END_WEEK_LIST[r]
  pred_steps <- TEST_END_WEEK_LIST[r] - TEST_START_WEEK_LIST[r] + 1
  pred_weeks <- TEST_START_WEEK_LIST[r]:TEST_END_WEEK_LIST[r]
  pred_weeks_ahead <- pred_weeks - TRAIN_END_WEEK_LIST[r]

  # Import training data
  train_df <- read.csv(file.path(TRAIN_DIR, paste0('train_round_', as.character(r), '.csv')))

  # Create a dataframe to hold all necessary data
  store_list <- unique(train_df$store)
  brand_list <- unique(train_df$brand)
  week_list <- TRAIN_START_WEEK:TRAIN_END_WEEK_LIST[r]
  data_grid <- expand.grid(store = store_list,
                           brand = brand_list,
                           week = week_list)
  train_filled <- merge(data_grid, train_df,
                        by = c('store', 'brand', 'week'),
                        all.x = TRUE)
  train_filled <- train_filled[, c('store','brand','week','logmove')]

  # Fill missing logmove
  train_filled <-
    train_filled %>%
    group_by(store, brand) %>%
    arrange(week) %>%
    fill(logmove) %>%
    fill(logmove, .direction = 'up')

  # Apply ARIMA method
  pred_arima_all[[paste0('Round', r)]] <-
    train_filled %>%
    group_by(store, brand) %>%
    do(apply_arima_method(., r))
}

# Combine and save forecast results
pred_arima_all <- do.call(rbind, pred_arima_all)
write.csv(pred_arima_all, output_file_name, row.names = FALSE)


library(lme4)
source("R/functions/get_score.r")

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

info = info %>%
  mutate(DA=factor(DA, levels=c("low","mid","high")),
         SUBJECT = factor(SUBJECT, levels=
                            unique(SUBJECT[order(as.numeric(sub("SLE-","",SUBJECT)))])))

treatment.fields = c("STEROID_IV_CATEGORY","CYCLOPHOSPHAMIDE_CATEGORY",
                     "ORAL_STEROIDS_CATEGORY","MYCOPHENOLATE_CATEGORY",
                     "HYDROXYCHLOROQUINE_CATEGORY")
for (f in treatment.fields) {
  info[,f] = factor(info[,f])
}

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

pb.file = "PB_DC.M4.11_ge_sig.txt"
pb.label = "PB.DC"

fn.pg = file.path(PROJECT_DIR, "data", "SLE", "phenotypes", "SLE_SUBJECT_PG.txt")
df.pg = read_tsv(fn.pg)

subj.lowDA = info %>%
               dplyr::select(SUBJECT, DA) %>%
               dplyr::filter(DA=="low") %>%
               distinct()

  fn.sig = file.path(PROJECT_DIR, "generated_data", "signatures", pb.file)
  pb.genes = fread(fn.sig, header = F) %>% unlist(use.names=F)

  gi = toupper(rownames(dat)) %in% toupper(pb.genes)
  sum(gi)
  info = mutate(info, PB=get_score(dat[gi,]))
  form = paste0("PB"," ~ 1 + ",
                paste(treatment.fields,sep="",collapse=" + "), " + (SLEDAI|SUBJECT)")
  m.lmer = lmer(as.formula(form), data=info)
  mre = ranef(m.lmer, condVar=T)
  x = mre$SUBJECT
  pv = attr(x, "postVar")
  se = unlist(lapply(1:ncol(x), function(i) sqrt(pv[i, i, ])))
  mre.df = data.frame(y=unlist(x),
                          se=se,
                          ci=1.96*se,
                          nQQ=rep(qnorm(ppoints(nrow(x))), ncol(x)),
                          SUBJECT=factor(rep(rownames(x), ncol(x)), levels=rownames(x)),
                          group=gl(ncol(x), nrow(x), labels=names(x))) %>%
    dplyr::filter(group %in% c("SLEDAI")) %>%
    mutate(z = y/ci)
  mre.z = mre.df %>%
    dplyr::select(SUBJECT,group,z) %>%
    spread(group,z) %>%
    dplyr::rename(PB_SLEDAI_corr_score=SLEDAI)

  df.out = left_join(mre.z, df.pg, by="SUBJECT")
  fn.sig = file.path(PROJECT_DIR, "generated_data", "SLE",
                     sprintf("SLE_%s_SLEDAI_corr_score.txt",pb.label))
  fwrite(df.out, fn.sig, sep="\t", quote=F)

  df.out = df.out %>% dplyr::filter(PG %in% 2:4, SUBJECT %in% subj.lowDA$SUBJECT)

  fn.sig.2 = file.path(PROJECT_DIR, "generated_data", "SLE",
                     sprintf("SLE_%s_SLEDAI_corr_score_PG234_lowDA.txt",pb.label))
  fwrite(df.out, fn.sig.2, sep="\t", quote=F)


fitProbitModel = function(minimal_data, num_cat, prior_inst_var = 1.5, prior_cat_var = 0.5, iters = 100, burn_in = 10){
	#For num_cont = 0

	#Parse w/ fitBabyMonitor
	r = fitBabyMonitor(minimal_data, num_cat, num_cont = 0, iters = 10, dat_out = TRUE)

	n_inst = dim(r$inst_mat)[1]

	model_mat = cbind(modelMatrix(r$dat$inst_vec, intercept = TRUE), scale(r$dat$model_mat[ ,-1] ))

	#Construct prior var
	total_p = dim(model_mat)[2]

	prior_var_vec = rep(prior_cat_var, total_p)
	prior_var_vec[1:n_inst] = prior_inst_var

	#FIt
	mcmc_iters = probitFit(r$dat$y,  model_mat, prior_var_vec,
	  iters = iters + burn_in)[-(1:burn_in),1:n_inst]

	#Now create vector of z's
	covv = cov(as.matrix(mcmc_iters))

	mcmc_iters[ ,1] = 0

	z_model_untransformed = mcmc_iters %*% diag(sqrt(1/diag(covv)))
	z_est = apply(z_model_untransformed, 2, median)

	return(z_est)
}


require(parallel)

# Reverse the coding of the major and minor alleles
complement <- function( marker ) {
  return ( 2 - marker )
}

calc.ld.matrix <- function(X, mc.cores, ld.fun=linkage.disequilibrium.D.prime) {

  if ( is.null(ld.fun) ) ld.fun <- linkage.disequilibrium.D.prime

  if ( min(X, na.rm=TRUE) < 0 && max(X, na.rm=TRUE) < 2 ) {
    warn('Converting -1/0/1 coded genotypes to 0/1/2')
    X <- X+1
  }

  # X need to be coded as 0, 1, 2
  stopifnot(min(X, na.rm=TRUE) >= 0, max(X, na.rm=TRUE) <= 2)

  # Check for columns with NA values
  na.indices <- lapply(1:ncol(X), function (j) { which(is.na(X[, j])) })

  # Complement all neccessary columns
  for (j in 1:ncol(X)) {
    if ( length(na.indices[[j]]) == 0) {
      p.A <- sum(X[, j])/ (2*nrow(X))
    } else {
      p.A <- sum(X[-na.indices[[j]], j])/ (2*nrow(X))
    }

    if ( p.A < 0.5 ) {
      X[, j] <- complement( X[, j] )
    }
  }

  n.geno <- ncol(X)
  # Make a list of all of all possible pairs of markers
  idx.pairs <- data.frame('a'=rep(1:n.geno, n.geno), 'b'=rep(1:n.geno, each=n.geno))
  # Keep only the pairs where a <= b
  idx.pairs <- idx.pairs[idx.pairs$a <= idx.pairs$b, ]

  # Remove NA values and calls linkage.disequilibrium.D.prime() for pair i
  do.pair <- function(i) {
    a <- idx.pairs$a[i]
    b <- idx.pairs$b[i]
    # exclude indices that are NA in either marker a or b
    exclude <- union(na.indices[[a]], na.indices[[b]])

    if ( length(exclude) == nrow(X))
      return ( 0 )

    if ( length(exclude) == 0) {
      marker1 <- X[, a]
      marker2 <- X[, b]
    } else {
      marker1 <- X[-exclude, a]
      marker2 <- X[-exclude, b]
    }
    return ( ld.fun(marker1, marker2) )
  }

  # use MC.CORES to calculate D' for every pair
  D.prime.values <- mclapply(1:nrow(idx.pairs), do.pair, mc.cores=mc.cores)

  # Convert list into a matrix
  D.prime <- matrix(-1, n.geno, n.geno)
  for ( i in 1:nrow(idx.pairs) ) {
    D.prime[idx.pairs$a[i], idx.pairs$b[i]] <- D.prime.values[[i]]
    D.prime[idx.pairs$b[i], idx.pairs$a[i]] <- D.prime.values[[i]]
  }

  return ( D.prime )
}

# The log likelihood function for pAB for calculating D'
# adaptived from LD function in library(genetics)
log.L.linkage.disequilibrium <- function(pAB, p.A, p.B, counts) {
  pAb <- p.A - pAB
  paB <- p.B - pAB
  pab <- 1 - p.A - p.B + pAB

  return (counts[1] * log(pab) +
            counts[2] * log(paB) +
            counts[3] * log(pAb) +
            counts[4] * log(pAB) +
            counts[5] * log(pAB*pab + pAb*paB))
}

# calculates D' much faster than the LD function in library(genetics)
# code is adapted from library(genetics)
#' @export
linkage.disequilibrium.D.prime <- function(X1, X2) {

  if ( all(X1==X2) ) {
    return ( 1 )
  }

  p.A <- sum(X1) / (2*length(X1))
  p.B <- sum(X2) / (2*length(X2))

  if ( p.A < 0.5 ) {
    p.A <- 1 - p.A
    X1 <- complement(X1)
  }

  if ( p.B < 0.5 ) {
    p.B <- 1 - p.B
    X2 <- complement(X2)
  }

  p.a <- 1 - p.A
  p.b <- 1 - p.B

  # Make a contingency table for makers X1 and X2
  N <- table(factor(X1, levels=0:2), factor(X2, levels=0:2))

  counts <- c()
  counts[1] <- 2*N[1, 1] + N[1, 2] + N[2, 1] # p(ab)
  counts[2] <- 2*N[1, 3] + N[1, 2] + N[2, 3] # p(aB)
  counts[3] <- 2*N[3, 1] + N[2, 1] + N[3, 2] # p(Ab)
  counts[4] <- 2*N[3, 3] + N[3, 2] + N[2, 3] # p(AB)
  counts[5] <- N[2, 2] # p(AB)p(ab) + p(Ab)*p(aB)

  Dmin <- max(-p.A*p.B, -p.a*p.b)
  Dmax <- min(p.A*p.b, p.B*p.a);

  pmin <- p.A*p.B + Dmin;
  pmax <- p.A*p.B + Dmax;

  # Find p(AB) by maximizing log-likelihood function
  solution <- tryCatch(optimize(log.L.linkage.disequilibrium,
                                lower=pmin + .Machine$double.eps,
                                upper=pmax - .Machine$double.eps,
                                maximum=TRUE,
                                p.A=p.A, p.B=p.B, counts=counts),
                       error=function(e) { return ( NA ) })

  if ( any(is.na(solution)) ) {
    return ( NA )
  }

  pAB <- solution$maximum

  D <- pAB - p.A*p.B

  if ( D > 0 ) {
    D.prime <- D / Dmax
  } else {
    D.prime <- D / Dmin
  }

  return ( D.prime )
}

#' @export
linkage.disequilibrium.r.squared <- function(X1, X2) {
  if ( all(X1==X2) ) {
    return ( 1 )
  }

  p.A <- sum(X1) / (2*length(X1))
  p.B <- sum(X2) / (2*length(X2))

  if ( p.A < 0.5 ) {
    p.A <- 1 - p.A
    X1 <- complement(X1)
  }

  if ( p.B < 0.5 ) {
    p.B <- 1 - p.B
    X2 <- complement(X2)
  }

  p.a <- 1 - p.A
  p.b <- 1 - p.B

  # Make a contingency table for makers X1 and X2
  N <- table(factor(X1, levels=0:2), factor(X2, levels=0:2))

  counts <- c()
  counts[1] <- 2*N[1, 1] + N[1, 2] + N[2, 1] # p(ab)
  counts[2] <- 2*N[1, 3] + N[1, 2] + N[2, 3] # p(aB)
  counts[3] <- 2*N[3, 1] + N[2, 1] + N[3, 2] # p(Ab)
  counts[4] <- 2*N[3, 3] + N[3, 2] + N[2, 3] # p(AB)
  counts[5] <- N[2, 2] # p(AB)p(ab) + p(Ab)*p(aB)

  Dmin <- max(-p.A*p.B, -p.a*p.b)
  Dmax <- min(p.A*p.b, p.B*p.a);

  pmin <- p.A*p.B + Dmin;
  pmax <- p.A*p.B + Dmax;

  # Find p(AB) by maximizing log-likelihood function
  solution <- tryCatch(optimize(log.L.linkage.disequilibrium,
                                lower=pmin + .Machine$double.eps,
                                upper=pmax - .Machine$double.eps,
                                maximum=TRUE,
                                p.A=p.A, p.B=p.B, counts=counts),
                       error=function(e) { return ( NA ) })

  if ( any(is.na(solution)) ) {
    return ( NA )
  }

  pAB <- solution$maximum

  D <- pAB - p.A*p.B

  r.squared <- D^2 / (p.A * p.a * p.B * p.b)

  return ( r.squared )
}

#' @export
ld.matrix <- function(genotypes, mc.cores, ld.fun=NULL, prune=FALSE, prune.window=50, prune.threshold=0.5, prune.ld.fun=NULL) {
  require('parallel')
  stopifnot(max(genotypes, na.rm=TRUE) <= 2,
            min(genotypes, na.rm=TRUE) >= 0)

  if ( missing(mc.cores) ) {
    mc.cores <- detectCores()
  }

  if ( prune ) {

    cat('Pruning SNPs for LD matrix...\n')
    if ( is.null(prune.ld.fun) )
      prune.ld.fun <- linkage.disequilibrium.r.squared
    window <- prune.window
    threshold <- prune.threshold

    n.snps <- ncol(genotypes)

    get.ld.sibs <- function(i) {
      min.idx <- max(1, i-window)
      max.idx <- min(n.snps, i+window)

      up.pairs <- down.pairs <- NULL
      if ( min.idx < i )
        down.pairs <- data.frame(a=min.idx:(i-1), b=i)
      if ( max.idx > i )
        up.pairs <- data.frame(a=(i+1):max.idx, b=i)

      pairs <- rbind(down.pairs, up.pairs)
      ld.vals <- sapply(1:nrow(pairs), function (x) with(pairs[x, , drop=FALSE],
                                                         prune.ld.fun(genotypes[, a], genotypes[, b])))
      pairs$a[ld.vals>threshold]
    }

    all.ld.sibs <- mclapply(1:n.snps, get.ld.sibs, mc.cores=detectCores())
    n.sibs <- sapply(all.ld.sibs, length)

    check.snps <- order(n.sibs, decreasing=TRUE)[1:sum(n.sibs>0)]
    sub.snp <- 1:n.snps
    sel.snp <- rep(0, n.snps)

    for ( i in check.snps ) {
      if ( sel.snp[i] != 0 ) next
      sel.snp[i] <- 1
      sibs <- all.ld.sibs[[i]]
      sib.sel <- sel.snp[sibs]
      sibs <- sibs[sib.sel < 1]
      sub.snp[sibs] <- i
      sel.snp[sibs] <- -1
    }

    selected <- which(sel.snp>=0)
    sel.sub.snp <- match(sub.snp, selected)

    cat('Calculating LD for', length(selected), 'of', ncol(genotypes), 'genotypes using', mc.cores, 'cores...\n')
    LDM.pruned <- calc.ld.matrix(genotypes[, selected], mc.cores, ld.fun=ld.fun)
    LDM <- (LDM.pruned[, sel.sub.snp])[sel.sub.snp, ]

  } else {
    cat('Calculating LD for', ncol(genotypes), 'genotypes using', mc.cores, 'cores...\n')
    LDM <- calc.ld.matrix(genotypes, mc.cores, ld.fun=ld.fun)
  }

  return ( LDM )
}

#' @export
ld.plot <- function(ld.matrix, snp.positions, start.pos, end.pos, ld.colors, drawscale=TRUE, scale.cex=0.6) {

  if ( missing(ld.colors) ) {
    ld.colors <- rgb(1, 99:0/99, 99:0/99)
  }
  stopifnot(ncol(ld.matrix)==length(snp.positions),
            nrow(ld.matrix)==length(snp.positions))

  if ( is.unsorted(snp.positions) ) warning('SNPs positions are not in order!')

  plot(0, type='n', ylim=c(min(snp.positions)-max(snp.positions), 0),
       xlim=range(snp.positions),
       axes=FALSE, bty='n', xlab='', ylab='', yaxs='i')

  # Calculate positions for SNPs
  num.snps <- length(snp.positions)
  x.pos <- snp.positions
  x.pos.mids <- (x.pos[-1] + x.pos[-num.snps])/2
  x.pos.left <- c(x.pos[1], x.pos.mids)
  x.pos.right <- c(x.pos.mids, x.pos[num.snps])

  # Loop through each position in the LDM array and draw polygon of appropriate shade
  for ( i in 1:num.snps ) {
    for ( j in 1:i ) {
      fill.color <- ld.colors[round(abs(ld.matrix[i, j]) * (length(ld.colors) - 1)) + 1]
      # Draw a diamond shape
      polygon(c(x.pos.left[i]+x.pos.left[j],
                x.pos.right[i]+x.pos.left[j],
                x.pos.right[i]+x.pos.right[j],
                x.pos.left[i]+x.pos.right[j])/2,
              -c(x.pos.left[i]-x.pos.left[j],
                 x.pos.right[i]-x.pos.left[j],
                 x.pos.right[i]-x.pos.right[j],
                 x.pos.left[i]-x.pos.right[j]),
              col=fill.color, border=fill.color)
      # NOTE: not drawing polygon borders (i.e. border=NA) causes jagged,
      # pixelated edges. So we draw a border in the same color as the fill
    }
  }

  if ( drawscale ) {
    draw.scale(ld.colors, c(0, 1), pos='bottomleft')
  }
}


# -*- coding: utf-8 -*-

#' Created on Fri Apr 13 15:38:28 2018
#' R version 3.4.3 (2017-11-30)
#'
#' @group   Group 2, DM2 2018 Semester 2
#' @author: Mendes R.
#' @author: Santos R.
#' @author: Martins T.
#'

# Libs --------------------------------------------------------------------
options(warn=-1)
source("src/packages.r")
include_packs(c("dygraphs","d3heatmap","rockchalk","forcats","rJava",
                "xlsxjars","xlsx","tidyverse","stringi","stringr","ggcorrplot",
                "sm","lubridate","magrittr","ggplot2","openxlsx","RColorBrewer",
                "psych","treemap","data.table","pROC","class",'gmodels','klaR',
                "C50","caret",'gmodels',"naivebayes"))

normalizedDataset <- xlsx::read.xlsx('datasets/normalizedDataset.xlsx',1, header= TRUE)

# Prep Training and Test data.
set.seed(333)
trainingRowIndex <- sample(1:nrow(normalizedDataset), 0.7*nrow(normalizedDataset))
trainData <- normalizedDataset[trainingRowIndex, ]
testData <- normalizedDataset[-trainingRowIndex, ]

trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")

testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

test_labels <- as.factor(testData$isChurn)

drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

ControlParamteres <- trainControl(method = "cv",
                                  number = 10,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

nb_CV <- train(isChurn~.,
                data=trainData,
                method = "naive_bayes",
                trControl = ControlParamteres)

nb_CV

predictions <- predict(nb_CV,testData)

caret::confusionMatrix(predictions, test_labels, positive = 'Yes',
                       dnn=c("Pred","Actual"))


#' tidy_stats method for manova objects
#'
#' Creates a tidystats data frame for a manova object.
#'
#' @param model A manova object
#'
#' @import dplyr
#' @import tidyr
#' @importFrom magrittr %>%
#'
#' @export
tidy_stats.summary.manova <- function(model) {

  # Extract statistics
  output <- as_data_frame(model$stats) %>%
    rename(
      `df model` = Df,
      `df numerator` = `num Df`,
      `df denominator` = `den Df`,
      p = `Pr(>F)`
    ) %>%
    mutate(
      term = model$row.names,
      order = 1:n()) %>%
    gather("statistic", "value", -term, -order) %>%
    arrange(order) %>%
    select(-order) %>%
    filter(!is.na(value))

  # Add method
  output$method <- "MANOVA"

  return(output)
}


# 1: READ THE DATA

churn = read.csv("churn.csv", header = TRUE) # IMPORTANT: set the working directory to source file location!

dim(churn)
names(churn)

churn[1:4,1:7]
churn[1:4,8:12]
churn[1:4,13:17]
churn[1:4,18:21]

# 2: BASIC INSPECTION

summary(churn)
attach(churn)

hist(state, 51)
hist(account_length, 20)
hist(area_code, 100)
hist(phone_number, 100)

hist(number_vmail_messages)

hist(number_customer_service_calls)

hist(total_intl_calls, 15)

mean(account_length)

hist(international_plan, 2)
sum(international_plan==0)/(sum(international_plan==0)+sum(international_plan==1))
sum(voice_mail_plan==0)/(sum(voice_mail_plan==0)+sum(voice_mail_plan==1))

sum(class==0)/(sum(class==0)+sum(class==1)) # priors for the variable we want to predict

# 3: DEALING WITH MISSING VALUES

# No missings, as seen in basic inspection

# 4: TREATMENT OF MIXED DATA TYPES

state = as.factor(state)
area_code = as.factor(area_code)
international_plan = as.factor(international_plan)
voice_mail_plan = as.factor(voice_mail_plan)
churned = as.factor(class)

# 5 states + district of columbia
levels(state) = c("AK","AL","AR","AZ","CA","CO","CT","DC","DE","FL","GA","HI","IA","ID","IL","IN","KS","KY","LA","MA","MD","ME","MI","MN","MO","MS","MT","NC","ND","NE","NH","NJ","NM","NV","NY","OH","OK","OR","PA","RI","SC","SD","TN","TX","UT","VA","VT","WA","WI","WV","WY")
levels(international_plan) = c("no","yes")
levels(voice_mail_plan) = c("no","yes")
levels(churned) = c("no","yes")

# 5: DERIVATION AND REMOVAL OF VARIABLES

# PHONE NUMBER
# We will not be including the variable phone number (not relevant)

# CHARGES AND MINUTES
pairs(data.frame(total_day_minutes, total_day_calls))
# We can observe a linear trend... probably because calls cost 17 cents/min

pairs(data.frame(total_eve_minutes, total_eve_charge))
# The same is observed, but calls cost 8.5 cents/min

pairs(data.frame(total_night_minutes, total_night_charge))
# The same, calls cost 4.5 cents/min

pairs(data.frame(total_intl_minutes, total_intl_charge))
# International calls cost 27 cents/min

# We will remove the charges since these are too redundant, and create a variable called total_charge
total_charge = total_day_charge + total_eve_charge + total_night_charge + total_intl_charge

# ACCOUNT_LENGTH
hist(account_length)
# We can see that it is quite normal, we dont know which order of magnitde uses
# but it does not matter, so no need to change it

pairs(data.frame(account_length, total_day_minutes))
# And that account length and minutes are not correlated
# meaning that total_x_y is a measure of last month or mean data, not cumulated. probably LAST MONTH

pairs(data.frame(account_length, number_customer_service_calls))
pairs(data.frame(account_length, number_vmail_messages))
# The same holds for customer service and vmail messages

pairs(data.frame(voice_mail_plan, number_vmail_messages))
hist(number_vmail_messages)
hist(number_vmail_messages[voice_mail_plan=="yes"])
# We can remove voice_mail_plan, since in general it does not provide additional information
# However, I think it may be a good idea to include it because there are 2 clear groups

hist(total_intl_charge)
hist(total_intl_charge[international_plan=="no"])
hist(total_intl_charge[international_plan=="yes"])
pairs(data.frame(international_plan, total_intl_calls))
# We will include international_plan, snce it seems to provide data not explained by total_intl_x

pairs(data.frame(total_day_calls+total_eve_calls+total_night_calls, total_intl_calls))
pairs(data.frame(total_day_charge+total_eve_charge+total_night_charge-total_intl_charge, total_intl_charge))
# There seems to be no correlation between total calls/charge and intl cars/charge
# we will treat them as separate calls from day/eve/night ones

# 6: CREATE NEW DATAFRAME

raw_churn = churn
churn = data.frame(state,area_code,account_length,international_plan,voice_mail_plan,number_vmail_messages,
                   total_day_minutes,total_day_calls,total_eve_minutes,total_eve_calls,
                   total_night_minutes,total_night_calls,total_intl_minutes,total_intl_calls,
                   total_charge,number_customer_service_calls,churned)
detach(churn)
attach(churn)

# 7: Gaussianity

barplot(table(state))
pie(table(area_code))
# OK

boxplot(account_length)
hist(account_length)
# Normal

pie(table(international_plan))
# Not balanced, but nothing problematic

hist(number_vmail_messages)
hist(total_intl_calls)
sum(total_intl_calls==0)/sum(total_day_calls)*100

hist(total_day_minutes)
hist(total_eve_minutes)
hist(total_night_minutes)
hist(total_intl_minutes)
# All these variables seem Gaussian

hist(total_charge)
hist(total_charge[churned=='no'])
hist(total_charge[churned=='yes'])
# This is really interesting, since it seems that user tends to churn when the total charge is not normal

hist(number_customer_service_calls, 10)

# 7: Shuffle

set.seed (1433)
churn = churn[sample.int(nrow(churn)),]

# 8: Save

save(churn, file = "churn.Rdata")