# <-- encoding UTF-8 -->
# Empirical study on CHARLS dataset (city level)
# -------------------------------------
## DOC STRING
#
#
# Tianhao Zhao (GitHub: Clpr)
# Dec 2018
# -------------------------------------

# -------------------------------------
## SECTION 0: ENVIRONMENT
library(sqldf)  # sql enquiry
library(openxlsx)  # easy xlsx IO
source("./src/mathtools.r")  # math tools, e.g. Lorenz, Theil, descriptive stats
source("./src/mapplots.r")  # tools of map plots, using ggplot2
# environment par dict
envCHARLS$Output <- "./output/proc_2_CHARLS/"  # alter output directory

# -------------------------------------
## SECTION 1: GENERAL DESCRIPTIVE STATISTICS
cat("\nGeneral descriptive statistics of CHARLS dataset:\n")
cat("(please note: the income now is the residuals of income ~ edu)\n")
cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
cat("PLEASE NOTE: because we have normalized PCA components, we only do descriptive statistics for income & edu!!!!!!")
cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
# --------------
li_Descript_CHARLS <- list()  # a list of descriptive statistics
for(tmpYname in envCHARLS$Ynames){
    # 1.1 get a namelist of all numeric variables, both Y and Xcore
    tmp <- c( tmpYname, envCHARLS$Xcore )
    li_Descript_CHARLS[[tmpYname]] <- func_DescrStat( li_Dat_CHARLS[[tmpYname]][,tmp] )
    # 1.2 print
    print(li_Descript_CHARLS[[tmpYname]]); cat("-----------------------------------------\n")
}
# output to xlsx
openxlsx::write.xlsx(li_Descript_CHARLS, paste(sep="",envCHARLS$Output,"Descript_CHARLS.xlsx")  )

# -------------------------------------
## SECTION 2: city-LEVEL LORENZ CURVE & GINI COEF
# ---------
# 2.0 prepare a df for Gini coefs
df_Gini_CHARLS <- data.frame(
    year = c(2011, 2013, 2015),   # years
    cities = c( sum(df_CHARLS$year == 2011),sum(df_CHARLS$year == 2013),sum(df_CHARLS$year == 2015)  ),  # number of cities in every year's data
    OUTP1M_RATIO = NA,
    CHRONIC_RATIO = NA
)

# 2.1 use functions in mathtools.r to compute Lorenz Curve & Gini coefficients
# NOTE: please refer to mathtools.r for how we calculated the both
#       and, if you want to see the plotting of Lorenz Curve, you may DIY (using tmp$LorenzX and tmp$LorenzY)
for(tmpYear in df_Gini_CHARLS$year){
    for(tmpYname in envCHARLS$Ynames){
        # 2.1.1 compute Lorenz Curve & Gini in specific year
        # eval(parse(text=paste(sep="",
        #     "tmp <- LorenzCurve( df_CHARLS$",tmpYname,"[df_CHARLS$",envCHARLS$flagT," == ",tmpYear,"] )"
        # )))
        tmp <- li_Dat_CHARLS[[tmpYname]]
        tmp <- LorenzCurve( tmp[ tmp[,envCHARLS$flagT] == tmpYear ,tmpYname] )
        # 2.1.2 save Gini coef
        df_Gini_CHARLS[,tmpYname][df_Gini_CHARLS$year == tmpYear] <- tmp$GiniIdx
    }
}
# print & output to xlsx
print(df_Gini_CHARLS)

# NOTE: the results will be output to a csv file with other kinds of indices, later

# -------------------------------------
## SECTION 3: CITY-LEVEL THEIL I & II INDEXES
# --------
# 3.0 prepare two df
df_Theil1_CHARLS <- data.frame(
    year = c(2011, 2013, 2015),   # years
    cities = c( sum(df_CHARLS$year == 2011),sum(df_CHARLS$year == 2013),sum(df_CHARLS$year == 2015)  ),  # number of counties in every year's data
    OUTP1M_RATIO = NA,
    CHRONIC_RATIO = NA
)
df_Theil2_CHARLS <- df_Theil1_CHARLS

# 3.1 use functions in mathtools.r to do computing
for(tmpYear in df_Gini_CHARLS$year){  # loop on years
    for(tmpYname in envCHARLS$Ynames){  # loop on health outcomes
        # slice a temp dataset
        tmpdf <- li_Dat_CHARLS[[tmpYname]]
        # 3.1.1 compute Theil-I & Theil-II in a specific year
        tmp <- Theil( tmpdf[,tmpYname][tmpdf[,envCHARLS$flagT] == tmpYear], Type = "T" )
        df_Theil1_CHARLS[,tmpYname][ df_Theil1_CHARLS$year == tmpYear ] <- tmp
        tmp <- Theil( tmpdf[,tmpYname][tmpdf[,envCHARLS$flagT] == tmpYear], Type = "L" )
        df_Theil2_CHARLS[,tmpYname][ df_Theil2_CHARLS$year == tmpYear ] <- tmp
    }
}

# 3.2 print info
cat("\nThe city-level Theil-I type index in every year of CHARLS dataset are:\n")
print(df_Theil1_CHARLS)
cat("\nThe city-level Theil-II type index in every year of CHARLS dataset are:\n")
print(df_Theil2_CHARLS)

# NOTE: the results will be output to a csv file with other kinds of indices, later

# -------------------------------------
## SECTION 4: CITY-LEVEL COEF OF VARIANCE (C.V.) & VARIANCE
# ----------
# 4.0 prepare two df
df_CoefVar_CHARLS <- data.frame(
    year = c(2011, 2013, 2015),   # years
    cities = c( sum(df_CHARLS$year == 2011),sum(df_CHARLS$year == 2013),sum(df_CHARLS$year == 2015)  ),  # number of counties in every year's data
    OUTP1M_RATIO = NA,
    CHRONIC_RATIO = NA
)
df_Variance_CHARLS <- df_CoefVar_CHARLS

# 4.1 calculation
for(tmpYear in df_Gini_CHARLS$year){  # loop on years
    for(tmpYname in envCHARLS$Ynames){  # loop on health outcomes
        # slice a temp dataset
        tmpdf <- li_Dat_CHARLS[[tmpYname]]
        # 4.1.1 get data vector
        tmp <- tmpdf[,tmpYname][ tmpdf[,envCHARLS$flagT] == tmpYear ]
        df_Variance_CHARLS[,tmpYname][df_Variance_CHARLS$year == tmpYear] <- var(tmp)
        df_CoefVar_CHARLS[,tmpYname][df_CoefVar_CHARLS$year == tmpYear] <- sd(tmp) / mean(tmp)
    }
}
# 4.2 print info
cat("\nThe county-level coef of variance in every year of CHARLS dataset are:\n")
print(df_CoefVar_CHARLS)
cat("\nThe county-level variances in every year of CHARLS dataset are:\n")
print(df_Variance_CHARLS)

# -------------------------------------
## SECTION 5: COLLECT INEQUALITY INDICES & OUTPUT TO CSV
# ---------------
# 5.1 table joining
df_InequalIdx_CHARLS <- data.frame( Index = rep(c("Gini","Theil-I","Theil-II","Variance","Coef of Variance"), each = 3) )
df_InequalIdx_CHARLS <- cbind(
    df_InequalIdx_CHARLS, rbind( df_Gini_CHARLS, df_Theil1_CHARLS, df_Theil2_CHARLS, df_Variance_CHARLS, df_CoefVar_CHARLS )
)
# 5.2 garbage recycling
rm( df_Gini_CHARLS, df_Theil1_CHARLS, df_Theil2_CHARLS, df_Variance_CHARLS, df_CoefVar_CHARLS )
rm( tmpYear, tmpYname )
# 5.3 output to csv
write.csv( df_InequalIdx_CHARLS, file = paste(sep="",envCHARLS$Output,"InequalityIdx_CHARLS.csv") )

# -------------------------------------
## INTERVAL: MATCH CITY GIS DATA WITH CHARLS DATASET
# -------------
tmpdf <- sqldf::sqldf("SELECT DISTINCT MapGIScity.long as long, MapGIScity.lat as lat, df_CHARLS.* FROM df_CHARLS,MapGIScity WHERE df_CHARLS.city = MapGIScity.county ")
# tmpdf <- plyr::join( df_CHARLS, MapGIScity[,c("ID","long","lat")], by = "city" )  # we use GB (country standard) codes of city/county to match by
tmpdf <- na.omit(tmpdf)

cat("\nPlotting ...\n")
# -------------------------------------
## SECTION 6: COLORED MAPS OF HEALTH OUTCOMES
# ------------
# 6.1 colored maps
# 2011,2013,2015 data are now seen as a pool dataset
for(tmpYname in envCHARLS$Ynames){
    # 6.1.1 temp slice: pooled health outcome & province tags
    tmp <- tmpdf[,c(tmpYname,envCHARLS$flagProv, "city", "long", "lat" )]

    # income -> health outcome
    tmpfig1 <- func_MapCityXY( tmpdf$AVGINDIINCOME_EARN, tmpdf[,tmpYname], tmpdf$lat, tmpdf$long,
                               Xname = "AVGINDIINCOME_EARN", Yname = tmpYname , FontSize = 5,
                               ColorScale = c("skyblue","red"), CircleScale = c(2,15) )
    # edu -> health outcome
    tmpfig2 <- func_MapCityXY( tmpdf$AVGEDU, tmpdf[,tmpYname], tmpdf$lat, tmpdf$long,
                               Xname = "AvgEdu", Yname = tmpYname , FontSize = 5,
                               ColorScale = c("skyblue","red"), CircleScale = c(2,15) )
    # output figures
    eval(parse(text=paste(sep="",
                          "func_SaveMap2PDF( tmpfig1, \"",envCHARLS$Output,"Map_AvgIndiIncome_2_",tmpYname,".pdf\" ) "
    )))
    eval(parse(text=paste(sep="",
                          "func_SaveMap2PDF( tmpfig2, \"",envCHARLS$Output,"Map_AvgEdu_2_",tmpYname,".pdf\" ) "
    )))
}

# 6.2 print info
cat("\n We have created colored maps for health outcomes and output them to the assigned output directory as PDF figures\n")

# --------------------------------------
# GARBAGE COLLECTION
rm( tmp, tmpfig1, tmpfig2, tmpYname, tmpdf )


#' @export
#' @title compute.sums
#' @description This function takes a matrix, and for a given column and index, returns a matrix of different unique values for each.
#' @param \code{x} =the input matrix
#' @param \code{var} =
#' @param \code{index}
#' @return \code{res}
#' @note A = matrix(c(2, 4, 3, 1, 5, 7,2,4,7,2,5,6,1,2,3,5,6,7), ncol=3, byrow = TRUE)
#' compute.sums(A,"a",1) = for the unique values of first column, var1= corresponding value in col "a", sums of corresponding values in column a
#' compute.sums(A,"a",2) = for the unique values of second column, var1= corresponding value in col "a", Freq = sums of corresponding values in column a
#' @family poorly documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
compute.sums = function (x, var, index) {
  res = as.data.frame.table( tapply( X=x[,var], INDEX=x[,index],
  	FUN=function(q) { sum(q, na.rm=T)}, simplify=T))
  for (i in index) { res[i,] = as.integer( res[i,] ) }
  return(res)
}


# Based on the paper by Dos Reis & al, 2004

naive_s = c(0, 0, 0, 0, 0.5, 0.5, 0.75, 0.5)

find_optimal_s = function (codon_usage, expression, lengths, trna) {
    f = function (s)
        cor(tai(codon_usage, w(trna, c(0, 0, 0, 0, exp(s))), lengths),
            expression,
            method = 'spearman')

    # Fix first four values, optimize rest.
    # Optimize `log(s)` to avoid getting negative values into `s`.
    par = log(naive_s[-(1 : 4)])
    within(optim(par, f, control = list(fnscale = -1)),
           {par = c(0, 0, 0, 0, exp(par))})
}

# Reverse complement of the anticodons, in the order of anticodons as given in
# Figure 1 of dos Reis & al.
rc_anticodons = c('TTT', 'TTC', 'TTA', 'TTG',
                  'TCT', 'TCC', 'TCA', 'TCG',
                  'TAT', 'TAC', 'TAA', 'TAG',
                  'TGT', 'TGC', 'TGA', 'TGG',

                  'CTT', 'CTC', 'CTA', 'CTG',
                  'CCT', 'CCC', 'CCA', 'CCG',
                  'CAT', 'CAC', 'CAA', 'CAG',
                  'CGT', 'CGC', 'CGA', 'CGG',

                  'ATT', 'ATC', 'ATA', 'ATG',
                  'ACT', 'ACC', 'ACA', 'ACG',
                  'AAT', 'AAC', 'AAA', 'AAG',
                  'AGT', 'AGC', 'AGA', 'AGG',

                  'GTT', 'GTC', 'GTA', 'GTG',
                  'GCT', 'GCC', 'GCA', 'GCG',
                  'GAT', 'GAC', 'GAA', 'GAG',
                  'GGT', 'GGC', 'GGA', 'GGG')

met_codon = match('ATG', rc_anticodons)
stop_codons = match(c('TAA', 'TAG', 'TGA'), rc_anticodons)

w = function (counts, s = naive_s) {
    counts = counts[rc_anticodons]
    counts[is.na(counts)] = 0
    p = 1 - s
    w = vector('numeric', length(counts))

    for (i in seq(1, length(counts), by = 4)) {
        w[i]     = p[1] * counts[i]     + p[5] * counts[i + 1]
        w[i + 1] = p[2] * counts[i + 1] + p[6] * counts[i]
        w[i + 2] = p[3] * counts[i + 2] + p[7] * counts[i]
        w[i + 3] = p[4] * counts[i + 3] + p[8] * counts[i + 2]
    }

    w[met_codon] = p[4] * counts[met_codon]
    w = w[-stop_codons]
    w_rel = w / max(w)
    nonzero_w = w_rel[w != 0]
    if (length(nonzero_w) != length(w_rel))
        w_rel[w_rel == 0] = exp(sum(log(nonzero_w)) / length(nonzero_w))

    w_rel
}

tai = function (codon_counts, w, lengths) {
    codons = rc_anticodons[-stop_codons]
    exp(colSums(apply(codon_counts[, codons], 1, `*`, log(w))) / lengths)
}


# Creat vectors with the combine function c()
numeric_vector <- c(1, 10, 49)
character_vector <- c("a", "b", "c")

# Complete the code for boolean_vector
boolean_vector <- c(TRUE, FALSE, TRUE)

# Poker winnings from Monday to Friday
poker_vector <- c(140, -50, 20, -120, 240)

# Roulette winnings from Monday to Friday
roulette_vector <- c(-24, -50, 100, -350, 10)


library(pROC)
source(file.path(PROJECT_DIR, "R/functions/load_sig.r"))
source(file.path(PROJECT_DIR, "R/functions/get_score.r"))
fn.cd38.cor = file.path(PROJECT_DIR, "generated_data", "CHI", "robust_corr_genes.txt")

# 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.txt")
info = fread(fn.si)

ng.max = 30
roc.df = data.frame()

for (tp in c(0,-7,70)) {
  cat(tp,"")

  day.pt = paste0("day ",tp)
  # test signature
  for(ng in 2:ng.max) {
    # load CD38 signature genes
    gene.sig = load_sig(fn.cd38.cor, "cor.mean.sd.ratio", ntop=ng)
    gi = toupper(rownames(dat)) %in% toupper(gene.sig)
    sum(gi)

    iday = info$time==tp
    ihl = info$adjMFC_class[iday] %in% c(0,2)
    X = get_score(dat[gi,iday])[ihl]
    Y = info$adjMFC_class[iday][ihl]

    auc.ng = ci.auc(Y,X, direction="<", quiet=T) %>% matrix(nrow=1)
    colnames(auc.ng) = c("auc.ci95.min", "AUC", "auc.ci95.max")
    r.df = data.frame(day=day.pt, ng, as.data.frame(auc.ng))

    roc.df = rbind(roc.df, r.df)
  }
}

roc.df = roc.df %>%
  mutate(day = factor(day, levels=c("day 0","day -7","day 70"))) %>%
  mutate(ngx = ifelse(day=="day -7", ng-0.2, ifelse(day=="day 70", ng+0.2, ng)))

ggplot(roc.df, aes(ng, AUC, group=day, col=day)) +
  # geom_linerange(aes(x=ngx, ymin=auc.ci95.min, ymax=auc.ci95.max)) +
  # geom_ribbon(aes(ymin=auc.ci95.min, ymax=auc.ci95.max, fill=day), alpha=0.2, col=NA) +
  geom_line(size=1) +
  geom_point(size=1, shape=21, fill="white", stroke=1) +
  scale_color_manual(values=c("grey65", "grey80","grey50")) +
  xlab("No. of genes") + ylab("AUC") + theme_bw() +
  theme(legend.key = element_blank())

fn.fig = file.path(PROJECT_DIR, "figure_generation",
                   sprintf("CHI_CD38.2-%d.genes_AUC_ci95",ng.max))
ggsave(paste0(fn.fig,".png"), w=5, h=4)
ggsave(paste0(fn.fig,".pdf"), w=5, h=4)


library(abind)
load("data_Fig4_5.RData")
effcontact<-data_Fig4_5[["effcontact"]]
breakdown<-data_Fig4_5[["breakdown"]]
totalcontact<-data_Fig4_5[["totalcontact"]]
beta=0.201956234147969

draw_effcontact<-function(effcontact){
    bindEC<-abind(effcontact[[1]],effcontact[[2]],effcontact[[3]],effcontact[[4]],along=3)
    par(mfrow=c(2,2),cex=1,xaxt="s",xaxs="r",las=2)
    for(typ in 1:4){
        barplot(t(bindEC[bindEC[,1,typ]>=0,,typ][order(totalcontact[typ,bindEC[,1,typ]>=0]),]),ylim=c(0,2.5),col=rev(c("mediumpurple","tomato","dodgerblue","yellowgreen")),ylab="Effective household contact",xlab="",axes=F)
        axis(side=2,at=0:5/10/beta,labels=format(0:5/10,nsmall=2))
        legend(x=0,y=2.6, legend=c("Child","Mother","Father","Other"),ncol=2,lty=0,bty="n",pch=19,col=rev(c("mediumpurple","dodgerblue","tomato","yellowgreen")),y.intersp=0.6,x.intersp=0.5,cex=0.9)
    }
}
draw_riskbreakdown<-function(breakdown){
    bindRB<-abind(breakdown[[1]],breakdown[[2]],breakdown[[3]],breakdown[[4]],along=3)
    par(mfrow=c(2,2),cex=1,xaxt="s",xaxs="r",las=2)
    for(typ in 1:4){
        barplot(t(1-exp(-bindRB[bindRB[,2,typ]>=0,,typ][order(totalcontact[typ,bindRB[,2,typ]>=0]),])),ylim=c(0,c(0.3,rep(0.15,3))[typ]),col=rev(c("mediumpurple","tomato","dodgerblue","yellowgreen","grey")),ylab="Risk of infection",xlab="")
        legend(x=0,y=c(0.32,rep(0.155,3))[typ], legend=c("From Outside","From Child","From Mother","From Father","From Other"),ncol=2,lty=0,bty="n",pch=19,col=rev(c("mediumpurple","dodgerblue","tomato","yellowgreen","grey")),y.intersp=0.75,x.intersp=0.5,cex=0.9)
    }
}

draw_effcontact(effcontact)
draw_riskbreakdown(breakdown)


# 4. faza: Analiza podatkov
#-------------------------------------------------------------------------------------

# Starost 65 do 69 let

tabela1_trajanje0 <- tabela1 %>% select(STAROST, LETO, POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI)
tabela1_trajanje <- tabela1_trajanje0[!(tabela1_trajanje0$STAROST=="Starost-SKUPAJ" | tabela1_trajanje0$STAROST=="Neznano"),]
tabela1_65do69 <- tabela1_trajanje %>% filter(tabela1_trajanje == "65 do 69 let")

g5 <- ggplot(tabela1_65do69)+
  aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI) +
  ggtitle("Starost 65 do 69 let") + xlab("Leto") + ylab("Povprečno trajanje ene odsotnosti") +
  scale_x_continuous(breaks=c(2005:2020)) +
  geom_point() +
  geom_smooth(method = gam, se = FALSE)

#izračun modela
model <- gam(POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI ~ LETO, data = tabela1_65do69)

# izris modela
# g6 <- ggplot(tabela1_65do69, aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI)) +
#   geom_point() +
#   geom_smooth(method=gam, formula=y~x) +
#   labs(x = "Leto", y = "Povprečno trajanje ene odsotnosti")

#predikcija
novaLeta <- data.frame(LETO=c(2021, 2022, 2023, 2024))
predict(model, novaLeta)
napoved <- novaLeta %>% mutate(POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI=predict(model, .))

#izris napovedi
napoved1 <- ggplot(tabela1_65do69, aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI)) +
  geom_point(shape=1) +
  scale_x_continuous("Leto",  breaks = seq(2005, 2024, 3)) +
  geom_smooth(method=gam, formula=y~x, color="purple1", fullrange=TRUE) +
  geom_point(data=napoved, aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI), color="salmon2", size=2) +
  labs(title = "Napoved povprečnega trajanja ene bolniške odsotnosti \npri starosti 65 do 69 let",
       x = "Leto", y = "Povprečno trajanje ene odsotnosti") +
  theme_bw()

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

# Starost 30 do 34 let
tabela1_30do34 <- tabela1_trajanje %>% filter(tabela1_trajanje == "30 do 34 let")

g7 <- ggplot(tabela1_30do34)+
  aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI) +
  #geom_line(col="blue") +
  ggtitle("Starost 30 do 34 let") + xlab("Leto") + ylab("Povprečno trajanje ene odsotnosti") +
  scale_x_continuous(breaks=c(2005:2020)) +
  geom_point() +
  geom_smooth(method = "gam", se = FALSE)

#izračun modela
model2 <- gam(POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI ~ LETO, data = tabela1_30do34)

# izris modela
g8 <- ggplot(tabela1_30do34, aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI)) +
  geom_point() +
  geom_smooth(method=gam, formula=y~x) +
  labs(x = "Leto", y = "Povprečno trajanje ene odsotnosti")

#predikcija
novaLeta <- data.frame(LETO=c(2021, 2022, 2023, 2024))
predict(model2, novaLeta)
napoved3 <- novaLeta %>% mutate(POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI=predict(model2, .))

#izris napovedi
napoved2 <- ggplot(tabela1_30do34, aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI)) +
  geom_point(shape=1) +
  scale_x_continuous("Leto",  breaks = seq(2005, 2024, 3)) +
  geom_smooth(method=gam, formula=y~x, color="purple1", fullrange=TRUE) +
  geom_point(data=napoved3, aes(x = LETO, y = POVPRECNO_TRAJANJE_ENE_ODSOTNOSTI), color="salmon2", size=2) +
  labs(title = "Napoved povprečnega trajanja ene bolniške odsotnosti \npri starosti 30 do 34 let",
       x = "Leto", y = "Povprečno trajanje ene odsotnosti") +
  theme_bw()


#' London Road network tomography data
#'
#' Data on traffic counts observed at a sequence of points on London Road in Leicester, UK. The aim is to sample the corresponding origin-destination traffic volumes that are consistent with those counts.
#' The dataset appears as a list prepared for that purpose.
#' Components of the list are A (the configuration matrix, which in this case is the link-path incidence matrix); y (observed traffic counts); lambda (assumed mean origin-destination traffic volumes);
#' and MarkovBasis (a matrix with columns corresponding to the vectors in full Markov basis for the resampling problem).
#'
#' @docType data
#'
#' @usage data(LondonRoad)
#' @export
#' @examples
#' data(LondonRoad)
#' Xsampler(A=LondonRoad$A,y=LondonRoad$y,lambda=LondonRoad$lambda,Model="Poisson",Method="Gibbs",tune.par=0.5,combine=FALSE)
"LondonRoad"


#' ---
#' author: "Jenny Bryan"
#' output: github_document
#' ---

#+ setup, include = FALSE
library(knitr)
opts_chunk$set(fig.path = 'figure/uni-quant-', error = TRUE)

#' Note: this is rendered by applying `knitr::spin()` to an R script. So the
#' narrative is very minimal.

#' load the data and ggplot2 (part of the tidyverse)
library(tidyverse)
library(gapminder)
gapminder

#' distribution of a quant var: histogram
ggplot(gapminder, aes(x = lifeExp)) +
  geom_histogram()

#' experiment with bin width; think in terms of the units of the x variable
ggplot(gapminder, aes(x = lifeExp)) +
  geom_histogram(binwidth = 1)

#' show the different continents, but it's weird to stack up the
#' histograms, which is what default of `position = "stack"` delivers
ggplot(gapminder, aes(x = lifeExp, fill = continent)) +
  geom_histogram()

#' `position = "identity"` is good to know about
#' it's still weird to layer them on top of each other like this
ggplot(gapminder, aes(x = lifeExp, fill = continent)) +
  geom_histogram(position = "identity")

#' geom_freqpoly() is better in this case
ggplot(gapminder, aes(x = lifeExp, color = continent)) +
  geom_freqpoly()

#' smooth histogram = densityplot
ggplot(gapminder, aes(x = lifeExp)) + geom_density()

#' you should look at different levels of smoothing
ggplot(gapminder, aes(x = lifeExp)) + geom_density(adjust = 1)
ggplot(gapminder, aes(x = lifeExp)) + geom_density(adjust = 0.2)

#' densityplots work better in terms of one continent not obscuring another
ggplot(gapminder, aes(x = lifeExp, color = continent)) + geom_density()

#' alpha transparency works here too
ggplot(gapminder, aes(x = lifeExp, fill = continent)) +
  geom_density(alpha = 0.2)

#' with only two countries, maybe we should ignore Oceania?
ggplot(subset(gapminder, continent != "Oceania"),
       aes(x = lifeExp, fill = continent)) + geom_density(alpha = 0.2)

#' facets work here too
ggplot(gapminder, aes(x = lifeExp)) + geom_density() + facet_wrap(~ continent)

ggplot(subset(gapminder, continent != "Oceania"),
       aes(x = lifeExp, fill = continent)) + geom_histogram() +
  facet_grid(continent ~ .)

#' boxplot for one quantitative variable against a discrete variable
#' first attempt does not work since year is not formally a factor
ggplot(gapminder, aes(x = year, y = lifeExp)) + geom_boxplot()

#' by explicitly specifying year as the grouping variable, we get what we want
ggplot(gapminder, aes(x = year, y = lifeExp)) + geom_boxplot(aes(group = year))

#' try geom_violin() instead and just generally goofing off now
ggplot(gapminder, aes(x = year, y = lifeExp)) +
  geom_violin(aes(group = year)) +
  geom_jitter(alpha = 1/4) +
  geom_smooth(se = FALSE)


# movies is pre-loaded in your workspace

# Build a customized histogram
hist(movies$runtime,breaks=20,
     main= "Distribution of Runtime",
     xlab="Runtime [-]",
     xlim=c(90,220),
     border="red")


#' graficarSegmento()
#' Grafica un segmento a partir de 2 puntos dados
#'
#' @param a vector
#' @param b vector
#'
#' @return grafica
#' @export
#'
#' @examples
#' graficarSegmento(c(1,1),c(2,2))
#'
#'
graficarSegmento <- function(a,b){
  puntosx <- c(a[1],b[1])
  puntosy <- c(a[2],b[2])

  plot(x <- puntosx,
       y <- puntosy,
       col = "red",
       lwd = 4
       )

  segments(a[1],a[2],b[1],b[2], col = "green", lwd= 3)
}


## ----echo = FALSE----------------------------------------------------------------------
knitr::opts_chunk$set(
  echo=TRUE,
  message = FALSE,
  warning = FALSE,
  error = FALSE,
  collapse = TRUE,
  comment = "",
  fig.height = 4,
  fig.width = 8,
  fig.align = "center",
  fig.retina = 3,
  cache = FALSE
)

## ----echo=FALSE------------------------------------------------------------------------
library(tidyverse)
library(lubridate)
library(GGally)
# remotes::install_github("ggobi/tourr")
library(tourr)
library(broom)
library(plotly)
# remotes::install_github("allisonhorst/palmerpenguins")
library(palmerpenguins)

## ----echo=FALSE------------------------------------------------------------------------
countdown::countdown(1,0)

## ----scatterplot matrix, fig.show='hide'-----------------------------------------------
# Make a simple scatterplot matrix of the new penguins data
penguins <- penguins %>% filter(!is.na(bill_length_mm))
ggpairs(penguins, columns=c(3:6))

## ----ref.label="scatterplot matrix", echo=FALSE, fig.width=6, fig.height=6-------------

## ----scatterplot matrix with colour, echo=TRUE, fig.show='hide'------------------------
# Re-make mapping colour to species (class)
ggpairs(penguins, columns=c(3:6),
        ggplot2::aes(colour=species))

## ----ref.label="scatterplot matrix with colour", echo=FALSE, fig.width=6, fig.height=6----

## ----correlation heatmap, echo=TRUE, fig.show='hide'-----------------------------------
# Look at one species only
adelie <- penguins %>%
  filter(species == "Adelie") %>%
  select(bill_length_mm:body_mass_g)
ggcorr(adelie)

## ----ref.label="correlation heatmap", echo=FALSE, fig.width=4, fig.height=4, out.width="90%"----

## ----corrgram, echo=TRUE, fig.show='hide'----------------------------------------------
# install.packages("corrgram")
library(corrgram)
corrgram(adelie,
  lower.panel=corrgram::panel.ellipse)

## ----ref.label="corrgram", echo=FALSE, fig.width=4, fig.height=4, out.width="90%"------

## ----generalised pairs plot, fig.show='hide'-------------------------------------------
# Matrix plot when variables are not numeric
data(australia_PISA2012)
australia_PISA2012 <- australia_PISA2012 %>%
  mutate(desk = factor(desk),
         room = factor(room),
         study = factor(study),
         computer = factor(computer),
         software = factor(software),
         internet = factor(internet),
         literature = factor(literature),
         poetry= factor(poetry),
         art = factor(art),
         textbook = factor(textbook),
         dictionary = factor(dictionary),
         dishwasher = factor(dishwasher))
australia_PISA2012 %>%
  filter(!is.na(dishwasher)) %>%
  ggpairs(columns=c(3, 15, 16, 21, 26))

## ----ref.label='generalised pairs plot', echo=FALSE, fig.width=6, fig.height=6, out.width="90%"----

## ----generalised pairs plot enhance plots, echo=TRUE, fig.width=6, fig.height=6--------
# Modify the defaults, set the transparency of points since there is a lot of data
australia_PISA2012 %>%
  filter(!is.na(dishwasher)) %>%
  ggpairs(columns=c(3, 15, 16, 21, 26),
          lower = list(continuous = wrap("points", alpha=0.05)))

## ----design own plot function----------------------------------------------------------
# Make a special style of plot to put in the matrix
my_fn <- function(data, mapping, method="loess", ...){
      p <- ggplot(data = data, mapping = mapping) +
      geom_point(alpha=0.2, size=1) +
      geom_smooth(method="lm", ...)
      p
}

## ----generalised pairs plot enhance more, echo=TRUE, fig.show='hide'-------------------
australia_PISA2012 %>%
  filter(!is.na(dishwasher)) %>%
  ggpairs(columns=c(3, 15, 16, 21, 26),
          lower = list(continuous = my_fn))

## ----ref.label='generalised pairs plot enhance more', echo=FALSE, fig.width=6, fig.height=6, outwidth="90%"----
australia_PISA2012 %>%
  filter(!is.na(dishwasher)) %>%
  ggpairs(columns=c(3, 15, 16, 21, 26),
          lower = list(continuous = my_fn))

## ----echo=FALSE------------------------------------------------------------------------
countdown::countdown(8,0)

## ----echo=FALSE, eval=FALSE------------------------------------------------------------
## australia_PISA2012 %>%
##   filter(!is.na(dishwasher)) %>%
##   ggpairs(columns=c(3, 15, 16, 21, 26),
##           lower = list(combo = "box_no_facet"),
##           upper = list(continuous = "density"))

## ----wrangle housing data--------------------------------------------------------------
housing <- read_csv(here::here("data/housing.csv")) %>%
  mutate(date = dmy(date)) %>%
  mutate(year = year(date)) %>%
  filter(year == 2016) %>%
  filter(!is.na(bedroom2), !is.na(price)) %>%
  filter(bedroom2 < 7, bathroom < 5) %>%
  mutate(bedroom2 = factor(bedroom2),
         bathroom = factor(bathroom))

## ----make a regression style pairs plot, out.width="100%", fig.width=8, fig.height=3----
ggduo(housing[, c(4,3,8,10,11)],
      columnsX = 2:5, columnsY = 1,
      aes(colour=type, fill=type),
      types = list(continuous =
                     wrap("smooth",
                       alpha = 0.10)))

## ----eval=FALSE, echo=FALSE------------------------------------------------------------
## if (!requireNamespace("BiocManager", quietly = TRUE))
##     install.packages("BiocManager")
## BiocManager::install("bigPint")

## ----soybean_scat, fig.show='hide'-----------------------------------------------------
library(bigPint) # BiocManager::install("bigPint")
data(soybean_ir_sub)
soybean_ir_sub[,-1] <- log(soybean_ir_sub[,-1]+1)
ggplot(soybean_ir_sub,
       aes(x=N.1, y=P.1)) +
  geom_point() +
  theme(aspect.ratio=1)

## ----ref.label='soybean_scat', fig.width=4, fig.height=4, out.width="90%", echo=FALSE----

## ----soybean_litre, fig.show='hide'----------------------------------------------------
geneList = soybean_ir_sub_metrics[["N_P"]][1:5,]$ID
ret <- plotLitre(data = soybean_ir_sub,
                 geneList = geneList,
                 pointColor = "deeppink")
names(ret)
ret[["N_P_Glyma.19G168700.Wm82.a2.v1"]]

## ----ref.label='soybean_litre', fig.width=6, fig.height=6, out.width="90%", echo=FALSE, results='hide'----

## ----soybean_litre_sm, fig.show='hide'-------------------------------------------------
ret <- plotSM(soybean_cn_sub,
              soybean_cn_sub_metrics,
              option = "hexagon",
              xbins = 5,
              pointSize = 0.1,
              saveFile = FALSE)
ret[[2]]

## ----ref.label='soybean_litre_sm', fig.width=6, fig.height=6, out.width="110%", echo=FALSE, results='hide'----

## ----soybean_pcp, fig.show='hide'------------------------------------------------------
ret <- plotPCP(data = soybean_ir_sub,
               geneList = geneList,
               lineSize = 0.3,
               saveFile = FALSE)
ret[[1]]

## ----ref.label='soybean_pcp', fig.width=6, fig.height=6, out.width="90%", echo=FALSE, results='hide'----


#  James Rekow

elbowSSTest = function(M = 40, numSubgroups = 2, N = 20, iStrength = 1, univ = 1,
                       sigmaMax = 0.1, thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4,
                       tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01, lambda = 0,
                       returnParams = FALSE, conGraph = NULL, rollRange = 0.025,
                       numClust = NULL, centersVec = 1:10){

  #  ARGS:
  #
  #  RETURNS:

  source("subgroupsAbdListCreator.r")
  source("computeInfoWeightMat.r")
  source("computeSSRatio.r")

  #  compute abundance list
  abdList = subgroupsAbdListCreator(M = M, numSubgroups = numSubgroups, N = N, iStrength = iStrength,
                                    univ = univ, sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                    maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                    interSmplMult = interSmplMult, lambda = lambda,
                                    returnParams = returnParams, conGraph = conGraph)

  #  compute matrix of info weights
  infoMat = computeInfoWeightMat(abdList = abdList, rollRange = rollRange)

  #  compute SS ratio of clusters for kmeans results using each number of centers in centersVec
  SSRatioVec = sapply(1:length(centersVec), function(n) computeSSRatio(inputMat = infoMat,
                                                                       centers = centersVec[n]))

  return(SSRatioVec)

} #  end elbowSSTest function


context("Beta diversity")
library(mbm)

nsites <- 10
nspecies <- 5
pr <- 0.3
yy <- matrix(sample(c(0,1), nspecies*nsites, replace = TRUE, prob = c(1-pr,pr)),
	nrow = nsites, ncol=nspecies)
y <- matrix(1, nrow = nsites, ncol = nspecies)

test_that("Beta diversity works as expected", {
	expect_error(jc <- jaccard(y), NA)
	expect_true(all(jc == 0))
	jc <- jaccard(yy)
	expect_true(all(jc >= 0 & jc <= 1 | is.nan(jc)))

	expect_error(bray <- bc(y), NA)
	expect_true(all(bray == 0))
	bray <- bc(yy)
	expect_true(all(bray >= 0 & bray <= 1 | is.nan(bray)))

	expect_error(sord <- sorensen(y), NA)
	expect_true(all(sord == 0))
	sord <- sorensen(yy)
	expect_true(all(sord >= 0 & sord <= 1 | is.nan(sord)))
	expect_lt(sqrt(mean((sord - mbm:::sor(yy))^2, na.rm=TRUE)), 1e-4)
	expect_error(sord <- sorensen(yy, TRUE), NA)
	expect_true(all(sapply(sord, function(x) x >= 0 & x <= 1 | is.nan(x))))
})


#' Raftery-Lewis procedure for determining iterations needed for convergence
#'
#' This function is \emph{exactly} the same as the code in the \code{\link[coda]{raftery.diag}} function in the \pkg{coda} package except that it anticipates some issues related to the \code{thin} function when adding additional iterations to a chain.
#' @param data An object of class \code{mcmc}.
#' @param thin Thinning interval.
#' @param q A quantile to be estimated.
#' @param r The precision (margin of error) with which to estimate \code{q}.
#' @param s Probability of obtaining an estimate in the interval (\code{q - r}, \code{q + r}).
#' @param converge.eps Precision for the estimate of time to converge.
#' @details Please see the help for \code{\link[coda]{raftery.diag}}.
#' @export

rafLewis <- function(
	data,
	thin = 1,
	q = 0.025,
	r = 0.005,
	s = 0.95,
	converge.eps = 0.001
) {
    if (is.mcmc.list(data))
        return(lapply(data, raftery.diag, q, r, s, converge.eps))
    data <- as.mcmc(data)
    resmatrix <- matrix(nrow = nvar(data), ncol = 4, dimnames = list(varnames(data,
        allow.null = TRUE), c("M", "N", "Nmin",
        "I")))
    phi <- qnorm(0.5 * (1 + s))
    nmin <- as.integer(ceiling((q * (1 - q) * phi^2)/r^2))
    if (nmin > niter(data))
        resmatrix <- c("Error", nmin)
    else for (i in 1:nvar(data)) {
        if (is.matrix(data)) {
            # quant <- quantile(data[ , i, drop = TRUE], probs = q)
            quant <- quantile(data[ , i, drop = TRUE], probs = q)
            # dichot <- mcmc(data[, i, drop = TRUE] <= quant, start = start(data),
                # end = end(data), thin = thin(data))
            dichot <- mcmc(data[ , i, drop = TRUE] <= quant, start = start(data),
                end = end(data), thin = thin)
        }
        else {
            quant <- quantile(data, probs = q)
            dichot <- mcmc(data <= quant, start = start(data),
                # end = end(data), thin = thin(mcmc))
                end = end(data), thin = thin)
        }
        kthin <- 0
        bic <- 1
        while (bic >= 0) {
            kthin <- kthin + thin(data)
            testres <- as.vector(window.mcmc(dichot, thin = kthin))
            testres <- factor(testres, levels = c(FALSE, TRUE))
            newdim <- length(testres)
            testtran <- table(testres[1:(newdim - 2)], testres[2:(newdim -
                1)], testres[3:newdim])
            testtran <- array(as.double(testtran), dim = dim(testtran))
            g2 <- 0
            for (i1 in 1:2) {
                for (i2 in 1:2) {
                  for (i3 in 1:2) {
                    if (testtran[i1, i2, i3] != 0) {
                      fitted <- (sum(testtran[i1, i2, 1:2]) *
                        sum(testtran[1:2, i2, i3]))/(sum(testtran[1:2,
                        i2, 1:2]))
                      g2 <- g2 + testtran[i1, i2, i3] * log(testtran[i1,
                        i2, i3]/fitted) * 2
                    }
                  }
                }
            }
            bic <- g2 - log(newdim - 2) * 2
        }
        finaltran <- table(testres[1:(newdim - 1)], testres[2:newdim])
        alpha <- finaltran[1, 2]/(finaltran[1, 1] + finaltran[1,
            2])
        beta <- finaltran[2, 1]/(finaltran[2, 1] + finaltran[2,
            2])
        tempburn <- log((converge.eps * (alpha + beta))/max(alpha,
            beta))/(log(abs(1 - alpha - beta)))
        nburn <- as.integer(ceiling(tempburn) * kthin)
        tempprec <- ((2 - alpha - beta) * alpha * beta * phi^2)/(((alpha +
            beta)^3) * r^2)
        nkeep <- as.integer(ceiling(tempprec) * kthin)
        iratio <- (nburn + nkeep)/nmin
        resmatrix[i, 1] <- nburn
        resmatrix[i, 2] <- nkeep + nburn
        resmatrix[i, 3] <- nmin
        resmatrix[i, 4] <- signif(iratio, digits = 3)
    }
    y <- list(params = c(r = r, s = s, q = q), resmatrix = resmatrix)
    class(y) <- "raftery.diag"
    return(y)
}


require(magrittr)
require(ggplot2)
require(gganimate)
require(transformr)

bike_traffic <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-02/bike_traffic.csv")

# formatting time and date

bike_traffic %<>%
         dplyr::mutate(date_time = lubridate::mdy_hms(date),
                      # date = format(date_time, '%d/%m/%Y'),
                      # time = format(date_time, '%H:%M:%S'),
                       hour = lubridate::hour(date_time))

# summarizing mean traffic by hour
mean_traffic <- bike_traffic %>%
  dplyr::group_by(hour, crossing, direction) %>%
  dplyr::summarize(bike_count =mean(bike_count, na.rm=T)) #%>% head()

# rush hour

rushhr <- data.frame(rush = c("AM Rush (6 - 9AM)", "PM Rush (4 - 7PM)"),
                     lb = c(6, 16),
                     ub = c(9, 19))
# static plot
ggplot2::ggplot(mean_traffic,
             ggplot2::aes(x=hour, y=bike_count, size = bike_count,
                    group = crossing, color = crossing)
     ) +
  ggplot2::geom_point(alpha = 0.8, show.legend = F) + geom_line(size = 1.25) +
  ggplot2::facet_wrap(~direction) +
  ggplot2::theme_classic() +
  ggplot2::geom_rect(data = rushhr,
                     ggplot2::aes(xmin = lb, xmax = ub,
                                  ymin = -Inf, ymax = Inf,
                                  fill=rush
                     ),
                     alpha = 0.25,
                     inherit.aes = F) +
  ggplot2::ylab("Bike Count") +
  ggplot2::xlab("Hour of Day") +
  ggplot2::theme(legend.position ="bottom",
                 legend.title = ggplot2::element_blank(),
                 legend.text = ggplot2::element_text(size = 16),
                 axis.text = ggplot2::element_text(size = 16),
                 axis.title = ggplot2::element_text(size = 20))

animated_traffic <- ggplot2::ggplot(mean_traffic,
                              ggplot2::aes(x=hour, y=bike_count,
                              group = crossing, color = crossing)
     ) +
  ggplot2::geom_point(alpha = 0.8, show.legend = F) +
  ggplot2::geom_line(size = 1.25, show.legend = F) +
  # geom_segment(aes(xend=25, yend = bike_count), linetype = 2, colour = 'grey') +

  ggplot2::facet_wrap(~direction) +
  ggplot2::theme_classic()   +
  ggplot2::geom_text(aes(x=hour, y = bike_count + 8, label = crossing), show.legend = F) +
  ggplot2::geom_rect(data = rushhr,
                     ggplot2::aes(xmin = lb, xmax = ub,
                                  ymin = -Inf, ymax = Inf,
                                  fill=rush
                     ),
                     alpha = 0.25,
                     inherit.aes = F) +
    ggplot2::ylab("Bike Count") +
    ggplot2::xlab("Hour of Day") +
    ggplot2::theme(legend.position ="top",
                 legend.title = ggplot2::element_blank(),
                 legend.text = ggplot2::element_text(size = 16),
                 axis.text = ggplot2::element_text(size = 16),
                 axis.title = ggplot2::element_text(size = 20)) +

  ggplot2::labs(title = 'Hour: {frame_along}') +
#  transition_time(date_time) #+
  gganimate::transition_reveal(hour)

gganimate::animate(animated_traffic, fps = 6)

gganimate::anim_save("animated_traffic.gif", animated_traffic)


library(plyr)
library(dplyr)
library(ggplot2)
library(cluster)

many_pam <- function(x, ks = ks.default(nrow(x)), ...) {
  ldply(seq_along(ks), function(i) {
    cl <- pam(x, k = ks[i], ...)
    data.frame(obs = seq_len(nrow(x)), i = i, k = ks[i], cluster = cl$clustering)
  })
}

ks.default <- function(rows) seq(2, max(3, rows %/% 4))

many_kmeans <- function(x, ks = ks.default(nrow(x)), ...) {
  ldply(seq_along(ks), function(i) {
    cl <- kmeans(x, centers = ks[i], ...)
    data.frame(obs = seq_len(nrow(x)), i = i, k = ks[i], cluster = cl$cluster)
  })
}

all_hclust <- function(x, ks = ks.default(nrow(x)), point.dist = "euclidean", cluster.dist = "ward") {
  d <- dist(x, method = point.dist)
  cl <- hclust(d, method = cluster.dist)

  ldply(seq_along(ks), function(i) {
    data.frame(
      obs = seq_len(nrow(x)), i = i, k = ks[i],
      cluster = cutree(cl, ks[i])
    )
  })
}

clustergram <- function(clusters, y, line.width = NULL) {
  clusters$y <- y[clusters$obs]
  clusters$center <- ave(clusters$y, clusters$i, clusters$cluster)

  if (is.null(line.width)) {
    line.width <- 0.5 * diff(range(clusters$center, na.rm = TRUE)) /
      length(unique(clusters$obs))
  }
  clusters$line.width <- line.width

  # Adjust center positions so that they don't overlap
  clusters <- clusters[with(clusters, order(i, cluster, y)), ]
  clusters <- ddply(clusters, c("i", "cluster"), transform,
                    adj = center + (line.width * seq_along(y))
  )

  structure(clusters,
            class = c("clustergram", class(clusters)),
            line.width = line.width)
}

plot.clustergram <- function(x) {
  i_pos <- !duplicated(x$i)

  means <- ddply(x, c("cluster", "i"), summarise,
                 min = min(adj), max = max(adj))

  ggplot(x, aes(i)) +
    geom_ribbon(aes(y = adj, group = obs, fill = y, ymin = adj - line.width/2, ymax = adj + line.width/2, colour = y)) +
    geom_errorbar(aes(ymin = min, ymax = max), data = means, width = 0.1) +
    scale_x_continuous("cluster", breaks = x$i[i_pos], labels = x$k[i_pos]) +
    labs(y = "Cluster average", colour = "Obs\nvalue", fill = "Obs\nvalue")

}

# Example:
# all_data_trans_std <- all_data_trans
# setDT(all_data_trans_std)
# n <- ncol(all_data_trans_std)
# all_data_trans_std[, (1:n) := lapply(.SD, fun_std), .SDcols = 1:n]
# k_2_20 <- many_kmeans(all_data_trans_std, 2:20, nstart = 1000, iter.max = 20)
# pam_2_20 <- many_pam(all_data_trans_std, 2:20)
# pr <- princomp(all_data_trans_std)
# pr1 <- predict(pr)[, 1]
# pr2 <- predict(pr)[, 2]
# plot(clustergram(k_2_20, pr1))


###**Guessing Game**
#ECON663-Experimental Economics
#*By Ryan McWay*

sample <- c(33.33,15,5,10,42,18.7,17,3,15,43,9)
t.test(sample,mu=0)

hist(sample,
     breaks=5,
     freq= TRUE,
     col="blue",
     main = "Frequency of Guesses",
     xlab= "Sample Guesses",
     labels = TRUE)
par(new=F)
d <- density(sample)
plot(d,
     type= "l",
     main = "Density of Guesses",
     xlab= "Sample Guesses")
library(rmarkdown)
render("GuessingGame.Rmd", output_format= "word_document")


library(igraph)
library(ggplot2)
#library(sna)
#library(network)

g = graph.data.frame(d = Cit.HepPh.WithDates[,c(1,3)], directed = T)

dg_in = degree(g,mode="in")
percent_in = degree.distribution(graph=g,mode="in")

nodes<-function(degree){
  attributes(dg_in[dg_in > degree])$names
}
wellcited<-nodes(6)
length(wellcited)

j<-1
for(i in 1:nrow(Cit.HepPh.WithDates)){
  if(any(Cit.HepPh.WithDates[i,3]==wellcited)){
    Cit.HepPh.WithDates.WellCited[j,]<-Cit.HepPh.WithDates[i,]
    j=j+1
  }
}


mcmc_performR <- function(data, period_start, init_state_num, init_pars, fix_pars,
                          niter = 1e5, BurnIn = 5e3, model = "Multinomial", trace_num = 100,
                          step_pars = init_pars/1000, ... ){
  Prior_func <- function(pars){
    if(any(pars < 0) || any(pars[(length(pars)/2 + 1):length(pars)] > 1)){
      return (0)
    }else{
      return (1) ## Set a non-informative prior
    }
  }

  ftime <- 1:dim(data)[1]

  Log_Likelihood_calculateR <- function(pars, period_start = parent.frame()$period_start, init_state_num = parent.frame()$init_state_num,
                                        ftime = parent.frame()$ftime, fix_pars = parent.frame()$fix_pars){
    ypred <- model_deterministic_simulateR(init_obs = init_state_num, period_start = parent.frame()$period_start,
                                        times = ftime, pars = pars, fix_pars = parent.frame()$fix_pars)
    p_new_pred_n <- round(ypred[, 11])
    p_new_pred_prob <- ypred[, 12]
    rd_new_pred_n <- round(ypred[, 13])
    r_new_pred_prob <- ypred[, 14]
    d_new_pred_prob <- ypred[, 15]
    p <- c()
    if(model=="Poisson"){
      ypred <-  p_new_pred_n  *  p_new_pred_prob
      p<-try(dpois(data$Confirmed, round(ypred),log=T),silent=T)
      if(any(is.nan(p))||any(p==-Inf)){
        logL <- -Inf
      }
      else{
        logL <- sum(p)
      }
    }
    else if(model=="Binomial"){
      p <- try(dbinom(data$Confirmed,round( p_new_pred_n), p_new_pred_prob, log = T),silent = T)
      if(any(p == -Inf) || any(is.nan(p))){
        logL <- -Inf
      }else{
        logL <- sum(p)
      }
    }
    else if(model=="Multinomial"){
      for(i in 1:dim(ypred)[1]){
      p[i] = try(dbinom(data$Confirmed[i], round(p_new_pred_n[i]) , p_new_pred_prob[i], log = T),silent =T)
      obs_size = data$Confirmed[max(i - 1, 1)]
      pred_size = round(ypred[max(i - 1, 1),"P"])
      if((data$Recovered[i] + data$Deceased[i]) > pred_size){
        p[i] = -Inf
      }
      else{
        p[i] = p[i] + try(dmultinom(c(round(c(data$Recovered[i], data$Deceased[i])), pred_size - (data$Recovered[i] + data$Deceased[i])),
                                pred_size, c(r_new_pred_prob[i], d_new_pred_prob[i], 1-r_new_pred_prob[i]-d_new_pred_prob[i]),
                                log = T),silent=T)
      }
    }
    if(any(p == -Inf) || any(is.nan(p))){
      logL <- -Inf
    }else{
      logL <- sum(p)
    }
   }
    return(logL)
  }

  if(period_start[1] != 1){
    period_start = c(1, period_start)
  }
  if(length(period_start) != length(init_pars)/2)
    stop("Number of period is not equal to number of initial parameters")

  ## build the matrix to store the results

  n_period = length(init_pars)/2 # number of periods
  pmat <- matrix(0, ((niter + BurnIn) / trace_num) + 1, 3*n_period) ## parameters + R0 for n_period periods
  colnames(pmat) <- unlist(lapply(c("b","r","R0") , function(y) lapply(1:n_period, function(x) paste(y,x, sep = ""))))
  pmat[1, 1:(2*n_period)] <- init_pars
  R0_est <- R0_calculateR(estpar = init_pars, fix_pars = fix_pars)
  pmat[1, ((2*n_period)+1):(3*n_period)] <- R0_est

  ## Start MCMC
  pars_now <- init_pars

  cat("MCMC:", fill = T)
  for(i in 2:(niter + BurnIn)){
    pars_new <- rep(0, 2*n_period)
    for(j in 1:(2*n_period)){
      pars_new[j] <- rnorm(1, mean = pars_now[j], sd = step_pars[j])
    }
    A <- 0
    if(Prior_func(pars_new) > 0){
      ll_pars_new <- Log_Likelihood_calculateR(pars = pars_new)
      if(ll_pars_new != -Inf) {
        ll_pars_now <- Log_Likelihood_calculateR(pars = pars_now)
        A <-  exp(1)^(ll_pars_new - ll_pars_now) # Prior_func(pars_new) / Prior_func(pars_now) * 10^(ll_pars_new - ll_pars_now)
      }
    }

    if(runif(1) < A){
      pars_now <- pars_new
    }
    if(i %% trace_num == 0) {
      R0_est <- R0_calculateR(estpar = pars_now, fix_pars = fix_pars)
      pmat[(i / trace_num) + 1, 1:(2*n_period)] <- pars_now
      pmat[(i / trace_num) + 1, ((2*n_period)+1):(3*n_period)] <- R0_est

    }
    if(i%%(niter/10) == 0) cat("Iter", i, " A =", round(A, digits=4), " : ", round(pars_now, digits=4), fill = T)

  }
  mcmc_estimates = pmat[-c(1:(BurnIn / trace_num + 1)), ]
  return(mcmc_estimates)

}


g1 = read.table(file="./g1.expr")
g2 = read.table(file="./g2.expr")

#g1 = g1+0.01
#g2 = g2+0.01

g1_mean = apply(g1, 1, mean)
g2_mean = apply(g2, 1, mean)

fc = (g2_mean+1)/(g1_mean+1)

logFC = log2(fc)

pv=c()
for(i in 1:length(rownames(g1))){
	r = t.test(g1[i,], g2[i,], alternative = "two.sided")
	pv = append(pv, r$p.value)
}

adjp=p.adjust(pv, method="hochberg")

dat = cbind(g1_mean, g2_mean, fc, logFC, pv, adjp)

write.table(dat, file="ttest.result", row.names=F, col.names=F, sep="\t")


library(lme4)
rm(list = ls())

mon_data <- read.csv("H:\\Gabilan Turbidity TMDL\\data\\ceden_ntu_r3_2019-07-26.csv")
lc_by_huc <- read.csv("H:\\Gabilan Turbidity TMDL\\gis\\stream-classification\\tables\\lu_by_huc.csv")
mon_stations <- read.csv("H:\\Gabilan Turbidity TMDL\\gis\\stream-classification\\tables\\mon_stations.csv")

# NLCD Codes
# "11 Open Water"
# "21 Developed Open Space"
# "22 Developed, Low Intensity"
# "23 Developed, Medium Intensity"
# "24 Developed, High Intensity"
# "31 Barren (Rock/Sand/Clay)"
# "41 Deciduous Forest"
# "42 Evergreen Forest"
# "43 Mixed Forest"
# "52 Shrub/Scrub"
# "71 Grassland/Herbaceous"
# "81 Pasture/Hay"
# "82 Cultivated Crops"
# "90 Woody Wetlands"
# "95 Emergent Herbaceous Wetlands"

sq_m_to_acres <- 0.000247105
lc_by_huc$total_acres <- apply(lc_by_huc[, 3:ncol(lc_by_huc)], 1, sum) * sq_m_to_acres
lc_by_huc$human_acres <-  apply(lc_by_huc[, c(4:7, 14:15)], 1, sum) * sq_m_to_acres
lc_by_huc$human_perc <-  lc_by_huc$human_acres / lc_by_huc$total_acres
lc_by_huc$huc_10 <- substr(lc_by_huc$HUC_12, 1, 10)

lc_by_huc_10 <- aggregate(cbind(human_acres, total_acres) ~ huc_10, lc_by_huc, sum)
lc_by_huc_10$human_perc <-  lc_by_huc_10$human_acres / lc_by_huc_10$total_acres

mon_stations$huc_10 <- substr(mon_stations$HUC_12, 1, 10)

mon_data_trim <- mon_data[c("StationCode",  "SampleDate",  "Result")]
data_dry <- mon_data_trim[
  as.numeric(substr(mon_data_trim$SampleDate, 6, 7)) < 10 &
  as.numeric(substr(mon_data_trim$SampleDate, 6, 7)) > 4, ]

data_mon_stations <-  merge(data_dry, mon_stations)[c(1:3, 8:9, 11)]
# data_lc <- merge(data_mon_stations, lc_by_huc)
data_lc <- merge(data_mon_stations, lc_by_huc_10)
data <- data_lc[c("Result", "Q0001E", "V0001E", "human_perc", "huc_10")]

mod_mm <- lmer(Result ~ Q0001E + human_perc + (1 | huc_10), data = data)
summary(mod_mm)

mod_lm <- lm(Result ~ Q0001E + human_perc, data = data)
summary(mod_lm)
max(data$human_perc)
intercept <- mod_lm$coefficients[1]
flow <- mod_lm$coefficients[2]
human <- mod_lm$coefficients[3]
intercept + flow * 10 + human * 60

head(data)
huc_10s <- rep(unique(data$huc_10), each = 10)
human_percs <- rep(seq(0, 100, length.out = 10), length = length(huc_10s))
Qs <- rep(1, length = length(huc_10s))
data_pred <- data.frame("huc_10" = huc_10s, "human_perc" = human_percs, "Q0001E" = Qs, stringsAsFactors = F)
pred_y <- predict(mod, newdata = data_pred)
pred_x <- data_pred$human_perc
plot(pred_y ~ pred_x, type = "l")
plot(sort(data$Result) ~ seq(1, nrow(data)))


ds_0 = read.delim('Restaurant_Reviews.tsv', sep = '\t', quote = "", stringsAsFactors = FALSE)

# Cleaning the text and creating the bag of words
library(tm)
corpus = VCorpus(VectorSource(ds_0$Review))

## If you want to clean separately like Hadelin did...

# corpus = tm_map(corpus, content_transformer(tolower))
# corpus = tm_map(corpus, removeNumbers)
# corpus = tm_map(corpus, removeWords, stopwords())
# corpus = tm_map(corpus, stemDocument)
# corpus = tm_map(corpus, stripWhitespace)

dtm = DocumentTermMatrix(corpus,
                         control = list(removePunctuation = TRUE,
                                        removeNumbers = TRUE,
                                        stemming = TRUE,
                                        stopwords = TRUE,
                                        tolower = TRUE
                                        ))

dtm = removeSparseTerms(dtm, sparse = 0.999)
ds = as.data.frame(as.matrix(dtm))
ds$Liked = ds_0$Liked

# Random forest
library(caTools)
ds$Liked= factor(ds$Liked, levels = c(0,1))
split = sample.split(ds$Liked, SplitRatio = 0.8)
train = subset(ds, split == TRUE)
test = subset(ds, split == FALSE)

library(randomForest)
clf = randomForest(x = train[-699], y = train$Liked, ntree = 100)
y_pred = predict(clf, newdata=test[-699])
cm = table(test[, 699], y_pred)


import_package('ggplot2', attach=TRUE)

#' Plot read count correlation for chromstar models
#'
#' @param models   Chromstar combined model or list of model objects
#' @param cluster  cluster the axes (default: TRUE)
#' @return         GGplot correlation matrix
cor = function(models, cluster=TRUE) {
    if (any(grepl("[mM]ultiHMM", class(models))))
        bin_counts = model$bins$counts.rpkm
    else {
        bin_counts = sapply(models, function(m) m$bins$counts.rpkm)
        colnames(bin_counts) = sapply(models, function(m) m$info$ID)
    }

    mat = stats::cor(bin_counts)
    df = reshape2::melt(mat, value.name='cor')

    if (cluster) {
        hc = stats::hclust(stats::dist(mat))
        df$Var1 = factor(df$Var1, levels=unique(df$Var1)[hc$order])
        df$Var2 = factor(df$Var2, levels=unique(df$Var2)[hc$order])
    }

    ggplot(df, aes(x=Var1, y=Var2)) +
        geom_tile(aes(fill=cor)) +
        geom_text(aes(label = sprintf("%.2f", cor)), size=min(4, 40/nrow(mat))) +
        labs(title = "Read count correlation", x = "", y = "") +
        theme_minimal() +
        theme(axis.text.x = element_text(angle=45, hjust=1, vjust=0)) +
        scale_fill_gradient2(low='blue', mid='white', high='red', limits=c(-1,1))
}


#' Continuous Habitat Suitability Function Generator
#'
#' Generate a continuous habitat suitability function given parameter values
#' and scores.
#'
#' @param value Vector of parameter values, or a dataframe containing
#'   parameters values in the first column and scores in the second column.
#'   \code{value} must be in ascending order.
#' @param score Vector of scores assigned to parameter values specified in
#'   \code{values}.
#' @param scoreleft the value to be returned when input values are less than
#'   \code{min(value)}.
#' @param scoreright the value to be returned when input values are greater
#'   than \code{max(value)}.
#' @param spline.expand Add curvature to the habitat suitability curve by
#'   expanding the resolution of \code{(value, score)} and fitting a spline
#'   using \code{spline()}. If \code{spline.expand = 1}, the habitat
#'   suitability curve is generated as a linear interpolation between
#'   \code{(value, score)} pairs. For integer values of
#'   \code{spline.expand > 1}, the lengths of \code{value} and \code{score} are
#'   increased to \code{spline.expand*length(value)}.
#' @param ... Additional arguments passed to \code{spline()}.
#' @return A function representing the habitat suitability curve
#'
#' @details When \code{spline.expand > 1}, an interpolating spline is first
#'   fit to the data. In order to ensure that no scores exceed the maximum
#'   score included in \code{score}, two separate splines are fit to data below
#'   and above the maximum value of \code{score}. The interpolated data are
#'   then approximated again using a linear interpolation to enforce the
#'   extrapolation rules specified by \code{scoreleft} and \code{scoreright}.
#'
#' @examples
#' make_hsc(c(5, 10, 15, 20, 25), c(0, 0.7, 1, 0.75, 0), spline.expand = 1)
#' make_hsc(c(5, 10, 15, 20, 25), c(0, 0.7, 1, 0.75, 0), spline.expand = 100)
#'
#' make_hsc(c(5, 10, 15), c(0, 0.7, 1), scoreright = 1, spline.expand = 1)
#' make_hsc(c(5, 10, 15), c(0, 0.7, 1), scoreright = 1, spline.expand = 100)
#'
#' @export
make_hsc = function(value, score, scoreleft = 0, scoreright = 0,
  spline.expand = 1L, ...){
  if(missing(score)){
    score = value[,2]
    value = value[,1]
  }
  if(!identical(sort(value), value))
    stop("Value must be strictly increasing")
  value2 = seq(min(value), max(value), length.out = spline.expand*length(value))
  value2 = unique(sort(c(value2, value)))
  whichval = value[which.max(score)]
  valfirst = value[value <= whichval]
  vallast = value[value >= whichval]
  val2first = value2[value2 <= whichval]
  val2last = value2[value2 >= whichval]
  scorefirst = score[seq(which.max(score))]
  scorelast = score[seq(which.max(score), length(score))]
  splinefirst = spline(valfirst, scorefirst, xout = val2first, ...)$y
  splinelast = spline(vallast, scorelast, xout = val2last, ...)$y
  score2 = c(splinefirst, tail(splinelast, -1))
  approxfun(value2, score2, method = "linear", yleft = scoreleft,
    yright = scoreright)
}

#' Discrete Habitat Suitability Function Generator
#'
#' Generate a discrete habitat suitability function given parameter windows and
#' scores.
#'
#' @param expr List of expressions evaluating the value of a parameter \code{x}.
#'   All expressions should be mutually exclusive. See examples for how to
#'   construct the expressions.
#' @param score Vector of scores assigned when a given expression evaluates as
#'   \code{TRUE}.
#' @return A function representing the habitat suitability index.
#'
#' @examples
#' windows = list(
#'   optimal = expression(x >= 14 & x <= 18),
#'   suitable = expression(x < 14 | (x >= 18 & x < 21)),
#'   stressful = expression(x >= 21 & x <= 25),
#'   unsuitable = expression(x > 25)
#' )
#' scores = c(3, 2, 1, 0)
#'
#' make_hsd(windows, scores)
#' make_hsd(windows, names(windows))
#'
#' @export
make_hsd = function(expr, score){
  function(x) score[unlist(lapply(expr, eval, envir = environment()))]
}

#' Habitat Suitability Index Generator
#'
#' Generate a habitat suitability index function based on a set of habitat
#' suitability curves and an aggregation rule.
#'
#' @param hsc A list of habitat suitability curve functions.
#' @param ag.fun A function used for aggregating the outputs of the habitat
#'   suitability curves.
#' @return A function that calculates the Habitat Suitability Index given a
#'   vector or dataframe of habitat suitability parameters corresponding (in
#'   order) to the habitat suitability curves contained in \code{hsc}.
#'
#' @examples
#' f1 = make_hsc(c(5, 10, 15, 20, 25), c(0, 0.7, 1, 0.75, 0))
#' f2 = make_hsc(c(0, 5, 10), c(1, 0.5, 0), scoreleft = 1)
#' make_hsi(list(f1, f2), ag.fun = mean)
#' make_hsi(list(f1, f2), ag.fun = min)
#'
#' @export
make_hsi = function(hsc = list(), ag.fun = mean){
  function(x)
    ag.fun(mapply(do.call, hsc, lapply(x, list)))
}

#' Join volume information
#'
#' Attach water volume information from estuary bathymetry to gridded data.
#'
#' @param d Dataframe containing data to have volume information attached to.
#' @param volumes Dataframe containing cell counts. If \code{cellvol} is
#'   missing, must also containing the attribute "resolution" which is a
#'   dataframe or list with elements \code{xres}, \code{yres}, and \code{zres}.
#' @param cellvol Numeric volume of cells desribed by \code{volumes}.
#' @param joincols Columns to use when joining \code{volumes} to \code{d}.
#' @param countcol Column name containing cell count data in \code{volumes}.
#' @param volcol The name of the column containing volume data to be added to
#'   \code{d}.
#' @return The dataframe \code{d} with the additional column \code{volcol}.
#'
#' @importFrom dplyr inner_join
#' @export
join_volume = function(d, volumes, cellvol, joincols = c("elev", "dist", "wse"),
  countcols = c("count", "count.littoral", "count.limnetic",
    "count.sublimnetic", "count.epibenthic", "count.profundal"),
  volcols = c("volume.total", "volume.littoral", "volume.limnetic",
    "volume.sublimnetic", "volume.epibenthic", "volume.profundal")){
  if(missing(volumes))
    data(volumes, envir = environment())
  if(missing(cellvol))
    cellvol = prod(attr(volumes, "resolution")[c("xres", "yres", "zres")])
  ind = d
  d[, joincols] = as.character(unlist(d[, joincols]))
  volumes[, joincols] = as.character(unlist(volumes[, joincols]))
  f = left_join(d, volumes, by = joincols)
  f[, joincols] = as.numeric(unlist(f[, joincols]))
  for(i in seq_along(volcols))
    ind[volcols[i]] = f[[countcols[i]]]*cellvol
  ind
}

#' Join water-surface elevation information
#'
#' Attach maximum water-surface elevation recorded in CTD transects to gridded
#'   data.
#'
#' @param d Dataframe containing data to have water surface elevation attached
#'   to.
#' @param ctd Dataframe containing ctd transects matching grids in \code{d}.
#' @param joincols Columns to use when joining \code{ctd} to \code{d}.
#' @param wsein The name of the column in \code{ctd} containing water-surface
#'   elevation data.
#' @param wseout The name of the column containing water-surface elevation data
#'   to be added to \code{d}.
#' @return The dataframe \code{d} with the additional column \code{wseout}.
#'
#' @importFrom dplyr inner_join
#' @importFrom dplyr group_by_
#' @importFrom dplyr summarize
#' @export
join_wse = function(d, ctd, joincols = c("date", "id"),
  wsein = "elev", wseout = "wse"){
  if(missing(ctd))
    data(ctd, envir = environment())
  ind = d
  ctd["wsein"] = ctd[[wsein]]
  wl = summarize(group_by_(ctd, .dots = joincols), wse = max(wsein))
  wse = left_join(d, wl, by = joincols)
  ind[wseout] = wse$wse
  ind
}

#' Summarize by Strata
#'
#' Group and summarize a dataframe by specific "strata" or groupings.
#'
#' @param d The dataframe to be summarized.
#' @param stratcols Vector or list of column names to group by.
#' @param summexpr Named vector or list of expressions to summarize the data.
#' @return A dataframe containing grouped and summarized data.
#'
#' @details This function is basically a wrapper for the \code{summarize} and
#'   \code{group_by} functions provided by \code{dplyr}.
#'
#' @importFrom dplyr summarize_
#' @importFrom dplyr group_by_
#' @export
summarize_by_strata = function(d, stratcols, summexpr){
  as.data.frame(summarize_(group_by_(d, .dots = stratcols),
    .dots = summexpr))
}


 C02ANJ Example Program Results

  Roots of quartic equation           Error estimates
                                    (machine-dependent)

  z =   3.0000E+00 -2.0000E+00*i          1.8E-15
  z =   1.0000E+00 -2.0000E+00*i          1.8E-15
  z =  -2.0000E+00 +1.0000E+00*i          1.8E-15
  z =  -2.0000E+00 +3.0000E+00*i          1.8E-15


# Grouped Bar Plot
table <- read.table("warnings.data", header = TRUE, sep = ",", quote = "\"")

counts <- table(table$category, table$fuzzer)

densities = c(15, 10)
angles = c(45, 145)

barplot(counts, main="",
  xlab="", ylab="Number of warnings", col=c("darkblue","red"),
  legend = rownames(counts),
  beside=TRUE, angle=angles, density=densities, cex.lab=2, cex.axis=2, cex.names=2, cex=2, args.legend=c(cex=1.15))


# Store the population in millions and save to population_in_millions
population_in_millions <- murders$population/10^6

# Create a histogram of this variable
hist(population_in_millions)