## ----load packages ----------------------------------------------------------
library(tidyverse)
library(lubridate)
library(GGally)
# remotes::install_github("ggobi/tourr")
library(tourr)
library(broom)
library(plotly)

## ----scatterplot matrix, echo=TRUE, fig.width=6, fig.height=6------------
# Make a simple scatterplot matrix of a classic data set
data(flea)
ggscatmat(flea, columns = 1:6)

## ----scatterplot matrix with colour, echo=TRUE, fig.width=8, fig.height=8----
# Re-make mapping colour to species (class)
data(flea)
ggscatmat(flea, columns = 1:6, color = "species") +
  theme(legend.position="bottom")

## ----PISA data wrangling-------------------------------------------------
# Matrix plot when variables are not numeric
data(australia_PISA2012)
australia_PISA2012 <- australia_PISA2012 %>%
  mutate(desk = factor(desk),
         room = factor(room),
         study = factor(study),
         computer = factor(computer),
         software = factor(software),
         internet = factor(internet),
         literature = factor(literature),
         poetry= factor(poetry),
         art = factor(art),
         textbook = factor(textbook),
         dictionary = factor(dictionary),
         dishwasher = factor(dishwasher))

## ----generalised pairs plot, echo=TRUE, fig.width=6, fig.height=6--------
australia_PISA2012 %>%
  filter(!is.na(dishwasher)) %>%
  ggpairs(columns=c(3, 15, 16, 21, 26))

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

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

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

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

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

## ----compute statistics on tb mortality trends---------------------------
# A more complex example of using the scatterplot matrix to explore
# a large collection of time series. Compute statistics for each time
# series, which might be called tignostics, and plot these. Explore
# the scatterplot matrix for anomalies and clusters.
load(here::here("data/tb_burden.rda"))
# Fit a model for each country, and extract statistics
tb_reg1 <- tb_burden %>%
  group_by(country) %>%
  nest() %>%
  mutate(model = purrr::map(data, ~lm(e_mort_exc_tbhiv_100k ~ year, data = .x) %>%
                       tidy)) %>%
  unnest(model) %>%
  select(country, term, estimate) %>%
  spread(term, estimate) %>%
  rename(intercept = `(Intercept)`, slope=year)
tb_reg2 <- tb_burden %>%
  group_by(country) %>%
  nest() %>%
  mutate(model = purrr::map(data, ~lm(e_mort_exc_tbhiv_100k ~ year, data = .x) %>%
                       glance)) %>%
  unnest(model) %>%
  select(country, r.squared, sigma, BIC, deviance)
tb_reg <- left_join(tb_reg1, tb_reg2)
# Drop the 0 deviance, 0 sigma countries
tb_reg <- tb_reg %>% filter(sigma > 0, BIC > -400)

## ----explore tb mortality trends, echo=TRUE, fig.width=6, fig.height=6----
ggscatmat(tb_reg, columns=3:7)

## ----wranglw data to show labels interactively, echo=TRUE----------------
# Add interaction to find the id's for countries that are anomalies
tb_reg_m <- as.data.frame(tb_reg[,3:7])
rownames(tb_reg_m) <- tb_reg$country

## ----explore tb mortality trends interactively, echo=TRUE, fig.width=8, fig.height=7----
tb_reg_m %>% ggpairs() %>% ggplotly()

## ----plot the countries that have decreasing mortality trend, echo=TRUE, fig.width=7, fig.height=4----
# Use a dotplot with model overlaid, to better match analysis conducted
declining <- tb_reg %>% filter(slope < -3.5)
tb_burden %>% filter(country %in% declining$country) %>%
  ggplot(aes(x=year, y=e_mort_exc_tbhiv_100k)) +
    geom_point() +
    geom_smooth(method="lm", se=F) +
  facet_wrap(~country, scales = "free_y")

## ----explore tb mortality trends problem countries, echo=TRUE,  fig.width=7, fig.height=3----
increasing <- tb_reg %>% filter(slope > 1, r.squared > 0.5)
tb_burden %>% filter(country %in% increasing$country) %>%
  ggplot(aes(x=year, y=e_mort_exc_tbhiv_100k)) +
    geom_point() +
    geom_smooth(method="lm", se=F) +
  facet_wrap(~country, scales = "free_y")

## ----guided tour 6D, eval=FALSE, echo=TRUE-------------------------------
# The tour requires making many plots, and updating.
# The RStudio graphics device doesn't work well
# Open a graphics window
# quartz()  # Mac OSX
# X11()     # Windows
animate_xy(flea[,1:6], guided_tour(lda_pp(flea$species)), axes="bottomleft")

## ----generate a sequence to rotate a variable out of a projection, eval=FALSE, echo=TRUE----
# When you find a low dimensional projection from some other technique
# such as principal component analysis, linear discriminant analysis or
# projection pursuit, it is useful to examine the sensitivity of structure
# to variables in the projection. This is the purpose of the manual tour.
# Take a variable, and rotate it out of the projection and see if the structure
# persists or disappears.
flea_std <- tourr::rescale(flea[, 1:6])
##
rb <- basis_random(n = ncol(flea_std))
mtour <- manual_tour(basis = rb, manip_var = 4)
sshow <- array2df(array = mtour, data = flea_std)
render_plotly(slides = sshow)
##
render_plotly(slides = sshow, col = col_of(flea$species),
  fps = 2)

## ----read and tour on in a classic data set, echo=TRUE, eval=FALSE-------
olive <- read_csv("http://www.ggobi.org/book/data/olive.csv") %>%
  rename(name=X1)
olive <- olive %>%
  filter(region == 1) %>%
  mutate(area = factor(area))
pal <- brewer.pal(4, "Dark2")
col <- pal[olive$area]
# drop eicosenoic, all low for south
animate_xy(olive[,4:10], axes="bottomleft", col=col)
# Drop Sicily
animate_xy(olive[olive$area!=4,4:10], axes="bottomleft", col=col[olive$area!=4])

## ----Fit a randomForest model an examine the vote matrix, echo=TRUE, eval=FALSE----
olive_rf <- randomForest(area~., data=olive[,-c(1, 2, 11)], importance=TRUE, proximity=TRUE)
olive_rf
vt <- data.frame(olive_rf$votes)
vt$area <- olive$area
ggscatmat(vt, columns=1:4, col="area") +
  scale_colour_brewer("", palette="Dark2")
proj <- t(geozoo::f_helmert(4)[-1,])
vtp <- as.matrix(vt[,-5])%*%proj
vtp <- data.frame(vtp, area=vt$area)
ggscatmat(vtp, columns=1:3, col="area") +
  scale_colour_brewer("", palette="Dark2")
pal <- brewer.pal(4, "Dark2")
col <- pal[as.numeric(vtp[, 4])]
animate_xy(vtp[,1:3], col=col, axes = "bottomleft")
# Add simplex
simp <- simplex(p=3)
sp <- data.frame(simp$points)
colnames(sp) <- c("x1", "x2", "x3")
colnames(vtp) <- c("x1", "x2", "x3")
vtp_s <- bind_rows(sp, vtp[,1:3])
animate_xy(vtp_s, col=col, axes = "bottomleft", edges=as.matrix(simp$edges), center=TRUE)

## ----tb pca analysis, eval=FALSE, echo=TRUE------------------------------
library(naniar) # Have missings!
tb_burden_wide <- tb_burden %>%
  select(country, g_whoregion, year,
         e_mort_exc_tbhiv_100k) %>%
  spread(year, e_mort_exc_tbhiv_100k) %>%
  filter(complete.cases(.)) %>%
  rename(region = g_whoregion) %>%
  mutate(country = factor(country),
         region = factor(region))
# vis_miss(tb_burden_wide)
tb_pca <- prcomp(tb_burden_wide[,-c(1:2)],
                 scale=FALSE, retx=TRUE)
screeplot(tb_pca, type="line")
tb_pcs <- bind_cols(as_tibble(tb_pca$x),
                    tb_burden_wide[,1:2])
ggscatmat(tb_pcs, columns=1:3, color="region")
# quartz()
# X11()
pal <- brewer.pal(6, "Dark2")
col <- pal[as.numeric(as.factor(tb_pcs$region))]
animate_xy(tb_pcs[,1:4], col=col,
           axes = "bottomleft")

## ----tb mortality line plots, eval=FALSE, echo=FALSE---------------------
tb_burden <- tb_burden %>%
  rename(region = g_whoregion)
ggplot(tb_burden, aes(x=year, y=e_mort_exc_tbhiv_100k,
                      group=country, colour=region)) +
  geom_line() + facet_wrap(~region)

## ----nonlinear dimension reduction, eval=FALSE, echo=TRUE----------------
# remotes::install_github("sa-lee/sneezy")
library(gganimate) # required for printing tours
library(sneezy)
# Read a benchmark data set
spheres <- subset(multi, key %in% c("A", "D"))
labels <- ifelse(spheres$key == "A", "sub-gaussian", "10-d 2x cluster")
spheres <- as.matrix(spheres[, -c(1,2)])
##
# t-SNE plot
set.seed(1010010)
coords <- basic_tsne(spheres, perplexity = 30)
pl <- ggplot(as.data.frame(coords$Y), aes(V1, V2)) +
  geom_point(aes(colour = labels)) +
  coord_equal() +
  scale_color_brewer(palette = "Dark2") +
  theme(axis.title = element_blank(),
        axis.ticks = element_blank(),
        axis.text = element_blank(),
        panel.grid = element_blank())
##
pl +  add_triangles(coords)
##
# in data space, with a triangulation of the points from the tSNE view
# quartz()
# X11()
pal <- c("#1B9E77", "#D95F02")[as.integer(as.factor(labels))]
sneezy_triangles(spheres, coords, col = pal)

## ----tour again for comparison, eval=FALSE, echo=FALSE-------------------
# quartz()
# X11()
pal <- brewer.pal(4, "Dark2")
col <- pal[olive$area]
# drop eicosenoic, all low for south
animate_xy(olive[,4:10], axes="bottomleft", col=col)
# Drop Sicily
animate_xy(olive[olive$area!=4,4:10], axes="bottomleft", col=col[olive$area!=4])

## ----make a parallel coordinate plot of the olive data, eval=FALSE, echo=TRUE----
ggparcoord(olive, columns=4:10, groupColumn=3, order="anyClass") +
  scale_colour_brewer("", palette="Dark2")

## ----make a heatmap of the olive data, eval=FALSE, echo=TRUE-------------
library(superheat)
superheat(olive[,4:10], scale=TRUE,
          pretty.order.rows=TRUE, pretty.order.cols=TRUE,
          row.dendrogram = TRUE)

## ----plotly tourr, eval=FALSE, echo=TRUE---------------------------------
flea_std <- rescale(tourr::flea[,1:6])
tpath    <- save_history(flea_std, max = 3)
##
pg <- play_tour_path(tour_path = tpath, data = flea_std, angle = .15)
pg
save_html(pg, file="mytour.html")

## ----saving a tour as an animated fig using gganimate, eval=FALSE, echo=TRUE----
library(gganimate)
render_gif(flea[,1:6], grand_tour(), display_xy(axes="off"),
           frames=200,
           gif_file="mytour.gif")


# Program to find the sum of natural numbers upto n using recursion
calculate_sum() <- function(n) {
if(n <= 1) {
return(n)
} else {
return(n + calculate_sum(n-1))
}
}


## expects 'outdir' as argument
trial <- TRIAL

## get command line arg
args = commandArgs(trailingOnly=TRUE)
if (length(args)==0) {
  stop("At least one argument must be supplied (output dir).\n")
} else if (length(args)==1) {
  outdir <- args[1]
}

print(outdir)
imfile <- paste(outdir, "/", "thread-", trial, ".RData", sep = "")
print(imfile)

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

## number of forcast trajecotries to draw for each method
## (if2: parametric bootstrap, hmcmc: bootstrap)
nTraj <- 200

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

library(reshape2)
library(rstan)
library(Rcpp)

T       <- 7*52 # 7 years of data +  forecast
Tlim    <- 5*52 # only 5 years of data
i_infec <- 10
steps   <- 7
N       <- 500
sigma   <- 3

## Generate true trajecory and synthetic data
##

pars_true <- c(R0 = 3.0,    # new infected people per infected person
          r = 0.1,      # recovery rate
          N = 500,      # population size
          eta = 0.5,    # geometric random walk
          berr = 0.5,	# Beta geometric walk noise
          re = 1 )    	# resusceptibility

true_init_cond <- c(S = N - i_infec,
                    I = i_infec,
                    R = 0)

## external files

# R source files
stoc_sirs_file 			<- paste(getwd(),"../../sir-functions", "StocSIRS.r", sep = "/")
stoc_sirs_stan_file 	<- paste(getwd(),"../../sir-functions", "StocSIRSstan.r", sep = "/")
if2_sirs_paraboot_file 	<- paste(getwd(), "if2-sirs-paraboot.r", sep = "/")
smap_file 				<- paste(getwd(), "../../smap", "smap.r", sep = "/")
source(stoc_sirs_file)
source(stoc_sirs_stan_file)
source(if2_sirs_paraboot_file)
source(smap_file)

# C++ source files
if2file 	<- paste(getwd(), "../../if2/if2-sirs", "if2-sirs.cpp", sep="/")
hmcfile 	<- paste(getwd(), "../../hmc/hmc-sirs", "sirs-euler.stan", sep="/")

## IF2 settings

NP          <- 2500
nPasses     <- 50
coolrate    <- 0.975

## Smap settings

E 			<- 14
theta 		<- 3

# get raw data
sdeout_true <- StocSIRS(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

## fit once to compile
##

# conform data to stan's required format, short data (not full)
samsize <- 10
datlen <- (samsize-1)*steps + 1

data <- matrix(data = -1, nrow = samsize, ncol = steps)
data[,1] <- infec_counts[1:10]
standata <- as.vector(t(data))[1:datlen]

#options
rstan_options(auto_write = TRUE)

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 2000, 		# iterations per chain
                        warmup = 1000, 		# warmup interations
                        thin   = 1)   		# thinning number

# data
sirs_data <- list(T = datlen,       # simulation time
                  y = standata,     # infection count data
                  N = 500,          # population size
                  h = 1/steps )     # step size per day

# fit!
initialfit <- with(stan_options,
                stan(file   = hmcfile,
                    data    = sirs_data,
                    chains  = chains,
                    iter    = iter,
                    warmup  = warmup,
                    thin    = thin)
                )

## Run multiple trajectories
#########################################################################################################

# get true trajectory
sdeout_true <- StocSIRS(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

# get full data
infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

datapart <- infec_counts[1:(Tlim+1)]

## IF2
################################################################################################
################################################################################################

# initial fit
sourceCpp(if2file)
if2time1 <- system.time( if2data <- if2_sirs(datapart, Tlim, N, NP, nPasses, coolrate) )

# IF2 parametric bootstrap
if2time2 <- system.time(if2_paraboot_data <- if2_sirs_paraboot(if2data,
                          T, Tlim, steps, N, nTraj,
                          if2file, stoc_sirs_file,
                          NP, nPasses, coolrate)
)

if2time <- if2time1 + if2time2

# get mean of trajectories
parabootdata <- data.frame(if2_paraboot_data)
countnames <- paste("counts",1:(dim(parabootdata)[2]-10), sep = "")
countdata <- parabootdata[,countnames]
countmeans <- colMeans(countdata)

# get SSE, save
truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
estfuture   <- countmeans[-1]
err <- estfuture - truefuture
if2sse <- sum(err^2)

if2pred <- estfuture

## HMC fitting with stan
################################################################################################
################################################################################################

datlen <- Tlim*steps + 1

data <- matrix(data = -1, nrow = Tlim+1, ncol = steps)
data[,1] <- datapart
standata <- as.vector(t(data))[1:datlen]

sir_data <- list( T = datlen,       # simulation time
                  y = standata,     # infection count data
                  N = 500,          # population size
                  h = 1/steps )     # step size per day

hmctime1 <- system.time( fit <- with(stan_options,
                        stan( fit = initialfit,
                              data    = sir_data,
                              chains  = chains,
                              iter    = iter,
                              warmup  = warmup,
                              thin    = thin)
                        	)
            			)

exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)

paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
                        r = melt(exfit[,,'r'])$value,
                        re = melt(exfit[,,'re'])$value,
                        sigma = melt(exfit[,,'sigma'])$value,
                        eta = melt(exfit[,,'eta'])$value,
                        berr = melt(exfit[,,'berr'])$value,
                        Iinit = melt(exfit[,,'Iinit'])$value )

for (j in 1:datlen) {
	varname <- paste('Bnoise[', j, ']', sep = '')
	paramdata[[varname]] <- melt( exfit[,,varname] )$value
}

parnames <- c("R0","r","re","sigma","eta","berr","Iinit")
parvars <- var(paramdata[parnames])
hmcparmeans <- colMeans(paramdata[parnames])
names(hmcparmeans) <- paste("hmc.", parnames,sep="")

bootstrapdata <- matrix(NA, nrow = nTraj, ncol = (T+1) )

pardatlen 	<- dim(paramdata)[1]
inds 	    <- sample.int(pardatlen,nTraj,replace = TRUE)
params 	    <- paramdata[inds,]

hmctime2 <- system.time(
for (i in 1:nTraj) {

	paramset <- params[i,]

	init_cond <- c(S = N - paramset$Iinit,
	               I = paramset$Iinit,
	               R = 0.0 )
	pars <- c(R0 = paramset$R0,
	          r = paramset$r,
	          re = paramset$re,
	          N = 500.0,
	          eta = paramset$eta,
	          berr = paramset$berr)

	berrvec <- numeric(datlen)
	for (j in 1:datlen) {
		varname <- paste("Bnoise[", j, "]", sep = "")
		berrvec[j] <- paramset[[varname]]
	}

	sdeout <- StocSIRSstan(init_cond, pars, T, steps, berrvec, datlen)
	colnames(sdeout) <- c('S','I','R','B')

	bootstrapdata[i,] <- sdeout[,'I']

}
)

hmctime <- hmctime1 + hmctime2

# in case of explosion
bootstrapdata <- bootstrapdata[complete.cases(bootstrapdata),]
goodbootsize <- dim(bootstrapdata)[1]

meanTraj 	<- colMeans(bootstrapdata)

truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
estfuture   <- meanTraj[(Tlim+2):(T+1)]
err <- estfuture - truefuture
hmcsse <- sum(err^2)

hmcpred <- estfuture

## Smapping
################################################################################################
################################################################################################

stepsAhead <- T-Tlim
smaptime <- system.time( predictions <- smap(datapart, E, theta, stepsAhead) )

truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
estfuture   <- predictions
err <- estfuture - truefuture
smapsse <- sum(err^2)

smappred <- predictions

## Save results
#########################################################################################################

vecout <- c(trunc = trunc, trial = trial, if2sse = if2sse, hmcsse = hmcsse, smapsse = smapsse,
            if2time = if2time[['user.self']], hmctime = hmctime[['user.self']], smaptime = smaptime[['user.self']])

save.image(imfile)


#################################################################################
## Code generating Figure 5  and expected serial interval quoted in manuscript #
################################################################################

####################
# Define functions #
####################

#truncated normal
rtnorm <- function(n, mean, sd, a = 0, b = 1){
  qnorm(runif(n, pnorm(a, mean, sd), pnorm(b, mean, sd)), mean, sd)
}

## Transparent colors
## Mark Gardener 2015
## www.dataanalytics.org.uk
t_col <- function(color, percent = 10, name = NULL) {
  #	  color = color name
  #	percent = % transparency
  #	   name = an optional name for the color
  ## Get RGB values for named color
  rgb.val <- col2rgb(color)
  ## Make new color using input color as base and alpha set by transparency
  t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
               max = 255,
               alpha = (100-percent)*255/100,
               names = name)
  ## Save the color
  invisible(t.col)

}
## END
l<-function(t,As){
  t[t<0]<-0
  As*t*exp(-0.5*As*t*t)}

line<-function(t,shift=15, A){lines(t,l(t-shift,A),type ="l", lwd=0.5, col= mycol)}

mycol<-t_col("red",percent =50)

# illustration of SI prior with parameters used in main text- this is from a truncated normal distribution, normal uniform bounded distribution version commented out

#incubation period
shift<-15
#Alpha parameter
As<-0.003

t<- c(1:200)

plot(t,l(t-shift,As),type ="l", lwd=0.5, col= "red", xlab = "Time", ylab="Probability density", ylim=c(0,0.12), cex.lab=1.5, cex.axis =1.5 )

#we set a prior for Alpha with mean 0.003 and sd 0.01,using a truncated normal distribution
#As<-runif(300,0.00001,0.02)
As<-rtnorm(1000,0.003,0.01)
#As<-rtnorm(1000,0.002,0.1)

quant<-quantile(As,c(0.025,0.975,0.5))
As_2.5<-quant[1]
As_97.5<-quant[2]
As_0.5<-quant[3]

#2.5% quantile
t[which.max(l(t-shift,As_2.5))]

#97.5% quantile
t[which.max(l(t-shift,As_97.5))]

#median
t[which.max(l(t-shift,As_0.5))]

for(i in 1:length(As)){
  line(t=t,A=As[i])
}
As<-0.003
lines(t,l(t-shift,As), type ="l", lwd=5, col= "black")
lines(t,l(t-shift,As_2.5), type ="l", lwd=5,lty="dashed", col= "black")
lines(t,l(t-shift,As_97.5), type ="l", lwd=5, lty= "dashed", col= "black")
title("Serial Interval Distribution", cex.main=2)


rm(list = ls())
library(ggplot2)
library(fpp2)
library(RMSE)
file <- "~/SeniorStats/HW4/STA372_Homework4_Question3.dat.txt"
data_table <- read.table(file, header = FALSE, sep = "")
colnames(data_table) <- c("Week","Y","FixedForcast")

head(data_table)
tail(data_table)

figure <- ggplot()
figure <- figure + geom_point(aes(data_table$Week, data_table$Y))
figure <- figure + geom_line(aes(data_table$Week, data_table$Y))
figure <- figure + scale_y_continuous()
figure <- figure + ggtitle("Time series plot of Y (Solid black line) and in-sample forecasts")
figure <- figure + xlab("Week") + ylab("Y")
print (figure)
print("There is a pattern in Y through time and it is a pattern of increasing over time")

data_table$Error <- data_table$Y - data_table$FixedForcast
RMSE_FixedForcast <- sqrt(sum(data_table$Error^2)/nrow(data_table))
print(RMSE_FixedForcast)

y_time_series <- ts(data_table[,2])
result_random_walk <- ses(y_time_series, alpha=1, initial="simple", h=1)
result_random_walk$model
accuracy(result_random_walk)
print("The RMSE here was 63.10765")

data_table$forcast <- result_random_walk$fitted
data_table$residualswalk <- result_random_walk$residuals
head(data_table)
tail(data_table)

result <- ses(y_time_series, initial="simple", h=3)
result$model

print(result)
data_table$forcast2 <- result$fitted
data_table$residuals <-result$residuals
head(data_table)
tail(data_table)

figure2 <- ggplot()
figure2 <- figure2 + geom_point(aes(data_table$Week, data_table$Y))
figure2 <- figure2 + geom_line(aes(data_table$Week, data_table$Y))
figure2 <- figure2 + geom_point(aes(data_table$Week, data_table$forcast2), color="Red")
figure2 <- figure2 + geom_line(aes(data_table$Week, data_table$forcast2), color="Red", lty=2)
figure2 <- figure2 + scale_y_continuous()
figure2 <- figure2 + ggtitle("Time series plot of Y (Solid black line) and in-sample forecasts")
figure2 <- figure2 + xlab("Week") + ylab("Y")
print (figure2)
accuracy(result)
print("The RMSE here is 54.70586")

figure3 <- ggplot()
figure3 <- figure3 + geom_point(aes(data_table$Week, data_table$residuals))
figure3 <- figure3 + geom_line(aes(data_table$Week, data_table$residuals))
figure3 <- figure3 + scale_y_continuous()
figure3 <- figure3 + ggtitle("In-sample forecast errors")
figure3 <- figure3 + xlab("Time") + ylab("Residuals")
print (figure3)

ggAcf(data_table$residuals)
summary(result)

print("The residuals are not independent, this implies that there is information leftover in the residuals that will not be reflected in the formal forcasting.")
print("We should use the model that was used for figure 2, the Simple Exponential smoothing model, not the random walk model")
print("seasonal factor is .975")
seasonal <- .975*839.4273
seasonal
print("The week 67 forcast of volume is 818.4416, and the 95% CI is (732.2058, 946.6488)")


#'@title calcDispUnitConversion
#'
#'@description Convert displacement in tonnages to cubic meters.
#'
#'@param tonnageDisp Displacement (vector of numericals, tonnage)
#'@param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#'supply either a vector of numericals, a single number, or rely on the default
#'
#'@return \code{disp} (vector of numericals, m^3)
#'
#'@examples
#'calcDispUnitConversion(70000, 1.025)
#'
#'@export

calcDispUnitConversion<- function(tonnageDisp, seawaterDensity=1.025){

  disp<- tonnageDisp/seawaterDensity

  return(disp)
}


library(dplyr)
library(sjmisc)
library(sjPlot)
library(ggplot2)

data(iris)

mean (iris$Sepal.Length)
sd (iris$Sepal.Length)
var (iris$Sepal.Length)

# good for now but....CREATE A BETTER HISTOGRAM :)
sjp.frq (iris$Sepal.Length,type="histogram",
         normal.curve = TRUE,title = "My chart")

#  A BETTER HISTOGRAM

myplot <- ggplot(iris, aes(x = Sepal.Length))
myplot + geom_histogram(bins = 50, color = "black", fill = "grey")


# CS422 Data Mining
# Vijay K. Gurbani, Ph.D.
# Illinois Institute of Technology

# DBSCAN clustering on non-globular data

library(fpc)
library(factoextra)
library(dbscan)

set.seed(123)

rm(list=ls())

data("multishapes", package = "factoextra")
df <- multishapes[, 1:2]

plot(df, main="Raw points before DBSCAN")

# Let's run k-means on this first.  Choose a value of k...
k <- kmeans(df, centers=5, nstart=25)
fviz_cluster(k, df)

# ---- Now, onto dbscan
# Run dbscan
db <- fpc::dbscan(df, eps = 0.15, MinPts = 5)
plot(db, df, main = "DBSCAN", frame = FALSE)

# You can also draw this using fviz_cluster
fviz_cluster(db, df, stand = FALSE, ellipse = F, geom = "point")

# In the output below, column names are cluster numbers.  Cluster 0 corresponds
# to noise (outliers)
print(db)

# How to determine eps and k (MinPts)?
# k is provided by the user.  EPS is determined by looking at the "knee".
# For example, head(kNNdist(df, k=5)) shows a numeric vector with distance
# to its k-nearest neighbours.  kNNdistplot() samples the points from df and
# calculates the distance to 5-NN.  Look at the "knee" and you will find the
# (pot of gold, err) eps.
dbscan::kNNdistplot(df, k =  5)
abline(h = 0.15, lty = 2)


=begin
  # sample-geometry02.rb

  require 'algebra'
  R = MPolynomial(Rational)
  x,y,a1,a2,b1,b2,c1,c2 = R.vars('xya1a2b1b2c1c2')

  V = Vector(R, 2)
  X, A, B, C = V[x,y], V[a1,a2], V[b1,b2], V[c1,c2]

  def line(p1, p2, p3)
    SquareMatrix.det([[1, *p1], [1, *p2], [1, *p3]])
  end

  def vline(p1, p2, p3)
    (p1-p2).norm2 - (p1-p3).norm2
  end

  l1 = vline(X, A, B)
  l2 = vline(X, B, C)
  l3 = vline(X, C, A)

  s = line(A, B, C)

  g = Groebner.basis [l1, l2, l3, s-1] #s-1 means non degeneracy

  g.each do |f|
    p f
  end
  #x - 1/2a1a2b1 + 1/2a1a2c1 + 1/2a1b1c2 - 1/2a1c1c2 - 1/2a1 - 1/2a2^2b2 + 1/2a2^2c2 + 1/2a2b1^2 - 1/2a2b1c1 + 1/2a2b2^2 - 1/2a2c2^2 - 1/2b1^2c2 + 1/2b1c1c2 - 1/2b2^2c2 + 1/2b2c2^2 - 1/2c1
  #y + 1/2a1^2b1 - 1/2a1^2c1 - 1/2a1b1^2 + 1/2a1c1^2 + 1/2a2^2b1 - 1/2a2^2c1 - 1/2a2b1b2 - 1/2a2b1c2 + 1/2a2b2c1 + 1/2a2c1c2 + 1/2b1^2c1 + 1/2b1b2c2 - 1/2b1c1^2 -1/2b2c1c2 - 1/2b2 - 1/2c2
  #a1b2 - a1c2 - a2b1 + a2c1 + b1c2 - b2c1 - 1
((<_|CONTENTS>))
=end


# Filename: 	code.r
# Project: 	/Users/shume/Developer/stat/MedicalStatisticsClass2015/01
# Author: 	shumez <https://github.com/shumez>
# Created: 	2019-06-26 20:15:5
# Modified: 	2019-07-03 16:24:11
# -----
# Copyright (c) 2019 shumez

x <- c(0.684, 1.406, -0.663, -0.124, 0.849, -0.888, -0.492, -0.044, -0.188, 0.536, 2.063, -1.379, 0.920, 0.453, 1.239)
df <- data.frame(x=x, class=rep('x', length(x)))
diamonds

View(df)

library('ggplot2')
length(df$carat)
round(1 + log2(length(diamonds$carat)))

p <- ggplot(df, aes(x)) + geom_histogram(binwidth=.5)
p <- ggplot(diamonds, aes(carat, fill=cut)) + geom_histogram(bins=round(1 + log2(length(diamonds$carat))))
p <- ggplot(df, aes(class, x)) +
  geom_boxplot() +
  geom_jitter(width=0)# +
p <- p + annotate('text', aes(label='25% quantile'), x=1, y=quantile(df$x, .25))
  # geom_text(aes(x=1, y=quantile(df$x, .25), label='25% quantile'))

p <- ggplot(df, aes(class, x)) + geom_violin(draw_quantiles = c(0.25, 0.5, 0.75)) + geom_jitter(width=0)

p <- ggplot(df, aes(class, x)) + geom_point()
p

# Two sample test
x1 <- c(8, 17, 9, 5, 14, 13, 13, 3, 9, 0)
x2 <- c(19, 13, 13, 18, 21, 18, 11, 21, 20, 11)

boxplot(x1, x2)

# Welch's t test
t.test(x1, x2)
# Mann-Whitney test, Wilcoxon’s rank sum test
wilcox.test(x1, x2)


# From Ben Bolker
library(reshape2)
library(lme4)
set.seed(1001)
source("data/xtable.r")

x <- rnorm(5, 20, 1)
y <- x + rnorm(5, 2, 1)
df1 <- data.frame(id = seq_along(y), x = x, y = y)
df2 <- melt(df1, id = "id")

xtable(df1, file = "model-1.tex")
xtable(df2, file = "model-2.tex")

t1 <- t.test(df1$x, df1$y, paired = TRUE)
m1 <- lmer(value ~ variable + (1 | id) , data = df2, REML = TRUE)

all.equal(abs(t1$statistic), coef(summary(m1))["variabley","t value"])

# The t statistic is (almost) the same. (all.equal() reports a relative
# difference of 4.618215e-07). REML=TRUE isn't necessary (it's the
# default) but it emphasizes the fact that the paired t test is exactly
# equivalent to REML.


setwd("C:/Users/Turing/Desktop")
load('AuditDataAnalysisB2.rdata')
library(Rtsne)
filtered <- read.csv(file = 'filtered_audit_data_alldata.csv')
filtered_numerical_features = which(gsub("fcur","",colnames(filtered)) != colnames(filtered))

numerical_features = which(gsub("fcur","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
categorical_features = which(gsub("fstr","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
city_features = which(gsub("City","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
zip_features = which(gsub("Zip","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
#categorical_features = c(categorical_features,city_features,zip_features)
data_categorical_part = NULL
for (i in 1 : length(categorical_features)){
    if (colnames(Return_RegistrationData)[categorical_features[i]] == "fstrSiteId")next
    if (colnames(Return_RegistrationData)[categorical_features[i]] == "fstrFormType") next
    types = unique(Return_RegistrationData[,categorical_features[i]])
    if (length(types) > 1){
        tmp_matrix = matrix(0,nrow=nrow(Return_RegistrationData),ncol=length(types))
        for (j in 1 : length(types)){
            tmp_matrix[which(Return_RegistrationData[,categorical_features[i]] == types[j]),j] = 1
        }
        colnames(tmp_matrix) = types
        data_categorical_part = cbind(data_categorical_part,tmp_matrix)
    }
}

data_numerical_part = Return_RegistrationData[,numerical_features]
filtered_data_numerical_part = filtered[,filtered_numerical_features]
filtered_data = cbind(filtered_data_numerical_part)
filtered_data_minmax = apply(filtered_data,2,function(x){(x-min(x))/(max(x)-min(x))})

data = cbind(data_numerical_part)
data_minmax = apply(data,2,function(x){(x-min(x))/(max(x)-min(x))})

data_zscore = apply(data,2,function(x){(x-mean(x))/(sd(x))})
data_normalized_grossSales = apply(data,2,function(x,grossSales){
    grossSales[grossSales < 1] = 1
    return(x/grossSales)
},data$fcurGrossSales)

if (!requireNamespace("BiocManager", quietly = TRUE))
    install.packages("BiocManager")

#BiocManager::install("preprocessCore")

library(preprocessCore)
data_quantile = normalize.quantiles(as.matrix((data)))
data_quantile = (data_quantile)
dimnames(data_quantile) = dimnames(data)
data_quantile = as.data.frame(data_quantile)
data_minmax = data_quantile

library(oce)
library(tidyverse)
library(plyr)

pca_res = prcomp(data_minmax,center = F,scale. = F)
filtered_pca_res = prcomp(na.omit(filtered_data_minmax),center = F,scale. = F)
pca_filtered = as.data.frame(filtered_pca_res$x)
pca = as.data.frame(pca_res$x)

audited = filtered$CASE_ID != 0
yield = filtered$TOPLINE_TAX > 0
yield2 = filtered$TOPLINE_TAX > 20000

pca_filtered$color = c("black")
pca_filtered$color[audited] = c("blue")
pca_filtered$color[yield] = c("red")
pca_filtered$color[yield2] = c("green")

colors <- c("black"="black",
            "red"="red",
            "blue"="blue",
            "green"="green")
size = 2
main_pca <- ggplot(data=pca_filtered, aes(x = PC1, y = PC2)) +
    geom_point(data=pca_filtered[pca_filtered$color == 'black',], aes(col="black"), size=size) +
    geom_point(data=pca_filtered[pca_filtered$color == 'blue',], aes(col="blue"), size=size) +
    geom_point(data=pca_filtered[pca_filtered$color == 'red',], aes(col="red"), size=size) +
    geom_point(data=pca_filtered[pca_filtered$color == 'green',], aes(col="green"), size=size) +
    ggtitle("Principal Component Analysis (Minmax Normalization)") +
    xlab("Principal Component 1 (78.87%)") +
    ylab("Principal Component 2 (10.43%)") +
    scale_colour_manual(name=element_blank(),
                        label=c("All returns","Audited returns","Tax yield > $20,000","Tax yield > $0"),
                        values=colors) +
    guides(color=guide_legend(override.aes=list(fill=NA))) +
    theme(panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=1),
          plot.title = element_text(hjust = 0.5),
          legend.key=element_blank(),
          legend.position = c(0.01, 0.01),
          legend.justification = c(0,0))
#main_pca

audited = Return_Audit$CASE_ID != 0
yield = Return_Audit$TOPLINE_TAX > 0
yield2 = Return_Audit$TOPLINE_TAX > 20000

pca$color = c("black")
pca$color[audited] = c("blue")
pca$color[yield] = c("red")
pca$color[yield2] = c("green")

size = 1
inset_pca <- ggplot(data=pca, aes(x = PC1, y = PC2)) +
    geom_point(data=pca[pca$color == 'black',], col="black", size=size) +
    geom_point(data=pca[pca$color == 'blue',], col="blue", size=size) +
    geom_point(data=pca[pca$color == 'red',], col="red", size=size) +
    geom_point(data=pca[pca$color == 'green',], col="green", size=size) +
    scale_x_continuous(position = 'bottom') +
    scale_y_continuous(position = 'right') +
    theme(axis.title.x=element_blank(),
          axis.title.y=element_blank(),
          panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=0.7))
#inset_pca
main_pca + annotation_custom(ggplotGrob(inset_pca),
                             xmin = -1.9, xmax = -1,
                             ymin = 0.5, ymax = 1)

#ggsave("Fig3_PCA_alldata.jpeg", dpi = 2500)

tsne = Rtsne(data_minmax,dims = 2,normalize=F, pca = FALSE, verbose=TRUE,max_iter = 500,check_duplicates=F)
filtered_tsne = Rtsne(filtered_data_minmax,dims = 2,normalize=F, pca = FALSE, verbose=TRUE,max_iter = 500,check_duplicates=F)
tsnedf = as.data.frame(tsne$Y)
filtered_tsnedf = as.data.frame(filtered_tsne$Y)
colnames(tsnedf) = c("tsne1", "tsne2")
colnames(filtered_tsnedf) = c("tsne1", "tsne2")

audited = filtered$CASE_ID != 0
yield = filtered$TOPLINE_TAX > 0
yield2 = filtered$TOPLINE_TAX > 20000

filtered_tsnedf$color = c("black")
filtered_tsnedf$color[audited] = c("blue")
filtered_tsnedf$color[yield] = c("red")
filtered_tsnedf$color[yield2] = c("green")

colors <- c("black"="black",
            "red"="red",
            "blue"="blue",
            "green"="green")

size = 2
main_tsne <- ggplot(data=filtered_tsnedf, aes(x = tsne1, y = tsne2)) +
    geom_point(data=filtered_tsnedf[filtered_tsnedf$color == 'black',], aes(col="black"), size=size) +
    geom_point(data=filtered_tsnedf[filtered_tsnedf$color == 'blue',], aes(col="blue"), size=size) +
    geom_point(data=filtered_tsnedf[filtered_tsnedf$color == 'red',], aes(col="red"), size=size) +
    geom_point(data=filtered_tsnedf[filtered_tsnedf$color == 'green',], aes(col="green"), size=size) +
    ggtitle("t-SNE (Minmax Normalization)") +
    xlab("t-SNE dimension 1") +
    ylab("t-SNE dimension 2") +
    xlim(-35, 20) +
    ylim(-20, 20) +
    scale_colour_manual(name=element_blank(),
                        label=c("All returns","Audited returns","Tax yield > $20,000","Tax yield > $0"),
                        values=colors) +
    guides(color=guide_legend(override.aes=list(fill=NA))) +
    theme(panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=1),
          plot.title = element_text(hjust = 0.5),
          legend.key=element_blank(),
          legend.position = c(0.01, 0.01),
          legend.justification = c(0,0))
main_tsne

audited = Return_Audit$CASE_ID != 0
yield = Return_Audit$TOPLINE_TAX > 0
yield2 = Return_Audit$TOPLINE_TAX > 20000

tsnedf$color = c("black")
tsnedf$color[audited] = c("blue")
tsnedf$color[yield] = c("red")
tsnedf$color[yield2] = c("green")

size = 0.001
inset_tsne <- ggplot(data=tsnedf, aes(x = tsne1, y = tsne2)) +
    geom_point(data=tsnedf[tsnedf$color == 'black',], aes(col="black"), size=size) +
    geom_point(data=tsnedf[tsnedf$color == 'blue',], aes(col="blue"), size=size) +
    geom_point(data=tsnedf[tsnedf$color == 'red',], aes(col="red"), size=size) +
    geom_point(data=tsnedf[tsnedf$color == 'green',], aes(col="green"), size=size) +
    scale_x_continuous(position = 'bottom') +
    scale_y_continuous(position = 'right') +
    scale_colour_manual(name=element_blank(),
                        values=colors) +
    theme(axis.title.x=element_blank(),
          axis.title.y=element_blank(),
          legend.position="none",
          panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=0.7))
inset_tsne

main_tsne + annotation_custom(ggplotGrob(inset_tsne),
                              xmin = -37.7, xmax = -17,
                              ymin = 3, ymax = 22)

#ggsave("Fig3_tSNE_alldata.jpeg", dpi = 2500)

#ONLY AUDIT DATA
filtered <- read.csv(file = 'filtered_audit_data.csv')
filtered_numerical_features = which(gsub("fcur","",colnames(filtered)) != colnames(filtered))
Return_RegistrationData <- read.csv(file = 'prefilter_audit_data.csv')
numerical_features = which(gsub("fcur","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
categorical_features = which(gsub("fstr","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
city_features = which(gsub("City","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
zip_features = which(gsub("Zip","",colnames(Return_RegistrationData)) != colnames(Return_RegistrationData))
#categorical_features = c(categorical_features,city_features,zip_features)
data_categorical_part = NULL
for (i in 1 : length(categorical_features)){
    if (colnames(Return_RegistrationData)[categorical_features[i]] == "fstrSiteId")next
    if (colnames(Return_RegistrationData)[categorical_features[i]] == "fstrFormType") next
    types = unique(Return_RegistrationData[,categorical_features[i]])
    if (length(types) > 1){
        tmp_matrix = matrix(0,nrow=nrow(Return_RegistrationData),ncol=length(types))
        for (j in 1 : length(types)){
            tmp_matrix[which(Return_RegistrationData[,categorical_features[i]] == types[j]),j] = 1
        }
        colnames(tmp_matrix) = types
        data_categorical_part = cbind(data_categorical_part,tmp_matrix)
    }
}

data_numerical_part = Return_RegistrationData[,numerical_features]
filtered_data_numerical_part = filtered[,filtered_numerical_features]
filtered_data = cbind(filtered_data_numerical_part)
data = cbind(data_numerical_part)

data_minmax = apply(data,2,function(x){(x-min(x))/(max(x)-min(x))})
filtered_data_minmax = apply(filtered_data,2,function(x){(x-min(x))/(max(x)-min(x))})

library(oce)
library(preprocessCore)
library(tidyverse)
library(plyr)

pca_res = prcomp(data_minmax,center = F,scale. = F)
filtered_pca_res = prcomp(na.omit(filtered_data_minmax),center = F,scale. = F)
pca_filtered = as.data.frame(filtered_pca_res$x)
pca = as.data.frame(pca_res$x)

audited = filtered$CASE_ID != 0
yield = filtered$TOPLINE_TAX > 0
yield2 = filtered$TOPLINE_TAX > 20000
pca_filtered$color = c("red")
pca_filtered$color[yield2] = c("green")

colors <- c("red3","turquoise4")

size = 1
main_pca <- ggplot(data=pca_filtered, aes(x = PC1, y = PC2)) +
    geom_point(data=pca_filtered[pca_filtered$color == 'red',], aes(col="red"), size=size) +
    geom_point(data=pca_filtered[pca_filtered$color == 'green',], aes(col="green"), size=size) +
    ggtitle("Principal Component Analysis (Minmax Normalization)") +
    xlab("Principal Component 1 (65.59%)") +
    ylab("Principal Component 2 (15.65%)") +
    scale_colour_manual(name=element_blank(),
                        label=c("Tax yield \u2265 $20,000","Tax yield < $20,000"),
                        values=colors) +
    guides(color=guide_legend(override.aes=list(fill=NA))) +
    theme(panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=1),
          plot.title = element_text(hjust = 0.5, size=18),
          axis.title.x=element_text(size=12),
          axis.title.y=element_text(size=12),
          legend.key=element_blank(),
          legend.text = element_text(size=15),
          legend.position = c(0.99, 0.99),
          legend.justification = c(1,1))
main_pca

audited = Return_RegistrationData$CASE_ID != 0
yield = Return_RegistrationData$TOPLINE_TAX > 0
yield2 = Return_RegistrationData$TOPLINE_TAX > 20000
pca$color = c("red")
pca$color[yield2] = c("green")

colors <- c("red3","turquoise4")

size = 0.1
inset_pca <- ggplot(data=pca, aes(x = PC1, y = PC2)) +
    geom_point(data=pca[pca$color == 'red',], aes(col="red"), size=size) +
    geom_point(data=pca[pca$color == 'green',],aes(col="green"), size=size) +
    scale_x_continuous(position = 'top') +
    scale_y_continuous(position = 'left') +
    scale_colour_manual(name=element_blank(),
                        values=colors) +
    labs(title="Before Normalization") +
    theme(plot.title=element_text(hjust=0.5, size=12),
          axis.title.x=element_blank(),
          axis.title.y=element_blank(),
          legend.position="none",
          panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=0.7))
#inset_pca

minmaxpca = main_pca + annotation_custom(ggplotGrob(inset_pca),
                             xmin = -0.9, xmax = 0,
                             ymin = -1.80, ymax = -0.65)

tsne = Rtsne(data_minmax,dims = 2,normalize=F, pca = FALSE, verbose=TRUE,max_iter = 500,check_duplicates=F)
filtered_tsne = Rtsne(filtered_data_minmax,dims = 2,normalize=F, pca = FALSE, verbose=TRUE,max_iter = 500,check_duplicates=F)
tsnedf = as.data.frame(tsne$Y)
filtered_tsnedf = as.data.frame(filtered_tsne$Y)
colnames(tsnedf) = c("tsne1", "tsne2")
colnames(filtered_tsnedf) = c("tsne1", "tsne2")

audited = filtered$CASE_ID != 0
yield = filtered$TOPLINE_TAX > 0
yield2 = filtered$TOPLINE_TAX > 20000

filtered_tsnedf$color = c("red")
filtered_tsnedf$color[yield2] = c("green")

colors <- c("red3","turquoise4")

size = 1
main_tsne <- ggplot(data=filtered_tsnedf, aes(x = tsne1, y = tsne2)) +
    geom_point(data=filtered_tsnedf[filtered_tsnedf$color == 'red',], aes(col="red"), size=size) +
    geom_point(data=filtered_tsnedf[filtered_tsnedf$color == 'green',], aes(col="green"), size=size) +
    ggtitle("t-SNE (Minmax Normalization)") +
    xlab("t-SNE dimension 1") +
    ylab("t-SNE dimension 2") +
    scale_colour_manual(name=element_blank(),
                        label=c("Tax yield \u2265 $20,000","Tax yield < $20,000"),
                        values=colors) +
    xlim(-40, 30) +
    ylim(-20, 45) +
    guides(color=guide_legend(override.aes=list(fill=NA))) +
    theme(panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=1),
          plot.title = element_text(hjust = 0.5, size=18),
          legend.key=element_blank(),
          axis.title.x=element_text(size=12),
          axis.title.y=element_text(size=12),
          legend.position = c(0.99, 0.99),
          legend.text = element_text(size=15),
          legend.justification = c(1,1))
main_tsne

audited = Return_RegistrationData$CASE_ID != 0
yield = Return_RegistrationData$TOPLINE_TAX > 0
yield2 = Return_RegistrationData$TOPLINE_TAX > 20000

tsnedf$color = c("red")
tsnedf$color[yield2] = c("green")

colors <- c("red3","turquoise4")

size = 0.1
inset_tsne <- ggplot(data=tsnedf, aes(x = tsne1, y = tsne2)) +
    geom_point(data=tsnedf[tsnedf$color == 'red',], aes(col="red"), size=size) +
    geom_point(data=tsnedf[tsnedf$color == 'green',], aes(col="green"), size=size) +
    scale_x_continuous(position = 'bottom') +
    scale_y_continuous(position = 'right') +
    scale_colour_manual(name=element_blank(),
                        values=colors) +
    xlab("Before Normalization") +
    theme(axis.title.x=element_text(size=12),
          axis.title.y=element_blank(),
          legend.position="none",
          panel.background = element_blank(),
          panel.border = element_rect(colour = "black", fill=NA, size=0.7))
inset_tsne

minmaxtsne = main_tsne + annotation_custom(ggplotGrob(inset_tsne),
                              xmin = -43, xmax = -17,
                              ymin =18, ymax = 47.5)

jpeg(filename = "Figure_2.jpeg", width = 3500, height = 1450,
     pointsize = 1, quality = 1000, bg = "white", res = 250)

ggarrange(minmaxpca, minmaxtsne,
          heights = c(850, 850), widths =c(1000, 1000),  align = "v",
          ncol = 2, nrow = 1)
dev.off()

data_zscore = apply(data,2,function(x){(x-mean(x))/(sd(x))})
data_normalized_grossSales = apply(data,2,function(x,grossSales){
    grossSales[grossSales < 1] = 1
    return(x/grossSales)
},data$fcurGrossSales)

if (!requireNamespace("BiocManager", quietly = TRUE))
    install.packages("BiocManager")

#BiocManager::install("preprocessCore")

pca_res = prcomp(data,center = F,scale. = F)
plot(pca_res$x[,1],pca_res$x[,2],pch=20,main="PCA (without Normalization)",
     xlab=paste0("PC 1 (",format(summary(pca_res)[[6]][2,1]*100,digits = 2),"%)"),
     ylab=paste0("PC 2 (",format(summary(pca_res)[[6]][2,2]*100,digits = 2),"%)"))

audited = Return_Audit$CASE_ID != 0
yield = Return_Audit$TOPLINE_TAX > 0
yield2 = Return_Audit$TOPLINE_TAX > 20000
points(pca_res$x[audited,1],pca_res$x[audited,2],col=3,pch=20)
points(pca_res$x[yield,1],pca_res$x[yield,2],col=2,pch=20)
points(pca_res$x[yield2,1],pca_res$x[yield2,2],col=4,pch=20)
legend("topright",c("All returns","Audited returns","Tax yield > 0","Tax yield > 20K"),col=c(1,3,2,4),pch=20,bty="n",cex=0.8)

library(RColorBrewer)
palette(brewer.pal(n = 8, name = "Set1"))
tmp = palette()
palette(c("#000000",tmp))
tsne = Rtsne(data,dims = 2,normalize=F, pca = FALSE, verbose=TRUE,max_iter = 500,check_duplicates=F)
plot(tsne$Y,pch=20,main = "t-SNE (without Normalization)",col=1, xlab="tsne dim 1",ylab = "tsne dim 2",xlim=c(-25,20))
points(tsne$Y[audited,],col=3,pch=20)
points(tsne$Y[yield,],col=2,pch=20)
points(tsne$Y[yield2,],col=4,pch=20)
legend("topleft",c("All returns","Audited returns","Tax yield > 0","Tax yield > 20K"),col=c(1,3,2,4),pch=20,bty="n",cex=0.8)

pca_res = prcomp(data_zscore,center = F,scale. = F)
plot(pca_res$x[,1],pca_res$x[,2],pch=20,main="PCA (Z-Score Normalization)",
     xlab=paste0("PC 1 (",format(summary(pca_res)[[6]][2,1]*100,digits = 2),"%)"),
     ylab=paste0("PC 2 (",format(summary(pca_res)[[6]][2,2]*100,digits = 2),"%)"))

audited = Return_Audit$CASE_ID != 0
yield2 = Return_Audit$TOPLINE_TAX > 20000
points(pca_res$x[audited,1],pca_res$x[audited,2],col=3,pch=20)
points(pca_res$x[yield,1],pca_res$x[yield,2],col=2,pch=20)
points(pca_res$x[yield2,1],pca_res$x[yield2,2],col=4,pch=20)
legend("topright",c("All returns","Audited returns","Tax yield > 0","Tax yield > 20K"),col=c(1,3,2,4),pch=20,bty="n",cex=0.8)

library(RColorBrewer)
palette(brewer.pal(n = 8, name = "Set1"))
tmp = palette()
palette(c("#000000",tmp))
tsne = Rtsne(data_zscore,dims = 2,normalize=F, pca = FALSE, verbose=TRUE,max_iter = 500,check_duplicates=F)
plot(tsne$Y,pch=20,main = "t-SNE (Z-Score Normalization)",col=1, xlab="tsne dim 1",ylab = "tsne dim 2",xlim=c(-25,20))
points(tsne$Y[audited,],col=3,pch=20)
points(tsne$Y[yield,],col=2,pch=20)
points(tsne$Y[yield2,],col=4,pch=20)
legend("topleft",c("All returns","Audited returns","Tax yield > 0","Tax yield > 20K"),col=c(1,3,2,4),pch=20,bty="n",cex=0.8)

pca_res = prcomp(data_quantile,center = F,scale. = F)
plot(pca_res$x[,1],pca_res$x[,2],pch=20,main="PCA (Quantile Normalization)",
     xlab=paste0("PC 1 (",format(summary(pca_res)[[6]][2,1]*100,digits = 2),"%)"),
     ylab=paste0("PC 2 (",format(summary(pca_res)[[6]][2,2]*100,digits = 2),"%)"))

audited = Return_Audit$CASE_ID != 0
yield = Return_Audit$TOPLINE_TAX > 0
yield2 = Return_Audit$TOPLINE_TAX > 20000
points(pca_res$x[audited,1],pca_res$x[audited,2],col=3,pch=20)
points(pca_res$x[yield,1],pca_res$x[yield,2],col=2,pch=20)
points(pca_res$x[yield2,1],pca_res$x[yield2,2],col=4,pch=20)
legend("topright",c("All returns","Audited returns","Tax yield > 0","Tax yield > 20K"),col=c(1,3,2,4),pch=20,bty="n",cex=0.8)

library(RColorBrewer)
palette(brewer.pal(n = 8, name = "Set1"))
tmp = palette()
palette(c("#000000",tmp))
tsne = Rtsne(data_quantile,dims = 2,normalize=F, pca = FALSE, verbose=TRUE,max_iter = 500,check_duplicates=F)
plot(tsne$Y,pch=20,main = "t-SNE (Quantile Normalization)",col=1, xlab="tsne dim 1",ylab = "tsne dim 2",xlim=c(-25,20))
points(tsne$Y[audited,],col=3,pch=20)
points(tsne$Y[yield,],col=2,pch=20)
yield2 = Return_Audit$TOPLINE_TAX > 20000
points(tsne$Y[yield2,],col=4,pch=20)
legend("topleft",c("All returns","Audited returns","Tax yield > 0","Tax yield > 20K"),col=c(1,3,2,4),pch=20,bty="n",cex=0.8)

library(clusternor)
xmeans_res = Xmeans(tsne$Y,200)

xmeans_res$cluster
plot(tsne$Y,pch=20,col=xmeans_res$cluster)
plot(tsne$Y,pch=20,col=1)

pval_cluster = numeric(max(xmeans_res$cluster))
hit_cluster = numeric(max(xmeans_res$cluster))
found_cluster = numeric(max(xmeans_res$cluster))
for (i in 1 : max(xmeans_res$cluster)){
    tmp = xmeans_res$cluster == i

    tmp_audited = audited & tmp
    tmp_yield = yield & tmp
    #white: hit
    #black: normal
    q = length(which(tmp_yield==T)) #white balls drawn from the urn without replacement
    m = length(which(yield==T)) #white balls in the urn
    n = length(which(yield==F & audited==T)) #black balls in the urn
    k = length(which(tmp_audited==T)) #balls drawn from the urn

    pval_cluster[i] = phyper(q,m,n,k,lower.tail = F)
    hit_cluster[i] = q
    found_cluster[i] = k
}

res = rbind(pval_cluster,hit_cluster,found_cluster,hit_cluster/found_cluster)
colnames(res) = 1:ncol(res)
res = res[,order(res[1,])]

tmp = xmeans_res$cluster == 18

tmp_audited = audited & tmp
tmp_yield = yield & tmp
tmp_yield2 = yield2 & tmp

plot(tsne$Y,pch=20,main = "tsne (Quantile Normalization)",col=1, xlab="tsne dim 1",ylab = "tsne dim 2")
points(tsne$Y[tmp,],col=5,pch=20)
points(tsne$Y[tmp_audited,],col=3,pch=20)
points(tsne$Y[tmp_yield,],col=2,pch=20)
points(tsne$Y[tmp_yield2,],col=4,pch=20)

plot(tsne$Y[tmp,],col=5,pch=20)
points(tsne$Y[tmp_audited,],col=3,pch=20)
points(tsne$Y[tmp_yield,],col=2,pch=20)
points(tsne$Y[tmp_yield2,],col=4,pch=20)

write.csv(cbind(Return_Audit,xmeans_res$cluster),"Return_Audit_Cluster.csv")

pval_col = numeric(length(numerical_features))
mean_out = numeric(length(numerical_features))
mean_in = numeric(length(numerical_features))
mean_out_raw = numeric(length(numerical_features))
mean_in_raw = numeric(length(numerical_features))
for(i in 1 : length(numerical_features)){

    val = data_quantile[,i]
    val_raw = data_normalized_grossSales[,i]
    boxplot(val_raw[!tmp],val_raw[tmp],main=colnames(data_quantile)[i],ylim=c(0,1))
    pval_col[i] = wilcox.test(val_raw[!tmp],val_raw[tmp],exact = T)[[3]]
    mean_out[i] = mean(val[!tmp])
    mean_in[i] = mean(val[tmp])
    mean_out_raw[i] = mean(val_raw[!tmp])
    mean_in_raw[i] = mean(val_raw[tmp])
}
res_comp = rbind(pval_col,mean_out,mean_in,mean_out_raw,mean_in_raw)
colnames(res_comp) = colnames(data_quantile)


library(e1071)

x <- seq(0, 7, by = 0.01)
y <- sin(x) + rnorm(x, sd = 0.1)

LModel<-lm(y~x)
summary(LModel)

plot(x, y)
abline(LModel)

PredLModel<- predict(LModel)

mse1 <- mean((y - PredLModel)^2)
mse1

SVModel <- svm(x, y)
summary(SVModel)

PredSVModel <- predict(SVModel)

mse2 <- mean((y - PredSVModel)^2)
mse2

plot(x, y)
points(x, PredSVModel)
abline(LModel)


#propogating worldclim2 uncertainty.
#1. prec model working great now. needed to sample more of the data. uncertainty increses with elevation. DONE.
###temperature- just stop fitting increasing variance with elevation. Fick seems fine with it. DONE.
#2. save these fits with more samples. DONE
#3. save summaries with variable names appended. DONE
#4. simulate variance or sd for an observation, given predicted and elevation. DONE.
#5. convert into a function.
#clear environment, load packages.
rm(list=ls())
library(runjags)

#load data
prec <- readRDS(wc_prec_raw_data.path)
temp <- readRDS(wc_temp_raw_data.path)

#subset prec for prelim fitting.
prec <- prec[sample(nrow(prec),20000),]
temp <- temp[sample(nrow(temp),10000),]

#prec_output.path
#temp_output.path

#plot(observed ~ predicted, data = prec, cex = 0.4, pch = 16, ylim = c(0,4000))

#setup runjags model. Same model for temperature and precipitation.
prec.model = "
model {
  #setup priors for model predictors.
  for(j in 1:N.preds){
    m[j] ~ dnorm(0, .0001) #flat uninformative priors.
  }

  #elevation affects uncertainty.
  #tau is still a function of sigma.
  #sigma is now a funtion of an intercept (as before) and elevation, with a parameter that gets fitted.
  k0 ~ dunif(0,100)
  k1 ~ dnorm(0, .0001)

  #fit a linear model
  #should be a way to store predictors as a list with an intercept.
  #then just multiply the m vector by the predictor list for the linear component of the model.
  for(i in 1:N){
    y.hat[i] <- m[1]*1 + m[2]*x[i]
    sigma[i] <- k0 + k1*elev[i]
      tau[i] <- pow(sigma[i], -2)
        y[i] ~ dnorm(y.hat[i], tau[i])
  }
} #close model loop.
"

#temperature model does not have an uncertainty that scales with elevation.
temp.model = "
model {
  #setup priors for model predictors.
  for(j in 1:N.preds){
    m[j] ~ dnorm(0, .0001) #flat uninformative priors.
  }

  #tau is still a function of sigma.
  #sigma is now a funtion of an intercept (as before) and elevation, with a parameter that gets fitted.
  sigma ~ dunif(0,100)
    tau <- pow(sigma, -2)

  #fit a linear model
  #should be a way to store predictors as a list with an intercept.
  #then just multiply the m vector by the predictor list for the linear component of the model.
  for(i in 1:N){
    y.hat[i] <- m[1]*1 + m[2]*x[i]
        y[i] ~ dnorm(y.hat[i], tau)
  }
} #close model loop.
"

#Setup data objects.
prec.data <- list(      y = prec$observed,
                        x = prec$predicted,
                     elev = prec$elev,
                        N = length(prec$observed),
                  N.preds = 2)
temp.data <- list(      y = temp$observed,
                        x = temp$predicted,
                        N = length(temp$observed),
                  N.preds = 2)

#pick starting values based on lm fits to help chain mixing and speed convergence.
start.prec <- list()
prec.freq <- lm(observed ~ predicted, data = prec)
start.prec[[1]] <- list(k0 = 47, k1 = 0.003, m = c(coef(prec.freq)))
start.prec[[2]] <- lapply(start.prec[[1]],'*',1.01)
start.prec[[3]] <- lapply(start.prec[[1]],'*',0.99)
start.temp <- list()
temp.freq <- lm(observed ~ predicted, data = temp)
start.temp[[1]] <- list(sigma = 1, m = c(coef(temp.freq)))
start.temp[[2]] <- lapply(start.temp[[1]],'*',1.01)
start.temp[[3]] <- lapply(start.temp[[1]],'*',0.99)

#fit precip model.
prec.out <- run.jags(prec.model,
                     data=prec.data,
                     adapt = 100,
                     burnin = 200,
                     sample = 400,
                     n.chains=3,
                     monitor=c('m','k0','k1'),
                     inits = start.prec)
summary(prec.out)
#plot(prec.out)

#fit temperature model.
temp.out <- run.jags(temp.model,
                       data = temp.data,
                      adapt = 100,
                     burnin = 300,
                     sample = 500,
                   n.chains = 3,
                    monitor = c('m','sigma'),
                      inits = start.temp
                     )
summary(temp.out)
plot(temp.out)

###check variance as a function of elevation###
#generate a single value of precip predicted at 101 different elevations.
d.pred <- data.frame(elevation = seq(0,1780, by = 17.8))
d.pred$predicted <- 1000

#grab parameter means and SD from precip model
parms <- summary(prec.out)[,4:5]

#sample from paramter distributions.
n.samps <- 100
out <- list()
for(i in 1:n.samps){
  #draw parameteres from distributions.
  m1 <- rnorm(1,parms[1,1],parms[1,2])
  m2 <- rnorm(1,parms[2,1],parms[2,2])
  k0 <- rnorm(1,parms[3,1],parms[3,2])
  k1 <- rnorm(1,parms[4,1],parms[4,2])

  #esitmate worldclim values based on parameter draws.
     sigma <- d.pred$elevation*k1 + k0
       tau <- sigma^-2
     y.hat <- m1 + m2*d.pred$predicted
         y <- rnorm(length(y.hat),y.hat, sigma)
  out[[i]] <- y
}
#summarize output and plot sd as a function of elevation.
out <- data.frame(do.call('rbind',out))
colnames(out) <- d.pred$elevation
d.pred$out.sd <- apply(out, 2, sd)
plot(d.pred$out.sd ~ d.pred$elevation)


setwd(dirname(rstudioapi::getActiveDocumentContext()$path))

df    <- read.table("../data/workshops.csv", h = T, sep = ";")
x     <- df$Instructor.s.pacing.within.allotted.time
x_avg <- tapply(x, df$ID, mean)

#### t-test & CI ---------------------------------------------------------------
t.test(x, mu = 1.5, alt = "greater")
t.test(x_avg, mu = 1.5, alt = "greater")

#### bootstrap -----------------------------------------------------------------
library(boot)

res <- boot(x, function(data, idx) { mean(data[idx]) }, R = m)
boot.ci(res, type = "perc", c(0.9, 0.95))

res <- boot(x_avg, function(data, idx) { mean(data[idx]) }, R = m)
boot.ci(res, type = "perc", c(0.9, 0.95))

#### 2-level bootstrap ---------------------------------------------------------
set.seed(1)
m <- 1000
n <- length(x_avg)
mus <- NULL

for (i in 1:m) {
  idx <- sample(1:n, n, rep = T)   # reasample workshops

  tmp <- c()

  for (j in idx) {   # resample scores
    x_tmp <- x[df$ID == j]
    z     <- sample(x_tmp, length(x_tmp), rep = T)
    y     <- c(tmp, mean(z))
  }

  mus <- rbind(mus, mean(y))
}

quantile(mus, p = c(0.05, 0.95))


# Example : 4.1A   Chapter : 4.1     Page No: 201
# Dimensions of the subspaces in the given space
dim_R<-9
dim_S<-6
print("Possible dimensions of the subspaces orthogonal to S")
x<-dim_R-dim_S
orthogonal_dimensions<-c(0:x)
print(orthogonal_dimensions)
print(paste("possible dimensions of orthogonal complement subspaces to S",dim_R-dim_S))
print(paste("The smallest matrix A in S is ",dim_S," by ",dim_R))
print(paste("The Null space matrix N is ",dim_R," by ",dim_R-dim_S))


library(npowerPrioR)
source("data_Gaussian.r")

gs.data <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = 1
)

###
get_l_a0_gaussian <- function(y0, n0, alpha0, beta0, m0, k0, a_0){
  nstar <- a_0 * n0
  ybar <- mean(y0)
  s <- mean( (y0-ybar)^2 )
  kappa_n <- k0 + nstar
  alpha_n <- alpha0 + nstar/2
  beta_n <- beta0 + .5 * (nstar * s +  (k0 * nstar * (ybar - m0)^2 )/kappa_n )
  ans <- lgamma(alpha_n)-lgamma(alpha0)
  ans <- ans + alpha0 * log(beta0) - alpha_n * log(beta_n)
  ans <- ans + .5 *( log(k0) - log(kappa_n) )-nstar/2 * log(2*pi)
  return(ans)
}
############
l_a0 <- function(x) {
  get_l_a0_gaussian(
    y0 = gs.data$y0,
    n0 = gs.data$N0,
    alpha0 = gs.data$alpha0,
    beta0 = gs.data$beta0,
    m0 = gs.data$mu0,
    k0 = gs.data$kappa0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
###
l_a0_p <- function(x) numDeriv::grad(l_a0, x)
l_a0_p <- Vectorize(l_a0_p)
l_a0_pp <- function(x) numDeriv::hessian(l_a0, x)
l_a0_pp <- Vectorize(l_a0_pp)

####################
J <- 20
maxA <- 10

## Importing
uniform.ca0.estimates <- read.csv(paste("../../data/constant_data/Gaussian_logCA0_uniform", "_J=", J, ".csv", sep = ""))
adaptive.ca0.estimates <- read.csv(paste("../../data/constant_data/Gaussian_logCA0_adaptive", "_J=", J, ".csv", sep = ""))
adaptive.ca0.estimates.derivOnly <- read.csv(paste("../../data/constant_data/Gaussian_logCA0_adaptive_derivOnly", "_J=", J, ".csv", sep = ""))

####
## Plotting the curves l(a_0) and derivatives

curve(l_a0_p, 0, 10, lwd = 3, lty = 2, col = 2,
      # ylim = c(-30, 60),
      ylab = "", xlab = expression(a[0]), cex.lab = 3, cex.axis = 2.5)
abline(h = 0, lwd = 2 , lty = 3)
curve(l_a0, 0, 10, lwd = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$lc_a0, cex = 1.5, pch = 16)
curve(l_a0_pp, 0, 10, lwd = 3, col = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$second_deriv_lc, cex = 1.5, col = 3, pch = 16)
legend(x = "bottomright", legend = c("l(a_0)", "l'(a_0)", "l''(a_0)"),
       col = 1:3, lwd = 2, bty = 'n', cex = 1.5)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$deriv_lc,
       pch = 16, cex = 1.5, col = 2)

#######

fit.gam.uniform <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = uniform.ca0.estimates)
fit.gam.adaptive <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)
deriv.gam.fit <- mgcv::gam(deriv_lc ~ s(a0, k = J + 1), data = adaptive.ca0.estimates.derivOnly)

########################
K <- 20000
pred_a0s <- seq(0, maxA, length.out = K)

preds.gam.uniform  <- get_band(fit.gam.uniform, xpred = pred_a0s)
preds.gam.adaptive  <- get_band(fit.gam.adaptive, xpred = pred_a0s)
deriv.preds <- cumsum(predict(deriv.gam.fit, newdata = data.frame(a0 = pred_a0s))) * diff(pred_a0s)[1]

true.lca0s <- l_a0(pred_a0s)
gam.preds.list <- list(
  uniform =  data.frame (a0 = pred_a0s, lca0 = preds.gam.uniform$mean, lwr = preds.gam.uniform$lwr,
                         upr = preds.gam.uniform$upr, approximating_function = "gam", design = "uniform"),
  adaptive =  data.frame (a0 = pred_a0s, lca0 = preds.gam.adaptive$mean, lwr = preds.gam.adaptive$lwr,
                          upr = preds.gam.adaptive$upr, approximating_function = "gam", design = "adaptive"),
  derivative = data.frame (a0 = pred_a0s, lca0 = deriv.preds, lwr = NA, upr = NA,
                           approximating_function = "numerical", design = "adaptive_numerical")
)

l_a0(.15)
predict(fit.gam.uniform, newdata = data.frame(a0 = .15))
predict(fit.gam.adaptive, newdata = data.frame(a0 = .15))

l_a0(.75)
predict(fit.gam.uniform, newdata = data.frame(a0 = .75))
predict(fit.gam.adaptive, newdata = data.frame(a0 = .75))

l_a0(5)
predict(fit.gam.uniform, newdata = data.frame(a0 = 5))
predict(fit.gam.adaptive, newdata = data.frame(a0 = 5))

## RMSE
lapply(gam.preds.list, function(pred) sqrt(mean( (pred$lca0 - true.lca0s)^2 )) )
## MAD
lapply(gam.preds.list, function(pred) mean( abs(pred$lca0 - true.lca0s) ))

## RMSE, a0 < 1
lapply(gam.preds.list, function(pred) sqrt(mean( (pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1])^2 )) )
## MAD, a0 < 1
lapply(gam.preds.list, function(pred) mean( abs(pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1]) ))

forplot_ca0 <- do.call(rbind, gam.preds.list)

write.csv(forplot_ca0,
          file = paste("../data/constant_data/fitted_predictions_lca0_Gaussian", "_J=", J, ".csv", sep = ""),
          row.names = FALSE)

library(ggplot2)

p0 <- ggplot(data = forplot_ca0, aes(x = a0, y = lca0, colour = design, fill = design)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  stat_function(fun = l_a0, linetype = "dashed", size = 1.2, colour = "black") +
  geom_point(data = adaptive.ca0.estimates,
             mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 16)
p0

p0b <- ggplot(data = subset(forplot_ca0, a0 < 1 & design != "uniform"), aes(x = a0, y = lca0, colour = design, fill = design)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  stat_function(fun = l_a0, linetype = "dashed", size = 1.2, colour = "black") +
  geom_point(data = subset(adaptive.ca0.estimates, a0 < 1),
             mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  scale_x_continuous(expression(a[0]), limits = c(0, 1)) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 16)
p0b

plot(pred_a0s, (true.lca0s-preds.gam.adaptive$mean))
plot(pred_a0s, (true.lca0s-deriv.preds))

ggsave(p0, filename = paste("../../figures/estimates_log_ca0_Gaussian_J=", J, ".pdf", sep = ""), dpi = 300)

ggsave(p0b, filename = paste("../../figures/estimates_log_ca0_Gaussian_restricted_J=", J, ".pdf", sep = ""), dpi = 300)


source("examples/slice.r")

mcmc <- function(x,g,method,niter=1000) {
  samples <- rep(0,niter)
  gx <- g(x)
  for (iter in 1:niter) {
    x <- method(x,g,gx)
    samples[iter] <- x
    gx <- attr(x,"log.density")
  }
  return(samples)
}

g <- function(x) dnorm(x,0,.5)
h <- function(x) dnorm(x,-1,.35) + 2*dnorm(x,1,.5) + 1.5*dnorm(x,2,.25)

lg <- function(x) log(g(x))
lh <- function(x) log(h(x))

slice <- function(x,g,gx) {
  uni.slice.alt(x,g,w=.5,m=10000,gx0=gx)
}

# Time 10000 iterations from slice sampler and save results for g and h
print(system.time(samples <- mcmc(0,lg,slice,niter=10000)))
write.csv(samples,file="examples/results/r.slice.g.dat",row.names=FALSE)

print(system.time(samples <- mcmc(0,lh,slice,niter=10000)))
write.csv(samples,file="examples/results/r.slice.h.dat",row.names=FALSE)


knapsack<- function(Value, Weight, Objects, Capacity){
  Fraction = rep(0, length(Value))
  Cost = Value/Weight
  #print(Cost)
  W = Weight[order(Cost, decreasing = TRUE)]
  Obs = Objects[order(Cost, decreasing = TRUE)]
  Val = Value[order(Cost, decreasing = TRUE)]
  #print(W)
  RemainCap = Capacity
  i = 1
  n = length(Cost)
  if (W[1] <= Capacity){
    Fits <- TRUE
  }
  else{
    Fits <- FALSE
  }
  while (Fits && i <= n ){
    Fraction[i] <- 1
    RemainCap <- RemainCap - W[i]
    i <- i+1
    #print(RemainCap)
    if (W[i] <= RemainCap){
      Fits <- TRUE
    }
    else{
      Fits <- FALSE
    }
  }
  #print(RemainCap)
  if (i <= n){
    Fraction[i] <- RemainCap/W[i]
  }
  names(Fraction) = Obs
  Quantity_to_take = W*Fraction
  Total_Value = sum(Val*Fraction)
  print("Fraction of available quantity to take:")
  print(round(Fraction, 3))
  print("KG of each to take:")
  print(Quantity_to_take)
  print("Total value of tasty meats:")
  print(Total_Value)
}


library("ggplot2")
library("manipulate")

# Tax function - using 2020 single filers tax brackets
BRACKETS <- list(rate=c(0.1, 0.12, 0.22, 0.24, 0.32, 0.35, 0.37),
                 cutoffs=c(9875, 40125, 85525, 163300, 207350, 518400, Inf))

clip <- function(vec, LB=0, UB=10) pmax( LB, pmin( vec, UB))
shift <- function(x, by) c(rep(0,times=by), x[1:length(x) - by])

tax_bracket_fn_helper <- function(income) {
  lb <- shift(BRACKETS$cutoffs, 1)
  ub <- BRACKETS$cutoffs
  if (income == 0) {
    BRACKETS$rate[1]
  } else {
    bracket_mask <- (income >  lb) & (income <= ub)
    stopifnot(sum(bracket_mask) == 1)
    BRACKETS$rate[[which(bracket_mask == TRUE)]]
  }
}
tax_bracket_fn <- Vectorize(tax_bracket_fn_helper)

avg_tax_fn_helper <- function(income) {
  lb <- shift(BRACKETS$cutoffs, 1)
  ub <- BRACKETS$cutoffs
  if (income == 0) {
    BRACKETS$rate[1]
  } else {
    (BRACKETS$rate %*% (clip(income, LB=lb, UB=ub) - lb)) / income
  }
}
avg_tax_fn <- Vectorize(avg_tax_fn_helper)

objective <- function(d_t, fund_limit, contribution_limit, interest_rate, income, n_invest_years, n_retirement_years) {
  r <- interest_rate
  n.i <- n_invest_years
  n.r <- n_retirement_years
  Rd <- r * (1 - r^n.i) / (1 - r) * r^n.r
  Rw <- r * (1 - r^n.r) / (1 - r)

  I <- income
  L <- fund_limit
  C <- contribution_limit

  mu <- Rd / Rw
  beta <- 1 - avg_tax_fn(d_t * mu)
  alpha <- 1 - avg_tax_fn(I - d_t)

  d_r <- pmin(L- d_t, (C - d_t) / alpha)
  beta * d_t * mu + d_r * alpha * mu
}

CONTRIBUTION_LIMIT <- 6e3
FUND_LIMIT <- 7e3
INTEREST_RATE <- 1.08
INCOME <- 1e5
START_INVEST_AGE <- 22
START_RETIREMENT_AGE <- 60
DEATH_AGE <- 100
manipulate(plot(1:5, cex=size), size = slider(0.5,10,step=0.5))
generate_plot <- function(fund_limit, interest_rate, income, start_invest_age, start_retirement_age, death_age) {
  traditional_deposit <- 0:min(CONTRIBUTION_LIMIT, fund_limit)
  n.i <- start_retirement_age - start_invest_age
  n.r <- death_age - start_retirement_age
  withdrawals <- objective(traditional_deposit, fund_limit, CONTRIBUTION_LIMIT, interest_rate, income, n.i, n.r)

  data <- data.frame(traditional_deposit = traditional_deposit, retirement_value = withdrawals)
  ggplot(data=data, mapping=aes(x=data$traditional_deposit, y=data$retirement_value)) + geom_line() +
    xlab("Traditional Deposit ($/yr)") + ylab("Total Withdrawals - Roth and Trad ($/yr)")
}

manipulate(
  generate_plot(fund_limit=fund_limit, interest_rate=interest_rate, income=income, start_invest_age=start_invest_age, start_retirement_age = start_retirement_age, death_age = death_age),
  fund_limit=slider(0, 2e4, initial = FUND_LIMIT),
  interest_rate=slider(0.5, 2.0, initial = INTEREST_RATE),
  income=slider(0, 1e6, initial = INCOME),
  start_invest_age=slider(18, 59, initial = START_INVEST_AGE),
  start_retirement_age=slider(60, 99, initial = START_RETIREMENT_AGE),
  death_age=slider(70, 120, initial=DEATH_AGE))


#server.r
rascha <- function(person, item, a) {
  exp(a*(person - item))/(1 + exp(a*(person - item)))
}

persons <- seq(-3, 3, by = .1)
b <- -3:3
a <- -3:3

data_full <- NULL
for(i in 1:length(b)){
  data <- matrix(nrow = length(persons), ncol = length(a))
  for(j in 1:length(a)){
    data[,j] <- rascha(persons, b[i], a[j])
  }
  data_full <- cbind(data_full,data)
}
x <- NULL
for(i in 1:length(b)){
  tmp <- paste(b[i], a, sep = "")
  x <- append(x, tmp)
}
colnames(data_full) <- x

shinyServer(
  function(input,output){
    output$twopl <- renderPlot({
      qplot(y = data_full[,paste(input$diff, input$disc, sep = "")], x = persons, geom = "line") + ylab("Probability of Getting Item Correct") + xlab("Person Ability") + coord_cartesian(ylim = c(0, 1), xlim = c(-3, 3)) + geom_vline(xintercept = as.numeric(input$diff), colour = "red", linetype = "longdash")
    })

  })


nums <- c(2,4,3,1,2)
sorted <- sort(nums)


class_update_train_ndp <- function(n, K , alpha, name_new, uniq_clabs, clabs,
                         y, x, x_cat_shell, x_num_shell,
                         cat_idx, num_idx,
                         beta_shell,  psi_shell,
                         beta_new, psi_new, cat_new, num_new){

  # shells
  c_shell <- matrix(NA, nrow = n, ncol = K + 1)
  colnames(c_shell) <- c(uniq_clabs, name_new)

  ## prior for existing cluster
  pr_exist <- matrix(NA, nrow = n, ncol = K)
  colnames(pr_exist) <- uniq_clabs

  pr_new <- numeric(length = n)

  clabs <- factor(clabs, levels = uniq_clabs)
  for(j in 1:n){
    n_min_j <- table(clabs[-j] )
    pr_exist[j,] <- log( (alpha*(n_min_j==0) + n_min_j)/(j + alpha - 1) )
    pr_new[j] <-  log( (alpha) / (j + alpha - 1) )
  }

  ## existing clusters
  for(k in uniq_clabs){

    lk_exist <- numeric(length = n)

    for(p in cat_idx){
      lk_exist <- lk_exist + dbinom(x[ ,p], 1, x_cat_shell[[p]][1,k], T)
    }

    for(p in num_idx){
      lk_exist <- lk_exist + dnorm(x[, p],
                                   x_num_shell[[p]][[1]][,k],
                                   sqrt(x_num_shell[[p]][[2]][,k]), T )
    }

    lk_exist <- lk_exist + dnorm(x = y,
                                 mean = x %*% beta_shell[,k, drop=F],
                                 sd = sqrt(psi_shell[,k]), T)

    c_shell[,k] <- lk_exist + pr_exist[,k]
  }

  ## New clusters
  lk_new <- numeric(length = n)

  for(p in cat_idx){
    lk_new <- lk_new + dbinom(x[ ,p], 1, cat_new[p], T)
  }

  for(p in num_idx){
    lk_new <- lk_new + dnorm(x[, p], num_new[1,p], sqrt(num_new[2,p]), T)
  }

  lk_new <- lk_new + dnorm(x = y,
                           mean = x %*% t(beta_new),
                           sd = sqrt(psi_new), T)

  c_shell[,name_new] <- lk_new + pr_new

  weights <- t(apply(c_shell, 1, function(x) exp(x)/sum(exp(x))  ))

  return(weights)
}

class_update_test_ndp <- function(n, K , alpha, name_new, uniq_clabs, clabs, x,
                             x_cat_shell, x_num_shell,
                             cat_idx, num_idx,
                             cat_new, num_new){

  # shells
  c_shell <- matrix(NA, nrow = n, ncol = K + 1)
  colnames(c_shell) <- c(uniq_clabs, name_new)

  ## prior for existing cluster
  clabs <- factor(clabs, levels = uniq_clabs)
  pr_exist <- log(table(clabs)/(length(clabs)+alpha))

  ## existing clusters
  for(k in uniq_clabs){

    lk_exist <- numeric(length = n)

    for(p in cat_idx){
      lk_exist <- lk_exist + dbinom(x[ ,p], 1, x_cat_shell[[p]][1,k], T)
    }

    for(p in num_idx){

      lk_exist <- lk_exist + dnorm(x[, p],
                                   x_num_shell[[p]][[1]][,k],
                                   sqrt(x_num_shell[[p]][[2]][,k]), T )
    }

    c_shell[,k] <- lk_exist + pr_exist[k]
  }

  ## New clusters
  lk_new <- numeric(length = n)

  for(p in cat_idx){
    lk_new <- lk_new + dbinom(x[ ,p], 1, cat_new[p], T)
  }

  for(p in num_idx){
    lk_new <- lk_new + dnorm(x[, p], num_new[1,p], sqrt(num_new[2,p]), T)
  }

  c_shell[,name_new] <- lk_new + log(alpha/(length(clabs)+alpha))

  weights <- t(apply(c_shell, 1, function(x) exp(x)/sum(exp(x))  ))

  return(weights)
}

post_pred_draw_train_ndp <- function(n, x, pc, beta_shell, psi_shell){

  y_pp <- numeric(length = n)

  clabs <- unique(pc)

  for( k in clabs ){
    y_pp[pc==k] <- rnorm(n = sum(pc==k),
                         mean = x[pc==k,, drop=F] %*% beta_shell[,k,drop=F],
                         sd = sqrt(psi_shell[1,k]) )
  }

  return(y_pp)
}

post_pred_draw_test_ndp <- function(n, x, pc, beta_shell, psi_shell,
                           name_new, beta_new, psi_new){

  y_pp <- numeric(length = n)

  clabs <- unique(pc)

  for( k in setdiff(clabs, name_new) ){
    y_pp[pc==k] <- rnorm(n = sum(pc==k),
                         mean = x[pc==k,, drop=F] %*% beta_shell[,k,drop=F],
                         sd = sqrt(psi_shell[1,k]) )
  }

  y_pp[pc==name_new] <- rnorm(n = sum(pc==name_new),
                       mean = x[pc==name_new,, drop=F] %*% t(beta_new),
                       sd = sqrt(psi_new) )

  return(y_pp)
}


library('nonpar')
library('DescTools')

#Psycho Experiments
method_a_ss_psycho <- matrix(c(49, 9, 16, 35, 63, 29, 40, 25, 64), 3,3)
method_b_ss_psycho <- as.table(matrix(c(49, 9, 16, 35, 63, 29, 40, 25, 64), nrow=3))
stuart.maxwell(method_a_ss_psycho)
StuartMaxwellTest(method_b_ss_psycho)


a <- c(0.4,0.3,0.2,0.1)
b <- c(0.1,0.4,0.3,0.2)
c <- c(0.1,0.2,0.4,0.3)
d <- c(0.1,0.2,0.3,0.4)

a <- c(0.7,0.1,0.1,0.1)
b <- c(0.1,0.7,0.1,0.1)
c <- c(0.1,0.1,0.7,0.1)
d <- c(0.1,0.1,0.1,0.7)

a <- c(0.4,0.1,0.2,0.3)
b <- c(0.3,0.4,0.1,0.2)
c <- c(0.2,0.3,0.4,0.1)
d <- c(0.1,0.2,0.3,0.4)

a <- c(0.4,0.3,0.2,0.1)
b <- c(0.25,0.25,0.25,0.25)
c <- c(0.25,0.25,0.25,0.25)
d <- c(0.25,0.25,0.25,0.25)

a <- c(0.7,0.1,0.1,0.1)
b <- c(0.1,0.6,0.2,0.1)
c <- c(0.1,0.1,0.6,0.2)
d <- c(0.1,0.1,0.2,0.6)

a <- c(0.4,0.3,0.2,0.1)
b <- c(0.3,0.4,0.2,0.1)
c <- c(0.2,0.3,0.4,0.1)
d <- c(0.1,0.2,0.3,0.4)

s <- c(0.25,0.25,0.25,0.25)
s <- c(0.1,0.2,0.3,0.4)
s <- t(as.matrix(s))
t <- rbind(a,b,c,d)
result = s
for(i in 1:100){
        s = s%*%t
        result = rbind(result,s)
}
n = 1:101
plot(result[,1]~n,type = 'l',ylim = c(0,0.4))
lines(result[,2]~n,col = 'red')
lines(result[,3]~n,col = 'green')
lines(result[,4]~n,col = 'blue')

result[101,]


## 2. Quantitative and Qualitative Variables ##

library(readr)
wnba <- read_csv("wnba.csv")

# variables <- c("Three_PA", "Age", "AST", "Birth_Place", "Birthdate", "BMI", "College",
#                "DREB", "Experience", "FGA", "FGM", "FT_perc", "FTA", "FTM", "Games_Played",
#                "Height", "MIN", "Name", "OREB", "Pos", "PTS", "REB", "Team", "Weight")
qualitative_vars <- c("Birth_Place", "College", "Name", "Pos", "Team")

quantitative_vars <- c("Three_PA", "Age", "AST", "Birthdate", "BMI", "DREB", "Experience",
                       "FGA", "FGM", "FT_perc", "FTA", "FTM", "Games_Played", "Height",
                       "MIN", "OREB", "PTS", "REB", "Weight")

qualitative_vars <- sort(qualitative_vars)
quantitative_vars <- sort(quantitative_vars)

## 4. The Nominal Scale ##

# variables <- c("Three_PA", "Age", "AST", "Birth_Place", "Birthdate",
#                "BMI", "College", "DREB", "Experience", "FGA",
#                "FGM", "FT_perc", "FTA", "FTM", "Games_Played",
#                "Height", "MIN", "Name", "OREB", "Pos",
#                "PTS", "REB", "Team", "Height_labels")
nominal_scale <- sort(c("Name", "Team", "Pos", "Birth_Place", "College"))

## 5. The Ordinal Scale ##

question_1 <- TRUE
question_2 <- FALSE
question_3 <- FALSE
question_4 <- TRUE
question_5 <- FALSE
question_6 <- FALSE

## 7. The Difference Between Ratio and Interval Scales ##

# quantitative_vars <- c("Three_PA", "Age", "AST", "Birthdate", "BMI", "DREB", "Experience",
#                        "FGA", "FGM", "FT_perc", "FTA", "FTM", "Games_Played", "Height",
#                        "MIN", "OREB", "PTS", "REB", "Weight", "Weight_deviation")
interval_scale <- sort(c("Birthdate", "Weight_deviation"))
ratio_scale <- sort(c("Three_PA", "Age", "AST", "BMI", "DREB", "Experience", "FGA", "FGM", "FT_perc", "FTA", "FTM",
                "Games_Played", "Height", "MIN", "OREB", "PTS", "REB", "Weight"))

## 9. Discrete and Continuous Variables ##

# ratio_scale <- sort(c("Three_PA", "Age", "AST", "BMI", "DREB", "Experience", "FGA", "FGM", "FT_perc", "FTA", "FTM",
#                 "Games_Played", "Height", "MIN", "OREB", "PTS", "REB", "Weight"))
continuous <- sort(c("Age", "BMI", "Experience", "FT_perc", "Height", "MIN", "Weight"))
discrete <- sort(c("Three_PA", "AST", "DREB", "FGA", "FGM", "FTA", "FTM", "Games_Played", "OREB", "PTS", "REB"))

## 10. Real Limits ##

# bmi <- list(
#   "21.201" = c(, ),
#   "21.329" = c(, ),
#   "23.875" = c(, ),
#   "24.543" = c(, ),
#   "25.469" = c(, ))
bmi <- list(
  "21.201" = c(21.2005, 21.2015),
  "21.329" = c(21.3285, 21.3295),
  "23.875" = c(23.8745, 23.8755),
  "24.543" = c(24.5425, 24.5435),
  "25.469" = c(25.4685, 25.4695))

bmi

Data Analyst in R/Step 5 - Probability and Statistics/1. Statistics Fundamentals in R/3. Variables in Statistics.r


# required package installation
install.packages("quantmod")
library(quantmod)
install.packages("tidyquant")
library(tidyquant)
install.packages("tidyverse")
library(tidyverse)
install.packages("corrplot")
library(corrplot)
install.packages("datasets")
install.packages("forecast")
install.packages("graphics")
install.packages("stats")
install.packages("tseries")
library(forecast)
library(graphics)
library(stats)
library(tseries)
library(datasets)
library(forecast)

#setwd("D:/GitHub/portfolio/tracker")
getmysymbols<-function(x) {getSymbols(x,src = "yahoo",from="2017-01-30",to=as.Date(today()),auto.assign = FALSE,complete_cases = FALSE)}
getSymbols("TATAMOTORS.NS", src="yahoo")
tickers<-c("TATAMOTORS.NS")
x<-na.omit(TATAMOTORS.NS)
x
prices_adj<-lapply(tickers[TATAMOTORS.NS],getmysymbols)%>%map(Ad)%>%reduce(merge.xts)
prices_adj
head(prices_adj)
tail(prices_adj)
install.packages("zoo")
library(zoo)
table(unlist(lapply(prices_adj,class)))
plot(prices_adj)
summary(prices_adj)
tsdata<-ts(x,frequency=12)
tsdata
autoplot(tsdata)
x<-log(tsdata)
x
subset_tsdata<-window(tsdata)
subset_tsdata
as.numeric(subset_tsdata)
decompose(subset_tsdata)
y<-as.vector(tsdata)
y
#1)open ,2.close,3.high, 4. low,5. volume,6. adjusted
tata_closeprices<-TATAMOTORS.NS[,4]
tata_closeprices
plot(tata_closeprices)
acf(y)
pacf(y)
adf.test(y)
y<-diff(tsdata)
y
ndiffs(tsdata)

install.packages('fpp2', dependencies = FALSE)
install.packages("remotes")
remotes::install_github("robjhyndman/fpp2-package")
set.seed(10)
y<-ts(rnorm(100))
y
library(fpp2)
opar<-par(no.readonly = FALSE)
par(mfrow=c(2,3))
#par(opar)
ylim<-c(min(x),max(x))
summary(tsdata)
plot(x, main="raw time series")
plot(ma(x,3),main="simple moving average(k=3)",ylim=ylim)
plot(ma(x,7),main="simple moving average(k=7)",ylim=ylim)
plot(ma(x,13),main="simple moving average(k=13)",ylim=ylim)
S<-ma(x,order=16)
S
plot(S)
plot(forecast(S,5))

table(unlist(lapply(x,class)))
plot.ts(x[,c(2)])
acf(x,lag.max = 20)
class(x)
install.packages("xts")
library(xts)
fita<-auto.arima(tata_closeprices,seasonal = FALSE)
tsdisplay(residuals(fita),lag.max = 40,main = "(0,1,1) residual model")
auto.arima(tata_closeprices,seasonal = FALSE)

fitA<-arima(tata_closeprices,order = c(5,1,4))
tsdisplay(residuals(fitA),lag.max = 40,main = "(5,2,4) residual model")
fitB<-arima(tata_closeprices,order = c(3,1,4))
tsdisplay(residuals(fitB),lag.max = 40,main = "(3,1,4) residual model")
fitC<-arima(tata_closeprices,order = c(3,1,3))
tsdisplay(residuals(fitC),lag.max = 40,main = "(3,1,3) residual model")
opar<-par(no.readonly = FALSE)
par(mfrow=c(2,2))
term<-5000
fcast1<-forecast(fitA,5,h=term)
plot(fcast1,ylab = "stock price",main = "Arima model of the tata motors")
fcast2<-forecast(fitB,5,h=term)
plot(fcast2)
fcast3<-forecast(fitC,5,h=term)
plot(fcast3)


library(boot)

T <- 1000
t = 1
X <- vector(length = T)
Y <- vector(length = T)
X[0] <- rnorm(0)
Y[0] <- rnorm(0)
while (t < T) {
    t = t + 1
    Y[t] <- 0.5*Y[t-1] + rnorm(1)
    X[t] <- 0.5*X[t-1] + rnorm(1)
}

xy <- data.frame(data$X, data$Y)

n = T
Brep = 10000

X <- vector(length = T)
Y <- vector(length = T)
T = 1000
nboot = 1000
p_valores = array(0, nboot)
for(boot in 1:nboot) {
	t = 1
	X[0] <- rnorm(0)
	Y[0] <- rnorm(0)
	while (t < T) {
		t = t + 1
		Y[t] <- 0.5*Y[t-1] + rnorm(1)
		X[t] <- 0.5*X[t-1] + rnorm(1)
	}

	rr <- correlations(X, Y)
	p_valores[boot] <- rr$p

}

# Bootstrap the Pearson correlation coefficient

pearson <- function(d,i=c(1:n)){
        d2 <- d[i,]
        return(cor(d2$X,d2$Y))
     }
bootcorr <- boot(data=data,statistic=pearson,R=Brep)

correlations <- function(x, y, block=10, nboot=1000) {

	orig <- cor(x,y)
	distr <- array(0, nboot)

	for(boot in 1:nboot) {

		nblock <- length(x)/block

		tmpx <- sample(seq(1:(length(x)-block)), size=nblock, replace=TRUE)
		tmpy <- sample(seq(1:(length(y)-block)), size=nblock, replace=TRUE)

		x.b <- 0
		y.b <- 0

		for(i in 1:nblock) {
			x.b <- c(x.b, x[tmpx[i]:(tmpx[i]+block-1)])
			y.b <- c(y.b, y[tmpy[i]:(tmpy[i]+block-1)])
		}
		distr[boot] <- cor(x.b, y.b)
	}

	p <- length(which(abs(distr) >= abs(orig)))/nboot

    my_return <- list('p' = p, 'distr' = distr)

	return (my_return)
}

X <- vector(length = T)
Y <- vector(length = T)
T = 1000
nboot = 1000
p_valores = array(0, nboot)
for(boot in 1:nboot) {
	t = 1
	X[0] <- rnorm(0)
	Y[0] <- rnorm(0)
	while (t < T) {
		t = t + 1
		Y[t] <- 0.5*Y[t-1] + rnorm(1)
		X[t] <- 0.5*X[t-1] + rnorm(1)
	}
	rr <- correlations(X, Y)
	p_valores[boot] <- rr$p
}

hist(p_valores)


 ZGELSS Example Program Results

 Least squares solution
 ( 1.1673,-3.3222) ( 1.3480, 5.5028) ( 4.1762, 2.3434) ( 0.6465, 0.0105)

 Tolerance used to estimate the rank of A
      1.00E-02
 Estimated rank of A
      3

 Singular values of A
      2.9979     1.9983     1.0044     0.0064


## utilities for manipulating positions

radec2hms <- function(...) {
  radec <- unlist(list(...))
  dec <- radec[2]
  ra <- radec[1]/15
  ra.h <- trunc(ra)
  ra <- 60*(ra-ra.h)
  ra.m <- trunc(ra)
  ra.s <- 60*(ra-ra.m)
  ds <- sign(dec)
  dec.d <- trunc(dec)
  dec <- 60*abs(dec-dec.d)
  dec.m <- trunc(dec)
  dec.s <- 60*(dec-dec.m)
  cat(paste(ra.h, ra.m, format(ra.s, digits=2),sep=":"))
  if (ds >= 0) cat(" +") else cat(" -")
  cat(paste(dec.d, dec.m, format(dec.s, digits=1), sep=":"), "\n")
}

hms2radec <- function(...) {
  radec <- unlist(list(...))
  nr <- length(radec)/2
  radec <- matrix(radec,nr,2)
  ra <- radec[,1]
  dec <- radec[,2]
  ra.h <- trunc(ra)
  ra <- 100*(ra-ra.h)
  ra.m <- trunc(ra)
  ra.s <- 100*(ra-ra.m)
  ra.d <- 15*(ra.h + ra.m/60 + ra.s/3600)
  dec.sign <- sign(dec)
  dec <- abs(dec)
  dec.d <- trunc(dec)
  dec <- 100*abs(dec-dec.d)
  dec.m <- trunc(dec)
  dec.s <- 100*(dec-dec.m)
  dec.d <- dec.sign*(dec.d+dec.m/60+dec.s/3600)
  list(ra=ra.d, dec=dec.d)
}

lb2radec <- function(...) {
  rotm <- matrix(c(-.054876, -.873437, -.483835,
        .494109, -0.444830, .746982,
        -0.867666, -0.198076, 0.455984), 3, 3)
  lb <- unlist(list(...))
  nr <- length(lb)/2
  lb <- matrix(lb, nr, 2)
  l <- pi*lb[,1]/180
  b <- pi*lb[,2]/180
  x.lb <- rbind(cos(b)*cos(l), cos(b)*sin(l), sin(b))
  x.ad <- rotm %*% x.lb
  a <- atan2(x.ad[2,], x.ad[1,])
  a[a<0] <- 2*pi+a[a<0]
  d <- asin(x.ad[3,])
  ad <- data.frame(ra=a*180/pi, dec=d*180/pi)
  ad
}

radec2lb <- function(...) {
    rotm <- t(matrix(c(-.054876, -.873437, -.483835,
        .494109, -0.444830, .746982,
        -0.867666, -0.198076, 0.455984), 3, 3))
    radec <- unlist(list(...))
    nr <- length(radec)/2
    radec <- matrix(radec,nr,2)
    ra <- pi*radec[,1]/180
    dec <- pi*radec[,2]/180
    x.ad <- rbind(cos(ra)*cos(dec),sin(ra)*cos(dec),sin(dec))
    x.lb <- rotm %*% x.ad
    l <- atan2(x.lb[2,], x.lb[1,])
    l[l<0] <- 2*pi+l[l<0]
    b <- asin(x.lb[3,])
    lb <- data.frame(l=180*l/pi, b=180*b/pi)
    lb
}


# A whole bunch more about atomic vectors
#10 Feb 2022
#RCS

#How to create an empty vector + add to it (DON'T DO THIS)

z <- vector(mode = 'numeric', length = 0)
z
c(z,5)
z <- c(z,5)
print(z)

#create a vector of predetermined length (DO THIS INSTEAD)
#create a vector of 100 zeroes

z <- rep(0,100)
head(z)
tail(z)

#better to build a vector of NAs
z <- rep(NA,100)
head(z)
typeof(z)
z[1] <- 'Washington'
typeof(z)

my_vector <- runif(1000)
head(my_vector)
my_names <- paste('Species',seq(1:length(my_vector)), sep='_')
head(my_names)

names(my_vector) <- my_names
head(my_vector)

#using rep to repeat elemetns and create vectors
rep(0.5,6) #give the element/vector + the number of times to repeat it

rep(x=0.5,times=6) #same function, but a bit more readable
rep(time=6,x=0.5)
rep(6,0.5) #doesn't work
my_vec <- c(1,2,3)
rep(x=my_vec,times=2)
rep(x=my_vec,each=2)
rep(x=my_vec, times=my_vec)
rep(x=my_vec,each=my_vec)

#use seq function to create regular sequences
seq(from=2, to=1)
2:4
4:2
seq(from=2,to=4,by=0.5)
seq(from=2,to=4,length=7)
my_vec <- 1:length(z)
seq_along(my_vec)
seq_len(100)

#Random numbers in r
#uniform distribution
runif(5) #generates 5 random numbers along a uniform distribution between 0 and 1
runif(n=3,min=100,max=110) #generates 3 random numbers between 100 and 110
#normal distribution
rnorm(6) #generates 6 numbers on a normal dist w/ mean = 0 and sd =1
rnorm(n=5,mean=100,sd=30)
library(ggplot2)
z <- runif(1000)
qplot(x=z) #hist of z
z <- rnorm(1000)
qplot(x=z)

#sample r.v's from a vector
long_vec <- seq_len(10)
typeof(long_vec)
sample(long_vec)
sample(x=long_vec,size=3)
sample(x=long_vec,size=3,replace=TRUE)
dice <- 1:6
sample(x=dice,size=1)
my_weights <- c(1,1,1,1,10,10)
equal_weights <- rep(1,6)
sample(x=dice,replace = TRUE, prob=my_weights)
sample(x=dice,replace = TRUE, prob=equal_weights)

#Techniques for subsetting atomic vectors
z <- c(3.1,9.2,1.3,0.4,0.75)

#use positive index values
z[3]
z[c(2,4)]
z[c(5,5,5,1)]
z[-3]
z[z<3]
which(z<3) #tells you the place of particular slots/conditions
z[which(z<3)]
z[-(length(z):length(z-2))]
#subsetting using names of elements
names(z) <- letters[1:5]
print(z)
z[c('b','c')]

#relational operators
# >
# <
# <=
# >=
# ==

#logical operators
# ! not
# & and (vector)
# | or
# xor(x,y) one or the other - not both
# && and (only on first element)
# || or (only on first element)

x <- 1:5
y <- c(1:3,7,7)
x == 2
x != 2
x == 1 & y == 7
x == 1 | y ==7
xor(x == 3,y == 3)
x == 3 && y ==3

#subscripting w/ missing values#
set.seed(90)
z <- runif(10)
z
z < 0.5
z[z < 0.5]
which(z < 0.5)
z[which(z < 0.5)]

zD <- c(z,NA,NA)
zD
zD[zD < 0.5]
zD[which(zD < 0.5)]


require(Hmisc)
n <- 100
set.seed(1)
d <- data.frame(sbp=rnorm(n, 120, 10),
                dbp=rnorm(n, 80, 10),
                age=rnorm(n, 50, 10),
                days=sample(1:n, n, TRUE),
                S1=Surv(2*runif(n)), S2=Surv(runif(n)),
                race=sample(c('Asian', 'Black/AA', 'White'), n, TRUE),
                sex=sample(c('Female', 'Male'), n, TRUE),
                treat=sample(c('A', 'B'), n, TRUE),
                region=sample(c('North America','Europe'), n, TRUE),
                meda=sample(0:1, n, TRUE), medb=sample(0:1, n, TRUE))

d <- upData(d, labels=c(sbp='Systolic BP', dbp='Diastolic BP',
                 race='Race', sex='Sex', treat='Treatment',
                 days='Time Since Randomization',
                 S1='Hospitalization', S2='Re-Operation',
                 meda='Medication A', medb='Medication B'),
            units=c(sbp='mmHg', dbp='mmHg', age='years', days='days'))

Png <- function(z) png(paste('/tmp/summaryS', z, '.png', sep=''))
Png(1)
s <- summaryS(age + sbp + dbp ~ days + region + treat,  data=d)
# d2 <- subset(d, region=='Europe')
# par(mfrow=c(2,1))
# with(d2, plot(days, dbp, col=as.integer(treat)))
# ss <- subset(s, region=='Europe' & yvar == 'dbp')
# dim(ss)
# with(ss, plot(days, y, col=as.integer(treat)))

# plot(s)   # 3 pages
plot(s, groups='treat')

Png(1)
plot(s, groups='treat', datadensity=TRUE,
     scat1d.opts=list(lwd=.5, nhistSpike=0))
dev.off()
Png(2)
plot(s, groups='treat', panel=panel.loess,
     key=list(space='bottom', columns=2),
     datadensity=TRUE, scat1d.opts=list(lwd=.5))
dev.off()
# Show both points and smooth curves:
Png(3)
plot(s, groups='treat',
     panel=function(...) {panel.xyplot(...); panel.loess(...)})
dev.off()
plot(s, y ~ days | yvar * region, groups='treat')

# Make your own plot using data frame created by summaryP
xyplot(y ~ days | yvar * region, groups=treat, data=s,
       scales=list(y='free', rot=0))

# Use loess to estimate the probability of two different types of events as
# a function of time
s <- summaryS(meda + medb ~ days + treat + region, data=d)
pan <- function(...)
  panel.plsmo(..., type='l', label.curves=max(which.packet()) == 1,
              datadensity=TRUE)
Png(4)
plot(s, groups='treat', panel=pan, paneldoesgroups=TRUE,
     scat1d.opts=list(lwd=.7), cex.strip=.8)
dev.off()

# Demonstrate dot charts of summary statistics
s <- summaryS(age + sbp + dbp ~ region + treat, data=d, fun=mean)
plot(s)
Png(5)
plot(s, groups='treat', funlabel=expression(bar(X)))
dev.off()

# Compute parametric confidence limits for mean, and include sample sizes
f <- function(x) {
  x <- x[! is.na(x)]
  c(smean.cl.normal(x, na.rm=FALSE), n=length(x))
}
s <- summaryS(age + sbp + dbp ~ region + treat, data=d, fun=f)
# Draw [ ] for lower and upper confidence limits in addition to thick line
Png(6)
plot(s, funlabel=expression(bar(X) %+-% t[0.975] %*% s),
     pch.stats=c(Lower=91, Upper=93))  # type show.pch() to see defs.
dev.off()
Png(7)
plot(s, textonly='n', textplot='Mean', digits=1)
dev.off()

# Customize printing of statistics to use X bar symbol and smaller
# font for n=...
cust <- function(y) {
  means <- format(round(y[, 'Mean'], 1))
  ns    <- format(y[, 'n'])
  simplyformatted <- paste('X=', means, ' n=', ns, '  ', sep='')
  s <- NULL
  for(i in 1:length(ns)) {
    w <- paste('paste(bar(X)==', means[i], ',~~scriptstyle(n==', ns[i],
               '))', sep='')
    s <- c(s, parse(text=w))
  }
  list(result=s,
       longest=simplyformatted[which.max(nchar(simplyformatted))])
}
Png(8)
plot(s, groups='treat', cex.values=.65,
     textplot='Mean', custom=cust,
     key=list(space='bottom', columns=2,
       text=c('Treatment A:','Treatment B:')))
dev.off()

## Stratifying by region and treat fit an exponential distribution to
## S1 and S2 and estimate the probability of an event within 0.5 years

f <- function(y) {
  hazard <- sum(y[,2]) / sum(y[,1])
  1. - exp(- hazard * 0.5)
}

s <- summaryS(S1 + S2 ~ region + treat, data=d, fun=f)
plot(s, groups='treat', funlabel='Prob[Event Within 6m]', xlim=c(.3, .7))

## Demonstrate simultaneous use of fun and panel
## First show the same quantile intervals used in panel.bppplot by
## default, stratified by region and day

d <- upData(d, days=round(days / 30) * 30)
g <- function(y) {
  probs <- c(0.05, 0.125, 0.25, 0.375)
  probs <- sort(c(probs, 1 - probs))
  y <- y[! is.na(y)]
  w <- hdquantile(y, probs)
  m <- hdquantile(y, 0.5, se=TRUE)
  se <- as.numeric(attr(m, 'se'))
  c(Median=as.numeric(m), w, se=se, n=length(y))
}
s <- summaryS(sbp + dbp ~ days + region, fun=g, data=d)
Png(9)
plot(s, groups='region', panel=mbarclPanel, paneldoesgroups=TRUE)
dev.off()

# Similar but use half-violin plots
s <- summaryS(sbp + dbp ~ days + region, data=d)
Png('9v')
plot(s, groups='region', panel=medvPanel, paneldoesgroups=TRUE)
dev.off()

## Show Wilson confidence intervals for proportions, and confidence
## intervals for difference in two proportions
g <- function(y) {
  y <- y[!is.na(y)]
  n <- length(y)
  p <- mean(y)
  se <- sqrt(p * (1. - p) / n)
  structure(c(binconf(sum(y), n), se=se, n=n),
            names=c('Proportion', 'Lower', 'Upper', 'se', 'n'))
}
s <- summaryS(meda + medb ~ days + region, fun=g, data=d)
Png(10)
plot(s, groups='region', panel=mbarclPanel, paneldoesgroups=TRUE)
dev.off()


##### Chapter 10: Evaluating Model Performance -------------------

## Create the predicted probabilities from the SMS classifier built in Chapter 4.
## NOTE: THIS SECTION WILL NOT RUN WITHOUT RUNNING THE CHAPTER 4 CODE TO CREATE THE SMS CLASSIFIER!

# 예측 정확도가 성능을 측정하는데 충분치 않은 이유와, 대신 사용할 수 있는 성능 척도
# 처음 보는 케이스에 대한 모델의 예측 능력을 성능 척도에 합리적으로 반영하는 방법
# 지금까지 여러 장에서 다뤘던 예측 모델에, 이런 유용한 척도와 방법들을 적용하기 위한 R 사용법

# obtain the predicted probabilities
sms_test_prob <- predict(sms_classifier, sms_test, type = "raw") # 나이브 베이즈 예측 확률 측ㅈ
head(sms_test_prob)

# combine the results into a data frame
sms_results <- data.frame(actual_type = sms_test_labels,
                          predict_type = sms_test_pred,
                          prob_spam = round(sms_test_prob[ , 2], 5),
                          prob_ham = round(sms_test_prob[ , 1], 5))

# uncomment this line to output the sms_results to CSV
# write.csv(sms_results, "sms_results.csv", row.names = FALSE)

## Confusion matrixes in R ----
sms_results <- read.csv("sms_results.csv")

# the first several test cases
head(sms_results)

# test cases where the model is less confident
head(subset(sms_results, prob_spam > 0.40 & prob_spam < 0.60))

# test cases where the model was wrong정
head(subset(sms_results, actual_type != predict_type))

# specifying vectors. 횟수 나타내는 ㅍ
table(sms_results$actual_type, sms_results$predict_type)

# alternative solution using the formula interface (not shown in book)
xtabs(~ actual_type + predict_type, sms_results)

# using the CrossTable function
library(gmodels)
CrossTable(sms_results$actual_type, sms_results$predict_type)

# accuracy and error rate calculation --
# accuracy
(152 + 1203) / (152 + 1203 + 4 + 31)
# error rate
(4 + 31) / (152 + 1203 + 4 + 31)
# error rate = 1 - accuracy
1 - 0.9748201

## Beyond accuracy: other performance measures ----표
# 모델이 positive 클래스를 분류하는 능력을 성능 척도로 제공 -> positive parameter 명시 필요.
# 이 sms 분류기는 spam을 탐지하기 때문에, positive = "spam"을 설정한다.
library(caret)
confusionMatrix(sms_results$predict_type, sms_results$actual_type, positive = "spam")

# Kappa statistic
# example using SMS classifier
pr_a <- 0.865 + 0.109
pr_a

pr_e <- 0.868 * 0.888 + 0.132 * 0.112
pr_e

k <- (pr_a - pr_e) / (1 - pr_e)
k

# calculate kappa via the vcd package
library(vcd)
Kappa(table(sms_results$actual_type, sms_results$predict_type))

# calculate kappa via the irr package
library(irr)
kappa2(sms_results[1:2])

# Sensitivity and specificity
# example using SMS classifier
sens <- 152 / (152 + 31)
sens

spec <- 1203 / (1203 + 4)
spec

# example using the caret package
library(caret)
sensitivity(sms_results$predict_type, sms_results$actual_type, positive = "spam")
specificity(sms_results$predict_type, sms_results$actual_type, negative = "ham")

# Precision and recall
prec <- 152 / (152 + 4)
prec

rec <- 152 / (152 + 31)
rec

# example using the caret package
library(caret)
posPredValue(sms_results$predict_type, sms_results$actual_type, positive = "spam")
sensitivity(sms_results$predict_type, sms_results$actual_type, positive = "spam")

# F-measure
f <- (2 * prec * rec) / (prec + rec)
f

f <- (2 * 152) / (2 * 152 + 4 + 31)
f

## Visualizing Performance Tradeoffs ----
library(ROCR)
pred <- prediction(predictions = sms_results$prob_spam,
                   labels = sms_results$actual_type)

# ROC curves
perf <- performance(pred, measure = "tpr", x.measure = "fpr")
plot(perf, main = "ROC curve for SMS spam filter", col = "blue", lwd = 2)

# add a reference line to the graph
abline(a = 0, b = 1, lwd = 2, lty = 2)

# calculate AUC
perf.auc <- performance(pred, measure = "auc")
str(perf.auc)
unlist(perf.auc@y.values)

## Estimating Future Performance ----

# partitioning data
library(caret)
credit <- read.csv("credit.csv")

# Holdout method
# using random IDs
random_ids <- order(runif(1000))
credit_train <- credit[random_ids[1:500],]
credit_validate <- credit[random_ids[501:750], ]
credit_test <- credit[random_ids[751:1000], ]

# using caret function
in_train <- createDataPartition(credit$default, p = 0.75, list = FALSE)
credit_train <- credit[in_train, ]
credit_test <- credit[-in_train, ]

# 10-fold CV
folds <- createFolds(credit$default, k = 10)
str(folds)
credit01_test <- credit[folds$Fold01, ]
credit01_train <- credit[-folds$Fold01, ]

## Automating 10-fold CV for a C5.0 Decision Tree using lapply() ----
library(caret)
library(C50)
library(irr)

credit <- read.csv("credit.csv")

set.seed(123)
folds <- createFolds(credit$default, k = 10)

cv_results <- lapply(folds, function(x) {
  credit_train <- credit[-x, ]
  credit_test <- credit[x, ]
  credit_model <- C5.0(default ~ ., data = credit_train)
  credit_pred <- predict(credit_model, credit_test)
  credit_actual <- credit_test$default
  kappa <- kappa2(data.frame(credit_actual, credit_pred))$value
  return(kappa)
})

str(cv_results)
mean(unlist(cv_results))