library(ggplot2)
library(dplyr)
library(lmPerm)

PSDS_PATH <- file.path('~', 'statistics-for-data-scientists')

session_times <- read.csv(file.path(PSDS_PATH, 'data', 'web_page_data.csv'))
session_times[,2] <- session_times[,2] * 100
four_sessions  <- read.csv(file.path(PSDS_PATH, 'data', 'four_sessions.csv'))
click_rate <-  read.csv(file.path(PSDS_PATH, 'data', 'click_rates.csv'))
imanishi <-  read.csv(file.path(PSDS_PATH, 'data', 'imanishi_data.csv'))

## Code snippet 3.1
ggplot(session_times, aes(x=Page, y=Time)) +
  geom_boxplot()

## Code for Figure 3
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0303.png'),  width = 4, height=4, units='in', res=300)
ggplot(session_times, aes(x=Page, y=Time)) +
  geom_boxplot() +
  labs(y='Time (in seconds)') +
  theme_bw()
dev.off()

mean_a <- mean(session_times[session_times['Page']=='Page A', 'Time'])
mean_b <- mean(session_times[session_times['Page']=='Page B', 'Time'])
mean_b - mean_a
## Permutation test example with stickiness
perm_fun <- function(x, n1, n2)
{
  n <- n1 + n2
  idx_b <- sample(1:n, n1)
  idx_a <- setdiff(1:n, idx_b)
  mean_diff <- mean(x[idx_b]) - mean(x[idx_a])
  return(mean_diff)
}

## Code for Figure 4
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0304.png'),  width = 4, height=4, units='in', res=300)
perm_diffs <- rep(0, 1000)
for(i in 1:1000)
  perm_diffs[i] = perm_fun(session_times[,'Time'], 21, 15)
par(mar=c(4,4,1,0)+.1)
hist(perm_diffs, xlab='Session time differences (in seconds)', main='')
abline(v = mean_b - mean_a)
dev.off()

mean(perm_diffs > (mean_b - mean_a))

## Code for Figure 5
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0305.png'),  width = 4, height=4, units='in', res=300)

obs_pct_diff <- 100*(200/23739 - 182/22588)
conversion <- c(rep(0, 45945), rep(1, 382))
perm_diffs <- rep(0, 1000)
for(i in 1:1000)
  perm_diffs[i] = 100*perm_fun(conversion, 23739, 22588 )
hist(perm_diffs, xlab='Conversion rate (percent)', main='')
abline(v = obs_pct_diff, lty=2, lwd=1.5)
text("  Observed\n  difference", x=obs_pct_diff,  y=par()$usr[4]-20, adj=0)

dev.off()

mean(perm_diffs > obs_pct_diff)

prop.test(x=c(200,182), n=c(23739,22588), alternative="greater")
## Histogram of resample
## t-test
t.test(Time ~ Page, data=session_times, alternative='less' )

## session times

## four groups ANOVA

## Code for Figure 6
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0306.png'),  width = 4, height=4, units='in', res=300)

ggplot(four_sessions, aes(x=Page, y=Time)) +
  geom_boxplot() +
  labs(y='Time (in seconds)') +
  theme_bw()

dev.off()

summary(aovp(Time ~ Page, data=four_sessions))
summary(aov(Time ~ Page, data=four_sessions))

## Chi square test
clicks <- matrix(click_rate$Rate, nrow=3, ncol=2, byrow=TRUE)
dimnames(clicks) <- list(unique(click_rate$Headline), unique(click_rate$Click))

chisq.test(clicks, simulate.p.value=TRUE)

chisq.test(clicks, simulate.p.value=FALSE)

## Code for Figure 7
x <- seq(1, 30, length=100)
chi <- data.frame(df = factor(rep(c(1, 2, 5, 10), rep(100, 4))),
                  x = rep(x, 4),
                  p = c(dchisq(x, 1), dchisq(x, 2), dchisq(x, 5), dchisq(x, 20)))

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0307.png'),  width = 5, height=3, units='in', res=300)

ggplot(chi, aes(x=x, y=p)) +
  geom_line(aes(linetype=df)) +
  theme_bw() +
  labs(x='', y='')

dev.off()

## Fishers exact test
fisher.test(clicks)
## Tufts example

## Code for Figure 8
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0308.png'),  width = 4, height=4, units='in', res=300)
imanishi$Digit <- factor(imanishi$Digit)

ggplot(imanishi, aes(x=Digit, y=Frequency)) +
  geom_bar(stat="identity") +
  theme_bw()

dev.off()


> x
[1] 7 1 8 3 2 6 5 2 2 4
> # sort in ascending order
> sort(x)
[1] 1 2 2 2 3 4 5 6 7 8
> # sort in descending order
> sort(x, decreasing=TRUE)
[1] 8 7 6 5 4 3 2 2 2 1
> # vector x remains unaffected
> x
[1] 7 1 8 3 2 6 5 2 2 4
> order(x)
[1]  2  5  8  9  4 10  7  6  1  3
> order(x, decreasing=TRUE)
[1]  3  1  6  7 10  4  5  8  9  2
> x[order(x)]    # this will also sort x
[1] 1 2 2 2 3 4 5 6 7 8


#######################################################################
# simple demo of testing a set of association rules against a separate test set
#######################################################################

library("arules");

#build rules
trainegs = read.transactions(file="C:\\Users\\issbas\\Documents\\EBAC\\EBAC-electives\\webanalytics\\workshops\\simplebasket.csv",rm.duplicates=TRUE, format="single", sep=",", cols=c("basketID","item"));
rules <- apriori(trainegs, parameter = list(supp=0.1, conf=0.1, minlen=2))
summary(rules)
inspect(rules)

# a useful plot of training data
itemFrequencyPlot(trainegs,topN=20,type="absolute")

#read the test data
testegs = read.csv(file="C:\\Users\\issbas\\Documents\\EBAC\\EBAC-electives\\webanalytics\\workshops\\simplebasket-test.csv");
colnames(testegs) <- c("basketID","items")  # set standard names, in case they are different in the data file

#execute rules against test data
rulesDF = as(rules,"data.frame")
testegs$preds = apply(testegs,1,function(X) makepreds(X["items"], rulesDF))

# extract unique predictions for each test user
userpreds = as.data.frame(aggregate(preds ~ basketID, data = testegs, paste, collapse=","))
userpreds$preds = apply(userpreds,1,function(X) uniqueitems(X["preds"]))

# extract unique items bought (or rated highly) for each test user
baskets = as.data.frame(aggregate(items ~ basketID, data = testegs, paste, collapse=","))
baskets$items = apply(baskets,1,function(X) uniqueitems(X["items"]))

#count how many unique predictions made are correct, i.e. have previously been bought (or rated highly) by the user
correctpreds = sum(apply(userpreds,1,function(X) checkpreds(X["preds"],X["basketID"])))

# count total number of unique predictions made
totalpreds = sum(apply(userpreds,1,function(X) countpreds(X["preds"][[1]])))

precision = correctpreds*100/totalpreds

cat("precision=", precision, "corr=",correctpreds,"total=",totalpreds)

#######################################################################
# the supporting functions
#######################################################################

#remove duplicate items from a basket (itemstrg)
uniqueitems <- function(itemstrg) {
  unique(as.list(strsplit(gsub(" ","",itemstrg),","))[[1]])
}

# execute ruleset using item as rule antecedent (handles single item antecedents only)
makepreds <- function(item, rulesDF) {
  antecedent = paste("{",item,"} =>",sep="")
  firingrules = rulesDF[grep(antecedent, rulesDF$rules,fixed=TRUE),1]
  gsub(" ","",toString(sub("\\}","",sub(".*=> \\{","",firingrules))))
}

# count how many predictions are in the basket of items already seen by that user
# Caution : refers to "baskets" as a global
checkpreds <- function(preds, baskID) {
  plist = preds[[1]]
  blist = baskets[baskets$basketID == baskID,"items"][[1]]
  cnt = 0
  for (p in plist) {
    if (p %in% blist) cnt = cnt+1
  }
  cnt
}

# count all predictions made
countpreds <- function(predlist) {
  len = length(predlist)
  if (len > 0 && (predlist[[1]] == "")) 0 # avoid counting an empty list
  else len
}

###########################################################################
# rule visualisation
# also see (for example) http://www.rdatamining.com/examples/association-rules
###########################################################################

library(arulesViz)
plot(rules)
plot(rules, method="graph")
plot(rules, method="graph",nodeCol=grey.colors(10),edgeCol=grey(.7),alpha=1)
plot(rules, method="matrix")
plot(rules, method="paracoord", control=list(reorder=TRUE))


require(quantmod)
require(PerformanceAnalytics)

getSymbols("^NSEI")
chartSeries(NSEI, TA=NULL)
data=NSEI[,4]

macd = MACD(data, nFast=12, nSlow=26,nSig=9,maType=SMA,percent = FALSE)
dfMACD <- data.frame(macd)

chartSeries(data, TA="addMACD()")
signal <- Lag(ifelse(dfMACD$macd < dfMACD$signal, -1, 1))

returns <- ROC(data)*signal
returns <- returns['2008-06-02/2015-09-22']

portfolio <- exp(cumsum(returns))
plot(portfolio)

table.Drawdowns(ret, top=10)
table.DownsideRisk(ret)
charts.PerformanceSummary(ret)


#' radtheoricR
#'
#' @description R function to assess raw  solar irradiance parameter.
#'
#' @param  timenow time "POSIXct" or "POSIXt" object.
#' @param  lat numeric latitude in decimal degrees.
#' @param  lon numeric longitude in decimal degrees.
#' @param  albedo numeric albedo of surface.
#' @return Theoretical radiation in W/mq
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#'
#'
#'
#' @export

radtheoricR <- function(timenow,lat,lon,albedo){
 rho=albedo
 sunpar=sunposition(timenow,lat, lon)
 elev=sunpar$elevation
 timeday=as.POSIXlt(timenow, "GMT")
 nday=format(timeday,"%j")
 # Solar constant
 SC = 1.361 # kW/m2
 # ET solar radition I0 kW/m2
 I0 <- SC*(1+0.034*cos((nday)*2*pi/365))
 # atmospheric effect
 A <- 1.160 + 0.075 * sin((nday-274)*2*pi/365)
 opt.depth <- 0.174 + 0.035 * sin((nday-100)*2*pi/365)
 air.mass <- 1/sin(elev*2*pi/360)
 # Direct
 IB <- I0*exp(-opt.depth*air.mass)
 # diffuse
 IDH <- IB*(0.095 + 0.04*sin((nday-100)*2*pi/365))
 ID <- IDH*(1+cos(pi-elev*2*pi/360))/2
 # reflected
 IBH <- IB*sin(elev*2*pi/360)
 IR <-  rho*(IBH+IDH)*(1+cos(pi-elev*2*pi/360))/2
 # total
 IT <- IB+ID+IR
 I <- cbind(IB,ID,IR,IT)
 return(list(I0=I0,A=A,opt.depth=opt.depth, air.mass=air.mass,I=I,jd=nday,elev=elev,azimuth=sunpar$azimuth))
}


funcion = funtion (init, xis, finc){
= lengt h(xis)
h=xis[2]-xis[1]
v.num = vector(length = n)
v.num [1] = init
for (j in 1:(n-1)){
  v.num [j+1] = v.num[j]+
    h*func (xis[j], v.num[j])
}
v.num
}
#---funcion
f = function (x,y) 1-*x^(2)+(x+y)
#---definir h y m
xis = seq (0, 300, 300/30)
#---llamando la funcion
sol = funcion (1, xis, f)
#---hacer la tabla
tabla = cbind (xis, sol)
colnames (tabla) = c ("x", "y")
tabla
#graficando
plot(xis, sol, type = "l", col = "blue")


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

## ----eval=FALSE---------------------------------------------------------------
## f <- areg.boot(Y ~ monotone(age) +
##                sex + weight + I(blood.pressure))
##
## plot(f)       #show transformations, CLs
## Function(f)   #generate S functions
##               #defining transformations
## predict(f)    #get predictions, smearing estimates
## summary(f)    #compute CLs on effects of each X
## smearingEst() #generalized smearing estimators
## Mean(f)       #derive S function to
##               #compute smearing mean Y
## Quantile(f)   #derive function to compute smearing quantile
##

## ----sim,results='asis'-------------------------------------------------------
require(rms)
set.seed(7)
n <- 400
x1 <- runif(n)
x2 <- runif(n)
x3 <- factor(sample(c('a','b','c'), n, TRUE))
y  <- exp(x1 + 2*abs(x2 - .5) + .3*(x3=='b') + .5*(x3=='c') +
          .5*rnorm(n))
# For reference fit appropriate OLS model
print(ols(log(y) ~ x1 + rcs(x2, 5) + x3), coefs=FALSE,
      latex=TRUE)

## ----aregboot,results='hide'--------------------------------------------------
f  <- areg.boot(y ~ x1 + x2 + x3, method='avas', B=300)

## ----pareg--------------------------------------------------------------------
f

## ----trans,mfrow=c(2,2),h=4,w=5,ps=10,cap='\\fu{avas} transformations: overall estimates, pointwise $0.95$ confidence bands, and $20$ bootstrap estimates (red lines).',scap='Transformations estimated by \\fu{avas}'----
plot(f, boot=20) # Figure (*\ref{fig:areg-trans}*)

## ----ytrans,w=3,h=2,bty='l',cap='Checking estimated against optimal transformation'----
ys <- seq(.8, 20, length=200)
ytrans <- Function(f)$y   # Function outputs all transforms
plot(log(ys), ytrans(ys), type='l')   # Figure (*\ref{fig:areg-ytrans}*)
abline(lm(ytrans(ys) ~ log(ys)), col=gray(.8))

## -----------------------------------------------------------------------------
summary(f, values=list(x1=c(.2, .8), x2=c(.1, .5)))

## ----pred,h=3.5,w=4.75,cap='Predicted median (left panel) and mean (right panel) \\co{y} as a function of \\co{x2} and \\co{x3}.  True population values are shown in gray.',scap='Predicted \\co{y} as a function of \\co{x2} and \\co{x3}'----
newdat <- expand.grid(x2=seq(.05, .95, length=200),
                      x3=c('a','b','c'), x1=.5,
                      statistic=c('median','mean'))
yhat <- c(predict(f, subset(newdat, statistic=='median'),
                  statistic='median'),
          predict(f, subset(newdat, statistic=='mean'),
                  statistic='mean'))
newdat <-
  upData(newdat,
         lp = x1 + 2*abs(x2 - .5) + .3*(x3=='b') +
              .5*(x3=='c'),
         ytrue = ifelse(statistic=='median', exp(lp),
           exp(lp + 0.5*(0.5^2))), pr=FALSE)

# Use Hmisc function xYplot to produce Figure (*\ref{fig:areg-pred}*)
xYplot(yhat ~ x2 | statistic, groups=x3,
       data=newdat, type='l', col=1,
       ylab=expression(hat(y)),
       panel=function(...) {
         panel.xYplot(...)
         dat <- subset(newdat,
           statistic==c('median','mean')[current.column()])
         for(w in c('a','b','c'))
           with(subset(dat, x3==w),
                llines(x2, ytrue, col=gray(.7), lwd=1.5))
       }
     )


#' Function for generating Scree Plots of Amen Data
#'
#' This function generates Scree Plots of Amen Data.
#' @param data Accepts a list with first row containing adult data and second row containing child data.
#' @keywords Scree, Variance
#' @export
#' @examples
#' Scree_Plot

Scree_Plot <- function(data){
	require(ggplot2)
	require(graphics)

	#Get data
	data_adults <- data[[1]]
	data_adults <- data[[2]]

	#Isolate columns of interest
	data_adults <- data_adults[,c(381:636)]
	data_children <- data_children[,c(381:636)]

	#Remove NAs
	data_adults <- na.omit(data_adults);
	data_children<-na.omit(data_children);

	#Separate data
	data_adults_baseline <- t(data_adults[,c(1:128)]);
	data_adults_concentration <- t(data_adults[,c(129:256)]);
	data_adults_combined <- t(data_adults[,c(1:256)]);
	data_children_baseline <- t(data_children[,c(1:128)]);
	data_children_concentration <- t(data_children[,c(129:256)]);
	data_children_combined <- t(data_children[,c(1:256)]);

	#Generate scree data, plot it, and output it to file for all data sets.
	fit <- prcomp(data_adults_baseline,center = TRUE,scale = TRUE);
	results <- data.frame(x = c(1:length(unlist(fit[1]))), y = cumsum(unlist(fit[1])^2) /  max(cumsum(unlist(fit[1])^2)));
	print(ggplot(results,aes(x,y)) + geom_line() + geom_point() + xlab("Components") + ylab("Percent Variance") + ggtitle("Adult Baseline Scree Plot"))

	fit <- prcomp(data_adults_concentration,center = TRUE,scale = TRUE);
	results <- data.frame(x = c(1:length(unlist(fit[1]))), y = cumsum(unlist(fit[1])^2) /  max(cumsum(unlist(fit[1])^2)));
	print(ggplot(results,aes(x,y)) + geom_line() + geom_point() + xlab("Components") + ylab("Percent Variance") + ggtitle("Adults Concentration Scree Plot"))

	fit <- prcomp(data_children_baseline,center = TRUE,scale = TRUE);
	results <- data.frame(x = c(1:length(unlist(fit[1]))), y = cumsum(unlist(fit[1])^2) /  max(cumsum(unlist(fit[1])^2)));
	print(ggplot(results,aes(x,y)) + geom_line() + geom_point() + xlab("Components") + ylab("Percent Variance") + ggtitle("Children Baseline Scree Plot"))

	fit <- prcomp(data_children_concentration,center = TRUE,scale = TRUE);
	results <- data.frame(x = c(1:length(unlist(fit[1]))), y = cumsum(unlist(fit[1])^2) /  max(cumsum(unlist(fit[1])^2)));
	print(ggplot(results,aes(x,y)) + geom_line() + geom_point()+ xlab("Components") + ylab("Percent Variance") + ggtitle("Children Concentration Scree Plot"))

	fit <- prcomp(data_adults_combined,center = TRUE,scale = TRUE);
	results <- data.frame(x = c(1:length(unlist(fit[1]))), y = cumsum(unlist(fit[1])^2) /  max(cumsum(unlist(fit[1])^2)));
	print(ggplot(results,aes(x,y)) + geom_line() + geom_point()+ xlab("Components") + ylab("Percent Variance") + ggtitle("Adult Combined Scree Plot"))

	fit <- prcomp(data_children_combined,center = TRUE,scale = TRUE);
	results <- data.frame(x = c(1:length(unlist(fit[1]))), y = cumsum(unlist(fit[1])^2) /  max(cumsum(unlist(fit[1])^2)));
	print(ggplot(results,aes(x,y)) + geom_line() + geom_point()+ xlab("Components") + ylab("Percent Variance") + ggtitle("Children Combined Scree Plot"))
}


Advertisting = read.table('C:\\Projects\\StatisticalLearning\\datasets\\Advertising.csv', header = TRUE, sep=",")
Advertisting$X <- NULL
attach(Advertisting)
plot(sales,TV)
AdvertisingLM = lm(sales~TV)
AdvertisingLM
summary(AdvertisingLM)
abline(AdvertisingLM)

StockPrice = read.table('C:\\Projects\\StatisticalLearning\\datasets\\StockPrice.csv', header = TRUE, sep=",")
StockPrice$i <- NULL
attach(StockPrice)
StockPriceLM = lm(StockIndexPrice~InterestRate+UnemploymentRate,data=StockPrice)


#Using data from insideairbnb.com - data from the Santa Cruz, CA area, last updated October 2015
santacruz = read.csv("documents/airbnb_santacruz.csv")
attach(santacruz)

#thanks to http://www.geodatasource.com/developers/javascript for ideas behind this function
#Note that "West" and "South" need negative signs for lat/lon
distance <- function(lat1, lon1, lat2, lon2) {
    #lat2 <- 36.9643, lon2 <- -122.0189 for Santa Cruz Beach Boardwalk
    radlat1 = pi * lat1/180
    radlat2 = pi * lat2/180
    theta = lon1-lon2
    radtheta = pi * theta/180
    dist = (sin(radlat1) * sin(radlat2) + cos(radlat1) * cos(radlat2) * cos(radtheta))
    dist = acos(dist)
    dist = dist * 180/pi
    dist = dist * 60 * 1.1515
    return(dist)
}

#use distance to regress price on distance, split by type of room (maybe focus on home first)
santacruz$distance<- distance(santacruz$latitude, santacruz$longitude,36.9643,-122.0189)

santacruz$room_type <- factor(santacruz$room_type)
lm <- lm(santacruz$price ~ santacruz$distance + santacruz$room_type)
summary(lm)

#These two regressions indicate somewhat odd findings.
#For one, the farther a house is away from the Santa Cruz Beach Boardwalk,
#the more expensive it is to stay per night.
#For another, you have very big negative coefficients for Private Room or Shared Room categories.
#The latter is easily explained upon realizing that the third category, renting a full house,
#should logically be more expensive per night. The former (positive distance variable) may be explained
#by physically looking through the data, where a lot of houses
#in the "Santa Cruz" area are actually closer to Capitola Beach.

santacruz$capitola<- distance(santacruz$latitude, santacruz$longitude,36.9716, -121.9516)
lmcap <- lm(santacruz$price ~ santacruz$capitola + santacruz$room_type)
summary(lmcap)

mean(santacruz$latitude)
mean(santacruz$longitude)

#I tried using Capitola Beach as another distance measure, but again the further away a house was from the beach,
#the more my model predicted it would cost.
#Upon checking the average location for latitude and longitude, I figured out the reason why:
#this dataset ranges from Santa Cruz Beach Boardwalk to Capitola Beach,
#making both anchor points the extremes of their datasets:
#https://www.google.com/maps/place/36%C2%B059'12.2%22N+121%C2%B059'13.0%22W/@36.9792869,-122.0092925,13.42z/data=!4m5!3m4!1s0x0:0x0!8m2!3d36.9867106!4d-121.9869506

#Separate Capitola from Santa Cruz Beach houses (focus on Santa Cruz Boardwalk first)
#first, see what neighborhoods are in there
unique(neighbourhood)

sconly <- subset(santacruz, santacruz$neighbourhood == "City of Santa Cruz")
sconly$distance<- distance(sconly$latitude, sconly$longitude,36.9643,-122.0189)
lmsconly <- lm(sconly$price ~ sconly$distance + sconly$room_type)
summary(lmsconly)

caponly <- subset(santacruz, santacruz$neighbourhood == "City of Capitola")
caponly$capitola<- distance(caponly$latitude, caponly$longitude,36.9716, -121.9516)
lmcaponly <- lm(caponly$price ~ caponly$capitola + caponly$room_type)
summary(lmcaponly)

#Now the adage of "location, location, location" is correctly displayed in the regression for Capitola
#the further away a house is from Capitola Beach, the less a person should be willing to pay to stay in an Airbnb),
#and is significant at the 5% level. The sign on the Santa Cruz coefficient is still positive,
#but it's not significant for the regression.


data <- ToothGrowth

data$supp <- factor(data$supp)
data$dose <- factor(data$dose)

fit <- aov(len ~ supp + dose, data=data)

layout(matrix(c(1,2,3,4),2,2)) # optional layout
plot(fit) # diagnostic plots

summary(fit) # display Type I ANOVA table
drop1(fit,~.,test="F") # type III SS and F Tests

TukeyHSD(fit)

layout(matrix(c(1),1,1))

library(gplots)
plotmeans(data$len~data$dose,xlab="Dose",
          ylab="Tooth Length", main="Mean Plot\nwith 95% CI")

plotmeans(data$len~data$supp,xlab="Supplement",
          ylab="Tooth Length", main="Mean Plot\nwith 95% CI")


library(rstan)

stanbootmean <- function(fit, nTraj, N, Tlim, steps) {

	source("../../sir-functions/StocSIRSstan.r")

	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,]

	# get mean final states
	final_states <- matrix(NA, nTraj, 4)

	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, Tlim, steps, berrvec, datlen)
		colnames(sdeout) <- c('S','I','R','B')

		final_states[i,] <- sdeout[Tlim+1,]

		bootstrapdata[i,1:(Tlim+1)] <- sdeout[,'I']

	}

	final_state_means <- colMeans(final_states)
	names(final_state_means) <- c('S','I','R','B')

	# bootstrap into future

	for (i in 1:nTraj) {

		paramset <- params[i,]

		init_cond <- c(	S = final_state_means[['S']],
		               	I = final_state_means[['I']],
		               	R = final_state_means[['R']])
		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-Tlim, steps, berrvec, datlen)
		colnames(sdeout) <- c('S','I','R','B')

		#print( length( bootstrapdata[i,(Tlim+2):(T+1)] ) )
		#print( length( sdeout[-1,'I'] ) )
		bootstrapdata[i,(Tlim+2):(T+1)] <- sdeout[-1,'I']

	}

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

	return( bootstrapdata )

}


context("dijkstra")

wiki_graph <-
  data.frame(v1=c(1,1,1,2,2,2,3,3,3,3,4,4,4,5,5,6,6,6),
             v2=c(2,3,6,1,3,4,1,2,4,6,2,3,5,4,6,1,3,5),
             w=c(7,9,14,7,10,15,9,10,11,2,15,11,6,6,9,14,2,9))

test_that("outputs are correct in the Dijkstra algorithm.", {
  expect_equal(dijkstra(wiki_graph,1), c(0,7,9,20,20,11))
  expect_equal(dijkstra(wiki_graph,3), c(9,10,0,11,11,2))
})

test_that("Error messages are returned for erronous input in the Dijkstra algorithm.", {
  wiki_wrong_graph <- wiki_graph
  names(wiki_wrong_graph) <- c("v1, v3, w")
  expect_error(dijkstra(wiki_wrong_graph, 3))
  wiki_wrong_graph <- wiki_graph[1:2]
  expect_error(dijkstra(wiki_wrong_graph, 3))
  expect_error(dijkstra(wiki_graph, 7))
  expect_error(dijkstra(as.matrix(wiki_graph), 3))
})


library(tidyverse)
library(grid)
library(gridExtra)
library(svglite)

lot_cn = 12
lot_var_0 = 3
lot_var_1 = 2.25

r0 = .75*exp((7-7)/lot_var_1)/exp(6/lot_var_1)

rent_full_df <- data.frame(x = rep(1:lot_cn, 1)) %>%
  mutate(r_0 = r0,
         r_1 = .75*exp((7-x)/lot_var_0)/exp(6/lot_var_1),
         r_2 = .75*exp((7-x)/lot_var_1)/exp(6/lot_var_1),
         `cap inv` = runif(x-x+1)*1+1,
         v_0 = `cap inv`*(1+r_0),
         v_1 = `cap inv`*(1+r_1),
         v_2 = `cap inv`*(1+r_2))

rates_df <- select(rent_full_df, -c(`cap inv`, r_0, starts_with('v_'))) %>%
  gather(key = scenario, value = values, -x) %>%
  mutate(scenario = gsub('r_', '', scenario),
         base = 'r',
         series = 'rates') %>%
  select(x, scenario, values, base, series)

value_df <- select(rent_full_df, -c(`cap inv`, v_0, starts_with('r_'))) %>%
  gather(key = scenario, value = values, -x) %>%
  mutate(scenario = gsub('v_', '', scenario),
         base = 'r') %>%
  rbind(
    mutate(select(rent_full_df, c(x, v_0)), scenario = '1') %>%
      rbind(mutate(select(rent_full_df, c(x, v_0)), scenario = '2')) %>%
      select(x, scenario, v_0) %>%
      rename(values = v_0) %>%
      mutate(base = 'r0')) %>%
  mutate(series = 'values')

rates.pl <- rates_df %>%
  mutate(scenario = paste('scenario', scenario)) %>%
  ggplot() +
  geom_vline(xintercept = 7.5, linetype = 'dashed') +

  geom_bar(aes(x = x, y = values, fill = base, color = base),
           stat = 'identity', position ="identity",
           width = 1, alpha = 0.4) +
  geom_hline(data = data.frame(yint = r0, series = "rates"),
             aes(yintercept=yint), linetype = "dashed") +
  coord_cartesian(ylim = c(0.035, max(rates_df$values))) +
  geom_hline(yintercept = 0) +
  facet_grid(~scenario, scales = 'free_y') +
  labs(y = 'rate') +
  theme_bw() +
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5, size = 15),
        axis.title.x = element_blank(),
        axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        legend.position = 'none',
        strip.background = element_blank(),
        strip.text.x = element_text(size = 18, face = 'bold'))

values.pl <- value_df %>%
  mutate(rate = factor(base, levels = c("r", "r0")),
         scenario = paste('scenario', scenario)) %>%
  arrange(scenario, series, base, x) %>%
  ggplot() +
  geom_bar(aes(x = x, y = values, fill = rate, color = rate, alpha = rate),
           stat = 'identity', position ="identity",
           width = 1) +
  geom_vline(xintercept = 7.5, linetype = 'dashed') +
  coord_cartesian(ylim = c(0.15, max(value_df$values))) +
  geom_hline(yintercept = 0) +
  facet_grid(~scenario) +
  ylab(NULL) +
  scale_fill_manual(labels = c(expression(italic(r[])), expression(italic(~r[0]))),
                    values = c('#F8766D', '#00BFC4')) +
  scale_alpha_manual(labels = c(expression(italic(r[])), expression(italic(~r[0]))),
                     values = c(.4, .4)) +
  scale_colour_manual(labels = c(expression(italic(r[])), expression(italic(~r[0]))),
                      values = c('#F8766D', '#00BFC4')) +
  scale_x_continuous(breaks=seq(1,12,2), labels=seq(1,12,2)) +

  labs(x = expression(italic(c[i][j]))) +
  labs(y = 'valuation') +
  theme_bw() +
  theme(axis.title.y = element_text(angle = 0, vjust = 0.5, size = 15),
        axis.title.x = element_text(size = 15),
        # axis.text.x=element_blank(),
        axis.ticks.x=element_blank(),
        axis.text.y=element_blank(),
        axis.ticks.y=element_blank(),
        legend.position = c(0.95, 0.85),
        legend.title = element_blank(),
        legend.text = element_text(size = 14),
        strip.text.x = element_blank(),
        strip.background = element_blank())

# grid.arrange(rates.pl, values.pl, ncol = 1)
# grid.text(expression(italic(r[0])), x = unit(0.045, "npc"), y = unit(0.57, "npc"),
#           gp = gpar(fontsize=14))

rates.gb <- ggplotGrob(rates.pl)
values.gb <- ggplotGrob(values.pl)

maxwidths <- grid::unit.pmax(rates.gb$widths[2:5], values.gb$widths[2:5])
rates.gb$widths[2:5] <- as.list(maxwidths)
values.gb$widths[2:5] <- as.list(maxwidths)

rent_var.gb <- arrangeGrob(rates.gb, values.gb, ncol = 1,
                 left=textGrob(expression(italic(r[0])),
                               x = unit(4.25, "npc"), y = unit(0.55, "npc"),
                               gp = gpar(fontsize=14)))
grid.draw(rent_var.gb) # interactive device

file1_nm <- 'rent_var.svg'
file_path <- paste("C:/Users/Carlos/Dropbox/Documents/Documents/Projects/Cognition Switch/cognitionswitch.github.io/images/ricardian_models_rent")
# ggsave(paste(file_path, file1_nm, sep="/"),
#        grid.draw(rent_var))
ggsave(file=paste(file_path, file1_nm, sep="/"),
       plot=grid.draw(rent_var.gb),
       width=14, height=8)


# This code computes minimum detectable odds ratio
# for the Vaccine effectiveness against referral
# to hospital and severe lung injury associated with COVID-19
# study
library(epiR)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load data to extract characteristics
load("data/ve_ct_paper/trc_dt.Rdata")

# Study characteristics
total_patients <- trc_dt[, .N] # 13893
completely_vaccinated_patients <- trc_dt[vac_status3 == "full_vac", .N] # 1291
partially_vaccinated_patients <- trc_dt[vac_status3 == "part_vac", .N] # 448

# Outcomes
hospitalized_patients <- trc_dt[hospitalization == 1, .N] # 495
any_lung_injury_patients <- trc_dt[ct_score != 0, .N] # 9368
saturation_less_than_96 <- trc_dt[saturation < 96 | is.na(saturation), .N] # 385

# MDE for hospitalization, complete vaccination
epi.sscc(OR = NA,
				 p0 = completely_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-hospitalized_patients)/hospitalized_patients)

# MDE for any lung injury, complete vaccination
epi.sscc(OR = NA,
				 p0 = completely_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-any_lung_injury_patients)/any_lung_injury_patients)

# MDE for oxygen saturation, complete vaccination
epi.sscc(OR = NA,
				 p0 = completely_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-saturation_less_than_96)/saturation_less_than_96)

# MDE for hospitalization, partial vaccination
epi.sscc(OR = NA,
				 p0 = partially_vaccinated_patients/total_patients,
				 n = total_patients,
				 conf.level = 0.95,
				 power = 0.8,
				 method = "unmatched",
				 r = (total_patients-hospitalized_patients)/hospitalized_patients)


bilinear.interp<-function(x,f){
	#interpolate a 2d point for fn f
	indx<-trunc(x[1]*(res-1)+1)
	indy<-trunc(x[2]*(res-1)+1)
	seq.Out<-seq(0,1,length.out=res)
	fr1<- (seq.Out[indx+1]-x[1])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx,indy] + (x[1]-seq.Out[indx])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx+1,indy]
	fr2<- (seq.Out[indx+1]-x[1])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx,indy+1] + (x[1]-seq.Out[indx])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx+1,indy+1]
	fp<- (seq.Out[indy+1]-x[2])/(seq.Out[indy+1]-seq.Out[indy]) * fr1 + (x[2]-seq.Out[indy])/(seq.Out[indy+1]-seq.Out[indy]) * fr2
	return(fp)
}

bilinear.interp(c(.4,.5),matrix(rnorm(res^2),res,res))

univ.interp<-function(x,f){
	seq.Out<-seq(0,1,length.out=res)
	indx<-trunc(x*(res-1)+1)
	(seq.Out[indx+1]-x)/(seq.Out[indx+1]-seq.Out[indx]) * f[indx] + (x-seq.Out[indx])/(seq.Out[indx+1]-seq.Out[indx]) * f[indx+1]
}

univ.interp(.4,1:res)

tree.mix.lik<-function(x,edge_den,beliefs,edgelist,tree.list,weights,part_fn){
	e<- dim(edgelist)[1]
	d<-dim(beliefs)[1]
	uni.prod<-mapply(function(u){
		log(univ.interp(x[u],beliefs[u,]))
	},1:d)
	if(e==0){
		return(sum(uni.prod))
	}
		if(any(is.na(uni.prod))) print("help!")

	biv.prod<-mapply(
				function(l){
					s<- edgelist[l,1]
					t<- edgelist[l,2]
					log(bilinear.interp(c(x[s],x[t]) , edge_den[,,l]))  - (uni.prod[s]) - (uni.prod[t])
				},
				1:e
			)
	tree.prod<- lapply(tree.list,
					function(t){
						tree<- graph.adjacency(t,mode="undirected")
						el1<-apply(get.edgelist(tree), 1, paste, collapse="-")
						el2<-apply(get.edgelist(tree), 1, function(x)paste(rev(x),collapse="-"))
						el<-apply(edgelist, 1, paste, collapse="-")
						ekeep<- (el %in% el1) | (el %in% el2)
						sum( biv.prod[ekeep] )
					})
		tree.prod<- unlist(tree.prod)
		tmax<- max(tree.prod)
		#tmax<-0
		#tree.weight<- exp(tree.prod-tmax)*weights
		#out<- sum( uni.prod ) + tmax + log( sum( tree.weight ) )
		out<- sum( uni.prod ) + weights * tree.prod
	return(out)
	}

# risk_path_tree<-lapply(path,function(x){
#   outvec<-lapply(1:dim(test)[1],
#   	function(i){
# 	  tree.mix.lik(test[i,],
# 		x$edge_den,
# 		x$beliefs,
# 		x$edgelist,
# 		x$tree_obj$tree.list,
# 		x$tree_obj$weight.list)
#   	})
#   	outvec<- unlist(outvec)
#   	return(- mean(outvec))
# })
# #risk_path_tree
#
# #
# # lik<-tree.mix.lik(test[1,],
# # 	fit$edge_den,
# # 	fit$beliefs,
# # 	edgelist,
# # 	tree_obj$tree.list,
# # 	tree_obj$weight.list
# # )


library(data.table)
args = commandArgs(trailingOnly=TRUE)
geno_file <- args[1]
X <- as.matrix(fread(geno_file),rownames=1)
print('Done with the reading')

X2=scale(X) # Centers (subtract the column means) and Scales (dividing the centered columns by their stdev)
G=tcrossprod(X2) # Take the cross product X transpose
G=G/mean(diag(G))
EVD=eigen(G)
rownames(EVD$vectors)=rownames(G)
save(EVD,file='EVD.RData')
write.csv(EVD$vectors,"PCA_matrix.csv",row.names=T,quote=F)
write.csv(EVD$vectors[,1:5],"PCA5_geno.csv",row.names=T,quote=F)


set.seed(666)

N_0 <- 100
P <- 10
true.betas <- sample(c(-1, -1/2, 1/2, 1), P, replace = TRUE)
X_0 <- matrix(NA, nrow = N_0, ncol = P)
for(i in 1:P) X_0[, i] <- rnorm(N_0)
sy <- 2
y_0 <- rnorm(N_0, mean = X_0%*%true.betas, sd = sy)

as <- .5
bs <- 2
vb <- 1.5

### will draw from the same process for simplicity
N <- 100
X <- matrix(NA, nrow = N, ncol = P)
for(i in 1:P) X[, i] <- rnorm(N)
y <- rnorm(N, mean = X%*%true.betas, sd = sy)

nu <- 1
eta <- 1


earnings <- read.csv("https://raw.githubusercontent.com/avehtari/ROS-Examples/master/Earnings/data/earnings.csv")
fitted_model <- lm(earnings$earn ~ earnings$height)

sink("lm_output.txt", append= FALSE)
print(Sys.time(),quote=FALSE)
print(summary(fitted_model))
closeAllConnections()

#modified model:
modified_model <- lm(earnings$height ~ earnings$earn)
sink("modified_lm_output.txt")
print(summary(modified_model))
sink()

png("reg01.png")
plot(earnings$height , earnings$earn, main="Height VS Earnings", xlab="height", ylab="earnings")
abline(a=modified_model$coefficients[1], b=modified_model$coefficients[2], col="red")
dev.off


dat = read.table('{{i.infile}}', header = T, row.names = 1, sep="\t", check.names = F)
sim = cor(t(dat), method = '{{args.method}}')
p   = sim
n   = ncol(dat)

{% if args.pval %}
{% if args.method == 'pearson' or args.method == 'spearman' %}
t = sim / sqrt((1-sim*sim)/(n-2))
p = 2*pt(-abs(t), n-2)

{% elif args.method == 'kendall' %}
z = 3*sim * sqrt( n*(n-1)/2/(2*n+5) )
p = 2*pnorm(-abs(z))

{% endif %}
{% endif %}

write.table(format(sim, digits=4, scientific=F), '{{o.outfile}}', sep="\t", row.names=T, col.names=T, quote=F)
write.table(format(p, digits=3, scientific=T)  , '{{o.outpval}}', sep="\t", row.names=T, col.names=T, quote=F)


library(survival)
library(survminer)
library(lubridate)
library(dplyr)
library(Hmisc)
library(corrplot)

hyips<-read.csv("{Path to directory}/Onine-Ponzi-Schemes/analysis_hyip.csv")
km_fit <- survfit(Surv(Number.of.Days, Censored) ~ 1, data=hyips)
xmax<-max(hyips$Number.of.Days)
plot(km_fit, xlim=c(50,xmax), log="x", xlab = " Lifetime (Days)", ylab = "Overall Survival Probability", main = "Survival Function of HYIP lifetimes")
legend(leg=c('Lifetime (Observed)','Lifetime (Observed) (95% CI)'),x='topright',lty=c('solid','dashed'), cex = 0.8)

#Fit Litecoin variable with survival function

fit_litecoin <- survfit(Surv(Lifetime.In.Days, Censored) ~ Litecoin, data = hyips)

#for plotting with logarithmic x-axis

plot(fit_litecoin, conf.int = TRUE, log="x", xlim=c(50,xmax), col=c("blue", "red"), xlab = "Lifetime (Days)", ylab = "Overall Survival Probability", main = "Survival Function for Litecoin")
lines(fit_litecoin[2], conf.int=TRUE, col="red")
legend(leg=c('Does not accepts Litecoin','Accepts Litecoin','Accepts Litecoin (95% CI)'),x='topright',col=c('blue','red','red'), lty=c(1,1,2), cex = 0.7)
#Fit Ethereum variable with survival function

fit_ethereum <- survfit(Surv(Lifetime.In.Days, Censored) ~ Ethereum, data = hyips)

#for plotting with logarithmic x-axis

plot(fit_ethereum, conf.int = TRUE, log="x", xlim=c(50,xmax), col=c("blue", "red"), xlab = "Lifetime (Days)", ylab = "Overall Survival Probability", main = "Survival Function for Ethereum")
lines(fit_ethereum[2], conf.int=TRUE, col="red")
legend(leg=c('Does not accepts Ethereum','Accepts Ethereum','Accepts Ethereum (95% CI)'),x='topright',col=c('blue','red','red'), lty=c(1,1,2), cex = 0.7)
#Fit UK Valid Address variable with survival function

uk_hyips_data<-read.csv("{Path to directory}/Online-Ponzi-Schemes/lifetime_analysis_address_UK.csv")
fit_valid_add <- survfit(Surv(Lifetime.In.Days, Censored) ~ Valid.Address, data = uk_hyips_data)
ggsurvplot(fit_valid_add, pval = TRUE, conf.int = TRUE, linetype = "strata", surv.median.line = "hv", ggtheme = theme_bw(),xlab = "Lifetime (Days)", ylab = "Overall Survival Probability", main = "Survival Function for Valid Address in UK",palette = c("#E7B800", "#2E9FDF"), legend.labs = c("Not Valid UK Address", "Valid UK Address"))

#log rank test

surv_diff_ethereum <- survdiff(Surv(Lifetime.In.Days, Censored) ~ Ethereum, data = hyips)
surv_diff_ethereum
surv_diff_lite <- survdiff(Surv(Lifetime.In.Days, Censored) ~ Litecoin, data = hyips)
surv_diff_lite
surv_diff_valid_add <- survdiff(Surv(Lifetime.In.Days, Censored) ~ Valid.Address, data = uk_hyips_data)
surv_diff_valid_add

#correlation

uk_hyips_var<-read.csv("{Path to directory}/Online-Ponzi-Schemes/UK_hyip_variables.csv")
total<- hyips %>% left_join(uk_hyips_var)
cor_data<-total[,c(16,17,18)]
res2 <- rcorr(as.matrix(cor_data))

#correlation matrix visualisation
cor_data<-total[,c(1,2,3,4,5,7,9,13,14,15,16,17,18,19,20)]
res <- rcorr(as.matrix(cor_data))
corrplot(res$r, type = "upper", order = "hclust", tl.col = "black", tl.srt = 45)

#univariate Cox Regression

coxph(Surv(Lifetime.In.Days, Censored) ~ Litecoin, data = hyips)%>% gtsummary::tbl_regression(exp = TRUE)
coxph(Surv(Lifetime.In.Days, Censored) ~ Ethereum, data = hyips)%>% gtsummary::tbl_regression(exp = TRUE)
coxph(Surv(Lifetime.In.Days, Censored) ~ Valid.Address, data = uk_hyips_data)%>% gtsummary::tbl_regression(exp = TRUE)

#multivariate Cox Regression
cox_uk_var<-coxph(Surv(Lifetime.In.Days,Censored) ~ Valid.Address + Same.Address + Registered.with.Companies.House + Perfect.Money + Payeer + Bitcoin + Litecoin + Ethereum + Telegram + Facebook + Youtube + Twitter + Instagram + Goldcoders.license.check + Contact.Number, data = total)
summary(cox_uk_var)

cox_uk_nonbinary<-coxph(Surv(Lifetime.In.Days,Censored) ~ Valid.Address + Same.Address + Registered.with.Companies.House + Goldcoders.license.check + Contact.Number + Social.Media.Platforms + Payment.Processors, data = total)
summary(cox_uk_nonbinary)

cox_all<-coxph(Surv(Lifetime.In.Days,Censored) ~ Perfect.Money + Payeer + Bitcoin + Litecoin + Ethereum + Telegram + Facebook + Youtube + Twitter + Instagram + Goldcoders.license.check + Contact.Number, data = hyips)
summary(cox_all)

cox_non_binary<-coxph(Surv(Lifetime.In.Days,Censored) ~ Goldcoders.license.check + Contact.Number + Social.Media.Platforms + Payment.Processors, data = hyips)
summary(cox_non_binary


# Normal Approximation to the Binomial
# number of trails
n<-100
# probability of success of single event
z<-0.2
Mean<-n*z
s<-sqrt(n*z*(1-z))
#  e probability that at least 15 of the 100 drugs are eventually licensed (>14.5)
pnorm(14.5, mean=Mean, sd=s, lower.tail=FALSE)


library(lme4)
library(lmerTest)
library(sjPlot) #for plotting lmer and glmer mods

df_full <- read_csv("longitudinal_analysis/glob_eff_df.csv")
df_full$timepoint = as.factor(df_full$timepoint) # converting to categorical
df_full$time_group = with(df_full, interaction(timepoint,  group))

df_st <- subset(df_full, group == "st")

# get parameter estimates from a linear regression with random effects
# probably better to separate into two models

# Model 1: testing time point hypothesis
timepoint_model_fit <- lmer(glob_eff ~ timepoint + (1|subject) + (1|density_bin), df_st)

# display results of linear regression
summary(timepoint_model_fit)
plot(timepoint_model_fit, main='Analysis of time points')
res<-resid(timepoint_model_fit)
plot(res, main='Analysis of time points')

sjPlot:: tab_model(timepoint_model_fit, title = 'Analysis of time points')

qqnorm(resid(timepoint_model_fit), main = 'QQ plot, Analysis of time points')

# Model 2: group difference at individual time points hypothesis
group_model_fit <- lmer(glob_eff ~ time_group + (1|subject)  + (1|density_bin), df_full)

# display results of linear regression
summary(group_model_fit)

plot(group_model_fit, main='Analysis of group difference at time points')
res<-resid(group_model_fit)
plot(res, main='Analysis of group difference at time points')

sjPlot:: tab_model(group_model_fit, title = 'Analysis of group difference at time points')

qqnorm(resid(group_model_fit), main = 'QQ plot, Analysis of group difference at time points')


# Clearing the environment
rm(list=ls())

# libraries
library(readr)
library(dplyr)
library(tidyr)
library(TSA)
library(tseries)
library(forecast)
library(fUnitRoots)
library(lmtest)
library(fGarch)
library(CombMSC)
library(stats)
library(FitAR)

# data preparation
waste <- read_csv("Waste_collected_per_month.csv")

waste <- waste %>% separate(date, into = c("month", "day","year"), sep = "/")  %>%
  separate(year, into = c("year", "time"), sep = " ") %>%
  arrange(year, month, day) %>% select(month, year, residential)

View(head(waste))
View(tail(waste))

# converting dataframe into time series
wasteTS = ts(waste$residential, start = c(2009,4), end = c(2020,3), frequency = 12)
wasteTS

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

# Functions for Time Series
plot_ts <- function(ts, transformation)
{
  win.graph(width = 45,
            height = 30,
            pointsize = 15)
  plot(ts,
       ylab = "Waste",
       main = c(paste0(toString(transformation),
                       " plot of Waste")),
       type="o")
  points(y=ts,x=time(ts), pch=as.vector(season(ts)))
}

# Function for ACF and PACF
autoCorrelation <- function(ts, time_series)
{
  win.graph(width = 20,
            height = 15,
            pointsize = 15)

  par(mfrow=c(2,1))
  acf(ts,
      lag.max = 48,
      main = c(paste0("ACF plot of ",toString(time_series))))

  pacf(ts,
       lag.max = 48,
       main = c(paste0("PACF plot of ",toString(time_series))))
  par(mfrow=c(1,1))
}

# Functions for its Residual Analysis
residual_model <- function(model, modelname)
{
  res.model = rstandard(model)
  win.graph(width = 20,
            height = 15,
            pointsize=15)

  par(mfrow=c(3,2))

  plot(y = res.model,
       x = as.vector(time(wasteTS)),
       main = c(paste0("Time Series plot of Standardised residuals of
                       fitted ", toString(modelname))),
       xlab = 'Time',
       ylab = 'Standardized Residuals',
       type = 'o')

  hist(res.model,
       main = c(paste0("Histogram of Standardised residuals of
                       fitted ", toString(modelname))),
       xlab='Standardized Residuals')

  qqnorm(y=res.model,
         main = c(paste0("QQ plot of standardised residuals of
                         fitted ", toString(modelname))))

  qqline(y=res.model,
         col = 2,
         lwd = 1,
         lty = 2)

  print(shapiro.test(res.model))

  acf(res.model,
      lag.max = 48,
      main = c(paste0("ACF plot of standardised residuals of
                      fitted ", toString(modelname))))

  pacf(res.model,
       lag.max = 48,
       main = c(paste0("PACF plot of standardised residuals of
                       fitted ", toString(modelname))))

  k=0
  LBQPlot(res.model,lag.max = 30, StartLag = k + 1, k = 0, SquaredQ = FALSE)
  par(mfrow=c(1,1))
}

# Function for SARIMA model
SARIMA <- function(p,d,q, modelname)
{
  ml = arima(wasteTSBC,order=c(p,d,q),
             seasonal = list(order = c(2,1,1), period = 12),
             method = "ML")

  print(coeftest(ml))
  residual_model(ml,toString(modelname))

  Model <- modelname

  AIC <- AIC(ml)
  aic <- cbind.data.frame(Model,AIC)
  AIC_SCORE <- rbind(AIC_SCORE, aic)
  AIC_SCORE <<- AIC_SCORE

  BIC <- AIC(ml,k=(log(length(wasteTS))))
  bic <- cbind.data.frame(Model,BIC)
  BIC_SCORE <- rbind(BIC_SCORE, bic)
  BIC_SCORE <<- BIC_SCORE
}

#----------------------------------------------------------------------
# Descriptive Analysis
#----------------------------------------------------------------------

# Original Time Series

par(mar=c(1,1,1,1))
plot_ts(wasteTS, "Time Series")

# ACF and PACF of original Time Series
autoCorrelation(wasteTS, "Time Series")

win.graph(width = 20,
          height = 15,
          pointsize=15)
# Scatter Plot of Consecutive Years
plot(y=wasteTS,
     x=zlag(wasteTS),
     ylab='Residential Waste (Tonnes)',
     xlab='Previous Month Residential Waste (Tonnes)',
     main = "Scatter plot of Residential Waste (Tonnes) in consequtive months")

# Correlation of Consecutive Years
y = wasteTS
x = zlag(wasteTS)
index = 2:length(x)
cor(y[index],x[index]) %>% round(3)

# -----------------------------------------------------------------------
# Box-cox Transformation
# -----------------------------------------------------------------------

win.graph(width = 20,
          height = 15,
          pointsize=15)
BC <- BoxCox.ar(wasteTS)

# box-cox confidence Interval
BC$ci

# maximum likelihood
lambda <- BC$lambda[which(max(BC$loglike) == BC$loglike)]
lambda

# box-cox transformation
wasteTSBC = ((wasteTS^lambda)-1)/lambda

plot_ts(wasteTSBC, "Box-Cox Transformation Time Series")

autoCorrelation(wasteTSBC, "Box-Cox Transformation Time Series")

# -----------------------------------------------------------------------
# Residual Approach SARIMA Models
# -----------------------------------------------------------------------

m1.temp = arima(wasteTSBC,order=c(0,0,0),
                seasonal = list(order = c(0,1,0), period = 12))
res.m1 = residuals(m1.temp)
plot_ts(res.m1,"Residuals SARIMA(0,0,0)x(0,1,0)")
autoCorrelation(res.m1,"Residuals SARIMA(0,0,0)x(0,1,0)")

m2.temp = arima(wasteTSBC,order=c(0,0,0),
                seasonal = list(order = c(2,1,1), period = 12))
res.m2 = residuals(m2.temp)
plot_ts(res.m2,"Residuals SARIMA(0,0,0)x(2,1,1)")
autoCorrelation(res.m2,"Residuals SARIMA(0,0,0)x(2,1,1)")

# P = 2, D = 1, Q = 1

# p = (1,2)
# q = (1,2,3)

# SARIMA(1,0,1)x(2,1,1),
# SARIMA(1,0,2)x(2,1,1),
# SARIMA(1,0,3)x(2,1,1),
# SARIMA(2,0,1)x(2,1,1),
# SARIMA(2,0,2)x(2,1,1),
# SARIMA(2,0,3)x(2,1,1),

m3.temp = arima(wasteTSBC,order=c(2,0,2),
                seasonal = list(order = c(2,1,1), period = 12))
res.m3 = residuals(m3.temp)
plot_ts(res.m3,"Residuals SARIMA(2,0,2)x(2,1,1)")
autoCorrelation(res.m3,"Residuals SARIMA(2,0,2)x(2,1,1)")

# -----------------------------------------------------------------------
# EACF
# -----------------------------------------------------------------------
eacf(res.m2)
# SARIMA(0,0,0)x(2,1,1),
# SARIMA(0,0,1)x(2,1,1),

# -----------------------------------------------------------------------
# BIC
# -----------------------------------------------------------------------
win.graph(width = 10,
          height = 10,
          pointsize = 15)
res = armasubsets(y=res.m2,
                  nar=8,
                  nma=8,
                  y.name='test',
                  ar.method='ols')
plot(res)
# SARIMA(1,0,3)x(2,1,1),
# SARIMA(3,0,3)x(2,1,1),

# -----------------------------------------------------------------------
# set of possible SARIMA models;
# -----------------------------------------------------------------------

# SARIMA(0,0,0)x(2,1,1),
# SARIMA(0,0,1)x(2,1,1),
# SARIMA(1,0,1)x(2,1,1),
# SARIMA(1,0,2)x(2,1,1),
# SARIMA(1,0,3)x(2,1,1),
# SARIMA(2,0,1)x(2,1,1),
# SARIMA(2,0,2)x(2,1,1),
# SARIMA(2,0,3)x(2,1,1),
# SARIMA(3,0,3)x(2,1,1)

# -----------------------------------------------------------------------
# creating null data frame for AIC and BIC
# -----------------------------------------------------------------------

AIC_SCORE <- data.frame(Model = c(),
                        AIC = c())

BIC_SCORE <- data.frame(Model = c(),
                        BIC = c())

# -----------------------------------------------------------------------
# Model Fitting
# -----------------------------------------------------------------------

# SARIMA(0,0,0)x(2,1,1),
SARIMA(0,0,0,"SARIMA(0,0,0) X (2,1,1)")

# SARIMA(0,0,1)x(2,1,1)
SARIMA(0,0,1,"SARIMA(0,0,1) X (2,1,1)")

# SARIMA(1,0,1)x(2,1,1)
SARIMA(1,0,1,"SARIMA(1,0,1) X (2,1,1)")

# SARIMA(1,0,2)x(2,1,1)
SARIMA(1,0,2,"SARIMA(1,0,2) X (2,1,1)")

# SARIMA(1,0,3)x(2,1,1)
SARIMA(1,0,3,"SARIMA(1,0,3) X (2,1,1)")

# SARIMA(2,0,1)x(2,1,1)
SARIMA(2,0,1,"SARIMA(2,0,1) X (2,1,1)")

# SARIMA(2,0,2)x(2,1,1)
SARIMA(2,0,2,"SARIMA(2,0,2) X (2,1,1)")

# SARIMA(2,0,3)x(2,1,1)
SARIMA(2,0,3,"SARIMA(2,0,3) X (2,1,1)")

# SARIMA(3,0,3)x(2,1,1)
SARIMA(3,0,3,"SARIMA(3,0,3) X (2,1,1)")

# -----------------------------------------------------------------------
# Finding Best Model
# -----------------------------------------------------------------------
AIC_SCORE %>% unique() %>%  arrange(AIC)
BIC_SCORE %>% unique() %>%  arrange(BIC)

# -----------------------------------------------------------------------
# SARIMA(3,0,3)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(4,0,3)x(2,1,1)
SARIMA(4,0,3,"SARIMA(4,0,3) X (2,1,1)")

# SARIMA(3,0,4)x(2,1,1)
SARIMA(3,0,4,"SARIMA(3,0,4) X (2,1,1)")

# -----------------------------------------------------------------------
# SARIMA(3,0,4)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(3,0,5)x(2,1,1)
SARIMA(3,0,5,"SARIMA(3,0,5) X (2,1,1)")

# SARIMA(4,0,4)x(2,1,1)
SARIMA(4,0,4,"SARIMA(4,0,4) X (2,1,1)")

# -----------------------------------------------------------------------
# SARIMA(3,0,5)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(3,0,6)x(2,1,1)
SARIMA(3,0,6,"SARIMA(3,0,6) X (2,1,1)")

# SARIMA(4,0,5)x(2,1,1)
SARIMA(4,0,5,"SARIMA(4,0,5) X (2,1,1)")

# -----------------------------------------------------------------------
# SARIMA(4,0,5)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(4,0,6)x(2,1,1)
SARIMA(4,0,6,"SARIMA(4,0,6) X (2,1,1)")

# SARIMA(5,0,5)x(2,1,1)
SARIMA(5,0,5,"SARIMA(5,0,5) X (2,1,1)")

# -----------------------------------------------------------------------
# Forecasting
# -----------------------------------------------------------------------
forecasting = Arima(wasteTS,order=c(4,0,5),
                    seasonal=list(order=c(2,1,1), period=12),
                    lambda = -0.1,
                    method = "ML")
prediction = forecast(forecasting, h = 10)

win.graph(width = 10,
          height = 10,
          pointsize = 15)
plot(prediction)

prediction


#' Compute trace of a square matrix, that is, the sum
#' of its diagonal elements.
#'
#' @param m a square matrix
#'
#' @return trace of input matrix
tr <- function(m) {
    sum(diag(m))
}


#'@title calcHMBulbousBowRes
#'
#'@description Calculate bulbous bow resistance (\code{Rb}) (kN) from the
#'Holtrop & Mennen method.
#'
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param forwardDraft Forward draft (deviation from actual draft indicates trim)
#' (vector of numericals, m)
#'@param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#'@param Abt Traverse bulb area (vector of numericals, m^2) (see
#' \code{\link{calcAbt}})
#'@param hb Center of bulb area above keel line (vector of numericals, m)
#' (see \code{\link{calchb}})
#'@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{Rb} (vector of numericals, kN)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcAbt}}
#'\item \code{\link{calchb}}
#'}
#'
#'@family Holtrop-Mennen Calculations
#'@family Resistance Calculations
#'
#'@examples
#' calcHMBulbousBowRes(seq(1,5,1),13.57,13.57,25.09,5.43,seawaterDensity=1.025)
#'
#'@export

calcHMBulbousBowRes<-function(shipSpeed,maxDraft,forwardDraft,
                            Abt,hb,seawaterDensity=1.025){
Rb<-
  0.11*exp(-3*((
  (0.56*sqrt(Abt)/(forwardDraft-1.5*hb))
)^-2))*((
  (shipSpeed)/sqrt(9.81*(forwardDraft-hb-0.25*sqrt(Abt))+0.15*((shipSpeed)^2))
)^3)*(Abt^1.5)*seawaterDensity*9.81/(1+((
  (shipSpeed)/sqrt(9.81*(forwardDraft-hb-0.25*sqrt(Abt))+0.15*((shipSpeed)^2))
)^2))

return(Rb)
}


'
Аналогично заданию 2, проверить работу арифметических операторов для векторов. Последовательно использовать векторы:
1) одного типа, одного размера
2) одного типа, разных размеров
3) разных типов, одного размера
4) разных типов, разного размера
Обобщить результаты расчетов в виде правил вычисления результирующего вектора.
'

#Одного типа, одного размера
vector1 <- c(1,2,3,4)
vector2 <- c(4,6,3,6)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2

#Одного типа, разных размеров
vector1 <- c(1,2,3,4, 4,5,2)
vector2 <- c(4,6,3,6)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2

#Разных типов, одного размера
vector1 <- c(TRUE, FALSE, TRUE, TRUE)
vector2 <- c(4,6,3,6)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2

#Разных типов, разного размера
vector1 <- c(TRUE, FALSE, TRUE, TRUE)
vector2 <- c(4,6,3,6,6,2,6,2,5)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2


####################
##this is r developing code for running simulation to generate
##the DNA/protein microarray data
## the model (ref: smyth 2004, Bayesian hierarchical model and linear model)
##  linear model:
##             Y_ijk=alpha_i+beta_j+ gamma_ij+ epsilon_ijk
##		see the doc named: "Microarray data simulation.doc"
##    feng@BU   09/03/2016
##
##	Note: Oct 1st 2016, the code listed here is the old one that before
##		writing them up into package functions. We keep them for reference
##
####################################
library(limma)

set.seed(2004);
#define the variables
numTreatment<-2   #number of different beta
numGene<-1000 #number of alpha
sampleSize<-100 ##this is the number of repeats for each group

alpha0_sigma<-2  #variance for alpha prior
beta0_sigma<-3   #variance for beta prior

#v0<-10  # the unscaled factor for gamma given gamma<=>0
gamma0_diff_sigma<-3

#the effects are assumed to be non negative and also fixed effect
#but following a normal distribution
alpha0<-(rnorm(numGene, 0,alpha0_sigma))
beta0<-(rnorm(numTreatment,0,beta0_sigma))

#
p_diff<-0.01
numGene_diff<-floor(numGene*p_diff)

#priors for variance distribution
d0<-5
sSquare0<-2

gamma0<-matrix(rep(0,numGene*numTreatment),nrow=numGene, byrow=T)

##in this following code snip, we randomly distribute the differential gamma into
##different positions across different treatment group
##other part is
for(i in c(1:numTreatment))
{
	pos_diff<-sample(numGene, size=numGene_diff, replace=T)
	gamma0[pos_diff,i]<-(rnorm(numGene_diff,0,gamma0_diff_sigma))
}

##now ready to generate variance
gamma0_var<-matrix(rchisq(numGene*numTreatment, df=d0),nrow=numGene, byrow=T)
gamma0_var<-1/(d0*sSquare0*sSquare0)*gamma0_var
gamma0_var<-1/gamma0_var

#now we have everything ready, do the observation values
#put them into matrix first
groupInfo<-rep(0,sampleSize*numTreatment)
Y_ijk<-matrix(rep(0,numGene*numTreatment*sampleSize),nrow=numGene,byrow=T)
for(j in c(1:numTreatment)) #for different treatment
{
	samplePos<-c(1:sampleSize)+(j-1)*sampleSize;
	groupInfo[samplePos]<-j;
	for(k in c(1:numGene))
	{
		#write the meta data first
		Y_ijk[k,samplePos]<-alpha0[k]+beta0[j]+gamma0[k,j]
		Y_ijk[k,samplePos]<-Y_ijk[k,samplePos]+rnorm(sampleSize,0,sqrt(gamma0_var[k,j]))
	}
}

##==========>now testing the function code in the module
library(ARPPA)

nGene<-2000
nTreatment<-numTreatment   #number of different beta
sampleSize<-20 ##this is the number of repeats for each group

alpha.mean<-0  #variance for alpha prior
alpha.sigma<-alpha0_sigma
beta.mean<-0
beta.sigma<-beta0_sigma   #variance for beta prior

#v0<-10  # the unscaled factor for gamma given gamma<=>0
gammaN0.sigma<-gamma0_diff_sigma

p_diff<-0.01

#priors for variance distribution
d0<-10
s0<-2

#call it
set.seed(2004);
dataExp<-simulateExpression(nGene, nTreatment, sampleSize,
					alpha.mean=alpha.mean, alpha.sigma=alpha.sigma,
					beta.mean=beta.mean, beta.sigma=beta.sigma,
					prob.nonZero=0.01, gamma.sigma=gammaN0.sigma,
					epsilon.d0=d0, epsilon.s0=s0
					)

##now start fitting the model to estimate the EBayes parameters
#defining a S3 function for calculating the prior variance and df
#based on the observed variance
calculatePriorVariance<-function (x,df)
{
	eg<-log(x)-digamma(df/2)+log(df/2)
	eg_bar<-mean(eg)
	tg_d02<-mean((eg-eg_bar)*(eg-eg_bar)*length(x)/(length(x)-1)-trigamma(df/2))
	d0<-trigammaInverse(tg_d02)*2
	s02<-exp(eg_bar+digamma(d0/2)-log(d0/2))

	prior<-list(d0=d0, s02=s02)

}

scaledChiSq_Pdf<-function(x, d0, s0)
{
	x_t<-d0*s0*s0/(x*x)
	#x_t<-sqrt(x_t)
	1/(2^(d0/2)*gamma(d0/2))*x_t^(d0/2-1)*exp(-1*x_t/2)
}

####testing code
###following the example for R help for eBayes
#  See also lmFit examples

#  Simula2te gene expression data,
#  6 microarrays and 100 genes with one gene differentially expressed
set.seed(2004); invisible(runif(100))
M <- matrix(rnorm(100000*60,sd=0.3),100000,60)
M[1,] <- M[1,] + 1
fit <- lmFit(M)

#  Moderated t-statistic
fit <- eBayes(fit)

x<-fit$sigma*fit$sigma
df<-fit$df.residual

r<-sampleVariancePrior(x,df)

#testing code 2
#testing the data generated by the Y_ijk model above
#first got the variance

Y_ijk<-dataExp$exp
tY<-data.frame(t(Y_ijk))
tY$group<-c(rep(1,sampleSize),rep(2,sampleSize))
varY<-aggregate(tY,by=list(tY$group),FUN=var) #by doing aggregate, the new dataframe is arranged to have first column for "by" criteria.
		#that is why in the next step, we need to get rid of the first column and last one, since the last one is the one we added as the group info.
varK<-varY[,c(-1,-nGene-2)]

x<-as.numeric(c(varK[1,],varK[2,]))
df<-rep(sampleSize-1,length(x))

r2<-calculatePriorVariance(x,df)


boltzmann <- 3.167e-6 #hartree/K

calcul.partition <- function(valeurs, temperature){
	expo <- exp(-valeurs/(temperature * boltzmann))
	return(sum(expo))
}

calcul.energie <- function(valeurs, temperature){
	derivee <- (calcul.partition(valeurs, temperature + 1) - calcul.partition(valeurs, temperature - 1)) / 2 #Premier ordre, dT = 1
	energie <- 2 * boltzmann * temperature^2 * derivee
	energie <- energie + min(valeurs) #Energie de point 0
	return(energie)
}


library(dplyr)
library(ggplot2)
library(cluster)
library(factoextra)
library(corrplot)
library(clValid)
# Preprocessing the data

data <- read.csv(file = 'data.csv', header = FALSE, row.names = 1)
head(data)
data = t(data)
ncol(data)
nrow(data)

data = as.data.frame(data)
data = dplyr::filter(data, pathology != 3)
length(data$pathology)
data.train = subset(data, select = -c(pathology))
label = data$pathology

# Viusalzing using PCA

library(factoextra)
pcclust=prcomp(data.train,scale=FALSE) #principal component analysis
summary(pcclust)
pcclust$rotation[,1:2]

dignm<-as.character(data$pathology)
Classes = factor(label,labels = c("Healthy","BAV patients"))
pcclust$x[,1:2]

plot(pcclust$x[,1:2], col = data$pathology,xlab ="PC-1",ylab="PC-2")
legend("topright",title = "clusters",legend = unique(dignm), fill=unique(data$pathology))

# Viz using ggplot
g = ggplot(data.frame(pcclust$x[,1:2]), aes(pcclust$x[,1], pcclust$x[,2], color = Classes)) +
  xlab("PCA 1") +
  ylab("PCA 2") +
  geom_point(size = 4)

g

# Visualizing using T-SNE plot
#perpl=35,iterations=2000

library(Rtsne)

label = as.factor(data$pathology)
Classes = factor(label,labels = c("Healthy","BAV patients"))
colors = rainbow(length(unique(label)))
names(colors) = unique(label)

tsne_plot <- function(perpl=5,iterations=500){
  set.seed(1) # for reproducibility
  tsne <- Rtsne(data.train, dims = 2, check_duplicates = FALSE,perplexity=perpl, verbose=TRUE, max_iter = iterations)
  ##Silhoutte coefficient
  df = data.frame(tsne$Y[,1],tsne$Y[,2])
  sil = silhouette(data$pathology, dist(df))
  print(mean(sil[,3]))
  ##correlation coefficient
  print(cor(tsne$Y[,1],tsne$Y[,2],  method = "pearson"))

  ## Connectivity
  #install.packages("clValid")
  print(connectivity(distance = dist(df), data$pathology, neighbSize = 4,
                    method = "euclidean"))
  g1 = ggplot(data.frame(tsne$Y), aes(tsne$Y[,1], tsne$Y[,2], color = Classes)) +
  xlab("TSNE 1") +
  ylab("TSNE 2")+
  ggtitle("Perplexity = 15,Iterations = 1000")+
  geom_point(size = 4)

}
g1 = tsne_plot()

g1

# Visualizing using UMAP
#n_neighbors = 56,min_dist = 0.5,metric = 'euclidean', random_state = as.integer(45))
#n_neighbors = 84,min_dist = 0.5,metric = 'euclidean', random_state = as.integer(12)
#n_neighbors = 12,min_dist = 0.1,metric = 'euclidean', random_state = as.integer(45)
#devtools::install_github("ropenscilabs/umapr")

library(umapr)
library(tidyverse)

df <- as.matrix(data.train)
label = as.factor(data$pathology)
Classes = factor(label,labels = c("Healthy","BAV patients"))
# run UMAP algorithm
embedding <- umap(df,n_neighbors = 56,min_dist = 0.5,random_state = as.integer(45))
#head(embedding)

g2 = embedding %>%
  ggplot(aes(UMAP1, UMAP2, color = Classes)) +
  xlab("UMAP 1") +
  ylab("UMAP 2")+
  ggtitle("n_neighbors = 12,min_dist = 0.1,metric = 'euclidean'")+
  geom_point(size = 4)

g2

#Silhoutte coefficient

df = data.frame(embedding$UMAP1,embedding$UMAP2)
sil = silhouette(data$pathology, dist(df))
mean(sil[,3])

#correlation coefficient
cor(embedding$UMAP1,embedding$UMAP2,  method = "pearson")

#Connectivity
#install.packages("clValid")
library(clValid)
connectivity(distance = dist(df), data$pathology, neighbSize = 4,
             method = "euclidean")

#Stability

mat = matrix(df)

stability(mat, Dist=NULL,del = 2,cluster = data$pathology, clusterDel= 2, method="euclidean")

#Working with hyperparameters

#n_neighbors
#min_dist
#n_components
#metric

neighbors <- c(4,8,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68,72,76,80,84,88,92,96,100)

neighbors %>%
  map_df(~umap(as.matrix(data.train), n_neighbors = .x, random_state = as.integer(45)) %>%
           mutate(pathology = data$pathology, Neighbor = .x)) %>%
  mutate(Neighbor = as.integer(Neighbor)) %>%
  ggplot(aes(UMAP1, UMAP2, color = pathology)) +
  geom_point() +
  facet_wrap(~ Neighbor, scales = "free")

# Multi Dimensional Scaling

data.train <- dist(data.train) # euclidean distances between the rows
fit <- cmdscale(data.train,eig=TRUE, k=2, add = FALSE, x.ret = FALSE)

x <- fit$points[,1]
y <- fit$points[,2]

ggplot(data.frame(fit$points), aes(x, y, color = Classes)) + geom_point(size = 3)

g1

install.packages("ggpubr")
library(ggpubr)

ggarrange(g,g1,g2,g3,
          labels = c("A", "B", "C","D"),
          ncol = 2, nrow = 2)

library(ggplot2)
library(Rtsne)
tsne_plot <- function(perpl=30,iterations=2000){
  set.seed(1) # for reproducibility
  tsne <- Rtsne(data.train, dims = 2, check_duplicates = FALSE,perplexity=perpl, verbose=TRUE, max_iter = iterations)
  ggplot(data.frame(tsne$Y), aes(tsne$Y[,1], tsne$Y[,2], color = data$pathology)) + geom_point()

}

perplexity_values <- c(2,5,30,50,100)
sapply(perplexity_values,function(i){tsne_plot(perpl=i)})

#install.packages("devtools")
library(usethis)
library(devtools)
install_github("crj32/M3C")
library(tsne)
library(M3C)

result = tsne(df, data$pathology, perplex=5)
result = data.frame(result)

ggplot(result, aes(X1, X2, color = data$pathology)) + geom_point()

p <- ggplot(mtcars, aes(mpg, wt)) +
  geom_point(aes(colour = factor(cyl)))
p + scale_colour_manual(values = c("red", "blue", "green"))


library(stats)
library(float, quietly=TRUE)
library(rbenchmark)
set.seed(1234)

reps = 5
cols <- c("test", "replications", "elapsed", "relative")

m = 7500
n = 500
x = matrix(rnorm(m*n), m, n)
s = fl(x)

cov_spm = function(x)
{
  s = scale(x, TRUE, FALSE)
  crossprod(s) / max(1L, nrow(x)-1)
}

cor_spm = function(x)
{
  s = scale(x, TRUE, TRUE)
  crossprod(s) / max(1L, nrow(x)-1)
}

cat("##### covariance\n")
benchmark(cov_spm(x), cov_spm(s), cov(x), replications=reps, columns=cols)
cat("\n##### correlation\n")
benchmark(cor_spm(x), cor_spm(s), cor(x), replications=reps, columns=cols)


# Euler1 in R

#Set recursion limit
options(expressions = 10000)

myInt <- function(n) ifelse (n%%3 == 0 || n%%5 == 0, n, 0)

euler <- function(n, acc) {
    ifelse (n == 0,
        acc,
        euler(n-1, myInt(n)+acc))
}

euler1 <- function(n) euler(n, 0)

euler1(999)


# Generate an object containing the data in “Aphid_longevity_A06_405.txt” using read.table()
Aphids <- read.table("Aphid_longevity_A06_405.txt", header = TRUE)

# Check that the data have been imported properly using str()
# str(Aphids)
# SUCCESS! RESULT => 'data.frame':   55 obs. of  2 variables:
# $ subline : Factor w/ 7 levels "H30","H323","H402",..: 2 7 5 3 1 4 6 2 1 6 ...
# $ age.days: int  22 27 20 26 21 34 29 14 25 27 ...

# Draw a boxplot with the factor levels on the x-axis and longevity on the y-axis
boxplot(age.days ~ subline,
data = Aphids,
main = "Longevity of Aphids Infected with Different Strains of H.defensa",
xlab = "Factor Levels",
ylab = "Longevity"
)

# Error: $ operator is invalid for atomic vectors (Aphids$age.days)
# Is there anything that might make an ANOVA unsuitable for analysing these data as they are?


# Maze generator in R
# Joe Wingbermuehle 2013-10-03

# Function to create an empty maze array of width by height.
init_maze <- function(width, height) {
   m <- rep(0, times = width * height)
   dim(m) <- c(width, height)
   m[1, 1:height] <- 1
   m[width, 1:height] <- 1
   m[1:width, 1] <- 1
   m[1:width, height] <- 1
   m
}

# Display a maze.
show_maze <- function(m) {
   for (y in 1:dim(m)[2]) {
      str <- ""
      for (x in 1:dim(m)[1]) {
         if(m[x, y] == 1) {
            str <- paste(str, "[]", sep = '')
         } else {
            str <- paste(str, "  ", sep = '')
         }
      }
      print(str)
   }
}

# Carve a maze starting at x, y.
carve_maze <- function(m, x, y) {
   m[x, y] <- 1
   d <- floor(3 * runif(1))
   xdirs <- c(1, -1, 0, 0)
   ydirs <- c(0, 0, 1, -1)
   for (i in 0:3) {
      j <- 1 + (i + d) %% 4
      dx <- xdirs[j]
      dy <- ydirs[j]
      nx1 <- x + dx
      nx2 <- nx1 + dx
      ny1 <- y + dy
      ny2 <- ny1 + dy
      if (m[nx1, ny1] == 0 && m[nx2, ny2] == 0) {
         m[nx1, ny1] <- 1
         m <- carve_maze(m, nx2, ny2)
      }
   }
   m
}

# Generate and display a random maze.
# Note that the width and height of the maze must be odd.
m <- init_maze(37, 23)
m <- carve_maze(m, 3, 3)
show_maze(m)


#Lesson 3: Interrogating your data

library(ggplot2)

filename <- "lesson_3/Encode_HMM_data.txt"

my_data <- read.csv(filename, sep="\t", header=FALSE)

head(my_data)

names(my_data)[1:4] <- c("chrom", "start", "stop", "type")

ggplot(my_data, aes(x=chrom, fill=type)) + geom_bar()

dim(my_data)

# We can ask our data some questions
# For categorical values, summary will give you how many rows have a given value
# For numerical values, summary will let you know some statistical calculations

summary(my_data)

# using "$", we can break down the data further

summary(my_data$chrom)
summary(my_data$type)
summary(my_data$start)
summary(my_data$stop)

#by using "$", you can even create new columns with data in our data-frame
my_data$size = my_data$stop - my_data$start
# you can get basic stats on a given column using mean(), sd(), median(), max(), min()
summary(my_data$size)

mean(my_data$size)
sd(my_data$size)
median(my_data$size)
max(my_data$size)
min(my_data$size)


#' @title line.intersection.2d
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
line.intersection.2d = function( p1a, p1b, p2a, p2b ) {

  dim_num = 2

  line1 = explicit.to.implicit.2d.line( p1a, p1b )
  line2 = explicit.to.implicit.2d.line( p2a, p2b )

#%  Set up and solve a linear system.
  a = rbind( line1, line2)
  y = - a[,3]
  X = a[,c(1:2)]
  p = try( solve ( X,y) )

#%  If the inverse exists, then the lines intersect at the solution point.

  if ( class( p ) == "try-error" ) p=NULL

#%  If the inverse does not exist, then the lines are parallel
#%  or coincident.

  return ( p )

}


library(GEOquery)
library(ggplot2)

# get the data from GEO ( GSE matrix & annotation GPL)
# define destination to save data, SO didn't need load data each time
series = "GSE34670"
platform = "GPL96"
gset = getGEO(series, GSEMatrix =TRUE, AnnotGPL=TRUE, destdir = "Data/")
# if the data have several platforms, choose the certain platform
if (length(gset) > 1) idx <- grep(platform, attr(gset, "names")) else idx <- 1
gset = gset[[idx]]

# define groups for samples
gr = c(rep("cALL_BM", 5) , "cALL_PB" ,rep("cALL_BM", 19), "CL_cALL2" , "CL_697" , "CL_NALM6" , rep("CD10", 6), rep("CD10_pool" , 3) )
# elicit expression matrix from data
ex = exprs(gset)

# log2 transformation
ex = log2(ex + 1 )
exprs(gset) = ex

# principal component analysis (PCA)
# PCA for genes & plot it
pc = prcomp(ex)
pdf("Results/pc.pdf")
plot(pc)
plot(pc$x[,1:2])
dev.off()

# zero mean normalization & compute PCA & plot it
ex.scale = t(scale(t(ex), scale = F))
pc = prcomp(ex.scale)
pdf("Results/pc_scaled.pdf")
plot(pc)
plot(pc$x[,1:2])
dev.off()

# PCA for samples & plot it
pcr = data.frame(pc$r[,1:3], Group=gr)
pdf("Results/PCA_SAmples.pdf")
ggplot(pcr, aes(PC1, PC2, color=Group)) + geom_point(size=3) + theme_bw()
dev.off()


mean_men<-177 #mean
sd_men<-10 #standard deviation
val_men<-200 #target value
z_mean<-(val_men - mean_men)/sd_men # calculating z-score
p_men<-pnorm(z_mean) #area under the curve from -infinity till the taget value
p_target<-1 - p_men #area under the curve is 1. So substracting from 1 toget the target area
Prob_target<-p_target*100

R Community/R Stats_Basics Part 1/Assignment4.r


Groesse <- c(176, 166, 172, 184, 179, 170, 176)
Gewicht <- c(65, 55, 67, 82, 75, 65, 75)

cor(Gewicht, Groesse, method="pearson")
reg <- lm(Gewicht~Groesse)
summary(reg)

plot(Gewicht~Groesse)
abline(reg)


#!/usr/bin/Rscript
# -*- coding: utf-8 -*-
# Name: data-mining.r
# Version: 0.1a2

library(caret)
library(data.table)
library(dplyr)
library(PerformanceAnalytics)
library(rpart.plot)

########## 1 Data Overview ##########
# Load `data_banknote_authentication.txt` file
url = paste('https://archive.ics.uci.edu/ml/machine-learning-databases/00267/',
            'data_banknote_authentication.txt', sep='')
df = data.frame(fread(url))
names(df) = c('variance', 'skewness', 'curtosis', 'entropy', 'class')

# Check size of `df` dataframe
nrow(df)

# Show the first part of `df` dataframe
head(df, 5)

# Show the last part of `df` dataframe
tail(df, 5)

########## 2 Summary Statistics ##########
########## 2.1 Mean ##########
print(noquote(paste0('Mean. Variance of Wavelet Transformed image: ', mean(df$variance))))
print(noquote(paste0('Mean. Skewness of Wavelet Transformed image: ', mean(df$skewness))))
print(noquote(paste0('Mean. Curtosis of Wavelet Transformed image: ', mean(df$curtosis))))
print(noquote(paste0('Mean. Entropy of image: ', mean(df$entropy))))

########## 2.2 Median ##########
print(noquote(paste0('Median. Variance of Wavelet Transformed image: ',
                     median(df$variance))))
print(noquote(paste0('Median. Skewness of Wavelet Transformed image: ',
                     median(df$skewness))))
print(noquote(paste0('Median. Curtosis of Wavelet Transformed image: ',
                     median(df$curtosis))))
print(noquote(paste0('Median. Entropy of image: ', median(df$entropy))))

########## 2.3 All-in-One ##########
print(noquote('Summary:'))
summary(select(df, -class))

########## 2.4 Correlation ##########
cor(df)

chart.Correlation(select(df, -class), histogram=TRUE)

########## 3 Graphics ##########
########## 3.1 Histograms ##########
par(mfrow=c(2,2))
hist(df$variance, main='Histogram of Variance',
     xlab='Variance of Wavelet Transformed Image')
hist(df$skewness, main='Histogram of Skewness',
     xlab='Skewness of Wavelet Transformed Image')
hist(df$curtosis, main='Histogram of Curtosis',
     xlab='Curtosis of Wavelet Transformed Image')
hist(df$entropy, main='Histogram of Entropy',
     xlab='Entropy of Image')

########## 3.2 Boxplots ##########
par(mfrow=c(2,2))
boxplot(df$variance, data=df, main='Boxplot. Variance', horizontal=TRUE)
boxplot(df$skewness, data=df, main='Boxplot. Skewness', horizontal=TRUE)
boxplot(df$curtosis, data=df, main='Boxplot. Curtosis', horizontal=TRUE)
boxplot(df$entropy, data=df, main='Boxplot. Entropy', horizontal=TRUE)

########## 4 Near Zero Variance Predictors ##########
nearZeroVar(select(df, -class), saveMetrics=TRUE)

########## 5 Linear Combinations ##########
findLinearCombos(select(df, -class))

########## 6 Highly Correlated Variables ##########
df$class = as.character(ifelse(df$class=='1', 'Y', 'N'))
df2 = select(df, -class)
cor_matrix = cor(df2)
print(noquote('Highly correlated variables:'))
summary(cor_matrix[upper.tri(cor_matrix)]) # upper triangular part of a matrix

high_cor_var = findCorrelation(cor_matrix, cutoff = 0.75) # check var above 0.75
print(noquote(paste0('Highly correlated variables: ', names(df2)[high_cor_var])))

# Delete highly correlated `skewness` column from dataframe
df2 = select(df2, -skewness)

cor_matrix = cor(df2)
print(noquote('Highly correlated variables:'))
summary(cor_matrix[upper.tri(cor_matrix)]) # upper triangular part of a matrix
df = cbind.data.frame(df2, class = df$class) # add class

########## 7 Distribution ##########
print(noquote('Distribution:'))
table(df$class)

class_freq = data.frame(table(df$class))
names(class_freq) = c('class', 'freq')
percent_chart = cbind(class_freq,
                      percent=round((class_freq$freq/sum(class_freq$freq))*100, 1))
percent_chart

slices = percent_chart$percent
lbls = c('N', 'Y')
pct = round(slices/sum(slices)*100, 1)
lbls = paste(lbls, pct) # add values of pct to labels
lbls = paste(lbls, '%', sep='') # add % char to labels
pie(slices, labels=lbls, radius=1, main='Pie Chart of Distribution',
    clockwise=TRUE)

featurePlot(x=select(df, -class), y=df$class, plot='box')

########## 8 Decision Tree ##########
rtree_set = rpart(class ~ ., df)
prp(rtree_set)

########## 9 Classification ##########
# Split the data to train and test sets
train_ind = createDataPartition(df$class, p=0.7, list=FALSE)
data_train = data.frame(df[train_ind, ])
data_test = data.frame(df[-train_ind, ])
print(noquote('Train:'))
table(data_train$class)
print(noquote('Test:'))
table(data_test$class)

# Choose validation method for the test of model
valid_par = trainControl(method='repeatedcv', number=5, repeats=10, p=0.70, preProc='range')

########## 9.1 SVM ##########
mod_svm = train(class ~ ., data=data_train, trControl=valid_par, method='svmRadial')
mod_svm

########## 9.2 KNN ##########
mod_knn = train(class ~. , data=data_train, trControl=valid_par, method='knn')
mod_knn

# Show summary
print(noquote('Summary:'))
mod_results = resamples(list(SVM=mod_svm, KNN=mod_knn))
summary(mod_results)

########## 9.3 SVM vs KNN ##########
bwplot(mod_results, scales=list(x=list(relation='free'), y=list(relation='free')))

# Test models
test = select(data_test, -class)
test_sum = data_test$class
mod_predict_svm = predict(mod_svm, test)
print(noquote('SMV:'))
confusionMatrix(mod_predict_svm, test_sum)
mod_predict_knn = predict(mod_knn, test)
print(noquote('KNN:'))
confusionMatrix(mod_predict_knn, test_sum)


##' Data Imputation
##'
##' Impute data by various methods.
##' @title Data Imputation
##' @param x the numeric data matrix
##' @param method imputation method; one of the following:
##' \describe{
##'   \item{below.min}{replace missing values by a value 20\% below the mininum}
##' }
##' @return the imputed data
##' @author Yihui Xie <\url{http://yihui.name}>
na.impute = function(x, method = 'below.min') {
    apply(x, 2, function(xx) {
        if (any(is.na(xx))) {
            xx[is.na(xx)] = switch(method,
              'below.min' = min(xx, na.rm = TRUE) - 0.2 * diff(range(xx, na.rm = TRUE)))
        }
        xx
    })
}

##' Give a column-wise scalar summary of the data frame or matrix.
##'
##' For numeric columns, the function specified by \code{fun} will be applied
##' (\code{median()} by default); for other types of columns, the mode will be
##' caculated (i.e. the categories that have the maximum frequencies) and the
##' returned value is a single string with the category labels separated by
##' \code{', '}.
##' @title Give a Column-wise Scalar Summary of the Data Frame or Matrix
##' @param x the data frame or matrix to be summarized
##' @param fun the function to be applied to numeric columns
##' @param ... other arguments to be passed to \code{fun}
##' @return a vector corresponding to columns of \code{x}
##' @author Yihui Xie <\url{http://yihui.name}>
##' @examples
##' summary_one(iris)
##' summary_one(iris[1:70, ])
##' summary_one(mtcars)
summary_one = function(x, fun = median, ...) {
    ## it is not easy to use this function in qmutaframe(); current implementation
    ## is ugly; we need mutalist; but how many people really care about the
    ## summarizing function other than median?
    x = as.data.frame(x)
    mode_label = function(x) {
        tb = table(x)
        paste(names(which(tb == max(tb))), collapse = ', ')
    }
    sapply(x, function(xx){
        ifelse(is.numeric(xx), fun(xx, ...), mode_label(xx))
    })
}


#' Random PCA
#'
#' @param x
#' The input data matrix.
#' @param k
#' The number of singular values and/or left/right singular vectors
#' to estimate.
#' @param q
#' An integer exponent, say 1, 2, or 3.  See the paper for details.
#' @param retx
#' Logical;  determines if the rotated data should be returned.
#' @param center,scale
#' Logical; determines if the data should be centered/scaled first.
#'
#' @return
#' An object of class \code{prcomp}.
#'
#' @references
#' Halko, Martinsson, and Tropp. 2011. Finding structure with
#' randomness: probabilistic algorithms for constructing approximate
#' matrix decompositions. SIAM Review 53 217-288.
#'
#' Duda, R. O., Hart, P. E., & Stork, D. G. (2012). Pattern classification,
#' chapter 10. John Wiley & Sons.
#'
#' @author
#' Drew Schmidt
#'
#' @examples
#' \dontrun{
#' x <- matrix(rnorm(30), 10)
#'
#' rpca(x)
#' }
#'
#' @keywords SVD PCA
#' @name rpca
#' @rdname rpca
#' @export
rpca <- function(x, k=1, q=3, retx=TRUE, center=TRUE, scale=FALSE)
{
  if (class(x) != "ddmatrix")
    x <- as.matrix(x)

  assert.type(retx, "logical")
  assert.type(center, "logical")
  assert.type(scale, "logical")

  # Check needs to be here so we don't do anything demanding before possibly needing to error out
  rsvd.checkargs(x=x, k=k, q=q, retu=FALSE, retvt=TRUE)

  assert.type(x, "numeric")

  if (center || scale)
    x <- scale(x, center=center, scale=scale)

  svd <- rsvd(x=x, k=k, q=q, retu=FALSE, retvt=TRUE)
  svd$d <- svd$d / sqrt(nrow(x) - 1L)

  if (center)
    center <- attr(x, "scaled:center")[1:k]
  if (scale)
    scale <- attr(x, "scaled:scale")[1:k]

  pca <- list(sdev=svd$d, rotation=t(svd$vt), center=center, scale=scale)

  if (is.matrix(x))
    colnames(pca$rotation) <- paste0("PC", 1:ncol(pca$rotation))
#  else #FIXME

  if (retx)
    pca$x <- x %*% pca$rotation
  class(pca) <- "prcomp"

  return(pca)
}


est_comp_joint_HMcontinuous <- function(tT,tU,TT,W,X,Y,tv,dev,k,type=c("norm","bino")){

# Estimate the joint model with continuous HM chain described in
# "A shared-parameter continuous-time hidden Markov and survival model for longitudinal data
#  with informative drop-out"
# by F.Bartolucci and A.Farcomeni (2018)
#
# COMPLETE DATA CASE
#
# INPUT:
# tT   = time of any (time-continuous jump)
# tU   = matrix of latent states
# TT   = matrix of times of observation of any longitudinal outcome
# W    = matrix of baseline covariates
# X    = array of time-varying covariates
# tv   = vector of survival times
# dev  = vector of censoring
# k    = number of latent states
#
# OUTPUT:
# bev  = estimated regression coefficients on the longitudinal process
# nu   = estimated parameter of the Weibull distribution
# xiv  = estimated vector of support points
# phi  = estimated relation between longitudal and survival process
# psiv = estimated vector of regression paraemters on the survival process
# piv  = estimated initial probability vector
# Q    = estimated infinitesimal transition matrix
# si2  = estimated variane for normal responses
# tnv  = vector of frequencies of each state at the first occasion
# tN   = vector of frequencies for each pair of states
# sv   = vector of sojourn times

# Preliminaries
	type = match.arg(type)
	n = nrow(tT)                    # sample size
	tjv = rowSums(!is.na(tU))-1     # number of jumps
	ncovW = ncol(W)
	TTX = dim(X)[2]
	ncovX = dim(X)[3]
# Initial values
	xiv = seq(1:k)                  # support points
	xiv = xiv-mean(xiv)
	piv = rep(1/k,k)                # initial probabilty vector
	Q = matrix(1/(k-1),k,k)         # infinitesimal transition matrix
	diag(Q) = -1
	if(type == "norm")	si2 = 1 else si2 = NULL   # variance of continuous data
	bev = rep(0,ncovX)              # corresponding regression parameters
	phi = 0                         # random-effect coefficient on survival process
	psiv = rep(0,ncovW)             # corresponding regression parameters
	nu = 2                          # parameter of the Weibull distribution
	eta = log(nu)                   # reparametrization
# Compute first log-likelihood component
	tnv = rep(0,k)                  # frequency of each state at the first occasion
	for(u in 1:k) tnv[u] = sum(tU[,1]==u)
	tN = matrix(0,k,k)              # frequencies for each pair of states
	for(i in 1:n) for(j in 1:tjv[i]) tN[tU[i,j],tU[i,j+1]] = tN[tU[i,j],tU[i,j+1]]+1
	sv = rep(0,k)                   # sojourn times
	for(i in 1:n) for(j in 1:tjv[i]) sv[tU[i,j]] = sv[tU[i,j]]+tT[i,j+1]-tT[i,j]
	qv = -diag(Q)
	lk1 = sum(tnv*log(piv))
	for(u in 1:k) lk1 = lk1+sum(tN[u,-u]*log(Q[u,-u]))
	lk1 = lk1-sum(sv*qv)
# Compute second and third log-likelihood components
	par = c(bev,eta,xiv,phi,psiv)
	lk23 = lk_comp_joint_HM(par,si2,tT,tU,TT,W,X,Y,tv,dev,k,type)
# Display initial log-likelihood
	lk = lk1+lk23
	print("Initial log-likelihood")
	print(lk)
# Estimate parameters
	piv = tnv/n
	Q = (1/sv)*tN
	qv = rowSums(Q)
	est = optim(par,lk_comp_joint_HM,gr=dlk_comp_joint_HM,method="BFGS",si2=si2,tT=tT,tU=tU,
                TT=TT,W=W,X=X,Y=Y,tv=tv,dev=dev,k=k,type=type,
                control=list(fnscale=-1,trace=1))
    par = est$par
	bev = par[1:ncovX]; eta = par[ncovX+1]; nu = exp(eta)
	xiv = par[(ncovX+2):(k+ncovX+1)]; phi = par[k+ncovX+2]; psiv = par[(k+ncovX+3):length(par)]
# estimate si2
	if(type=="norm"){
		jv = rowSums(!is.na(Y))
		si2 = 0
		for(i in 1:n){
			for(j in 1:jv[i]){
				tj = sum(tT[i,]<=TT[i,j],na.rm=TRUE)
				mu = xiv[tU[i,tj]]+as.vector(X[i,j,]%*%bev)
				si2 = si2+(Y[i,j]-mu)^2/sum(jv)
			}
		}
	}
# Compute first log-likelihood component
	lk1 = sum(tnv*log(piv))
	for(u in 1:k) lk1 = lk1+sum(tN[u,-u]*log(Q[u,-u]))
	lk1 = lk1-sum(sv*qv)
# Compute second and third log-likelihood components
	lk23 = lk_comp_joint_HM(par,si2,tT,tU,TT,W,X,Y,tv,dev,k,type)
	lk = lk1+lk23
	print("Final log-likelihood")
	print(lk)
# output
	out = list(bev=bev,nu=nu,xiv=xiv,phi=phi,psiv=psiv,piv=piv,Q=Q,si2=si2,tnv=tnv,tN=tN,sv=sv)

}
# ---------------------------------------------------------------------------------------------------
lk_comp_joint_HM <- function(par,si2,tT,tU,TT,W,X,Y,tv,dev,k,type){

# to compute the second and third components of the expect complete log-likelihood

# Preliminaries
	ncovW = ncol(W)
	ncovX = dim(X)[3]
	bev = par[1:ncovX]; eta = par[ncovX+1]; nu = exp(eta)
	xiv = par[(ncovX+2):(k+ncovX+1)]; phi = par[k+ncovX+2]; psiv = par[(k+ncovX+3):length(par)]
	n = nrow(TT)
	jv = rowSums(!is.na(Y))
	if(type=="norm") lsi2pi = log(si2)+log(2*pi)
# compute functions
	lk2 = lk3 = 0
	for(i in 1:n){
		tmp0 = as.vector(W[i,]%*%psiv)
		for(j in 1:jv[i]){
			tj = sum(tT[i,]<=TT[i,j],na.rm=TRUE)
			mu = xiv[tU[i,tj]]+as.vector(X[i,j,]%*%bev)
			if(type=="norm") lk2 = lk2-1/2*(lsi2pi+(Y[i,j]-mu)^2/si2)
			if(type=="bino"){
				mu = exp(mu)/(1+exp(mu))
				lk2 = lk2+(Y[i,j]*log(mu)+(1-Y[i,j])*log(1-mu))
			}
		}
		di = sum(tT[i,]<tv[i],na.rm=TRUE)
		if(tT[i,di]>0) for(j in 2:di) lk3 = lk3-(exp(xiv[tU[i,j-1]]*phi+tmp0)*(tT[i,j]^nu-tT[i,j-1]^nu))
		lk3 = lk3+dev[i]*(eta+(nu-1)*log(tv[i])+xiv[tU[i,di]]*phi+tmp0)-exp(xiv[tU[i,di]]*phi+tmp0)*
		                 (tv[i]^nu-tT[i,di]^nu)
	}
	lk23 = as.vector(lk2+lk3)

}
# ---------------------------------------------------------------------------------------------------
dlk_comp_joint_HM <- function(par,si2,tT,tU,TT,W,X,Y,tv,dev,k,type){

# Compute derivative of lk_comp_joint_HM

# Preliminaries
  ncovW = ncol(W)
  ncovX = dim(X)[3]
  bev = par[1:ncovX]; eta = par[ncovX+1]; nu = exp(eta)
  xiv = par[(ncovX+2):(k+ncovX+1)]; phi = par[k+ncovX+2]; psiv = par[(k+ncovX+3):length(par)]
  n = nrow(TT)
  jv = rowSums(!is.na(Y))
  if(type=="norm") lsi2pi = log(si2)+log(2*pi)
# compute functions
	dlk2bev = rep(0,ncovX)
	dlk3eta = 0
	dlk2xiv = dlk3xiv = rep(0,k)
	dlk3phi = 0
	dlk3psiv = rep(0,ncovW)
	for(i in 1:n){
		tmp0 = as.vector(W[i,]%*%psiv)
		for(j in 1:jv[i]){
		  tj = sum(tT[i,]<=TT[i,j],na.rm=TRUE)
		  mu = xiv[tU[i,tj]]+as.vector(X[i,j,]%*%bev)
		  if(type=="norm"){
				dlk2bev = dlk2bev+X[i,j,]*(Y[i,j]-mu)/si2
				dlk2xiv[tU[i,tj]] = dlk2xiv[tU[i,tj]]+(Y[i,j]-mu)/si2
			}
			if(type=="bino"){
				mu = exp(mu)/(1+exp(mu))
				dlk2bev = dlk2bev+X[i,j,]*(Y[i,j]-mu)
				dlk2xiv[tU[i,tj]] = dlk2xiv[tU[i,tj]]+(Y[i,j]-mu)
			}
		}
		di = sum(tT[i,]<tv[i],na.rm=TRUE)
		if(tT[i,di]>0) for(j in 2:di){
			if(tT[i,j-1]>0) tmp = log(tT[i,j-1]) else tmp = 0
			tmp1 = exp(xiv[tU[i,j-1]]*phi+tmp0)
			dlk3eta = dlk3eta-tmp1*(log(tT[i,j])*tT[i,j]^nu-tmp*tT[i,j-1]^nu)*nu
			dlk3xiv[tU[i,j-1]] = dlk3xiv[tU[i,j-1]]-tmp1*(tT[i,j]^nu-tT[i,j-1]^nu)*phi
			dlk3phi = dlk3phi-tmp1*(tT[i,j]^nu-tT[i,j-1]^nu)*xiv[tU[i,j-1]]
			dlk3psiv = dlk3psiv-W[i,]*tmp1*(tT[i,j]^nu-tT[i,j-1]^nu)
		}
		if(tT[i,di]>0) tmp = log(tT[i,di]) else tmp = 0
		tmp1 = exp(xiv[tU[i,di]]*phi+tmp0)
		dlk3eta = dlk3eta+dev[i]*(1+nu*log(tv[i]))-tmp1*(log(tv[i])*tv[i]^nu-tmp*tT[i,di]^nu)*nu
		dlk3xiv[tU[i,di]] = dlk3xiv[tU[i,di]]+(dev[i]-tmp1*(tv[i]^nu-tT[i,di]^nu))*phi
		dlk3phi = dlk3phi+(dev[i]*xiv[tU[i,di]]-tmp1*(tv[i]^nu-tT[i,di]^nu)*xiv[tU[i,di]])
		dlk3psiv = dlk3psiv+W[i,]*(dev[i]-tmp1*(tv[i]^nu-tT[i,di]^nu))
	}
	dlk23 = c(dlk2bev,dlk3eta,dlk2xiv+dlk3xiv,dlk3phi,dlk3psiv)

}


#' Updates the weight matrix of an ART network.
#'
#' This function returns a new weight matrix that has "learned" the input
#' in the given category, as well as a value correspoding to whether or
#' not the weight matrix was changed (0 = no change; 1 = change).
#' @title ART_Update_Weights
#' @param input Vector of size NumFeatures that contains the input signal into the network.
#' @param weight Matrix of size NumFeatures-by-NumCategories which holds the weights of the network.
#' @param categoryNumer Number of the category that codes the current input.
#' @param learningRate Rate at which the network should learn new inputs.
#' @return List containing the UPDATEDWEIGHT and WEIGHTCHANGE. The UPDATEDWEIGHT is a matrix of size NumFeatures-by-NumCategories
#' that holds the new weights of the network after the input has been successfully learned.
#' The WEIGHTCHANGE is a value (0 or 1) which relays whether or not
#' the weight matrix was changed during this updating. Here, 0 represents
#' no change and 1 represents a change.
#' @details The length of the INPUT vector must equal the number of rows in the WEIGHT matrix, the CATEGORYNUMBER must
#' be in the range [1, NumCategories], and the LEARNINGRATE must be in the range [0, 1].
ART_Update_Weights = function(input, weight, categoryNumber, learningRate)
{
  # Get the number of features from the weight matrix.
  numFeatures = ncol(weight);
  numCategories = nrow(weight);
  # Check the input parameters for correct ranges.
  if(length(input) != numFeatures)
  {
    stop('The length of the input and rows of the weights do not match.');
  }
  if((categoryNumber < 1) | (categoryNumber > numCategories))
  {
    stop('The category number must be in the range [1, NumCategories].');
  }
  if((learningRate < 0) | (learningRate > 1))
  {
    stop('The learning rate must be within the range [0, 1].');
  }

  weightChange = 0;
  for (i in 1:numFeatures)
  {
    if(input[i] < weight[categoryNumber,i])
    {
      weight[categoryNumber,i] = (learningRate * input[i]) + ((1 - learningRate) * weight[categoryNumber,i]);
      weightChange = 1;
    }
  }

  # Return the updated weight matrix.
  updatedWeight = weight;
  return (list(updatedWeight, weightChange));
}


# Dexter Barrows
#
# run: Rscript if2-paraboot-script.r > if2-paraboot-script.log 2>&1

library(foreach)
library(parallel)
library(doParallel)
library(ggplot2)
library(Rcpp)

set.seed(8265813)

# R source files
stoc_sir_file 		<- paste(getwd(),"../../sir-functions", "StocSIR.r", sep = "/")
if2_paraboot_file 	<- paste(getwd(), "if2-paraboot.r", sep = "/")
source(stoc_sir_file)
source(if2_paraboot_file)

# C++ source files
if2file <- paste(getwd(),"../../if2", "if2.cpp", sep="/")
if2_s_file <- paste(getwd(),"../../if2", "if2-s.cpp", sep="/")

## data params
T       <- 60
i_infec <- 5
steps   <- 7
N       <- 500
sigma   <- 10
Tlim    <- round(T * 1/2)

## 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

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

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

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

## parallel setup
##

nTrials <- 10

numCores <- detectCores()
cl <- makeCluster(min(numCores, nTrials))
registerDoParallel(cl)

## if2 setup
##

NP          <- 3000
nPasses     <- 50
coolrate    <- 0.975

## initial fit
##

#if (FALSE) {
sourceCpp(if2file)
if2time <- system.time( if2data <- if2(infec_counts[1:(Tlim+1)], Tlim+1, N, NP, nPasses, coolrate) )

# get parameter estimates

paramdata <- data.frame( if2data$paramdata )
names(paramdata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")
parmeans <- colMeans(paramdata)
names(parmeans) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

if2_paraboot_data <- if2_paraboot(if2data,
                                  T, Tlim, steps, N, nTrials,
                                  if2file, if2_s_file, stoc_sir_file,
                                  NP, nPasses, coolrate)

stopCluster(cl)

save.image(file = "if2-paraboot.RData")