library(tidyverse)
library(albersusa)
library(data.table)
library(ggforce)
library(plotly)
library(RcppRoll)

setwd("~/Public_Policy/Projects/COVID-19")

### get covid data and lockdown info ###
us_covid_data_by_state_with_calcs = read_csv('data/us_covid_data_by_state_with_calcs.csv')

lockdowns_by_state = select(us_covid_data_by_state_with_calcs,
                            state_name = location_name,
                            state_abbr = location,
                            lockdown_start, lockdown_end
) %>% unique()

#### get census and FRED data #####
state_census_data = read_csv('data/ACSDP5Y2018.DP03_data_with_overlays_2020-04-13T221826.csv',
                             skip = 2, na = c('', 'NA', '(X)'),
                             col_names = F)
state_census_data_names = read_csv('data/ACSDP5Y2018.DP03_data_with_overlays_2020-04-13T221826.csv',
                              n_max = 1, na = c('', 'NA', '(X)'),
                             col_names = T)

names(state_census_data) = names(state_census_data_names)
state_census_data_names_desc = pivot_longer(state_census_data_names, everything()) %>%
  as.data.frame()

industry_vals = paste0('DP03_00', 33:45, 'PE')
insurance_coverage = paste0('DP03_00', 98:99, 'PE')

selected_state_census_data = select(state_census_data, GEO_ID, state_name = NAME,
                                    all_of(industry_vals), all_of(insurance_coverage)) %>%
  mutate_if(is.numeric, function(x){x/100})

### get state and US population data  ###
fred_sqlite = dbConnect(SQLite(), dbname= "data/fred_sqlite.sqlite")

state_economic_data = dbGetQuery(fred_sqlite, 'select * from state_economic_data') %>%
  mutate(
    date = as.Date(date, origin = '1970-01-01'),
    title_clean = str_extract(title, '(.* in )|(.* for )') %>% str_replace('( in )|( for )', ''),
    title_for_col = paste0("x_", str_replace_all(title_clean, '[ \\-%,]', '_'))
  ) %>%
  arrange(state_name, title_clean, date) %>%
  data.table() %>%
  # accidentally inserted duplicate records for Alabama, dedup here (need to index this db later)
  unique(by = c('state_name', 'title_clean', 'date'))

annual_population_by_state = filter(state_economic_data, title_clean == 'Resident Population') %>%
  mutate(
    year = year(date)
  )

population_by_state = filter(annual_population_by_state, date == max(date))
us_population = sum(population_by_state$value)

if (max(annual_population_by_state$year) < year(Sys.Date())) {
  annual_population_by_state_fin =
    bind_rows(
      annual_population_by_state,
      filter(annual_population_by_state, year == max(year)) %>%
        mutate(
          year = year(Sys.Date())
        )
    )
}

initial_claims_by_state = filter(state_economic_data, title_clean == 'Initial Claims') %>%
  mutate(
    year = year(date)
  ) %>%
  left_join(annual_population_by_state_fin %>% select(state_name, year, population = value ),
            by = c('state_name', 'year')) %>%
  rename(initial_claims = value) %>%
  mutate(
    population_total = population * 1000,
    claims_pct_pop = initial_claims / population_total
  ) %>%
  arrange(state_name, date) %>%
  data.table()

initial_claims_by_state_calcs = initial_claims_by_state[, {

  rolling_monthly_claims = c(rep(NA, 3), roll_sum(initial_claims, 4))
  rolling_monthly_claims_pop = rolling_monthly_claims / population_total

  lag_claims = lag(initial_claims, 1)
  delta_claims = initial_claims - lag_claims
  pct_change_claims = delta_claims / lag_claims

  lag_claims_pct_pop = lag(claims_pct_pop, 1)
  delta_claims_pct_pop = claims_pct_pop - lag_claims_pct_pop

  list(
    date = date,
    rolling_monthly_claims = rolling_monthly_claims,
    rolling_monthly_claims_pop = rolling_monthly_claims_pop,
    pct_change_claims = pct_change_claims,
    delta_claims_pct_pop = delta_claims_pct_pop
  )
}, by = list(state_name)]

initial_claims_by_state_fin =
  select(initial_claims_by_state, contains('state'), date, year, initial_claims,
         population_total, claims_pct_pop) %>%
  left_join(initial_claims_by_state_calcs) %>%
  # get weekly covid counts
  inner_join(us_covid_data_by_state_with_calcs %>%
               select(state_name, date, value_total_cases, cases_per_100k)) %>%
  left_join(selected_state_census_data) %>%
  inner_join(lockdowns_by_state) %>%
  mutate(
    days_since_lockdown_start = as.numeric(date - lockdown_start),
    lockdown_status = ifelse(days_since_lockdown_start >= 0, 'Lockdown Period', 'Pre-Lockdown')
  )

pivot_longer(initial_claims_by_state_fin, cols = contains('DP03')) %>%
  group_by(name) %>%
  summarize(
    correlation = cor(rolling_monthly_claims_pop, value),
    correlation2 = correlation^2
  ) %>%
  arrange(-correlation2)

latest_initial_claims_by_state_fin = filter(initial_claims_by_state_fin,
                                            date == max(date))

filter(initial_claims_by_state_fin,
       # date >= as.Date('2020-01-01'),
       # state_abbr %in% c('NY', 'CA', 'AL', 'GA'),
       year==2020, month(date) == 3) %>%
ggplot(aes(days_since_lockdown_start, group = state_name))+
  # facet_wrap(~state_name) +
  geom_vline(aes(xintercept = 0), colour = 'red', linetype = 'dashed', size = 1) +
  geom_line(aes(y = rolling_monthly_claims_pop), size= 0.75, alpha = 0.4) +
  # geom_bezier0(aes(y = claims_pct_pop)) +
  geom_point(aes(y = rolling_monthly_claims_pop)) +
  labs(
    x = '\nDays Until State Lockdown',
    y = 'Initial Claims as a Percent of State Population\n',
    title = 'COVID-19 State Lockdowns vs. Initial Unemployment Claims'
  ) +
  # theme_dark() +
  scale_y_continuous(labels = percent)
  # theme_classic() +

ggsave('output/initial_claims_vs_lockdowns.png', height = 6, width = 8, units = 'in', dpi = 800)

a = ggplot(initial_claims_by_state_fin, aes(log(cases_per_100k), claims_pct_pop, colour = state_name)) +
  geom_path() +
  geom_point(aes(size = value_total_cases)) +
  # scale_size(range = c(1, 7)) +
  scale_colour_hue(guide = F)
  # stat_smooth(method = 'loess', span = 1.5)

 ggplotly(a)


#' @title CurlyBraces
#' @description function to draw curly braces
#' @param x, y position where to put the braces range is the length of the brace
#' @param pos: 1 vertical, 2 horizontal
#' @param direction: 1 left/down, 2 right/up
#' @param depth controls width of the shape
#' @family abysmally documented
#' @author  Sharon from stackoverflow
#' @export

CurlyBraces = function(x0, x1, y0, y1, pos = 1, direction = 1, depth = 1) {

    a=c(1,2,3,48,50)    # set flexion point for spline
    b=c(0,.2,.28,.7,.8) # set depth for spline flexion point

    curve = spline(a, b, n = 50, method = "natural")$y * depth

    curve = c(curve,rev(curve))

    if (pos == 1){
        a_sequence = seq(x0,x1,length=100)
        b_sequence = seq(y0,y1,length=100)
    }
    if (pos == 2){
        b_sequence = seq(x0,x1,length=100)
        a_sequence = seq(y0,y1,length=100)
    }

    # direction
    if(direction==1)
        a_sequence = a_sequence+curve
    if(direction==2)
        a_sequence = a_sequence-curve

    # pos
    if(pos==1)
        lines(a_sequence,b_sequence, lwd=1.5,   xpd=NA) # vertical
    if(pos==2)
        lines(b_sequence,a_sequence, lwd=1.5, xpd=NA) # horizontal

}


library(dslabs)
library(tidyverse)
data (murders)

murders %>%
  ggplot(aes(population, total, label = abb, color = region)) +
  geom_label()


## from https://github.com/anbena/ABC-FDSS/blob/master/2pop/div_and_mig.r
## publication: https://www.biorxiv.org/content/10.1101/507897v2.full

#wrapper script to simulate two population split with asymmetrical gene flow from divergence to the present
#Rscript --vanilla ./div_and_mig.r <nchr> <locuslength> <nlociXsim> <rec.rate=1e-8> <nsimulations>
args<-commandArgs(trailingOnly=TRUE)
ms<-"/opt/software/genetics/ms/ms"
cpd<-"./"
mod<-"m2"
nchr<-as.character(args[1])
tgen<-1
mu<-1e-8
recomb<-as.numeric(args[4])#recombination rate
ll<-as.numeric(args[2])#locus length
nsims<-as.numeric(args[5])#number of ABC simulations
nloci<-as.numeric(args[3])#loci to simulate in each sim
out<-paste(mod,"_ll",as.character(ll),"_nl",as.character(nloci),"_r",as.character(recomb),"_nc",nchr,sep="")

#Prior distributions parameters
n1<-sample(500:50000,nsims,replace=T)
n2<-sample(500:50000,nsims,replace=T)
na<-sample(500:50000,nsims,replace=T)
td<-sample(300:20000,nsims,replace=T)
m12<-rexp(nsims,0.1)*4
m21<-rexp(nsims,0.1)*4

#Parameters transformation for ms simulator
tn1<-4*n1*mu*ll
rn2<-n2*4*mu*ll/tn1
rna<-na*4*mu*ll/tn1
tds<-(td/tgen)/(4*n1)
srec<-4*n1*(recomb*(ll-1))

#Output: parameters files
partable<-cbind(n1,n2,na,td,m12,m21)
colnames(partable)<-c("n1","n2","na","td","m12","m21")
partablescaled<-cbind(tn1,rn2,tds,tds,rna,m12,m21,srec)
write.table(partable,paste(out,".param",sep=""),row.names=F,quote=F,sep="\t")
write.table(partablescaled,paste(out,".paramscaled",sep=""),row.names=F,col.names=T,quote=F,sep="\t")

#Output summary statistics: FDSS
i<-1
write(paste(ms," ",as.character(2*as.numeric(nchr))," ",as.character(nloci)," -t ",as.character(tn1[i])," -r ",as.character(srec[i])," ",as.character(ll)," -I 2 ",nchr," ",nchr," -n 2 ",as.character(rn2[i])," -m 1 2 ",as.character(m12[i])," -m 2 1 ",as.character(m21[i])," -ej ",as.character(tds[i])," 2 1 -en ",as.character(tds[i])," 1 ",as.character(rna[i]),"| ",cpd,"compute_ss.py -np 2 -nc ",nchr," -w 30 -b 50 -s > ",out,".tab",sep=""), stderr())
for (i in 1:nsims){
	print(i)
	if (i==1){
		system(paste(ms," ",as.character(2*as.numeric(nchr))," ",as.character(nloci)," -t ",as.character(tn1[i])," -r ",as.character(srec[i])," ",as.character(ll)," -I 2 ",nchr," ",nchr," -n 2 ",as.character(rn2[i])," -m 1 2 ",as.character(m12[i])," -m 2 1 ",as.character(m21[i])," -ej ",as.character(tds[i])," 2 1 -en ",as.character(tds[i])," 1 ",as.character(rna[i]),"| ",cpd,"compute_ss.py -np 2 -nc ",nchr," -w 30 -b 50 -s > ",out,".tab",sep=""))
	}
	else{
		system(paste(ms," ",as.character(2*as.numeric(nchr))," ",as.character(nloci)," -t ",as.character(tn1[i])," -r ",as.character(srec[i])," ",as.character(ll)," -I 2 ",nchr," ",nchr," -n 2 ",as.character(rn2[i])," -m 1 2 ",as.character(m12[i])," -m 2 1 ",as.character(m21[i])," -ej ",as.character(tds[i])," 2 1 -en ",as.character(tds[i])," 1 ",as.character(rna[i]),"| ",cpd,"compute_ss.py -np 2 -nc ",nchr," -w 30 -b 50 -s >> ",out,".tab",sep=""))
	}
}


## Created on Sunday, August 29, 2021 at 11:17pm EDT by Weekend Editor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

library("gsDesign")                                    # For ciBinomial()
library("plyr")                                        # For ddply()

toolsDir <- "../../tools"                              # Various tools available from author
source(file.path(toolsDir, "graphics-tools.r"))        # Various graphics hacks
source(file.path(toolsDir, "pipeline-tools.r"))        # Various graphics hacks

##
## Take summary data on Israeli population (vax, unvax, part vax) stratified by age.
## Compute efficacy and 95% confidence interval by posterior Beta function + Monte Carlo method.
##

doit <- function(## Inputs
                 dataDir  = ".",
                 dataFile = "2021-08-29-covid-simpson-Israeli_data_August_15_2021-vax-summary.tsv",

                 ## Outputs
                 resultsDir = ".",
                 txFile     = "2021-08-29-covid-simpson-ve-confidence-intervals-by-age.txt",
                 plotFile   = "2021-08-29-covid-simpson-ve-confidence-intervals-by-age.png") {

  loadData <- function(dataDir, dataFile) {            # Load the Israeli summary data of Morris
    f <- file.path(dataDir, dataFile)                  # Full pathname to data
    cat(sprintf("* Loading data from %s", f))          # Announce what we're doing
    vaxData <- read.table(f, header = TRUE, sep = "\t")# Read the data
    cat(sprintf("\n  - Found this dataframe:\n"))      # Capture what we got to the transcript
    print(vaxData)                                     # It's short enough that this is doable
    cat("\n")                                          # Final newline
    vaxData                                            # Return the dataframe
  }                                                    #

  addEfficacyAndCI <- function(vaxData) {              #

#    efficacyCI <- function(Ntrt, NtrtInf, Ncnt, NcntInf,
#                                  n = 1000000, probs = c(0.025, 0.500, 0.975)) {
#      ## *** This gets negative CI's when case counts are 0
#      ## Median as best guess, 2.5% and 97.5% as confidence limits
#      alphaNum   <- NtrtInf + 1                        # Numerator Beta distribution, alpha
#      betaNum    <- Ntrt - NtrtInf + 1                 #  and beta parameters (treatment)
#      alphaDenom <- NcntInf + 1                        # Denominator Beta distribution, alpha
#      betaDenom  <- Ncnt - NcntInf + 1                 #  and beta parameters (control)
#      effs       <- 100.0 * (1 - rbeta(n, alphaNum, betaNum) / rbeta(n, alphaDenom, betaDenom))
#      round(quantile(effs, probs = probs), digits = 1) # Get just the quantiles requested
#    }                                                  #

    efficacyCI <- function(Ntrt, NtrtInf, Ncnt, NcntInf, probs = c(0.025, 0.500, 0.975)) {
      ## Frequentist method: risk rates are scaled binomial, so we use the binomial
      ## confidence interval function in the gsDesign package.
      ci <- 100.0 * (1 - rev(ciBinomial(NtrtInf, NcntInf, Ntrt, Ncnt, scale = "RR")))
      c("2.5%"  = ci[[1]],                             #
        "ve"    = 100.0 * (1 - (NtrtInf / Ntrt) / (NcntInf / Ncnt)),
        "97.5%" = ci[[2]])                             #
    }                                                  #

    cat(sprintf("* Adding vaccine efficacies and 95%% confidence limits"))

    vaxDataEffs <- merge(vaxData,                      #
                         ddply(vaxData, "Age.Cohort", function(acdf) {
                           stopifnot(nrow(acdf) == 1)  # Defensive programming: unique age cohorts?
                           ves  <- efficacyCI(acdf[1, "Vax.Popln"],
                                              acdf[1, "Vax.Severe"],
                                              acdf[1, "Unvax.Popln"],
                                              acdf[1, "Unvax.Severe"])
                           pves <- efficacyCI(acdf[1, "Part.Vax.Popln"],
                                              acdf[1, "Part.Vax.Severe"],
                                              acdf[1, "Unvax.Popln"],
                                              acdf[1, "Unvax.Severe"])
                           data.frame(## Efficacy for the fully vaccinated
                                      VE      = ves[["ve"]],
                                      VE.LCL  = ves[["2.5%"]],
                                      VE.UCL  = ves[["97.5%"]],
                                      ## Efficacy for the partly vaccinated
                                      PVE     = pves[["ve"]],
                                      PVE.LCL = pves[["2.5%"]],
                                      PVE.UCL = pves[["97.5%"]])
                         }),                           #
                         by = "Age.Cohort")            #

    cat("\n")                                          # Final newline
    vaxDataEffs                                        # Return augmented dataframe
  }                                                    #

  plotVEs <- function(vaxDataEffs, resultsDir, plotFile) {
    f <- file.path(resultsDir, plotFile)               #
    withPNG(f, 400, 400, FALSE, function() {           #
      withPars(function() {                            #
        cols <- c("blue", "green")
        matplot(x = 1 : nrow(vaxDataEffs),
                y = subset(vaxDataEffs, select = c(VE)), #, PVE)),
                type = "b", pch = 21, col = "black", bg = cols,
                xaxt = "n", xlab = NA, ylab = "Vaccine Efficacy (%)", ylim = c(0, 100),
                main = "Vaccine efficacy by age cohort")
        sapply(1 : nrow(vaxDataEffs), function(rn) {
          drawErrorBar(x0 = rn,
                       y0 = vaxDataEffs[[rn, "VE.LCL"]],
                       x1 = rn,
                       y1 = vaxDataEffs[[rn, "VE.UCL"]],
                       col = "blue")
#          drawErrorBar(x0 = rn,
#                       y0 = vaxDataEffs[[rn, "PVE.LCL"]],
#                       x1 = rn,
#                       y1 = vaxDataEffs[[rn, "PVE.UCL"]],
#                       col = "green")
        })
#        legend("bottomright", inset = 0.05, bg = "antiquewhite",
#               pch = 21, pt.bg = cols, legend = c("Fully vaccinated", "Partially vaccinated"))
        axis(side = 1, at = 1 : nrow(vaxDataEffs), labels = as.character(vaxDataEffs$"Age.Cohort"))
        title(xlab = "Age Cohort", line = 3.5)         # Horizontal axis title
      }, pty = "m",                                    # Maximal plotting area
         bg  = "white",                                # White background
         mar = c(5, 3, 2, 1),                          # Pull in on margins a bit
         mgp = c(1.7, 0.5, 0),                         # Axis title, label, tick
         las = 2,                                      # Axis labels perp to axis
         ps  = 16)                                     # Larger type size for file capture
    })                                                 #
    cat(sprintf("* Plotted to %s\n", f))               # Capture to transcript
    TRUE                                               # Flag that it's done
  }                                                    #

  withTranscript(dataDir, resultsDir, txFile, "Israeli COVID-19 VE Stratified by Age", function() {

    heraldPhase("Loading Data")                        #
    maybeAssign("vaxData", function() { loadData(dataDir, dataFile) })

    heraldPhase("Computing efficacies and confidence interval")
    maybeAssign("vaxDataEffs", function() { addEfficacyAndCI(vaxData) })

    cat("\n"); print(vaxDataEffs) # ***

    heraldPhase("Making plot")                         #
    maybeAssign("plotDone", function() { plotVEs(vaxDataEffs, resultsDir, plotFile) })

    invisible(NA)                                      # Return nothing of interest
  })                                                   # Done with transcript capture
}                                                      # Done overall


#' clomin_7730
#'
#' Calculate minimal clothing insulation value required to reach thermal comfort in moderate thermal environments ( -0.5 < PMV <0.5) based on PMV ISO 7730.
#'
#' @param t numeric    Air temperature in degC.
#' @param rh numeric   Air Relative humidity in percentage.
#' @param wind numeric Wind speed in meters per second.
#' @param tr numeric   Mean radiant temperature in degC.
#' @param M numeric    Metabolic rate of subject in W/mq.
#' @param W numeric    Mechanical work of subject in W/mq. Generally 0.
#' @return mimimal clothing insulation required
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#'
#' @export
#'
#'
#'
#'

clomin_7730=function(t,rh,wind,tr,M,W) {
                         ct$assign("ta", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("vel", as.array(wind))
                         ct$assign("tr", as.array(tr))
                         ct$assign("M", as.array(M))
                         ct$assign("W", as.array(W))
                         ct$eval("var res=[]; for(var i=0, len=ta.length; i < len; i++){ res[i]=clomin_7730(ta[i],rh[i],vel[i],tr[i],M[0],W[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


dfr <- read.table(tc <- textConnection(
">=  0.00  <  0.06  :=  0.10
>=  0.06  <  0.11  :=  0.18
>=  0.11  <  0.16  :=  0.26
>=  0.16  <  0.21  :=  0.32
>=  0.21  <  0.26  :=  0.38
>=  0.26  <  0.31  :=  0.44
>=  0.31  <  0.36  :=  0.50
>=  0.36  <  0.41  :=  0.54
>=  0.41  <  0.46  :=  0.58
>=  0.46  <  0.51  :=  0.62
>=  0.51  <  0.56  :=  0.66
>=  0.56  <  0.61  :=  0.70
>=  0.61  <  0.66  :=  0.74
>=  0.66  <  0.71  :=  0.78
>=  0.71  <  0.76  :=  0.82
>=  0.76  <  0.81  :=  0.86
>=  0.81  <  0.86  :=  0.90
>=  0.86  <  0.91  :=  0.94
>=  0.91  <  0.96  :=  0.98
>=  0.96  <  1.01  :=  1.00")); close(tc)
breaks <- dfr$V4
values <- dfr$V6


setClass("humanreadable", representation="VIRTUAL")

hr_make_humanreadable = function(printsize, unit, sepchar)
{
  ret = paste(printsize, unit, sep=sepchar)
  ret = gsub(ret, pattern=" $", replacement="", perl=TRUE)
  class(ret) = "humanreadable"
  ret
}

hr_trivial = function(x, digits)
{
  printsize = as.character(round(x, digits=digits))
  sepchar = " "
  unit = ""

  hr_make_humanreadable(printsize, unit, sepchar)
}

hr_names = function(x, digits, ordmag, names)
{
  index = max(1, min(which(.numbers$exponent >= ordmag)) - 1)

  if (names == "long")
  {
    sepchar = " "
    unit = .numbers$name[index]
  }
  else if (names == "short")
  {
    sepchar = ""
    unit = .numbers$shorthand[index]
  }

  printsize = round(round(x, 0)/(10^.numbers$exponent[index]), digits=digits)

  hr_make_humanreadable(printsize, unit, sepchar)
}

hr_comma = function(x, digits)
{
  sgn = sign(x)
  dec = round(abs(x) - floor(abs(x)), digits) * 10^digits
  x = floor(abs(x))

  y = digits2zero(format(x, scientific=FALSE))

  if (dec > 0)
    sepchar = "."
  else
  {
    dec = ""
    sepchar = ""
  }

  if (sgn < 0)
    sgnchar = "-"
  else
    sgnchar = ""

  # dat regex
  printsize = gsub("(?<=\\d)(?=(\\d{3})+(?!\\d))", ",", x=y, perl=TRUE)
  printsize = paste0(paste0(sgnchar, printsize), sepchar, dec)
  unit = ""

  hr_make_humanreadable(printsize, unit, "")
}

#' hr
#'
#' Approximate size of an integer.  Very useful when dealing with potentially
#' large values, such as those from \code{howmany()}.
#'
#' @description
#' A rich man's exponential notation.
#'
#' @param x
#' A number.
#' @param names
#' "long", "short", or "comma"; determines wheter the output
#' reads like "10 million", "10m", or "10,000,000", respectively.
#' @param digits
#' The number of decimal digits to retain.
#'
#' @return
#' An object of class \code{humanreadable}.
#'
#' @examples
#' \dontrun{
#' library(memuse)
#'
#' hr(12345678)
#' hr(12345678, "long")
#' }
#'
#' @seealso \code{\link{howmany}}
#' @export
hr = function(x, names="comma", digits=2)
{
  names = match.arg(tolower(names), c("long", "short", "comma"))

  if (length(x) > 1)
  {
    ret = sapply(x, hr)
    class(ret) = "approx"

    return(ret)
  }

  ordmag = floor(log10(x)) + 1

  if (ordmag < 4)
    hr_trivial(x, digits)
  else if (names != "comma")
    hr_names(x, digits, ordmag, names)
  else
    hr_comma(x, digits)
}

#' @title Print \code{humanreadable} objects
#' @description Printing for \code{hr()}
#' @param x \code{humanreadable} object
#' @param ... unused
#' @name print-hr
#' @rdname print-hr
#' @method print humanreadable
#' @export
print.humanreadable = function(x, ...)
{
  cat(paste(paste(x, collapse=" "), "\n"))
}


library(tidyverse)

link <- 'https://github.com/gumdropsteve/datasets/raw/master/december_real_estate.csv'
df <- read.csv(link)

# view dataset tidy (note the difference with how these display in console)
df
as_tibble(df)

df <- as_tibble(df)

# view like excel or github
View(df)

### filter function

# single filter
filter(df, closing_price > 1000000)

filter(df, client == 'seller')

filter(df, ds > '12/14/2019')

# multiple filters
filter(df, client != 'seller', commission > 10000)

filter(df, ds <= '12/14/2019', realtor_id == 0)

filter(df, client == 'seller', ds == '12/14/2019', realtor_id == 0)

filter(df,
       realtor_id == 3,
       location == 'pleasanton')

### arrange function

# order by single column
arrange(df, ds)

arrange(df, closing_price)

# descending order by single column
arrange(df, desc(ds))

# order by multiple columns
arrange(df, ds, realtor_id)

arrange(df, ds, realtor_id, closing_price)

# descending order by multiple columns
arrange(df, desc(realtor_id), desc(closing_price))

# mixed order by multiple columns
arrange(df, desc(realtor_id), desc(commission), location)

### select function

# select a single column
select(df, ds)

# select multiple columns
select(df, ds, closing_price)

select(df, realtor_id, closing_price, ds)

# select all columns, but put one (realtor_id in our case) first (most left)
select(df, realtor_id, everything())

select(df, realtor_id, commission, everything())

# keep results around as a variable
r_df <- select(df, ds, client, realtor_id, everything())
View(r_df)

### mutate function
df_small <- select(df, ds, client, realtor_id, closing_price, commission_rate)
df_small

# create (add) a single new column
mutate(df_small,
       commission = closing_price * commission_rate)

# create (add) multiple new columns
mutate(df_small,
       commission = closing_price * commission_rate,
       was_listing_agent = client == 'seller')

### transmute function

# create a single column (drop all others)
transmute(df_small,
          commission = closing_price * commission_rate)

# create multiple columns (drop all others)
transmute(df_small,
          commission = closing_price * commission_rate,
          was_listing_agent = client == 'seller')

# create multiple columns (keep a few original around as well, drop all others)
transmute(df_small,
          ds,
          closing_price,
          commission = closing_price * commission_rate,
          was_listing_agent = client == 'seller')

### summarize function
summarize(df, mean(closing_price))

# best when used with group by
by_id <- group_by(df, realtor_id)
summarize(by_id, count = n())

summarize(by_id,
          count = n(),
          avg_closing_price = mean(closing_price),
          avg_commission = mean(commission),
          gross_commission = sum(commission))

s_df <- summarize(by_id, count=n(), avg_closing_price=mean(closing_price),
          avg_commission=mean(commission), gross_commission=sum(commission))

filter(s_df, count > 5)


refugees = c(23,175,15543,11,338796,1244,63,53)
asylumseekers = c(140,77,2872,6,255,91,6,7)
origins = c('Burundi','Dem. Rep. of the Congo', 'Eritrea', 'Rwanda', 'Somalia','South Sudan','Sudan','Uganda')
countries <- factor(origins)
popstats <- data.frame(refugees, asylumseekers, countries)
print("---Whole dataframe---")
print(popstats)
print("---Just the asylum seekers column---")
print(popstats$asylumseekers)


# Data Wrangling in R
# 3.7 Importing Excel Files into R

# School breakfast program data
# Reading data stored in Excel

# Load the tidyverse
library(tidyverse)

# The readxl package isn't part of the core tidyverse so we need to install and
# load it separately
install.packages("readxl")
library(readxl)

# Try just reading the file without other arguments
breakfast <- read_excel('breakfast.xls')
glimpse(breakfast)

# Try skipping three lines

breakfast <- read_excel('breakfast.xls', skip=3)
glimpse(breakfast)

# It looks like we need to skip five lines, which will remove the column names
# So lets create a vector with column names
names <- c("Year", "FreeStudents", "ReducedStudents", "PaidStudents", "TotalStudents",
           "MealsServed", "PercentFree")

# And then try reading the file again
breakfast <- read_excel('breakfast.xls',skip=5, col_names = names)
glimpse(breakfast)

# I'll do a little quick manipulation of this tibble.
# First, convert the numbers of students and meals to real values
breakfast$FreeStudents = breakfast$FreeStudents * 1000000
breakfast$ReducedStudents = breakfast$ReducedStudents * 1000000
breakfast$PaidStudents = breakfast$PaidStudents * 1000000
breakfast$TotalStudents = breakfast$TotalStudents * 1000000
breakfast$MealsServed = breakfast$MealsServed * 1000000

# And show the percentage as a decimal
breakfast$PercentFree = breakfast$PercentFree / 100
glimpse(breakfast)


cpu <- c(55,56,98,100,15,12,33,45,32,67,82,19,25)

summary(cpu)
cpu_usage <- 100 -cpu
#png("BUSY.png")
plot(cpu_usage, type="b", main="CPU busy time over time steps", xlab="Time step", ylab="% busy")

x <- c(rep(1:13))

y <- lm(cpu_usage ~ x)

abline(y)

#dev.off()


###################################################################
#
# R source code providing generalized bilinear mixed effects modeling
# for social network data. For more information on the model fitting
# procedure, see
# "Bilinear Mixed-Effects Models for Dyadic Data" (Hoff 2003)
# http://www.stat.washington.edu/www/research/reports/2003/tr430.pdf
#
# This research was supported by ONR grant N00014-02-1-1011
#
# Copyright (C) 2003 Peter D. Hoff
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA  02111-1307, USA.
#
##################################################################

###Last modification : 2/22/04

###Preconditions of the main function "gbme"

##objects with no defaults
#Y : a square matrix (n*n)

##objects with defaults
#Xd : an n*n*rd array representing dyad-specific predictors
#Xs : an n*rs matrix of sender-specific predictors
#Xr : an n*rr matrix of receiver-specific predictors

# fam : "gaussian" "binomial", or "poisson"
# if fam="binomial" then an (n*n) matrix N of trials is needed
#
# pi.Sab = (s2a0,sab0,s2b0,v0) : parameters of inverse wishart dist
# pi.s2u = vector of length 2: parameters of an inv-gamma distribution
# pi.s2v = vector of length 2: parameters of an inv-gamma distribution
# pi.s2z = k*2 matrix : parameters of k inv-gamma distributions
#
# pim.bd  : vector of length rd, the prior mean for beta.d
# piS.bd  : a rd*rd pos def matrix, the prior covariance for beta.d
#
# pim.b0sr : vector of length 1+rs+rr, prior mean for (beta0,beta.s,beta.r)
# piS.b0sr  : a (1+rs+rr)*(1+rs+rr) pos def matrix,
#             the prior variance for (beta0,beta.s,beta.r)

# k     : dimension of latent space
# directed : T or F. Is the data directed or undirected? If set to F,
#                    estimation proceeds assuming Y[i,j]==Y[j,i],
#                    and any supplied value of Xr is not used
#                    also, only s2a0 and v0 in pi.Sab need be supplied,
#                    and pi.s2v is not used. rr is zero, so pim.b0sr is
#                    length 1+rs

# starting values
# beta.d   #a vector of length rd
# beta.u   #a vector of length 1+rs+rr
# s        #a vector of length n
# r        #a vector of length n
# z        #an n*k matrix

###the main  function
gbme<-function(
 #data
 Y,
 Xd=array(dim=c(n,n,0)),
 Xs=matrix(nrow=dim(Y)[1],ncol=0),
 Xr=matrix(nrow=dim(Y)[1],ncol=0),

 #model specification
 fam="gaussian",
 N=NULL,
 k=0,
 directed=T,

#compute starting values and emp Bayes for priors?
 estart=T,

#priors  - provide if estart=F
 pi.Sab=NULL,
 pi.s2u=NULL,
 pi.s2v=NULL,
 pi.s2z=NULL,
 pim.bd=NULL,
 piS.bd=NULL,
 pim.b0sr=NULL,
 piS.b0sr=NULL,

 #starting values - provide if estart=F
 beta.d=NULL,
 beta.u=NULL,
 s=NULL,
 r=NULL,
 z=NULL,

 #random seed,
 seed=0,

 #details of output
 NS=100000,         #number of scans of mcmc to run
 odens=100,         #output density
 owrite=T,          #write output to a file?
 ofilename="OUT",   #name of output file
 oround=3,          #rounding of output
 zwrite=(k>0),      #write z to  file
 zfilename="Z",     #outfile for z
 sdigz=3,           #rounding for z
 awrite=F,bwrite=F,
 afilename="A",
 bfilename="B"
	       )
{

###set seed
set.seed(seed)

###dimensions of everything
n<<-dim(Y)[1]
rd<<-dim(Xd)[3]
rs<<-dim(Xs)[2]
rr<<-dim(Xr)[2]
diag(Y)<<-rep(0,n)
###

###column names for output file
if(directed==T) {
cnames<-c("k","scan","ll",paste("bd",seq(1,rd,length=rd),sep="")[0:rd],"b0",
                          paste("bs",seq(1,rs,length=rs),sep="")[0:rs],
                          paste("br",seq(1,rr,length=rr),sep="")[0:rr],
  "s2a","sab","s2b","s2e","rho", paste("s2z",seq(1,k,length=k),sep="")[0:k] )
                }

if(directed==F) {
cnames<-c("k","scan","ll",paste("bd",seq(1,rd,length=rd),sep="")[0:rd],"b0",
                          paste("bs",seq(1,rs,length=rs),sep="")[0:rs],
                "s2a","s2e",paste("s2z",seq(1,k,length=k),sep="")[0:k] )
                }

###design matrix for unit-specific predictors
if(directed==T) {
X.u<<-rbind( cbind( rep(.5,n), Xs, matrix(0,nrow=n,ncol=rr)),
            cbind( rep(.5,n),  matrix(0,nrow=n,ncol=rs), Xr ) )
                 }

if(directed==F) { X.u<<-cbind( rep(.5,n), Xs )  }
###

###construct an upper triangular matrix (useful for later computations)
tmp<-matrix(1,n,n)
tmp[lower.tri(tmp,diag=T)]<-NA
UT<<-tmp
###

###get starting values and empirical bayes priors using a glm-type approach
if(estart==T) {tmp<-gbme.glmstart(Y,Xd,Xs,Xr,N=N,fam,k,directed)
               priors<-tmp$priors ; startv<-tmp$startv
              }

if(directed==T) {
 pi.Sab<-priors$pi.Sab; pi.s2u<-priors$pi.s2u; pi.s2v<-priors$pi.s2v
 pi.s2z<-priors$pi.s2z ; pim.bd<-priors$pim.bd ; piS.bd<-priors$piS.bd
 pim.b0sr<-priors$pim.b0sr ; piS.b0sr<-priors$piS.b0sr
 beta.d<-startv$beta.d ; beta.u<-startv$beta.u
 s<-startv$s ; r<-startv$r ; z<-startv$z
               }
###

if(directed == F) {  rho<-1  ;sv<-0 ;  Xr<-Xs ; rr<-rs
                  pi.s2u<-priors$pi.s2u ; pi.s2z<-priors$pi.s2z
                  pim.bd<-priors$pim.bd ; piS.bd<-priors$piS.bd
                  beta.d<-startv$beta.d ; beta.u<-startv$beta.u ; z<-startv$z
                  s<-startv$s ;
                  pi.s2a<-priors$pi.s2a ;
                  pim.b0s<-priors$pim.b0s ;  piS.b0s<-priors$piS.b0s
                  Xr<-NULL ; rr<-0 ; r<-s*0   }

###Matrices for ANOVA  on Xd, s, r
tmp<-TuTv(n)   #unit level effects design matrix for u=yij+yji, v=yij-yji
Tu<-tmp$Tu
Tv<-tmp$Tv

if(directed==F) { Tu<-2*Tu[,1:n] }

tmp<-XuXv(Xd)   #regression design matrix for u=yij+yji, v=yij-yji
Xu<-tmp$Xu
Xv<-tmp$Xv

XTu<<-cbind(Xu,Tu)
XTv<<-cbind(Xv,Tv)

tXTuXTu<<-t(XTu)%*%XTu
tXTvXTv<<-t(XTv)%*%XTv
###

###redefining hyperparams
if(directed==T){
Sab0<-matrix( c(pi.Sab[1],pi.Sab[2],pi.Sab[2],pi.Sab[3]),nrow=2,ncol=2)
v0<-pi.Sab[4]   }
###

###initializing error matrix
E<-matrix(0,nrow=n,ncol=n)
###

###if using the linear link, then theta=Y
if(fam=="gaussian"){ theta<-Y }
###

##### The Markov chain Monte Carlo algorithm
for(ns in 1:NS){

###update value of theta
if(fam!="gaussian"){theta<-theta.betaX.d.srE.z(beta.d,Xd,s,s*(1-directed)+r*directed,E,z)  }

###impute any missing values if gaussian
if(fam=="gaussian" & any(is.na(Y))) {
  rho<-(pi.s2u[2]-pi.s2v[2])/(pi.s2u[2]+pi.s2v[2])
  se<-(pi.s2u[2]+pi.s2v[2])/4
  mu<-theta.betaX.d.srE.z(beta.d,Xd,s,s*(1-directed)+r*directed,E*0,z)
  imiss<-(1:n)[ is.na(Y%*%rep(1,n))  ]
  for(i in imiss){
    for(j in (1:n)[is.na(Y[i,])]) {
    if( is.na(Y[i,j]) & is.na(Y[j,i]) )       {
      smp<-rmvnorm(c(mu[i,j],mu[j,i]),matrix( se*c(1,rho,rho,1),nrow=2,ncol=2))
      theta[i,j]<-smp[1] ; theta[j,i]<-smp[2] }
else{theta[i,j]<-rmvnorm( mu[i,j]+rho*(theta[j,i]-mu[j,i]), sqrt(se*(1-rho^2)))}
                                   }
                  }
                                    }

###Update regression part
tmp<-uv.E(theta-z%*%t(z)) #the regression part
u<-tmp$u                  #u=yij+yji,  i<j
v<-tmp$v                  #v=yij-yji,  i<j

#First get variance - covariance terms
if(directed==T) {
su<-rse.beta.d.gibbs(pi.s2u[1],pi.s2u[2],u,XTu,s,r,beta.d)  #for rho, se
sv<-rse.beta.d.gibbs(pi.s2v[1],pi.s2v[2],v,XTv,s,r,beta.d)
rho<-(su-sv)/(su+sv)
se<-(su+sv)/4
                 }
if(directed==F) {
su<-rse.beta.d.gibbs(pi.s2u[1],pi.s2u[2],u,XTu,s,NULL,beta.d) #for se
se<-su/4       }

sr.hat<-X.u%*%beta.u                                        #Sab
a<-s-sr.hat[1:n]
b<-r-sr.hat[n+(1:n)]
if( directed==T ) {Sab<-rSab.gibbs(a,b,Sab0,v0)}
if( directed==F ) { s2a<-1/rgamma( 1, pi.s2a[1]+n/2 , pi.s2a[2]+sum(a^2)/2 ) }

#dyad specific regression coef and unit level effects
mu<-c(pim.bd, X.u%*%beta.u)    #"prior" mean for (beta.d,s,r)
if(directed==T){
beta.d.sr<-rbeta.d.sr.gibbs(u,v,su,sv,piS.bd,mu,Sab)
beta.d<-beta.d.sr$beta.d ; s<-beta.d.sr$s ; r<-beta.d.sr$r
#regression coef for unit level effects
beta.u<-rbeta.sr.gibbs(s,r,X.u,pim.b0sr,piS.b0sr,Sab)
                }
if(directed==F) {
beta.d.s<-rbeta.d.s.gibbs(u,su,piS.bd,mu,s2a)
beta.d<-beta.d.s$beta.d ; s<-beta.d.s$s
#regression coef for unit level effects
beta.u<-rbeta.s.gibbs(s,X.u,pim.b0s,piS.b0s,s2a)
                 }
###

###bilinear effects
if(k>0){

#update variance
#tmp<-eigen(z%*%t(z))
#z<-tmp$vec[,1:k]%*%sqrt(diag(tmp$val[1:k],nrow=k)) #make cols of z orthogonal
sz<-1/rgamma(k,pi.s2z[,1]+n/2,pi.s2z[,2]+diag( t(z)%*%z)/2)

#Gibbs for zs, using regression
res<-theta-theta.betaX.d.srE.z(beta.d,Xd,s,s*(1-directed)+r*directed,0*E,0*z) #theta-(beta*x+a+b)
s.ares<-se*(1+rho)/2
for(i in sample(1:n))      {
ares<-(res[i,-i]+res[-i,i])/2
Zi<-z[-i,]
Szi<-chol2inv(chol(diag(1/(sz),nrow=k) +
     t(Zi)%*%Zi/s.ares)) #cond variance of z[i,]
muzi<-Szi%*%( t(Zi)%*%ares/s.ares )                      #cond mean of z[i,]
z[i,]<-t(rmvnorm(muzi,Szi)) }
         }
###
if(k==0){sz<-NULL }

#update E
if( fam!="gaussian"){
E<-theta-theta.betaX.d.srE.z(beta.d,Xd,s,s*(1-directed)+r*directed,E*0,z)
      #current E|beta.d,Xd,s,r,z

UU<-VV<-Y*0

u<-rnorm(n*(n-1)/2,0,sqrt(su))
v<-rnorm(n*(n-1)/2,0,sqrt(sv))

UU[!is.na(UT)]<-u
tmp<-t(UU)
tmp[!is.na(UT)]<-u
UU<-t(tmp)

VV[!is.na(UT)]<-v
tmp<-t(VV)
tmp[!is.na(UT)]<--v
VV<-t(tmp)

Ep<-(UU+VV)/2
theta.p<-theta-E+Ep

diag(theta.p)<-diag(theta)<-NA

##cases
if(fam=="poisson") { mup<-exp(theta.p) ;  mu<-exp(theta)
                     M.lhr<-dpois(Y,mup,log=T) - dpois(Y,mu,log=T)   }

if(fam=="binomial"){ mup<-exp(theta.p)/(1+exp(theta.p))
                          mu<-exp(theta)/(1+exp(theta))
         M.lhr<-dbinom(Y,N,mup,log=T) - dbinom(Y,N,mu,log=T)   }

   M.lhr[ is.na(M.lhr) ]<-0
   M.lhr<-(M.lhr+t(M.lhr))/( 2^(1-directed) )
   RU<-matrix(log(runif(n*n)),nrow=n,ncol=n)
   RU[is.na(UT)]<-0  ; RU<-RU+t(RU)
   E[M.lhr>RU]<-Ep[M.lhr>RU]
                 }

####output
if(ns%%odens==0){

#compute loglikelihoods of interest
if(fam=="poisson") { lpy.th<-sum( dpois(Y,exp(theta),log=T),na.rm=T) }
if(fam=="binomial"){ lpy.th<-sum( dbinom(Y,N,exp(theta)/(1+exp(theta)),
                                    log=T),na.rm=T) }

if(fam=="gaussian"){
E<-theta-theta.betaX.d.srE.z(beta.d,Xd,s,s*(1-directed)+r*directed,E*0,z)
tmp<-uv.E(theta-z%*%t(z)) #the regression part
u<-tmp$u                  #u=yij+yji,  i<j
v<-tmp$v                  #v=yij-yji,  i<j
if(directed==T) {
lpy.th<-sum(dnorm(u,0,sqrt(su),log=T) + dnorm(v,0,sqrt(sv),log=T)) }
if(directed==F) { lpy.th<-2*sum(dnorm(u,0,sqrt(su),log=T))  }
                    }
if(directed==F) {lpy.th<-lpy.th/2
                 out<-round(c(k,ns,lpy.th,beta.d,beta.u,s2a,se,sz[0:k]),oround) }
if(directed==T) {
out<-round(c(k,ns,lpy.th,beta.d,beta.u,Sab[1,1],Sab[1,2],Sab[2,2],
             se,rho,sz[0:k]),oround) }

if(owrite==T) {
    if(ns==odens) { write.table(t(out),file=ofilename,quote=F,
                     row.names=F,col.names=cnames) }
    if(ns>odens)  { write.table(t(out),file=ofilename,append=T,quote=F,
                    row.names=F,col.names=F) }
              }
if(owrite==F) {cat(out,"\n") }
if(zwrite==T) { write.table(signif(z,sdigz),file=zfilename,
                      append=T*(ns>odens),quote=F,row.names=F,col.names=F) }

if(awrite==T){write.table(round(t(a),oround),file=afilename,append=T*(ns>odens),quote=F,
                    row.names=F,col.names=F)  }
if(bwrite==T & directed==T){write.table(round(t(b),oround),
                    file=bfilename,append=T*(ns>odens),quote=F,
                    row.names=F,col.names=F) }

                 }

}}

#####################End of main function : below are helper functions

####
TuTv<-function(n){
Xu<-Xv<-NULL
for(i in 1:(n-1)){
tmp<-tmp<-NULL
if( i >1 ){ for(j in 1:(i-1)){ tmp<-cbind(tmp,rep(0,n-i)) } }
tmp<-cbind(tmp,rep(1,n-i))
tmpu<-cbind(tmp,diag(1,n-i)) ; tmpv<-cbind(tmp,-diag(1,n-i))
Xu<-rbind(Xu,tmpu) ; Xv<-rbind(Xv,tmpv)
         }

list(Tu=cbind(Xu,Xu),Tv=cbind(Xv,-Xv))
                   }
####

XuXv<-function(X){
Xu<-Xv<-NULL
if(dim(X)[3]>0){
for(r in 1:dim(X)[3]){
xu<-xv<-NULL
for(i in 1:(n-1)){
for(j in (i+1):n){ xu<-c(xu,X[i,j,r]+X[j,i,r])
                   xv<-c(xv,X[i,j,r]-X[j,i,r]) }}
Xu<-cbind(Xu,xu)
Xv<-cbind(Xv,xv)  }
                }
list(Xu=Xu,Xv=Xv)}

###
uv.E<-function(E){
u<- c(  t( (  E + t(E) )  *UT ) )
u<-u[!is.na(u)]

v<-c(  t( (  E - t(E) )  *UT ) )
v<-v[!is.na(v)]
list(u=u,v=v)}
####

####
theta.betaX.d.srE.z<-function(beta.d,X.d,s,r,E,z){
m<-dim(X.d)[3]
mu<-matrix(0,nrow=length(s),ncol=length(s))
if(m>0){for(l in 1:m){ mu<-mu+beta.d[l]*X.d[,,l] }}
tmp<-mu+re(s,r,E,z)
diag(tmp)<-0
tmp}
####

####
re<-function(a,b,E,z){
n<-length(a)
matrix(a,nrow=n,ncol=n,byrow=F)+matrix(b,nrow=n,ncol=n,byrow=T)+E+z%*%t(z) }
####

####
rbeta.d.sr.gibbs<-function(u,v,su,sv,piS.bd,mu,Sab){
del<-Sab[1,1]*Sab[2,2]-Sab[1,2]^2
iSab<-rbind(cbind( diag(rep(1,n))*Sab[2,2]/del ,-diag(rep(1,n))*Sab[1,2]/del),
          cbind( -diag(rep(1,n))*Sab[1,2]/del,diag(rep(1,n))*Sab[1,1]/del) )
rd<-dim(as.matrix(piS.bd))[1]

if(dim(piS.bd)[1]>0){
cov.beta.sr<-matrix(0,nrow=rd,ncol=2*n)
iS<-rbind(cbind(solve(piS.bd),cov.beta.sr),
   cbind(t(cov.beta.sr),iSab)) }
else{iS<-iSab}

Sig<-chol2inv( chol(iS + tXTuXTu/su + tXTvXTv/sv ) )
    #this may have a closed form expression

#theta<-Sig%*%( (t(XTu)%*%u)/su + (t(XTv)%*%v)/sv + iS%*%mu)
theta<-Sig%*%( t(  (u%*%XTu)/su + (v%*%XTv)/sv ) + iS%*%mu)

beta.sr<-rmvnorm(theta,Sig)
list(beta.d=beta.sr[(rd>0):rd],s=beta.sr[rd+1:n],r=beta.sr[rd+n+1:n]) }
####

####
rse.beta.d.gibbs<-function(g0,g1,x,XTx,s,r,beta.d){
n<-length(s)
1/rgamma(1, g0+choose(n,2)/2,g1+.5*sum( (x-XTx%*%c(beta.d,s,r))^2 ) ) }
####

####
rbeta.sr.gibbs<-function(s,r,X.u,pim.b0sr,piS.b0sr,Sab) {
del<-Sab[1,1]*Sab[2,2]-Sab[1,2]^2
iSab<-rbind(cbind( diag(rep(1,n))*Sab[2,2]/del ,-diag(rep(1,n))*Sab[1,2]/del),
          cbind( -diag(rep(1,n))*Sab[1,2]/del,diag(rep(1,n))*Sab[1,1]/del) )

S<-solve( solve(piS.b0sr) + t(X.u)%*%iSab%*%X.u )
mu<-S%*%(  solve(piS.b0sr)%*%pim.b0sr+ t(X.u)%*%iSab%*%c(s,r))
rmvnorm( mu,S)
                                               }
####

####
rSab.gibbs<-function(a,b,S0,v0){
n<-length(a)
ab<-cbind(a,b)
Sn<-S0+ (t(ab)%*%ab)
solve(rwish(solve(Sn),v0+n) )
                               }

####
rmvnorm<-function(mu,Sig2){
R<-t(chol(Sig2))
R%*%(rnorm(length(mu),0,1)) +mu }

####
rwish<-function(S0,nu){
S<-S0*0
for(i in 1:nu){ z<-rmvnorm(rep(0,dim(as.matrix(S0))[1]), S0)
                S<-S+z%*%t(z)  }
		S }

###  Procrustes transformation: rotation and reflection
proc.rr<-function(Y,X){
k<-dim(X)[2]
A<-t(Y)%*%(  X%*%t(X)  )%*%Y
eA<-eigen(A,symmetric=T)
Ahalf<-eA$vec[,1:k]%*%diag(sqrt(eA$val[1:k]),nrow=k)%*%t(eA$vec[,1:k])

t(t(X)%*%Y%*%solve(Ahalf)%*%t(Y)) }
###

gbme.glmstart<-function(Y,Xd,Xs,Xr,N=NULL,fam,k,directed){
#generate starting values and emp bayes priors from
#approximate mles

if(fam!="binomial"){
y<-x<-NULL
for (i in 1:n) {
for (j in (1:n)[-i]) {
y<-c(y,Y[i,j])
x<-rbind(x,c(i,j,Xd[i,j,])) }}
                    }

if(fam=="binomial"){
y<-x<-NULL
for (i in 1:n) {
for (j in (1:n)[-i]) {
y<-rbind(y,c(Y[i,j], N[i,j]-Y[i,j] ))
x<-rbind(x,c(i,j,Xd[i,j,])) }}
                    }

if(rd>0) {
 fit1<-glm(y~-1+as.factor(x[,1])+as.factor(x[,2])+x[,-(1:2)],family=fam) }
if(rd==0){ fit1<-glm(y~-1+as.factor(x[,1])+as.factor(x[,2]),family=fam) }

s<-fit1$coef[1:n]
r<-c(0,fit1$coef[n+1:(n-1)])
if(rd>0){
beta.d<-fit1$coef[(2*n):length(fit1$coef)]               #beta.d
        }

la<-lm( s~-1+cbind(rep(.5,n),Xs)); a<-la$res
lb<-lm( r~-1+cbind(rep(.5,n),Xr)); b<-lb$res

b0<-(la$coef[1]+lb$coef[1])/2

s1<-s+( b0-la$coef[1])/2                 #s
r1<-r+( b0-lb$coef[1])/2                 #r

la<-lm( s1~-1+cbind(rep(.5,n),Xs)); a<-la$res
lb<-lm( r1~-1+cbind(rep(.5,n),Xr)); b<-lb$res

beta.u<-c(lb$coef[1], la$coef[-1],lb$coef[-1])
Sab<-var(cbind(a,b))                    #Sab

Res<-matrix(0,nrow=n,ncol=n)
l<-1
for( m in 1:dim(x)[1] ) {
if( !is.na(y[m]) ) { Res[x[m,1],x[m,2]]<-fit1$res[l] ; l<-l+1 }
                         }
######
Res[Res>quantile(Res,.95,na.rm=T) ] <- quantile(Res,.95,na.rm=T)
diag(Res)<-rep(0,n)

if(k>0){
for(i in 1:50){
tmp<-eigen( .5*(Res+t(Res) ))
z<-tmp$vec[,1:k] %*%diag(sqrt(tmp$val[1:k]),nrow=k)
diag(Res)<-diag(z%*%t(z))
                 }
sz<-var(c(z))                         #z,sz
E<-Res-z%*%t(z)                           #E
          }
if(k==0){E<-Res ; z<-matrix(0,nrow=n,ncol=1) ;sz<-.1}

u<-E+t(E)
u<-c(u[!is.na(UT)])                      #su
su<-var(u)                               #sv
v<-E-t(E)
v<-c(v[!is.na(UT)])
sv<-var(v)

rho<-(su-sv)/(su+sv)
se<-(su+sv)/4

###construct priors centered on these empirical values
pi.Sab<-c(Sab[1,1],Sab[2,1],Sab[2,2],4)
pi.s2u<-c(2,su)
pi.s2v<-c(2,sv)
pi.s2z<-cbind( rep(2,k), diag( t(z)%*%z)/n )

if(rd>0){
pim.bd<-c(beta.d)
piS.bd<-as.matrix((n*(n-1))^2*summary(fit1)$cov.unscaled[(2*n):length(fit1$coef),
                                          (2*n):length(fit1$coef)] )
         }

if(rd==0){ beta.d<-pim.bd<-NULL ;  piS.bd<-matrix(nrow=0,ncol=0) }

if(directed==T) {
pim.b0sr<-beta.u
piS.b0sr<-rbind(cbind( summary(la)$cov[-1,-1], matrix(0,nrow=rs,ncol=rr)),
# cbind(matrix(0,nrow=rs,ncol=rr),summary(lb)$cov[-1,-1]))
# error found 7-7-6
  cbind(matrix(0,nrow=rr,ncol=rs),summary(lb)$cov[-1,-1]))

piS.b0sr<-rbind(c(summary(la)$cov[1,-1],summary(lb)$cov[1,-1]),piS.b0sr)
piS.b0sr<-cbind(c(summary(la)$cov[1,1:(rs+1)],
                  summary(lb)$cov[1,-1]),piS.b0sr)
piS.b0sr<-as.matrix(piS.b0sr*n*n)

pim.b0s<-NULL ; piS.b0s<-NULL  ;pi.s2a<-NULL
                }
if(directed==F) { pim.b0sr<-NULL ; piS.b0sr<-NULL ; pi.Sab<-NULL
                  s<-(s+r)/2  ; r<-s*0
                  tmp2<-lm(s~-1+cbind( rep(.5,n),Xs))
                  beta.u<-tmp2$coef ; pi.s2a<-c(2,var(tmp2$res)) ;
                  pim.b0s<-tmp2$coef ; piS.b0s<-summary(tmp2)$cov*n*n }

###
list( priors=list(pi.Sab=pi.Sab,pi.s2u=pi.s2u,pi.s2v=pi.s2v,pi.s2z=pi.s2z,
                  pim.bd=pim.bd,piS.bd=piS.bd,
                  pim.b0sr=pim.b0sr,piS.b0sr=piS.b0sr,
                  pim.b0s=pim.b0s, piS.b0s=piS.b0s , pi.s2a=pi.s2a) ,
      startv=list(beta.d=beta.d,beta.u=beta.u,s=s,r=r,z=z)
     )
}

####
rbeta.d.s.gibbs<-function(u,su,piS.bd,mu,s2a){
iSa<-diag(rep(1/s2a,n))

if(dim(piS.bd)[1]>0){
cov.beta.s<-matrix(0,nrow=rd,ncol=n)
iS<-rbind(cbind(solve(piS.bd),cov.beta.s),
   cbind(t(cov.beta.s),iSa)) }
else{iS<-iSa}

Sig<-chol2inv( chol(iS + tXTuXTu/su ) )
    #this may have a closed form expression

theta<-Sig%*%( t(  (u%*%XTu)/su) + iS%*%mu)

beta.s<-rmvnorm(theta,Sig)
list(beta.d=beta.s[(rd>0):rd],s=beta.s[rd+1:n]) }
####

####
rbeta.s.gibbs<-function(s,X.u,pim.b0s,piS.b0s,s2a) {
iSa<-diag(rep(1/s2a,n))

S<-solve( solve(piS.b0s) + t(X.u)%*%iSa%*%X.u )
mu<-S%*%(  solve(piS.b0s)%*%pim.b0s+ t(X.u)%*%iSa%*%s)
rmvnorm( mu,S)
                                               }


model_snowwet <- function (Swet_t1 = 0.0,
         precip = 0.0,
         Snowaccu = 0.0,
         Mrf = 0.0,
         M = 0.0,
         Sdry = 0.0){
    #'- Name: SnowWet -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: water in liquid state in the snow cover calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: water in liquid state in the snow cover
    #'- inputs:
    #'            * name: Swet_t1
    #'                          ** description : water in liquid state in the snow cover in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: precip
    #'                          ** description : current precipitation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Snowaccu
    #'                          ** description :  snowfall accumulation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: Mrf
    #'                          ** description : liquid water in the snow cover in the process of refreezing
    #'                          ** inputtype : variable
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: M
    #'                          ** description : snow in the process of melting
    #'                          ** inputtype : variable
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: Sdry
    #'                          ** description : water in solid state in the snow cover
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'- outputs:
    #'            * name: Swet
    #'                          ** description : water in liquid state in the snow cover
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    Swet <- 0.0
    if (Mrf <= Swet_t1)
    {
        tmp_swet <- Swet_t1 + precip - Snowaccu + M - Mrf
        frac_sdry <- 0.1 * Sdry
        if (tmp_swet < frac_sdry)
        {
            Swet <- tmp_swet
        }
        else
        {
            Swet <- frac_sdry
        }
    }
    return (list('Swet' = Swet))
}


#' Patient similarity using mutual information MLE metric of patients' most modular, perturbed subsets.
#'
#' This function calculates the universal distance between patients, using a mutual information metric, where self-information comes from the minimum encoding length of each patient's encoded modular perturbations in the background knowledge graph.
#' @param p1.optBS - The optimal bitstring associated with patient 1.
#' @param ptID - The identifier associated with patient 1's sample.
#' @param p2.optBS - The optimal bitstring associated with patient 2.
#' @param ptID - The identifier associated with patient 2's sample.
#' @param data_mx - The matrix that gives the perturbation strength (z-scores) for all variables (columns) for each patient (rows).
#' @return patientSim - a similarity matrix, where row and columns are patient identifiers.
#' @export mle.getPtSim
#' @examples
#' # Get patient distances
#' data_mx.pvals = apply(data_mx, c(1,2), function(i) 2*pnorm(abs(i), lower.tail = FALSE))
#' res = list()
#' tt = list(ncd=matrix(NA, nrow=ncol(data_mx), ncol=ncol(data_mx)))
#' rownames(t$ncd) = colnames(data_mx)
#' colnames(t$ncd) = colnames(data_mx)
#' for (i in 1:kmx) {
#'   res[[i]] = tt
#' }
#' for (pt in 1:ncol(data_mx)) {
#'   print(pt)
#'   ptID = colnames(data_mx)[pt]
#'   for (pt2 in pt:ncol(data_mx)) {
#'     ptID2 = colnames(data_mx)[pt2]
#'     for (k in 1:kmx) {
#'       tmp = mle.getPtSim(ptBSbyK[[ptID]][k], ptID, ptBSbyK[[ptID2]][k], ptID2, data_mx, ranks)
#'       res[[k]]$ncd[ptID, ptID2] = tmp$NCD
#'       res[[k]]$ncd[ptID2, ptID] = tmp$NCD
#'     }
#'   }
#' }
mle.getPtSim = function(p1.optBS, ptID, p2.optBS, ptID2, data_mx, ranks) {
  if (length(p1.optBS) != length(p2.optBS)) {
    print("Make sure subset from patient1 is the same size as subset from patient2.")
    return(0)
  }

  G = vector(mode="list", length=nrow(data_mx))
  names(G) = rownames(data_mx)
  p1.e = mle.getEncodingLength(p1.optBS, NULL, ptID, G)[,"IS.alt"]
  p2.e = mle.getEncodingLength(p2.optBS, NULL, ptID2, G)[,"IS.alt"]

  # Get optimal bitstring for encoding of patient1's union patient2's subsets
  dirSim = vector("numeric", length=length(p1.optBS))
  for (k in 1:length(p1.optBS)) {
    p1.sig.nodes = rownames(data_mx)[order(abs(data_mx[, ptID]), decreasing = TRUE)][1:k]
    p2.sig.nodes = rownames(data_mx)[order(abs(data_mx[, ptID2]), decreasing = TRUE)][1:k]
    p1.dirs = data_mx[p1.sig.nodes, ptID]
    p1.dirs[which(!(p1.dirs>0))] = 0
    p1.dirs[which(p1.dirs>0)] = 1
    p2.dirs = data_mx[p2.sig.nodes, ptID2]
    p2.dirs[which(!(p2.dirs>0))] = 0
    p2.dirs[which(p2.dirs>0)] = 1
    p1.sig.nodes = sprintf("%s%d", p1.sig.nodes, p1.dirs)
    p2.sig.nodes = sprintf("%s%d", p2.sig.nodes, p2.dirs)
    dirSim[k] = 1 - (length(intersect(p1.sig.nodes, p2.sig.nodes))/length(union(p1.sig.nodes, p2.sig.nodes)))
  }

  if (is.null(ranks)) {
    # Using the single-node network walker, get optimal bitstring for encoding of patient1's union patient2's subsets
    p1.sig.nodes = sapply(names(sort(abs(data_mx[,ptID]), decreasing = TRUE)[1:length(p1.optBS)]), trimws)
    p2.sig.nodes = sapply(names(sort(abs(data_mx[,ptID2]), decreasing = TRUE)[1:length(p2.optBS)]), trimws)
    p12.sig.nodes = as.character(sapply(unique(c(p1.sig.nodes, p2.sig.nodes)), trimws))
    ranks = list()
    for (i in 1:length(p12.sig.nodes)) {
      ind = which(names(G)==p12.sig.nodes[i])
      ranks[[i]] = singleNode.getNodeRanksN(n=ind, G=G, S=p12.sig.nodes, num.misses=log2(length(G)))
    }
    p12.e = c()
    for (k in 1:length(p1.optBS)) {
      p1.sig.nodes_cpy = p1.sig.nodes
      p2.sig.nodes_cpy = p2.sig.nodes

      p1.sig.nodes_k = names(which(p1.optBS[[k]]==1))
      p2.sig.nodes_k = names(which(p2.optBS[[k]]==1))
      while (length(p1.sig.nodes_k)<k) {
        p1.sig.nodes_k = unique(c(p1.sig.nodes_k, p1.sig.nodes_cpy[1]))
        p1.sig.nodes_cpy = p1.sig.nodes_cpy[-1]
      }
      while (length(p2.sig.nodes_k)<k) {
        p2.sig.nodes_k = unique(c(p2.sig.nodes_k, p2.sig.nodes_cpy[1]))
        p2.sig.nodes_cpy = p2.sig.nodes_cpy[-1]
      }
      p12.sig.nodes_k = sapply(unique(c(p1.sig.nodes_k, p2.sig.nodes_k)), trimws)
      p12.optBS = singleNode.getPtBSbyK(p12.sig.nodes_k, ranks)
      res = mle.getEncodingLength(p12.optBS, NULL, NULL, G)
      p12.e[k] = res[which.max(res[,"d.score"]), "IS.alt"] + log2(choose(length(G), 1))*(length(p12.sig.nodes_k)-which.max(res[,"d.score"]))
    }
  } else {
    # Using predefined node ranks, get optimal bitstring for encoding of patient1's union patient2's subsets.
    p1.sig.nodes = names(sort(abs(data_mx[,ptID]), decreasing = TRUE)[1:length(p1.optBS)])
    p2.sig.nodes = names(sort(abs(data_mx[,ptID2]), decreasing = TRUE)[1:length(p2.optBS)])
    p12.sig.nodes = unique(c(p1.sig.nodes, p2.sig.nodes))

    p12.e = c()
    for (k in 1:length(p1.optBS)) {
      p1.sig.nodes_cpy = p1.sig.nodes
      p2.sig.nodes_cpy = p2.sig.nodes

      p1.sig.nodes_k = names(which(p1.optBS[[k]]==1))
      p2.sig.nodes_k = names(which(p2.optBS[[k]]==1))
      while (length(p1.sig.nodes_k)<k) {
        p1.sig.nodes_k = unique(c(p1.sig.nodes_k, p1.sig.nodes_cpy[1]))
        p1.sig.nodes_cpy = p1.sig.nodes_cpy[-1]
      }
      while (length(p2.sig.nodes_k)<k) {
        p2.sig.nodes_k = unique(c(p2.sig.nodes_k, p2.sig.nodes_cpy[1]))
        p2.sig.nodes_cpy = p2.sig.nodes_cpy[-1]
      }
      p12.sig.nodes_k = sapply(unique(c(p1.sig.nodes_k, p2.sig.nodes_k)), trimws)
      p12.optBS = singleNode.getPtBSbyK(p12.sig.nodes_k, ranks)
      res = mle.getEncodingLength(p12.optBS, NULL, NULL, G)
      p12.e[k] = res[which.max(res[,"d.score"]), "IS.alt"] + log2(choose(length(G), 1))*(length(p12.sig.nodes_k)-which.max(res[,"d.score"]))
    }
  }

  # Normalized Compression Distance, Percent Mutual Information, Jaccard Set Similarity (w/ Directionality)
  return (list(p1.e=p1.e, p2.e=p2.e, p12.e=p12.e,
               NCD=(p12.e-apply(cbind(p1.e, p2.e), 1, min))/apply(cbind(p1.e, p2.e), 1, max),
               mutualInfoPer=1-((p1.e+p2.e-p12.e)/p12.e),
               dirSim=dirSim))
}


#!/bin/Rscript
library("R.utils")
library("dplyr")
library("plyr")
library("ggplot2")
library("dplyr")
library("broom")
library("ggpubr")
library("Amelia")
library("mlbench")
library("corrplot")
library("neuralnet")

df <- read.csv("./data/weatherAUS.csv", header = TRUE, sep = ",", fill = TRUE)

n <- length(df[, 1])
index <- sample(1:n, n, replace = FALSE)
df <- df[index, ]

df[, "Date"] <- as.Date(df[, "Date"])
df[, "Location"] <- as.factor(df[, "Location"])
df[, "WindGustDir"] <- as.factor(df[, "WindGustDir"])
df[, "WindDir9am"] <- as.factor(df[, "WindDir9am"])
df[, "WindDir3pm"] <- as.factor(df[, "WindDir3pm"])
df[, "RainToday"] <- as.factor(df[, "RainToday"])
df[, "RainTomorrow"] <- as.factor(df [, "RainTomorrow"])
df["Cloud9am"][df["Cloud9am"] == 9] <- 8
df["Cloud3pm"][df["Cloud3pm"] == 9] <- 8

# # Deskriptive Analyse

parameters <- names(select_if(df, is.numeric))

parameters <- names(select_if(df, is.numeric))

dfmin <- subset(df, !is.na(df$RainToday) & !is.na(df$RainTomorrow))

for (x in parameters) {
  dfmin[x][is.na(dfmin[x])] <- mean(dfmin[, x], na.rm = TRUE)
}

levels(dfmin$WindGustDir) <- c(levels(dfmin$WindGustDir), "NOWIND")
levels(dfmin$WindDir9am) <- c(levels(dfmin$WindDir9am), "NOWIND")
levels(dfmin$WindDir3pm) <- c(levels(dfmin$WindDir3pm), "NOWIND")

dfmin$WindGustDir[is.na(dfmin[, "WindGustDir"])] <- "NOWIND"
dfmin$WindDir9am[is.na(dfmin[, "WindDir9am"])] <- "NOWIND"
dfmin$WindDir3pm[is.na(dfmin[, "WindDir3pm"])] <- "NOWIND"

set.seed(450)
cv_error <- NULL
k <- 2

pbar <- create_progress_bar("text")
pbar$init(k)
dfmin[] <- sapply(dfmin, as.numeric) # keeps in the format of dataframe.
maxs <- apply(dfmin, 2, max)
mins <- apply(dfmin, 2, min)
dfmin <- as.data.frame(scale(dfmin, center = mins, scale = maxs - mins))

x_train_formular <- as.formula(
                               RainTomorrow ~
                                 Date +
                                 Location +
                                 MinTemp +
                                 MaxTemp +
                                 Rainfall +
                                 Evaporation +
                                 Sunshine +
                                 WindGustDir +
                                 WindGustSpeed +
                                 WindDir9am +
                                 WindDir3pm +
                                 WindSpeed9am +
                                 WindSpeed3pm +
                                 Humidity9am +
                                 Humidity3pm +
                                 Pressure9am +
                                 Pressure3pm +
                                 Cloud9am +
                                 Cloud3pm +
                                 Temp9am +
                                 Temp3pm +
                                 RainToday
)

for (i in 1:k) {
  smp_size <- floor(0.85 * nrow(dfmin))
  set.seed(123)
  train_ind <- sample(seq_len(nrow(dfmin)), size = smp_size)
  train <- dfmin[train_ind, ]
  test <- dfmin[-train_ind, ]

  y_train <- train[, "RainTomorrow"]
  y_test <- test[, "RainTomorrow"]

  nn <- neuralnet(x_train_formular,
                  data = train,
                  hidden = c(60, 20, 5, 2),
                  rep = 100,
                  linear.output = FALSE,
                  learningrate = 0.05
  )
  file_name <- gsub(" ", "", paste("model_", i))
  saveRDS(nn, file_name)

  pr_nn <- compute(nn, test[, 1:23])
  results <- data.frame(
                        actual = test$RainTomorrow,
                        prediction = pr_nn$net.result
  )
  roundedresults <- sapply(results, round, digits = 0)
  print(roundedresults)
  roundedresultsdf <- data.frame(roundedresults)
  attach(roundedresultsdf)
  table(actual, prediction)
  print(mean(results == y_test))

  pr_nn <- pr_nn$net.result * (
                               max(dfmin$RainTomorrow) -
                                 min(dfmin$RainTomorrow)) +
                               min(dfmin$RainTomorrow)

                             test_r <- (test$RainTomorrow) *
                               (max(dfmin$RainTomorrow) -
                                min(dfmin$RainTomorrow)) +
                               min(dfmin$RainTomorrow)

                             cv_error[i] <- sum((test_r - pr_nn)^2) / nrow(test)

                             pbar$step()
}

mean(cv_error)
cv_error


library(ComplexHeatmap)
library(circlize)
library(cluster)
library(svglite)

setwd('D:/1998c/Documents/Research/202002scRNA/package_release/scETM/scripts/heatmap_fig/AD')
mat <- read.table('delta_sampled.csv', row.names = 1,sep=',',
                  header = TRUE, stringsAsFactors = FALSE,check.names=F)
mat<-t(mat)
metadata  <- read.table('meta_sampled.csv',sep=',', row.names = 1,
                        header = TRUE, stringsAsFactors = FALSE)
colorscheme = colorRamp2(c(min(mat) ,0, max(mat)), c("blue", "white", "red"))

ann <- data.frame(metadata$condition, metadata$cell_types, metadata$batch_indices)
colnames(ann) <- c('condition','cell_type','batch_id')

colours <- list(
  'condition' = c('0' = 'black', '1' = 'green'),
  'cell_type' = c('Ex'='red','Per'='grey',
                  'Ast' = 'blue','In' = 'purple',
                  'Opc' = 'pink', 'Mic' = 'yellow',
                  'Oli' = 'cyan', 'End' = 'limegreen'
  ))

colAnn <- HeatmapAnnotation(df = ann,
                            which = 'column',
                            annotation_width = unit(c(1, 2), 'cm'),
                            gap = unit(1, 'mm'),
                            col = colours)
hmap <- Heatmap(
  mat,
  col=colorscheme,
  column_title = "AD",
  name='Topic Intensity',
  column_dend_side = "bottom",
  column_dend_height = unit(10, "mm"),
  clustering_method_rows='average',
  show_row_names = TRUE,
  show_column_names = FALSE,
  cluster_rows = TRUE,
  cluster_columns = TRUE,
  show_column_dend = FALSE,
  show_row_dend = TRUE,
  row_dend_reorder = TRUE,
  column_dend_reorder = TRUE,
  clustering_method_columns = "average",
  row_names_gp = gpar(fontsize = 7),
  top_annotation=colAnn)

pdf(file = "panel_b_theta_sampled.pdf",width=8,height=6)
draw(hmap, heatmap_legend_side="left", annotation_legend_side="right")
dev.off()

svglite("panel_b_theta_sampled.svg",width=8,height=6)
draw(hmap, heatmap_legend_side="left", annotation_legend_side="right")
dev.off()

#extract order
row_order_hmap = row_order(hmap)
actual_topic_name = dimnames(hmap@matrix)[1]
mylist = list()
mylist[["order"]] = row_order_hmap
mylist[["topic"]] = actual_topic_name
write.table(as.data.frame(mylist),file="order.csv", quote=F,sep=",",row.names=F)


# INITIALIZATION

# number of hours in model run
size=500

t_lines = list('203')
methods = list('')

# MARS
# Linear regression
# Random forest
# kNN
# Support vector regression

input_file <- "Input.csv"
output_file <- "Output.csv"

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

# LIBRARIES
library(foreign)
library(lubridate)
library(caret)
library(Metrics)
library(ggplot2)
library(vip)
library(earth)
library(plyr)
library(openxlsx)

source("functions.R")
source("Preprocessing.R")

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

# PREPROCESSING
#Preprocessing()

set.seed(123)

# load configuration data from input file
input_data <- read_case_data(size, input_file)

# get input data and convert formats
covariates <- input_data$covariates
covariates[,-1] <- sapply(input_data$covariates[,-1], as.numeric)
lines <- input_data$lines
lines[,-1] <- sapply(input_data$lines[,-1], as.numeric)
#t_lines = input_data$t_lines
#methods = input_data$methods

# create empty dataframe
results <- data.frame(row.names = t_lines)

covariate_data <- read.csv("Data/Covariates.csv")

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

# PREPARE DATA AND RUN MODELS

for (line in c(t_lines)){

    #add lagged line if not included in covariates and delete NAs
    covariates_l <- covariates
    covariates_l <- merge(covariates_l, lines[,c("Time",line)] ,by="Time")
    if (!(paste(line, ".lag", sep="") %in% names(covariates_l))){
        covariates_l <- merge(covariates_l, lagged(lines[,c("Time",line)]), by="Time")
    }
    covariates_l <- na.omit(covariates_l)

    # select training and test data
    trainingRowIndex <- sample(1:nrow(covariates_l), 0.7*nrow(covariates_l))
    trainingData <- covariates_l[sample(trainingRowIndex, min(size, nrow(trainingRowIndex))), ]
    testData  <- covariates_l[-trainingRowIndex, ]

    # perform training and estimation
    for (method in methods){
        if (method == "MARS") {
            results[line, method] <- mars(line, trainingData, testData)

        } else if (method == "Linear regression") {
            results[line, method] <- lin_reg(line, trainingData, testData)

        } else if (method == "Random forest") {
            results[line, method] <- ran_forest(line, trainingData, testData)

        } else if (method == "Multiple linear regression") {
            print('Function is not implemented yet')

        } else if (method == "kNN") {
            results[line, method] <- kNN(line, trainingData, testData)

        } else if (method == "Support vector regression") {
            results[line, method] <- SVR(line, trainingData, testData)
        }
    }
}

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

# OUTPUT PROCESSING

input <- read.csv(input_file, fileEncoding="UTF-8-BOM")

write.xlsx(
      input,
      input_file,
      sheetName = 'Input',
      col.names = TRUE,
      row.names = TRUE,
      append = TRUE,
    )

for (method in methods){
    write.xlsx(
      results[method],
      output_file,
      sheetName = String(method),
      col.names = TRUE,
      row.names = TRUE,
      append = TRUE,
    )
}


dataFile <- read.csv('/Users/saugat/Downloads/2008.csv')

head(dataFile)

head(dataFile$Origin)

sum(dataFile$Origin == 'ORD')
sum(dataFile$Dest == 'ORD')
sum(dataFile$Origin == 'IND' & dataFile$Dest == 'ORD')

sum(dataFile$Origin == 'TUP' & dataFile$Year == 2008)

head(dataFile$Origin == 'TUP')

tup2008 <- subset(dataFile, dataFile$Origin == 'TUP' & dataFile$Year == 2008)
sum(tup2008$DepDelay)

sum(dataFile$Dest == 'LAX' & dataFile$Year == 2008)
atlToLax <- subset(dataFile, dataFile$Origin == 'ATL' & dataFile$Dest == 'LAX')

sum(atlToLax$DepTime < 1200, na.rm = TRUE)

brk = seq(0,2400,by=100)
hist(atlToLax$DepTime, brk, plot=TRUE)


rm(list=ls(all=TRUE)) #workspace cleanup
library(ggplot2); library(ggthemes)   #for visualization
library(mice)                         #for imputation
library(dplyr)                        #for data handling
library(glmx)                         #for running GLM model (logistic regression)
library(randomForest)                 #for random forest
library(evtree)                       #for classification trees
library(e1071)                        #for Naive bayesian model

setwd("") ##add the directory with the files inside the double quotes
train <- read.csv('train.csv',stringsAsFactors = F,na.strings=c(""))
test <- read.csv('test.csv',stringsAsFactors = F, na.strings=c(""))
head(train)
summary(train)

#calculating family size based on the number of children/parents aboard the ship
train$famsize <- train$SibSp+train$Parch+1
test$famsize <- test$SibSp+test$Parch+1

## families of 4 individuals seem to have the higest survival rate
## generally, families sized 2-4 have a higher survival rate than others
ggplot(train, aes(x = famsize, fill = factor(Survived))) +
  geom_bar(stat='count', position='fill') +
  scale_x_continuous(breaks=c(1:12)) +
  labs(x = 'family size', y = 'proportion')

#Females tend to have better chances at survival
ggplot(train, aes(x = Sex, fill = factor(Survived))) +
  geom_bar(position = 'fill') +
  labs(x = 'sex', y = 'proportion of survival')

#First class has better chances at survival
ggplot(train, aes(x = Pclass, fill = factor(Survived))) +
  geom_bar(position = 'fill') +
  labs(x = 'Passenger Class', y = 'proportion of survival')

#Breaking down the gender data by passenger class
#Class and gender combined give a better picture
#First and Second class females are highly likely to have survuved
ggplot(train, aes(x = Sex, fill = factor(Survived))) +
  geom_bar(position = 'fill') +
  labs(x = 'sex/class', y = 'proportion of survival') + facet_grid(~Pclass)

##Plotting survival rate with respect to age
# Younger people have better survival rates
df <- aggregate(formula=Survived~Age,
                data=train, FUN=function(x) { mean(x) })
ggplot(df,aes(x=Age, y=Survived)) +
  geom_smooth()

##Survival based on age and fare, broken down by gender and passenger class
#This chart indicates that classification tree could be a good techinque for
#the data set. Notice how there are few deaths in the top left and top middle
#chart. In the top right chart, we can see a cluster of deahts towards the
#higher age. In the bottom middle chart, the survivors are clustered towards
#lower age. In the bottom right chart, the survivors are clustered close to
#the origin. The bottom left chart is less straightforward.
ggplot(train, aes(x=Age,y=Fare, color=as.factor(Survived))) +
  geom_point(size=2) + facet_grid(Sex~Pclass)

##missing data
#lots of Age data is missing
cbind(sapply(train,function(x) sum(is.na(x))))
cbind(sapply(test,function(x) sum(is.na(x))))

##Combining the training and testing dataset
full <- bind_rows(train, test)
#263 rows with Age data missing, thats roughly 20% rows
#this being a small data set, we cannot just remove 20% of the rows
cbind(sapply(full,function(x) sum(is.na(x))))

#Finding the people with missing Embarked data
subset(full, is.na(full$Embarked))

#both have a fare of 80. This fits in well with other people who Embarked
#at C and were in 1st class
ggplot(full, aes(x = Embarked, y = Fare, fill = factor(Pclass))) +
  geom_boxplot() + geom_hline(aes(yintercept=80))

#It is a good guess to mark these two people as embarked from C
full$Embarked[c(62, 830)] <- 'C'

#Finding the individual with the missing Fare
subset(full, is.na(full$Fare))

#Its logical to think that tickets are similarly priced for a specific class
# at a specific port. So we filter the data which has the same class and
# port as the individual with the missing fare
temp1 <- full[(full$Embarked == 'S' & full$Pclass == 3),]

#We see thatthe average Fare from port S and class 3 is 7.854.
summary(temp1)
ggplot(temp1, aes(x=Fare)) +
  geom_density(fill='red', alpha = 0.3) +
  geom_vline(aes(xintercept=7.854))
full$Fare[1044] <- 7.854

set.seed(176)
mice <- mice(full[, !names(full) %in% c('PassengerId','Name','Ticket',
                                            'Cabin','Survived')], method='rf')

full_imp <- complete(mice)
cbind(sapply(full_imp,function(x) sum(is.na(x))))

ggplot() +
  geom_density(data = full, aes(x = Age), color= NA , fill='darkred', alpha = 0.4 ) +
  geom_density(data = full_imp, aes(x=Age), color='darkred', fill='darkred', alpha = 0.0 ) +
  labs(x = 'age', y = 'frequency')

summary(full$Age)
summary(full_imp$Age)

full$Age <- full_imp$Age
cbind(sapply(full,function(x) sum(is.na(x))))

train2 <- full[1:891,]
test2 <- full[892:1309,]

# temp2 <- c('Survived','Pclass','Sex','Embarked')
# train2[temp2] <- sapply(train2[temp2],function(x) as.factor(x))
# test2[temp2] <- sapply(test2[temp2],function(x) as.factor(x))
#code not working as i intended it to

head(train2)

train2$Survived <- as.factor(train2$Survived)
train2$Pclass <- as.factor(train2$Pclass)
train2$Sex <- as.factor(train2$Sex)
train2$Embarked <- as.factor(train2$Embarked)

test2$Survived <- as.factor(test2$Survived)
test2$Pclass <- as.factor(test2$Pclass)
test2$Sex <- as.factor(test2$Sex)
test2$Embarked <- as.factor(test2$Embarked)

formula <- Survived ~ Pclass + Sex + Age + SibSp + Parch +
  Fare + Embarked + famsize

##Classification tree visualization
set.seed(176)
model1 <- evtree(formula, data=train2)
model1
plot(model1)
#classification error
acc1 <- 1 - mean(predict(model1) == train2$Survived)

##Logit regression
model2 <- glm(formula, data=train2, family=binomial(link="logit"))
summary(model2)
#classification error
acc2 <- 1 - mean(round(predict(model2, type="response")) == train2$Survived)  #classification error

##Random Forest
set.seed(176)
model3 <- randomForest(formula, data = train2)
#classification error
acc3 <- 1 - mean(predict(model3) == train2$Survived)
plot(model3, ylim=c(0,0.36))
legend('topright', colnames(model3$err.rate), col=1:3, fill=1:3)

##Naive Bayesian method
model4 <- naiveBayes(formula, data = train2)
acc4 <- 1 - mean(predict(model4, train2, type="class") == train2$Survived)  #classification error

##Comparing model training accuracy (lower is better)
acc <- data.frame(cbind(c("Classification Tree","Logistic Regression",
                          "Random Forest","Naive Bayesian"),
                        c(acc1,acc2,acc3,acc4)*100))
colnames(acc) <- c("Method","Classification error %")
acc

## Predicting survival on test data using random forest
# I am using random forest and not classification tree because
# classification trees can overfit the dataset. Random forest are less
# likely to overfit.
predict(model3, test2)

#Making a data frame from the predictions and writing as csv
solution <- data.frame(PassengerID = test$PassengerId, Survived = predict(model3, test2))
write.csv(solution, file = 'submission.csv', row.names = F)


train <- read.csv(file = 'train.csv')
test <- read.csv(file = 'test.csv')

head(train)
str(train)
summary(train)

head(test)
str(test)
summary(test)

#plots
plot(train$satisfaction ~ train$Flight.Distance)
plot(train$satisfaction ~ train$Baggage.handling)
plot(train$satisfaction ~ train$Inflight.service)
plot(train$satisfaction ~ train$Inflight.entertainment)
plot(train$satisfaction ~ train$Food.and.drink)
plot(train$satisfaction ~ train$Type.of.Travel)
plot(train$satisfaction ~ train$On.board.service)
plot(train$satisfaction ~ train$Seat.comfort)
plot(train$satisfaction ~ train$Cleanliness)

#boxplots
boxplot(train$Flight.Distance)
boxplot(train$On.board.service)
boxplot(train$Seat.comfort)
boxplot(train$Cleanliness)
boxplot(train$Inflight.service)
boxplot(train$Inflight.entertainment)
boxplot(train$Food.and.drink)
boxplot(train$Baggage.handling)


library(ggplot2)

x=read.table('axiomSolved.dat',header=TRUE,sep=";",as.is=TRUE)
colnames(x) <- c("inv","ax","solved")
top =as.data.frame(
	Reduce(
		rbind,
		lapply(
			unique(x$inv),
			function(i)
				cbind(
					seq(1,60),
					rep(i,60),
					#Normalizamos por la suma de la columna.
					as.double(x[x$inv==i,]$solved/sum(x[x$inv == i,]$solved))
				)
		)
	)
)

colnames(top) <- c("ax","inv","val")
#norms = Reduce(rbind,sapply(unique(x$inv),function(i) rep(as.double(sum(x[x$inv ==i,]$solved)),60)))
#x$norms=x$solved/norms

norms = unique(sapply(unique(x$inv),function(i) rbind(rep(as.double(sum(x[x$inv == i,]$solved)),60))))

toplot = as.data.frame(Reduce(rbind,lapply(seq(1,360),function(i) cbind(x[i,]$inv,x[i,]$ax,as.double(x[i,]$solved/norms[colnames(norms) == x[i,]$inv])))))
toplot$norms=as.double(as.character(toplot$V3))
colnames(toplot) <- c("inv","ax","V3","norms")
toplot$ax = as.double(as.character(toplot$ax))
top$inv = factor(top$inv)
#ggplot(top,aes(x=factor(ax),y=val,fill=factor(inv))) + geom_bar(stat="identity")
#ggplot(x,aes(x=ax,y=norms,fill=inv)) + geom_bar(stat = "identity") + xlab("Number of axioms") + ylab("Number of problems solved")
ggplot(toplot,aes(x=ax,y=norms,fill=inv)) + geom_bar(stat = "identity") + xlab("Number of axioms") + ylab("Number of problems solved")

ggsave('ei.png')


# ************************************************
### simon munzert
### introduction to R
# ************************************************

source("packages.r")
source("functions.r")

# ************************************************
# WHAT'S R? --------------------------------------

# - software environment for numeric and visual data analysis
# - statistical programming language based on S
# - open source
# - works on all main platforms (Windows, macOS, Linux)
# - under continuous development
# - masses of addons ('packages') available, ~4-8 new ones every day (currently more than 10,000 on CRAN)

# ************************************************
# WORKING WITH RSTUDIO ---------------------------

### a first view
# - point-and-click menu
# - many windows, many buttons

### console input

# - R is ready when the console offers '>'
# - input is incomplete if R answers with '+' (you are likely to have forgotten a ')' or ']')
1 + 2 - 3 +

# - R is 'case sensitve'
sum(1,2)
Sum(1,2)

# - the assignment operator '<-' stores something in the workspace. You can call this something again later. We can also  use '=' instead, but it is less common among R users and I do not recommend it
x <- log(10)
x

# - R uses English vocabulary, therefore we have to follow the English default in using commas and dots:
3.1415
3,1415

# - commas are very important when it comes to matrices and data frames: they separate row from column values
mat <- matrix(c("this", "is", "a", "matrix"), nrow = 2, byrow = TRUE)
mat[1,2]
mat[1,]
mat[,1]

# - we use # to comment in the code
# - the RStudio editor provides auto completion (use 'TAB')
# - very useful: recycle previous commands by using the arrow keys (up/down) in the console

### list of helpful shortcuts (replace CTRL with Command on a Mac)
# CTRL+1         point cursor in editor
# CTRL+2         point cursor in console
# ESC            interrupt R
# CTRL+F         search and replace
# CTRL+SHIFT+C   comment code (and undo commenting)
# CTRL+ENTER     execute code
# CTRL+S         save document

# ************************************************
# IMPORTING PACKAGES -----------------------------

# - in contrast to Stata, base R has a rather limited functionality
# - when we start R, we usually have to load a bunch of packages for our analysis

# overview of packages:
browseURL("http://cran.r-project.org/web/packages/")

# - packages are installed once (usually after downloading them from CRAN)
# - installing packages in RStudio is straightforward
# - updating packages is straightforward, too
# - we can also use the console to install packages
install.packages("readr")

# packages are loaded for every session
library(readr)

# how to get more info about package?
# - browse CRAN online!
browseURL("https://cran.rstudio.com/web/packages/readr/index.html")
# - inspect reference manual (often overly technical) or vignette (if available)

# how to learn about individual functions?
?read_csv

# ************************************************
# IMPORTING AND EXPORTING DATA -------------------

# importing rectangular spreadsheet data
library(readr)

# import and export comma-delimited files
wage1 <- read_csv("../data/wage1.csv")
names(wage1)
View(wage1)
write_csv(wage1, "../data/wage1-comma.csv")

# import and export semi-colon delimited files (Germans!)
write_delim(wage1, delim = ";", path = "../data/wage1-semicolon.csv")
wage1 <- read_csv2("../data/wage1-semicolon.csv")

# importing Stata files
library(haven)
wage1 <- read_dta("../data/wage1.dta")
head(wage1)

# ************************************************
# INSPECTING DATA --------------------------------

# what's the data about? (works for packaged data frames only)
?wage1

# summarize variables
summary(wage1)
summary(wage1$wage)

# simple histogram
hist(wage1$wage)

# simple bar chart
plot(as.factor(wage1$educ))

# simple scatterplot
plot(wage1$educ, wage1$wage)

# add smoothing spline
smoothingSpline = smooth.spline(wage1$educ, wage1$wage, spar = 0.3)
lines(smoothingSpline, col = "red")

# multidimensional inspection
plot(wage1[,1:5])

# linear regression
model_out <- lm(wage ~ educ + female, data = wage1)
summary(model_out)

# ************************************************
# MANIPULATING DATA FRAMES -----------------------

library(dplyr)

# dplyr provides an intuitive grammar of data manipulation
# - identifies the most important data manipulation tasks
# - ...and makes them easy to use from R
# - important dplyr verbs:
    # select()    select columns
    # filter()    filter rows
    # arrange()   re-order or arrange rows
    # mutate()    create new columns
    # summarise() summarise values
    # group_by()  allows for group operations

### let's try it out with an interesting dataset!
library(nycflights13)
?flights
head(flights)
nrow(flights)
table(flights$origin)

# filter observations
flights_sub <- filter(flights, distance < 100)
table(flights_sub$dest)

flights_sub <- filter(flights, month == 1, day == 1, air_time > 60*7)
table(flights_sub$dest)

# arrange rows (= sort by variable values)
flights_sub <- arrange(flights, air_time, distance)
View(flights_sub)

flights_sub <- arrange(flights, desc(air_time), distance)
View(flights_sub)

# select variables
flights_sub <-  select(flights, year, month, day)
head(flights_sub)

names(flights)
flights_sub <-  select(flights, -(dep_delay:time_hour))
head(flights_sub)

flights_sub <-select(flights, contains("time"))
head(flights_sub)

?select_helpers

# rename variables
flights_sub <- rename(flights, tail_num = tailnum)
names(flights_sub)

# create variables (add new columns)
flights_sub <- mutate(flights, gain = arr_delay - dep_delay,
                               speed = distance / air_time * 60)

# group observations
  # - verbs above are useful on their own, but...
  # - can be applied to groups of observations within a dataset
  # - group_by() helps you break down your dataset into specified groups of rows
  # - afterwards, applying verbs from above on the grouped object, they'll be automatically applied by group

flights_by_origin <- group_by(flights, origin)
class(flights_by_origin)

summarize(flights_by_origin, n_deps = n())
summarize(flights_by_origin, dep_delay = mean(dep_delay, na.rm = TRUE))

# here's a useful cheatsheet that points to other useful dplyr functions:
browseURL("hhttps://www.rstudio.com/wp-content/uploads/2015/02/data-wrangling-cheatsheet.pdf")

# **************************
# EXERCISE -----------------

# Use the "nycflights13" package to answer the following questions!

# 1. How many flights started from all the NYC airports in 2013?
# 2. How many flights started from NYC airports in 2013, by month?
# 3. Which were the most frequent destinations?
# 4. Which flights went from JFK to PWM (Portland) in January between midnight and 5am?
# 5. Which carrier had the biggest mean net delay (departure delay minus arrival delay), which the lowest?
# 6. Inspect visually how the net delays are distributed!
# 7. How are distance and net delay related?


resR1R22 <- read.csv(file="reasonsR1R2-2.csv", header = TRUE)
resR2R32 <- read.csv(file="reasonsR2R3-2.csv", header = TRUE)
resR1R32 <- read.csv(file="reasonsR1R3-2.csv", header = TRUE)

json3.R1R2 <- read.csv(file="json_pilot_reason_3_r1r2.csv", header = TRUE)
json3.R2R3 <- read.csv(file="json_pilot_reason_3_r2r3.csv", header = TRUE)
json3.R1R3 <- read.csv(file="json_pilot_reason_3_r1r3.csv", header = TRUE)

django3.R1R2 <- read.csv(file="django_pilot_reason_3_r1r2.csv", header = TRUE)
django3.R2R3 <- read.csv(file="django_pilot_reason_3_r2r3.csv", header = TRUE)
django3.R1R3 <- read.csv(file="django_pilot_reason_3_r1r3.csv", header = TRUE)

regex3.R1R2 <- read.csv(file="regex_pilot_reason_3_r1r2.csv", header = TRUE)
regex3.R2R3 <- read.csv(file="regex_pilot_reason_3_r2r3.csv", header = TRUE)
regex3.R1R3 <- read.csv(file="regex_pilot_reason_3_r1r3.csv", header = TRUE)

library(irr)

kappam.fleiss(json3.R1R2[c("Rater1", "Rater2")])
kappam.fleiss(json3.R2R3[c("Rater2", "Rater3")])
kappam.fleiss(json3.R1R3[c("Rater1", "Rater3")])

kappam.fleiss(django3.R1R2[c("Rater1", "Rater2")])
kappam.fleiss(django3.R2R3[c("Rater2", "Rater3")])
kappam.fleiss(django3.R1R3[c("Rater1", "Rater3")])

kappam.fleiss(regex3.R1R2[c("Rater1", "Rater2")])
kappam.fleiss(regex3.R2R3[c("Rater2", "Rater3")])
kappam.fleiss(regex3.R1R3[c("Rater1", "Rater3")])

# overall between raters
pilot.R1R2 <- rbind(json3.R1R2, django3.R1R2, regex3.R1R2)
kappam.fleiss(pilot.R1R2[c("Rater1", "Rater2")])

pilot.R2R3 <- rbind(json3.R2R3, django3.R2R3, regex3.R2R3)
kappam.fleiss(pilot.R2R3[c("Rater2", "Rater3")])

pilot.R1R3 <- rbind(json3.R1R3, django3.R1R3, regex3.R1R3)
kappam.fleiss(pilot.R1R3[c("Rater1", "Rater3")])

# adding round V with round VI data
pilot.R1R2 <- rbind(json3.R1R2, django3.R1R2, regex3.R1R2, resR1R22)
kappam.fleiss(pilot.R1R2[c("Rater1", "Rater2")])

pilot.R2R3 <- rbind(json3.R2R3, django3.R2R3, regex3.R2R3, resR2R32)
kappam.fleiss(pilot.R2R3[c("Rater2", "Rater3")])

pilot.R1R3 <- rbind(json3.R1R3, django3.R1R3, regex3.R1R3, resR1R32)
kappam.fleiss(pilot.R1R3[c("Rater1", "Rater3")])


#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：voltage_ov , onset voltge 启动电压与三种液体之间随流量、极间距离、针头直径变化的影响

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

#读取v~h的数据
de_h<-read.xlsx("voltage.xls",sheetName="ethanol_d", header=TRUE)
da_h<-read.xlsx("voltage.xls",sheetName="acetone_d", header=TRUE)
di_h<-read.xlsx("voltage.xls",sheetName="iso_d", header=TRUE)

#保存pdf
pdf("distance_3liquids_ov.pdf")
#画图-乙醇

plot(de_h$distance, de_h$OV,  col=0, xaxs="i", xlim=c(0, 4.2), ylim=c(1, 3),
xlab="Distance (mm)", mgp=c(1, 0, 0),
tck=0.02,cex.lab=1.1, ylab=expression(V["os"](kv)))

title(main="Onset Voltage changes with distance",line=0.5,cex.main=1.1)

model_hov <- loess(de_h$OV ~ de_h$distance)
fit <- fitted(model_hov)
ord <- order(de_h$distance)

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

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

model_aov <- loess(da_h$OV ~ da_h$distance)
fit <- fitted(model_aov)
ord <- order(da_h$distance)

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

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

model_iov <- loess(di_h$OV ~ di_h$distance)
fit <- fitted(model_iov)
ord <- order(di_h$distance)

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

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

dev.off()


REBOL [
	System: "REBOL [R3] Language Interpreter and Run-time Environment"
	Title: "Infix operator symbol definitions"
	Rights: {
		Copyright 2012 REBOL Technologies
		REBOL is a trademark of REBOL Technologies
	}
	License: {
		Licensed under the Apache License, Version 2.0.
		See: http://www.apache.org/licenses/LICENSE-2.0
	}
	Purpose: {
		This table maps infix operator symbols to function names.
	}
]

+  add
-  subtract
*  multiply
/  divide
// remainder
** power
=  equal?
=? same?
== strict-equal?
!= not-equal?
<> not-equal?
!== strict-not-equal?
<  lesser?
<= lesser-or-equal?
>  greater?
>= greater-or-equal?
& and~
|  or~
and and~
or  or~
xor xor~


#H2O-R script for Bay Area UseR group's meetup
#Demoing data munging and model building

#Clear R 's var environment
rm(list=ls())

# Detach and remove old H2O package if it exists
if ("package:h2o" %in% search()) { detach("package:h2o", unload=TRUE) }
if ("h2o" %in% rownames(installed.packages())) { remove.packages("h2o") }

# Install H2O from online repository
install.packages("h2o", repos=(c("http://h2o-release.s3.amazonaws.com/h2o/rel-kahan/5/R", getOption("repos"))))

# Load H2O library
library(h2o)

# Start H2O with default or specified IP and port
myIP = '127.0.0.1'
myPort =  54321
local.h2o <- h2o.init(ip = myIP, port = myPort,Xmx="12g")

#Parsing data to H2O
system.time(air<-h2o.uploadFile.FV(local.h2o,"/Users/nidhimehta/Desktop/airlines.1987.2013.10p.csv.zip",key="air"))
dim(air)
colnames(air)
summary(air)

#Removing Columns from data frame
air_trim = h2o.assign(air[,setdiff(colnames(air), c("IsArrDelayed", "IsDepDelayed"))], key = "air_trim")
#air_trim <- h2o.assign(air[,-c(30,31)],key = "air_trim")
colnames(air_trim)
dim(air_trim)

#Range
range(air_trim$DepDelay)
range(air_trim$ArrDelay)

#Quantile
air.DepQs <- quantile(air_trim$DepDelay, prob = seq(0,1,.1), na.rm = T)
print(air.DepQs)
air.ArrQs <- quantile(air_trim$ArrDelay, prob = seq(0,1,.1), na.rm = T)
print(air.ArrQs)

#Cut
as.data.frame(h2o.table(h2o.cut(air_trim$DepDelay, breaks=c(-1000, -60, -15, 15, 60, 120, 180, 1500))))
as.data.frame(h2o.table(h2o.cut(air_trim$ArrDelay, breaks=c(-1000, -60, -15, 15, 60, 120, 180, 1500))))

#Outlier Removal
#outliers.indx = air$ArrDelay <= air.ArrQs[2] | air$ArrDelay >= air.ArrQs[10]
#arrdelay.outliers = h2o.assign(air[!outliers.indx,], "arrdelay.outliers")

#Adding columns to a Data frame
air_trim$IsDepDelayed <- ifelse(!is.na(air_trim$DepDelay) & air_trim$DepDelay > 15 , 1, 0)
air_trim$IsArrDelayed <- ifelse(!is.na(air_trim$ArrDelay) & air_trim$ArrDelay > 15 , 1, 0)

summary(air_trim)

# To Factor
air_trim$IsArrDelayed <- as.factor(air_trim$IsArrDelayed)
air_trim$IsDepDelayed <- as.factor(air_trim$IsDepDelayed)
str(air_trim)

#Freeing some memory
h2o.ls(local.h2o)
keys_to_remove = grep("Last\\.value\\.", x=h2o.ls(local.h2o)$Key, value=TRUE)
keys_to_remove
h2o.rm(local.h2o, keys_to_remove)
h2o.ls(local.h2o)

#Ddply
# Mean Departure delay by day of week
fun2 = function(df) { mean(df$DepDelay)}
h2o.addFunction(local.h2o, fun2)
res = h2o.ddply(air, "DayOfWeek", fun2)
colnames(res) = c("DayOfWeek", "Avg_DepDelay")
as.data.frame(res)    # Convert H2O dataset to R data frame

# Avg distance betwwen airports
#fun = function(df) { mean<- mean(df$Distance);sd <-sd(df$Distance) }
fun = function(df) { cbind( mean(df$Distance),sd(df$Distance), length(df$Distance) ) }
h2o.addFunction(local.h2o, fun)
system.time(res <- h2o.ddply(air, c("Origin","Dest"), fun))
avg_dis = as.data.frame(res)
head(avg_dis)
colnames(avg_dis) = c("Origin", "Dest", "Avg_Distance", "sd", "count")
cbind(avg_dis[order(avg_dis$Avg_Distance, decreasing = F)[1:10],], avg_dis[order(avg_dis$Avg_Distance, decreasing = T)[1:10],])

#How many departure delay records are misssing (i.e NA) per year
fun3 = function(df) { sum(is.na(df$DepDelay))}
h2o.addFunction(local.h2o, fun3)
res = h2o.ddply(air, "Year", fun3)
result = as.data.frame(res)    # Convert H2O dataset
colnames(result) = c("YEAR", "Count_of_NAs")
cbind(result[order(result$Count_of_NAs, decreasing = F)[1:10],], result[order(result$Count_of_NAs, decreasing = T)[1:10],])

#Some Modeling

#Spliting Dataset into Train and validation sets
system.time(s <- h2o.runif(air))    # Useful when number of rows too large for R to handle
air.train = h2o.assign(air[s <= 0.8,], key = "air.train" )
air.valid = h2o.assign(air[s > 0.8,], key = "air.valid" )
colnames(air.train)

#Parsing test file
system.time(air.test<-h2o.uploadFile.FV(local.h2o,"/Users/nidhimehta/Desktop/airlines.1987.2013.05p.csv.zip",key="air.test"))
dim(air.test)

myX = c("Origin", "Dest", "Distance", "UniqueCarrier", "Month", "DayofMonth", "DayOfWeek", "Year" )
myY="IsDepDelayed"

# Run GBM on training and validation set
air.gbm = h2o.gbm(x = myX, y = myY, distribution = "multinomial", data = air.train, n.trees = 5,n.minobsinnode=1,
                  interaction.depth = 2, shrinkage = 0.01, n.bins = 20, validation = air.valid, importance = T)
air.gbm

# Run RF on training and validation set
air.rf=h2o.randomForest.FV(x=myX,y=myY,data=air.train,ntree=5,
                           depth=20,seed=12,importance=T,validation=air.valid)
air.rf
air.rf@model
barplot(as.matrix(air.rf@model$varimp[1,]))
air.rf@model$auc

model_object=air.rf #air.gbm , air.glm

#predicting on test file
pred = h2o.predict(model_object,air.test)
head(pred)

#Building confusion matrix
CM=h2o.confusionMatrix(pred$predict,air.test$IsDepDelayed)
print(CM)
dim(air.test)

#Plot ROC for test set
perf = h2o.performance(pred$YES,air.test$IsDepDelayed )
print(perf)
perf@model$precision
perf@model$accuracy
perf@model$auc
plot(perf,type="roc")

h2o.shutdown(local.h2o)

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

#MultiNode demo
rm(list=ls())

myIP = "192.168.1.163"
myPort =  54545
remote.h2o = h2o.init(ip = myIP, port = myPort)
#remote.h2o = h2o.init()

system.time(air <- h2o.importFile(remote.h2o,"/home/0xdiag/datasets/airlines/airlines_all.csv",key = "air"))
dim(air)
colnames(air)
summary(air)

myX = c("Origin", "Dest", "Distance", "UniqueCarrier", "Month", "DayofMonth", "DayOfWeek", "Year" )
myY="IsDepDelayed"

air.glm = h2o.glm.FV(x=myX, y=myY, data=air, family="binomial", nfolds=0,standardize=T)
air.glm
model_object=air.glm

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


# set working directory
setwd("~/data622-group4/hw3")

# load packages
packages <- c(
    'tidyverse',
    'corrplot',
    'palmerpenguins',
    'class',
    'kableExtra',
    'naniar',
    'DataExplorer',
    'caret',
    'tidymodels',
    'rsample',
    'themis',
    'randomForest',
    # 'htmlTable',
    # 'gmodels',
    # 'car',
    # 'mice',
    # 'tidyselect',
    # 'skimr',
    # 'tidymodels',
    'broom'
    # 'dotwhisker',
    # 'vip',
    # 'parsnip',
    # 'workflows',
    # 'recipes',
    # 'tune',
    # 'yardstick'
)

for (pkg in packages) {
    suppressPackageStartupMessages(suppressWarnings(
        library(
            pkg, character.only = TRUE,
            warn.conflicts = FALSE, quietly = TRUE)
    ))
}

# load rds into session
rds_files = c(paste0("output/", list.files("output")),
              paste0("data/", list.files("data"))) %>%
    grep(pattern = ".rds$", ., ignore.case = TRUE, value = TRUE)

var_names = gsub(pattern = "(output/|data/|.[Rr]ds)", replacement = "", x = rds_files) %>%
    gsub(pattern = "-", replacement = "_", .)

sapply(1:length(rds_files), function(x) assign(var_names[x], readRDS(rds_files[x]), envir = .GlobalEnv)) %>% invisible()

#########################################
### look at prediction result

# reorder level
loans_test_target <- relevel(loans_test$Loan_Status, ref = "Y")

# decision tree
dt_testing_predictions = relevel(dt_testing_Predictions$.pred_class, ref = "Y")
dt_confusionMatrix = caret::confusionMatrix(dt_testing_predictions, loans_test_target)
dt_confusionMatrix

# random forest
rf_mod2_predictions = relevel(rf_mod2_predictions, ref = "Y")
rf_confusionMatrix = caret::confusionMatrix(rf_mod2_predictions, loans_test_target)
rf_confusionMatrix

# xgb boost
xgb_pred = ifelse(xgb_final_predictions > .5, 'Y', 'N') %>%
    factor(., levels = c("Y", "N"), labels = c("Y", "N"))
xgb_confusionMatrix = caret::confusionMatrix(xgb_pred, loans_test_target)
xgb_confusionMatrix

# tidy output
dt_stat = broom::tidy(dt_confusionMatrix)
rf_stat = broom::tidy(rf_confusionMatrix)
xgb_stat = broom::tidy(xgb_confusionMatrix)

model_stat_tidy = dplyr::inner_join(dt_stat %>% dplyr::select(term, `decision tree` = estimate),
                                    rf_stat %>% dplyr::select(term, `random forest` = estimate),
                                    by = "term") %>%
    dplyr::inner_join(., xgb_stat %>% dplyr::select(term, `gradient boosting` = estimate),
                      by = "term")

model_stat_tidy %>% dplyr::filter(term != "mcnemar")


#' Fast fitting of Bayesian occupancy models
#'
#' The package implements the methods to fit Bayesian occupancy models as
#' described in Diana et al. (2021). The model performs estimate of temporal and
#' spatial trends in the occupancy probability and can incorporate covariates.
#' The inference is performed using the  Polya-Gamma scheme for efficient inference.
#'
#' @details
#'
#' Example of the use of the package can be found in the vignette.
#'
#' @references Diana A., Dennis E., Matechou E. and B.J.T. Morgan.
#' Fast Bayesian inference for large occupancy datasets, using the Polya-Gamma scheme
#'
#' @useDynLib FastOccupancy
#' @importFrom Rcpp sourceCpp
#'
#' @examples
#' modelResults <- runModel(sampleData,
#'                          index_year = 1,
#'                          index_site = 2,
#'                          index_occ = 8,
#'                          index_spatial_x = 3,
#'                          index_spatial_y = 4,
#'                          covariates_psi_text = "5",
#'                          covariates_p_text = "6-7",
#'                          usingSpatial = TRUE,
#'                          gridStep = .2,
#'                          nchain = 1,
#'                          nburn = 100,
#'                          niter = 100)
#'
#' plotOccupancyIndex(modelResults)
#'
#' @docType package
#' @name FastOccupancy
NULL
#> NULL