setwd("/media/sarthak/OS/Users/Sarthak/Desktop/Projects/CustomerSegmentation/data")
data=read.csv("/media/sarthak/OS/Users/Sarthak/Desktop/Projects/CustomerSegmentation/data/Mall_Customers.csv")
str(data)
names(data)
head(data)
summary(data$Age)
summary(data$Spending.Score..1.100.)
sd(data$Age)
sd(data$Annual.Income..k..)
sd(data$Spending.Score..1.100.)

#Gender Distribution Plots
a=table(data$Gender)
barplot(a,main="BarPlot to Illustrate Gender Comparision",
        ylab="Count",
        xlab="Gender",
        col=rainbow(2),
        legend=rownames(a))

pct=round(a/sum(a)*100)
lbs=paste(c("Female","Male")," ",pct,"%",sep=" ")
library(plotrix)
pie3D(a,labels=lbs,
      main="Pie Chart comparing Female and Male Percentage")

#Visuals for Age Distributions
summary(data$Age)
hist(data$Age,
     col="green",
     main="Count Plot of different Age Groups",
     xlab="Age Class",
     ylab="Frequency",
     labels=TRUE)

boxplot(data$Age,
        col="blue",
        main="Boxplot for Descriptive Analysis of Age")

#Analysis of Annual Income of the Customers
summary(data$Annual.Income..k..)
hist(data$Annual.Income..k..,
     col="red",
     main="Count Plot for Annual Income",
     xlab="Annual Income Class",
     ylab="Frequency",
     labels=TRUE)

#Analysis of Spending Score of the Customers
summary(data$Spending.Score..1.100.)
boxplot(data$Spending.Score..1.100.,
        horizontal=TRUE,
        col="white",
        main="BoxPlot for Spending Score")

hist(data$Spending.Score..1.100.,
     main="HistoGram for Spending Score",
     xlab="Spending Score Class",
     ylab="Frequency",
     col="#6600cc",
     labels=TRUE)

#K-means Clustering Algorithm

#Elbow Method
library(purrr)
set.seed(123)
# function to calculate total intra-cluster sum of square
iss <- function(k) {
  kmeans(data[,3:5],k,iter.max=100,nstart=100,algorithm="Lloyd" )$tot.withinss
}
k.values <- 1:10
iss_values <- map_dbl(k.values, iss)
plot(k.values, iss_values,
     type="b", pch = 19, frame = FALSE,
     xlab="Number of clusters K",
     ylab="Total intra-clusters sum of squares")

#Average Silhouette Method
library(cluster)
library(grid)
k2<-kmeans(data[,3:5],2,iter.max=100,nstart=50,algorithm="Lloyd")
s2<-plot(silhouette(k2$cluster,dist(data[,3:5],"euclidean")))
k3<-kmeans(data[,3:5],3,iter.max=100,nstart=50,algorithm="Lloyd")
s3<-plot(silhouette(k3$cluster,dist(data[,3:5],"euclidean")))
k4<-kmeans(data[,3:5],4,iter.max=100,nstart=50,algorithm="Lloyd")
s4<-plot(silhouette(k4$cluster,dist(data[,3:5],"euclidean")))
k5<-kmeans(data[,3:5],5,iter.max=100,nstart=50,algorithm="Lloyd")
s5<-plot(silhouette(k5$cluster,dist(data[,3:5],"euclidean")))
k6<-kmeans(data[,3:5],6,iter.max=100,nstart=50,algorithm="Lloyd")
s6<-plot(silhouette(k6$cluster,dist(data[,3:5],"euclidean")))
k7<-kmeans(data[,3:5],7,iter.max=100,nstart=50,algorithm="Lloyd")
s7<-plot(silhouette(k7$cluster,dist(data[,3:5],"euclidean")))
k8<-kmeans(data[,3:5],8,iter.max=100,nstart=50,algorithm="Lloyd")
s8<-plot(silhouette(k8$cluster,dist(data[,3:5],"euclidean")))
k9<-kmeans(data[,3:5],9,iter.max=100,nstart=50,algorithm="Lloyd")
s9<-plot(silhouette(k9$cluster,dist(data[,3:5],"euclidean")))
k10<-kmeans(data[,3:5],10,iter.max=100,nstart=50,algorithm="Lloyd")
s10<-plot(silhouette(k10$cluster,dist(data[,3:5],"euclidean")))

#Optimal Number of Clusters
install.packages("NbClust",dependencies = TRUE)
library(NbClust)
install.packages("factoextra",dependencies = TRUE)
library(factoextra)
fviz_nbclust(data[,3:5], kmeans, method = "silhouette")

#Number of Clusters k = 6
k6<-kmeans(data[,3:5],6,iter.max=100,nstart=50,algorithm="Lloyd")
k6

#Visuals of the Clustering of first 2 principal Components
pcclust=prcomp(data[,3:5],scale=FALSE) #principal component analysis
summary(pcclust)
pcclust$rotation[,1:2]

set.seed(1)
ggplot(data, aes(x =Annual.Income..k.., y = Spending.Score..1.100.)) +
  geom_point(stat = "identity", aes(color = as.factor(k6$cluster))) +
  scale_color_discrete(name=" ",
                       breaks=c("1", "2", "3", "4", "5","6"),
                       labels=c("Cluster 1", "Cluster 2", "Cluster 3", "Cluster 4", "Cluster 5","Cluster 6")) +
  ggtitle("Segments of Mall Customers", subtitle = "Using K-means Clustering")

ggplot(customer_data, aes(x =Spending.Score..1.100., y =Age)) +
  geom_point(stat = "identity", aes(color = as.factor(k6$cluster))) +
  scale_color_discrete(name=" ",
                       breaks=c("1", "2", "3", "4", "5","6"),
                       labels=c("Cluster 1", "Cluster 2", "Cluster 3", "Cluster 4", "Cluster 5","Cluster 6")) +
  ggtitle("Segments of Mall Customers", subtitle = "Using K-means Clustering")

kCols=function(vec){cols=rainbow (length (unique (vec)))
return (cols[as.numeric(as.factor(vec))])}
digCluster<-k6$cluster; dignm<-as.character(digCluster);
plot(pcclust$x[,1:2], col =kCols(digCluster),pch =19,xlab ="K-means",ylab="classes")
legend("bottomleft",unique(dignm),fill=unique(kCols(digCluster)))


# Barometric formula: altitude analysis
# https://en.wikipedia.org/wiki/Barometric_formula
# Ideal law: P = rho * R/M * T

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

df.list <- sapply(logger.names, function(name) {
  df <- gwloggeR.data::read(name)$df

  # Filter
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!is.na(TIMESTAMP_UTC), ]

  # Aggregate
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Filter
  df <- df[PRESSURE_VALUE < 1100,]
  df <- df[PRESSURE_VALUE > 975,]

  # Meta data
  df[, FILE := basename(name)]
  df[, N := .N]

  data.table::setkey(df, TIMESTAMP_UTC)

  df
}, simplify = FALSE, USE.NAMES = TRUE)

df <- data.table::rbindlist(df.list, use.names = TRUE)

medians <- sapply(df.list, function(df) {
  median(df$PRESSURE_VALUE, na.rm = TRUE)
}, simplify = TRUE, USE.NAMES = TRUE)

# Load functions from analysis 07.
sys.source('./drifts/analysis_07.r', envir = (bf <- new.env()))

# This function computes the altitude in function of pressure.
# LR stands for lapse rate: the drop in temperature in function of altitude is
# here taken into consideration. For altitude between 0 and 11 km, the drop
# in temperature is taken as a linear function: T = T_b + L_b*h.
# See: https://en.wikipedia.org/wiki/Barometric_formula#Derivation
# Other assumption here is that the air pressure is hydrostatic (i.e. "fluid" is not moving).
bf$h.lr <- function(P.Pa) {
  A <- g0 * M / (R * L_b)
  B <- log(P_b / P.Pa)/A + log(T_b)
  (exp(B) - T_b)/L_b + h_b
}
environment(bf$h.lr) <- bf

bf$h.lr(bf$P_b)
bf$h.lr(bf$P.lr(50)) # Test, should be the same as input: 50

medians.Pa <- sapply(medians, bf$P.cmH2O_to_Pa, simplify = TRUE, USE.NAMES = TRUE)

altitude.m.bf <- sapply(medians.Pa, bf$h.lr, simplify = TRUE, USE.NAMES = TRUE)

hist(altitude.m.bf, breaks = 50, main = 'Altitudes (m) based on barometric formula', xlab = 'Altitude (m)')

df <- merge(x = df,
            y = data.frame(FILE = basename(names(altitude.m.bf)), ALTITUDE = as.vector(altitude.m.bf)),
            all.x = TRUE, by = 'FILE')

data.table::setkey(df, FILE, TIMESTAMP_UTC)

ggplot2::ggplot(data = df, mapping = ggplot2::aes(y = PRESSURE_VALUE, x = sprintf('%s (#%i)', FILE, N))) +
  ggplot2::geom_boxplot() +
  ggplot2::coord_flip() +
  ggplot2::ggtitle(label = 'Barometer boxplots (2 obs/day)') +
  ggplot2::xlab(NULL) +
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_08/baro_hist_uhd-1.png', width = 2160/96, height = 3840/96, dpi = 96)

ggplot2::ggplot(data = df, mapping = ggplot2::aes(y = PRESSURE_VALUE, x = sprintf('%s (#%i) [%.2fm]', FILE, N, ALTITUDE))) +
  ggplot2::geom_boxplot() +
  ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(0)), size = 1.5, col = 'darkblue') +
  ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(50*c(-1,1))), size = 1.5, col = 'green') +
  ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(100*c(-1,1))), size = 1.5, col = 'red') +
  ggplot2::coord_flip() +
  ggplot2::ggtitle(label = 'Barometer boxplots (2 obs/day) with altitudes (barometric formula) based on medians',
                   subtitle = 'Blue: 0m, green: ±50m and red: ±100m') +
  ggplot2::xlab(NULL) +
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_08/baro_hist_altitudes_uhd-1.png', width = 2160/96, height = 3840/96, dpi = 96)

write.csv(as.data.frame(altitude.m.bf), file = './drifts/analysis_08/baro_barometric_formula_altitudes.csv')


mergeSort <- function(x) {
  len <- length(x)
  if (len < 2)
    result <- x
  else {
    y <- x[1:(len / 2)]
    z <- x[-(1:(len / 2))]
    cat("Call mergeSort with parameter", y, "\n")
    y <- mergeSort(y)
    cat("Call mergeSort with parameter", z, "\n")
    z <- mergeSort(z)
    result <- c()
    cat("Merge ", y, " and ", z)
    while (min(length(y), length(z)) > 0) {
      if (y[1] < z[1]) {
        result <- c(result, y[1])
        y <- y[-1]
      } else{
        result <- c(result, z[1])
        z <- z[-1]
      }
    }
    if (length(y) > 0)
      result <- c(result, y)
    else
      result <- c(result, z)
  }
  return (result)
}

startTime <- Sys.time()
r <- mergeSort(c(38, 27, 43, 39, 82))
print(r)
endTime <- Sys.time()
timeTaken <- endTime - startTime
cat("Time required : ", as.numeric(timeTaken), "\n")


require(ggplot2)
head(diamonds)
hist(diamonds$carat, main="Carat Histogram", xlab="Carat")
plot(price ~ carat, data=diamonds, main="Price versus Carats", xlab="Label")
boxplot(diamonds$carat)
class(diamonds)
ggplot(diamonds) + geom_histogram(aes(diamonds$carat), binwidth=.25)
ggplot(diamonds) + geom_density(aes(diamonds$carat), fill="grey50")
ggplot(diamonds, aes(carat, price)) + geom_point(aes(color=color, shape=cut))
ggplot(diamonds, aes(carat,x=cut)) + geom_boxplot()
ggplot(diamonds, aes(carat,x=cut)) + geom_jitter() + geom_violin()

head(economics)
ggplot(economics, aes(date, pop)) + geom_line()

require(lubridate)
economics$year <- year(economics$date)
economics$month <- month(economics$date)
head(economics)

econ2000 <- economics[which(economics$year >= 2000), ]
head(econ2000)
econ2000$month <- month(econ2000$date, label=TRUE)

require(scales)
g <- ggplot(econ2000, aes(month, pop))
g <- g + geom_line(aes(color=factor(year), group=year))
g <- g + scale_color_discrete(name="Year")
g <- g + scale_y_continuous(labels=comma)
g <- g + labs(title="Population Growth", x="Month", y="Population")
g <- g + theme(axis.text.x=element_text(angle = 90, hjust=1))
g

g <- ggplot(diamonds, aes(carat, price))
g <- g + geom_point(aes(color=color)) + facet_wrap(~color)
g <- g + geom_point(aes(color=color)) + facet_grid(cut~clarity)
g

g <- ggplot(diamonds, aes(carat))
g <- g + geom_histogram(aes()) + facet_wrap(~color)
g

require(ggthemes)

g <- ggplot(diamonds, aes(carat, price, color=color))
g <- g + geom_point()
g

g + theme_tufte() + scale_color_colorblind()


polling <- read.csv("PollingData.csv")
str(polling)
table(polling$Year)
summary(polling)

# handle missing data NAs
library(mice)
simple <- polling[c("Rasmussen", "SurveyUSA", "PropR", "DiffCount")]
summary(simple)

set.seed(144)
imputed <- complete(mice(simple))
summary(imputed)

# Feedback imputed data to the original
polling$Rasmussen <- imputed$Rasmussen
polling$SurveyUSA <- imputed$SurveyUSA
summary(polling)

train <- subset(polling, Year == 2004 | Year == 2008)
test <- subset(polling, Year == 2012)
table(train$Republican)

sign(20)

table(sign(train$Rasmussen))
table(train$Republican, sign(train$Rasmussen))

# Finding multicollinearity
cor(train[c("Rasmussen", "SurveyUSA", "PropR", "DiffCount", "Republican")])
mod1 <- glm(Republican ~ PropR, data = train, family = 'binomial')
summary(mod1)

pred1 <- predict(mod1, type = 'response')
table(train$Republican, pred1 >= 0.5)

mod2 <- glm(Republican ~ SurveyUSA + DiffCount, data = train, family = 'binomial')
summary(mod2)
pred2 <- predict(mod2, type = 'response')
table(train$Republican, pred2 >= 0.5)

##

table(test$Republican, sign(test$Rasmussen))

TestPrediction <- predict(mod2, newdata = test, type = "response")
table(test$Republican, TestPrediction >= 0.5)

subset(test, TestPrediction >= 0.5 & Republican == 0)


#'@title Create and return the neighborhood data frame for a given time series
#'
#'@description A neighborhood of a point p, consists of all the points within a certain distance from p.
#'             For the given time series, the neighborhood data frame consists of each element of
#'             the time series, the previous and next elements, the magnitude of the first difference,
#'             the percent change of the first difference, and the sign of the change.  The column, IS_TP,
#'             is a boolean that indicates whether or not a given element is a transition point.
#'
#'@usage  tsData.nhoodDf <- getNeighborhoodDf(tsData)
#'
#'@param tsData  A time series object.
#'
#'@return A data frame characterizing each time series element and the first difference
#'
#'@export

getNeighborhoodDf <- function(tsData)
{

	neighborhoodDf <- data.frame(
		PREV_VALUE=c(NA,tsData[-length(tsData)]),
		CURRENT_VALUE=c(tsData),
		NEXT_VALUE=c(tsData[-1],NA),
		DIFF_VALUE=c(NA,diff(tsData)),
		DIFF_SIGN=c(NA,sign(diff(tsData))),
		PCT_CHANGE=c(NA,round(abs(diff(tsData)/tsData[-length(tsData)]),4)),
		IS_TP=c(NA,NA,sign(diff(sign(diff(tsData))))) != 0)

	return (neighborhoodDf)

}


library(shiny)
library(matrixcalc)
library(plotly)

ui <- fluidPage(
  titlePanel("Gaussian PDF 3D demo"),
  sidebarLayout(
    sidebarPanel(
      h6("Expected value, μ"),
      fluidRow(
        column(6,
               numericInput("mu1", value = 0, label = "μ1")
        ),
        column(6,
               numericInput("mu2", value = 0, label = "μ2")
        )
      ),
      h6("Covariance matrix, Σ"),
      fluidRow(
        column(6,
               numericInput("E1", value = 2, label = "Σ (1,1)")
        ),
        column(6,
               numericInput("E2", value = 0.9, label = "Σ (1,2)")
        )
      ),
      fluidRow(
        column(6,
               numericInput("E3", value = 0.9, label = "Σ (2,1)")
        ),
        column(6,
               numericInput("E4", value = 2, label = "Σ (2,2)")
        )
      ),
      textOutput("err")
    ),
    mainPanel(plotlyOutput(outputId = "p"))
  )
)

5 - Contour lines of the Gaussian distribution PDF/shiny/ui.r


input <- file('stdin', 'r')

a <- as.double(readLines(input, n=1))
b <- as.double(readLines(input, n=1))

result = sprintf("MEDIA = %.5f", (a * 3.5 + b * 7.5) / 11.0)
write(result, "")


# nrow = rows
# ncol = columns
# 3 x 3 matrix using numbers 9 to 1
matrix(9:1, nrow = (3),ncol = (3))
# dimnames = dimension names
# list = keyword to create lists
# c = Combine Values Into A Vector Or List
# byrow = If FALSE (the default) the matrix is filled by columns, otherwise the matrix is filled by rows.
# 3 x 3 matrix using numbers 9 to 1
matrix(9:1,byrow = TRUE, nrow = (3),ncol = (3), dimnames=list(c("x","y","z"),c("a","b","c")))
# 5 x 5 matrix using numbers 1 to 20
matrix(1:20, byrow = TRUE, nrow = (5), dimnames=list(c("u","v","x","y","z"),c("a","b","c","d")))


# importing libraries
library(grf)
library(dplyr)
library(ggplot2)

# setting the working directory
setwd('C:/Users/Guilherme/Documents/Projetos & Estudos/Side Projects/causal_inference')

# reading our data
df <- read.csv('treat_effect_data.csv')

# extracting relevant variables
X <- df[,1:20]
W <- df[,22]
Y <- df[,23]
cluster <- df[,21]

# training the causal forest
tau.forest <- causal_forest(X, Y, W)

# Estimate treatment effects for the training data using out-of-bag prediction.
tau.hat.oob <- predict(tau.forest)

# creating a dataframe for evaluation
eval_df <- data.frame(cluster=cluster, effect=tau.hat.oob$predictions, y=Y, treated=W)

# showing a histogram of effects
eval_df %>% ggplot(aes(x=effect)) + geom_histogram(bins=60)

# real_treatment effects
real_effects <- eval_df %>%
                group_by(cluster, treated) %>%
                summarise(y_mean=mean(y)) %>%
                group_by(cluster) %>%
                summarise(real_effect=y_mean[2] - y_mean[1])

# showing the estimated treatment effect by cluster
estimated_effects <- eval_df %>%
                     group_by(cluster) %>%
                     summarise(estimated_effect=mean(effect))

# joining
merge(real_effects, estimated_effects)

# saving dataframe
write.csv(eval_df, 'estimated_effects_grf.csv')


prData <- 0.0081
domanda1 <- 5
domanda2_1 <- 9;
domanda2_2 <- 5;

p <- 1;

pr <- function(p){

  somma <- 0;
  for( i in 1:(domanda1-1) ){

    somma <- somma + p*(1-p)^(i-1);

  }
  return(somma);

}

f <- function(x){

  1 - prData - (pr(x));

}

prX <- function(x){

    p*(1-p)^(x-1);

}

p <- round(uniroot(f, c(0,1), extendInt="yes")$root, digits = 3);

print(p);

somma <- 0;

for( i in domanda2_2:domanda2_1 ){

    somma <- somma + prX(i);

}

prCondizionante <- 1;

for( i in 1:(domanda2_2-1) ){

  prCondizionante <- prCondizionante - prX(i);

}

risposta2 <- somma/prCondizionante;
risposta2_1 <- somma/prData;

print(risposta2)
print(risposta2_1)


require(heplots)
require(candisc)
setwd(outputpath)

l_table= subset(f_table,f_table$group != "freewalk_CS")
l_table= subset(f_table,f_table$group != "20d_CS")
l_table= subset(f_table,f_table$group != "11d_CS")
l_table= drop.levels(l_table)
#l_table$group
#l_table= f_table
#l_table= f_table2
i_table <- na.omit(l_table)
g_table<-i_table[,c(3:(length(i_table)))]

gen <-i_table[,2]
h=as.matrix(g_table)
m1= manova(h~gen)
plot(h~gen)
summary(m1)
summary.aov(m1)
class(m1)

heplot3d(m1)
pairs(m1)
####

m2 <- lm(h~gen)

can1= candisc(m1)
can2 = candisc(m2)

heplot(can1, prefix = "canonical dimension", main = "canonical HE plot")

#####
h=as.matrix(PCA_res[,1:22])
gen= PCA_res[,23]

h_table<-f_table[,c(3:(length(f_table)))]
g_table <- na.omit(h_table)
g=scale(as.matrix(g_table))
fit <- kmeans(g, 4)
library(cluster)
clusplot(h, as.numeric(gen), color=TRUE, shade=TRUE,
   labels=2, lines=0)
clusplot(, fit$cluster, color=TRUE, shade=TRUE,
   labels=2, lines=0)

   library(fpc)
plotcluster(g, na.omit(f_table)[,2],,method="wnc",clnum=2)
clusplot(g, na.omit(f_table)[,2])


mylist <- c(1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 1)
data <- matrix(mylist, nrow=4, ncol=3)
print(data)
target <- matrix(c(1, 0, 1, 0), nrow=4)
print(target)

sigmoid <- function(x, deriv) {
    if (deriv == TRUE) {
        return (x*(1-x))
        }
    return (1/(1+exp(-x)))
    }
w0 = matrix(c(0.1, -0.1, 0.01), nrow=3)
learning_rate <- 1
for (i in 1:10000) {
    layer0 <- data
    layer1 <- sigmoid(layer0%*%w0, FALSE)
    error <- layer1-target
    delta <- error*sigmoid(layer1, TRUE)
    w0 <- w0 - learning_rate*t(layer0)%*%delta
}
print(layer1)


# SVR

# Importar el dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[, 2:3]

# Dividir los datos en conjunto de entrenamiento y conjunto de test
# install.packages("caTools")
# library(caTools)
# set.seed(123)
# split = sample.split(dataset$Purchased, SplitRatio = 0.8)
# training_set = subset(dataset, split == TRUE)
# testing_set = subset(dataset, split == FALSE)

# Escalado de valores
# training_set[,2:3] = scale(training_set[,2:3])
# testing_set[,2:3] = scale(testing_set[,2:3])

# Ajustar SVR con el Conjunto de Datos
#install.packages("e1071")
library(e1071)
regression = svm(formula = Salary ~ .,
                 data = dataset,
                 type = "eps-regression", #"eps-regression" porque es un problema de regresión, si fuera clasificación seria C-classification, u otro, ver información.
                 kernel = "radial")

# Predicción de nuevos resultados con SVR
y_pred = predict(regression, newdata = data.frame(Level = 6.5)) #Para predecir el salario con un nivel de 6.5 en la empresa.

# Visualización del modelo de SVR
# install.packages("ggplot2")
library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.1)
ggplot() +
  geom_point(aes(x = dataset$Level , y = dataset$Salary),
             color = "red") +
  geom_line(aes(x = dataset$Level, y = predict(regression,
                                        newdata = data.frame(Level = dataset$Level))),
            color = "blue") +
  ggtitle("Predicción (SVR)") +
  xlab("Nivel del empleado") +
  ylab("Sueldo (en $)")

datasets/Part 2 - Regression/Section 7 - Support Vector Regression (SVR)/svr.r


#' Simple method to calculate paleoslope from preserved sediments
#'
#' \code{lynds_one} calculates the slope of an ancient river, provided you know the flow depth, the grain size of the bed material, and make some assumptions about shear stress in the river. Implemented from Lynds et al. (2014)
#' @param tau_mode Denotes whether to use a fixed value for the shields number of the flow, or to use a logarithmically-spaced range going from one to ten.
#' @param D The median grain size of bedload sediments.
#' @param rhos The density of the sediment in kg/m^3
#' @param rhof The density of the fluid in kg/m^3
#' @return Returns a single dimensionless number giving the slope.
#' @export

#	First method to reconstruct paleoslope from Lynds et al 2014
#	Eric Barefoot
#	Nov 2017

#	define needed variables and data types

lynds_one = function(D, H, tau_mode = 'fixed', rhos = 2650, rhof = 1000) {

	#	D is the D50b or median bedload grainsize
	#	H is Hbf or the bankfull flow depth

	rhos = rhos
	rhof = rhof

	#	key assumption is that shields number is equal to one. But paper varies it by up to ten. Provide here a choice for selecting either the recommended value of 1 or a range of estimates from one to ten spaced evenly in log space.

	tau_bf_50 = switch(tau_mode, fixed = 1, range = round(log10(seq(1.258935,10,length = 10)) * 10, 4))

	#	R is assumed in the paper, but we will calculate it here, and provide defaults above.

	R = rhos/rhof - 1

	#	now we calculate the slope based on equation (3) in Lynds et al 2014

	S = (tau_bf_50 * R * D)	/ H

	return(S)

}


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

suppressMessages(library(nlreg))

fitNLMLE <- function(data,tol=1e-10,reltol=1e-10,stepmin=1/5120,maxitr=250)
{
	func <- y ~ a * X ^ b
	model <- nlreg(func,data=data,start=list(a=0.1,b=1,k=1),weights=~X**k,control=list(x.tol=tol,rel.tol=reltol,step.min=stepmin,maxit=maxitr))
	return(model)
}

yhatNLMLE <- function(data,model)
{
	a <- coefficients(model)[1]
	b <- coefficients(model)[2]
	y <- a * data$X ^ b
	return(y)
}

residuals <- function(model,data)
{
	yp <- yhat(model,data)
	resids <- data$y - yp
	return(resids)
}

getModelExpForGgplot <- function(model)
{
        b0 <- toString(round(param(model)[1],3))
        b1 <- toString(round(param(model)[2],3))
        k <- toString(round(param(model)[3],3))
        sigma <- toString(max(round(exp(param(model)[4]),3),0.001))
	#return(as.expression(bquote(.(b0)~X^{.(b1)}*","~sigma^{2}==.(sigma)*","~k==.(k))))
        return(as.expression(bquote(beta["0"]==.(b0)*","~beta["1"]==.(b1)*","~sigma^{2}==.(sigma)*","~k==.(k))))
}


## See http://stats.stackexchange.com/questions/104889/k-fold-or-hold-out-cross-validation-for-ridge-regression-using-r/105453?noredirect=1#comment203976_105453

require(rms)
#random population of 200 subjects with 1000 variables
M <- matrix(rep(0, 200 * 100), 200, 1000)
for (i in 1 : 200) {
  set.seed(i)
  M[i,] <- ifelse(runif(1000) < 0.5, -1, 1)
}
rownames(M) <- 1:200

##random yvars
set.seed(1234)
u <- rnorm(1000)
g <- as.vector(crossprod(t(M), u))
h2 <- 0.5
set.seed(234)
y <- g + rnorm(200, mean=0, sd=sqrt((1 - h2) / h2 * var(g)))

myd <- data.frame(y=y, M)
training.id <- sample(1 : nrow(myd), round(nrow(myd) / 2, 0), replace = FALSE)
test.id <- setdiff(1 : nrow(myd), training.id)

myd_train <- myd[training.id,]
myd_test  <- myd[test.id,]

frm <- as.formula(paste("y~", paste(names(myd_train)[2:100], collapse="+")))
f <- ols(frm, data = myd_train, x=TRUE, y=TRUE)
p <- pentrace(f, seq(.05, 5, by=.05), noaddzero=TRUE)
plot(p)


# Obtaining CrI around estimates: re_formula = NA vs. re_formula = NULL.
#
# 2021-12-05
# jan.vanhove@unifr.ch, @janhove
#
# Also see https://janhove.github.io/visualise_uncertainty/

# Load packages
library(tidyverse)
library(lme4)
library(brms)

# Prepare dataset
data(sleepstudy)
sleep <- sleepstudy
sleep$Subject <- as.character(sleep$Subject)

# Raw data
sleepstudy %>%
  ggplot(aes(x = Days, y = Reaction)) +
  geom_point() +
  geom_smooth(method = "lm") +
  facet_wrap(~ reorder(Subject, Reaction))

# Fit model
sleep.brm <- brm(Reaction ~ 1 + Days + (1 + Days|Subject),
                 data = sleep,
                 warmup = 1000, iter = 3000,
                 cores = 4,
                 control = list(adapt_delta = 0.95))

# From this model we can derive answers to a variety of questions.
# (1a) If you obtained a fresh set of observations from a known participant,
#      i.e., one for whom you've already collected data, where are these
#      observations likely to lie?
#
# (1b) If you obtained a fresh set of observations from an unknown participant,
#      i.e., one for whom you haven't got any data, where are these
#      observations likely to lie?
#
# (2a) If you obtained lots and lots of fresh sets of observations from a
#      known participant, where is the *average* observation bound to lie?
#
# (2b) If you obtained lots and lots of fresh sets of observations from an
#      unknown participant, where is the *average* observation bound to lie?
#
# (2c) Where is the average observation of the average participant bound to lie?
#
# Which question you're interested in will determine how you generate
# uncertainty intervals for your estimes. I'll illustrate this below.

# (1a, 1b): Generate data for three known participants and one new one.
new_sleep <- expand.grid(
  Days = 0:9,
  Subject = c("309", "334", "337", "new subject")
)

individual_observations <- predict(sleep.brm, newdata = new_sleep,
                                   re_formula = NULL, allow_new_levels = TRUE) %>%
  as_tibble() %>%
  bind_cols(new_sleep, .)

individual_observations %>%
  ggplot(aes(x = Days, y = Estimate,
             ymin = `Q2.5`, ymax = `Q97.5`)) +
  geom_ribbon(fill = "grey") +
  geom_line() +
  ylim(100, 500) +
  facet_wrap(~ Subject) +
  labs(title = "Prediction interval for known and unknown participants")

# (2a, 2b)
individual_averages <- fitted(sleep.brm, newdata = new_sleep,
                              re_formula = NULL, allow_new_levels = TRUE) %>%
  as_tibble() %>%
  bind_cols(new_sleep, .)

individual_averages %>%
  ggplot(aes(x = Days, y = Estimate,
             ymin = `Q2.5`, ymax = `Q97.5`)) +
  geom_ribbon(fill = "grey") +
  geom_line() +
  ylim(100, 500) +
  facet_wrap(~ Subject) +
  labs(title = "Credible interval (for average) for known and unknown participants")

# Note that the second type of computation yields narrower uncertainty bands.
# The reason is quite simply that individual observations will vary more
# than the average of individual observations.
# Also, the uncertainty bands of participants for whom you've already
# obtained information are narrower. (More information = less uncertainty.)

# (2c): Switching "re_formula = NULL" to NA, viz.,
overall_average <- fitted(sleep.brm, newdata = new_sleep, re_formula = NA) %>%
  as_tibble() %>%
  bind_cols(new_sleep, .)
overall_average %>%
  ggplot(aes(x = Days, y = Estimate,
             ymin = `Q2.5`, ymax = `Q97.5`)) +
  geom_ribbon(fill = "grey") +
  geom_line() +
  ylim(100, 500) +
  facet_wrap(~ Subject) +
  labs(title = "Credible interval (for average) for average participant")


# Binomial logistic regression with mediation simulation code
# NOTE: The assumption is that the mediator is a continuous variable

# Raymond Viviano
# rayviviano@gmail.com
# March 25, 2020

# TODO: Implement checks to make sure that all models converged

#' Inverse Logit Function
inv.logit <- function(p){
    return(exp(p)/(1+exp(p)))
}

#' Sobel indirect effect standard error approximation
sobel.std.err <- function(a, b, se.a, se.b){
    return((b^2 * se.a^2) + (a^2 + se.b^2))
}

#' Coverage Probability, i.e., the probability that the confidence interval (ci)
#' for a parameter will contain the true value
#' Inputs:
#'          b       - Estimate
#'          se      - Standard Error of the Estimate
#'          true    - True value of parameter for data-generating process
#'          cl      - Confidence level
#'          dof     - Degrees of Freedom
#' Output:
#'          List containing coverage probability, vect
coverage.prob <- function(b, se, true, cl=.95, dof=Inf){
    # Compute quantile based on confidence level
    coverage.quantile <- cl + (1-cl)/2

    # Compute confidence interval upper and lower bounds
    ci.lower <- b - qt(coverage.quantile, df=dof)*se
    ci.upper <- b + qt(coverage.quantile, df=dof)*se

    # For each ci generated for each b/se pair, eval if true param is in ci
    ci.contain.true <- ifelse(true>=ci.lower & true<=ci.upper, 1, 0)

    # Calculate coverage probability
    cp <- mean(ci.contain.true)

    # Calculate Monte Carlo Error
    mc.err.lower <- cp - 1.96*sqrt((cp*(1-cp))/length(b))
    mc.err.upper <- cp + 1.96*sqrt((cp*(1-cp))/length(b))

    # Return coverage probability and error
    return(list(cp=cp, ci=cbind(mc.err.lower, mc.err.upper)))
}

#' Power to detect any effect at various alpha levels
#' Takes a vector of p-values and calculates the proportion of modell where the
#' p-val for the effect of interest was < .5, .01, and .001.
power.detect.effect <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    prop.05 <- sum(less.than.05)/length(less.than.05)

    less.than.01 <- ifelse(p.val.vec < .01, 1, 0)
    prop.01 <- sum(less.than.01)/length(less.than.01)

    less.than.001 <- ifelse(p.val.vec < .001, 1, 0)
    prop.001 <- sum(less.than.001)/length(less.than.001)

    cat(paste0('Power to detect effect at .05: ', prop.05, '\n'))
    cat(paste0('Power to detect effect at .01: ', prop.01, '\n'))
    cat(paste0('Power to detect effect at .001: ', prop.001, '\n'))
}

# Some equations to keep in mind for logistic regression with mediation:
#
# EQ1.  Y   =   B0_1 + Tau*X + e1
# EQ2.  Y   =   B0_2 + Tau_Prime*X + Beta*M + e2
# EQ3.  M   =   B0_3 + alpha*X + e3
# EQ4.  Tau =   alpha*beta + Tau_Prime   || (c = ab + c') (approx for logistic)
#
# Tau = total effect, tau_prime = direct effect of X on Y accounting for
# mediating relationship, alpha = effect of X on M, beta = effect of M on Y
# B0_1,2,&3 are intercept terms for their respective equations.
#
# Assuming zero error, the mean, or expected value, for the intercept term for
# EQ1 can be defined by the other variables.
#
# EQ5. E[B0_1] = E[B0_2] + Tau_Prime*E[X] + Beta*(E[B0_3] + Alpha*E[X]) - Tau*[X]
#
# If we force the mean of X to 1, then we get equation 6:
#
# EQ6. E[B0_1] = E[B0_2] + Tau_Prime + Beta*E[B0_3] + Alpha*Beta - Tau
#
# As Tau_Prime - Tau = -1 * Alpha*Beta, we get equation 7:
#
# EQ7. E[B0_1] = E[B0_2] + Beta*E[B0_3]
#
# We also get equation 7 if we force the mean of x to 0...and the derivation is easier...
#
# Define B0_1, B0_2, B0_3, alpha, beta, tau, and tau_prime for the data
# generation process.
#
# Use Eq3 to generate M, then use Eq2 to generate Y
# Test that you recover the expected values for alpha, beta, tau, tau_prime,
# B0_1, B02, and B03

# Specify indirect and direct effect terms
alpha = .2
beta = .2
tau_prime = .1

# Specify total effect (note that for logit this is actually approximate)
tau = alpha*beta + tau_prime

# Intercept terms for EQ2 and EQ3 (Means or expected values)
B0_2 <- .2
B0_3 <- .4

# Calculate intercept term for EQ1 based on the other specified values
B0_1 <- B0_2 + beta*B0_3

# Ensure reproducible results
set.seed(10000)

# Define sample size
n <- 16000

# Define number of simulations
nsims <- 50

# Define matrix to hold simulation data (estimates, std.errors, and pvals)
sim.prms <- matrix(NA, nrow=nsims, ncol=20)

# Loop through simulations
for(i in 1:nsims){
    # Generate independant variable data, uniform random between -1 and 1
    # The expected value, or expected mean of this vector should be 0
    x <- runif(n, -1, 1)

    # Generate data for the mediating variable, the mean or expected value
    # should equal B03. But, we'll add some noise
    m <- alpha*x + B0_3
    # Add noise
    m <- m + rnorm(length(m), 0, .2)

    # True data-generation-process for Bernoulli trials
    y <- rbinom(n, 1, inv.logit(B0_2 + tau_prime*x + beta*m))

    # Estimate logit model
    model1 <- glm(y ~ x, family=binomial(link=logit))
    model2 <- glm(y ~ x + m, family=binomial(link=logit))
    model3 <-  lm(m ~ x)

    # TODO: Implement checks to make sure that all models converged

    # Put model paramters in simulation matrix
    sim.prms[i, 1] <- model1$coef[1]                    # Estimate for B0_1
    sim.prms[i, 2] <- model2$coef[1]                    # Estimate for B0_2
    sim.prms[i, 3] <- model3$coef[1]                    # Estimate for B0_3
    sim.prms[i, 4] <- model3$coef[2]                    # Estimate for Alpha
    sim.prms[i, 5] <- model2$coef[3]                    # Estimate for Beta
    sim.prms[i, 6] <- sim.prms[i, 4] * sim.prms[i, 5]   # Estimate for Indirect
    sim.prms[i, 7] <- model1$coef[2]                    # Estimate for Tau
    sim.prms[i, 8] <- model2$coef[2]                    # Estimate for Tau_Prime
    sim.prms[i, 9] <- summary(model3)$coefficients[,2][2]  # Alpha Std.Err
    sim.prms[i,10] <- summary(model2)$coefficients[,2][3]  # Beta Std.Err
    sim.prms[i,11] <- sobel.std.err(sim.prms[i,4], sim.prms[i,5],
                                    sim.prms[i,9], sim.prms[i,10]) # Indirect Std.Err
    sim.prms[i,12] <- summary(model1)$coefficients[,2][2]  # Tau Std.Err
    sim.prms[i,13] <- summary(model2)$coefficients[,2][2]  # Tau_Prime Std.Err
    sim.prms[i,14] <- summary(model1)$coefficients[,4][1]  # P-Value for B0_1
    sim.prms[i,15] <- summary(model2)$coefficients[,4][1]  # P-Value for B0_2
    sim.prms[i,16] <- summary(model3)$coefficients[,4][1]  # P-Value for B0_3
    sim.prms[i,17] <- summary(model3)$coefficients[,4][2]  # P-Value for Alpha
    sim.prms[i,18] <- summary(model2)$coefficients[,4][3]  # P-Value for Beta
    sim.prms[i,19] <- summary(model1)$coefficients[,4][2]  # P-Value for Tau
    sim.prms[i,20] <- summary(model2)$coefficients[,4][2]  # P-Value for Tau'

}

# Note: The assumption for this simulation is that the mediator is continuous
cat("Note: This simulation assumes that the mediator is continous...\n\n")

# Get Covarage probabilities for the parameters
# B0_1.coverage <- coverage.prob(sim.prms[,1], sim.prms[,], B0_1, .95, n-model1$rank) TODO: Add these std.errs to sim.prms
# B0_2.coverage <- coverage.prob(sim.prms[,2], sim.prms[,], B0_2, .95, n-model2$rank) TODO: Add these std.errs to sim.prms
# B0_3.coverage <- coverage.prob(sim.prms[,3], sim.prms[,], B0_3, .95, n-model3$rank) TODO: Add these std.errs to sim.prms
alpha.coverage     <- coverage.prob(sim.prms[,4], sim.prms[, 9], alpha, .95, n-model3$rank)
beta.coverage      <- coverage.prob(sim.prms[,5], sim.prms[,10], beta,  .95, n-model2$rank)
indirect.coverage  <- coverage.prob(sim.prms[,6], sim.prms[,11], alpha*beta, .95, n-model2$rank) # TODO: Figure out confidence interval for sobel std.err
tau.coverage       <- coverage.prob(sim.prms[,7], sim.prms[,12], tau,        .95, n-model3$rank)
tau.prime.coverage <- coverage.prob(sim.prms[,8], sim.prms[,13], tau_prime,  .95, n-model2$rank)

# # Intercept coverage probabilities     -- TODO
# print("Coverage Probability for B0_1")
# print(B0_1.coverage)
# print("Coverage Probability for B0_2")
# print(B0_2.coverage)
# print("Coverage Probability for B0_3")
# print(B0_3.coverage)

print("alpha.coverage")
print(alpha.coverage)
print("beta.coverage")
print(beta.coverage)
print("indirect.coverage")
print(indirect.coverage)
print("tau.coverage")
print(tau.coverage)
print("tau.prime.coverage")
print(tau.prime.coverage)

# TODO: Update/Fix Proportion Code
# power.detect.effect(sim.prms[,5])
# power.detect.effect(sim.prms[,6])


# range
accounts_due<-c(55.20,  4.88 ,271.95,
                18.06, 180.29, 365.29,
                28.16, 399.11 ,807.80,
                44.14, 97.47, 9.98,
                61.61, 56.89 ,82.73)
range(accounts_due)
diff=max(accounts_due)-min(accounts_due)
print(diff)


#!/usr/bin/env r

RMS <- function(num) { sqrt(sum((num-ave(num))^2)/length(num)) }

## tmp <- hist(tmpdat$V1,freq=FALSE,breaks=5,xlim=c(range(tmpdat$V1)[1] - 200,range(tmpdat$V1)[2]+200),ylim=c(0,2000))
AIOQual <- function( channel, tmpdata , hexvalues , exactbreaks ) {
  retval = paste("")
  stats <- fivenum(tmpdata)
  if( hexvalues ) {
    retval <- paste(retval, sprintf("Channel: %d\nMin:%X Max:%X\nSamples:%d\nAvg: %X\n",channel,stats[1],stats[5], length(tmpdata), as.integer(mean(tmpdata))),sep="")
  } else {
    retval <- paste(retval, sprintf("Channel: %d\nMin:%f Max:%f\nSamples:%d\nAvg: %f\n",channel,stats[1],stats[5], length(tmpdata), as.integer(mean(tmpdata))),sep="")
  }
  if ( exactbreaks ) {
      tmpstats <- hist(tmpdata,plot=FALSE,breaks=unique(tmpdata))
  } else {
      tmpstats <- hist(tmpdata,plot=FALSE)
  }
  ## retval <- paste(retval, sprintf("Bins: %d RMS: %f\n", length(tmpstats$counts[tmpstats$counts > 0]),RMS(tmpdata)),sep="" )
  if( is.integer(stats[5]-stats[1] ) ) {
    retval <- paste(retval, sprintf("Bins: %d RMS: %f\n", stats[5]-stats[1],RMS(tmpdata)),sep="" )
  } else {
    retval <- paste(retval, sprintf("Bins: %f RMS: %f\n", stats[5]-stats[1],RMS(tmpdata)),sep="" )
  }
  for ( i in 1:length(tmpstats$counts) ) {
    ## printf("%d\n", i )
    if( tmpstats$counts[i] != 0 ) {
      if( hexvalues ) {
        retval <- paste(retval,sprintf("%X  %d   %.2f\n", as.integer(tmpstats$breaks[i]), tmpstats$counts[i], (100*tmpstats$counts[i] / sum(tmpstats$counts)),sep=""))
      } else {
        retval <- paste(retval,sprintf("%f  %d   %.2f\n", tmpstats$breaks[i], tmpstats$counts[i], (100*tmpstats$counts[i] / sum(tmpstats$counts)),sep=""))
      }
    }
  }
  retval
}

if( length(argv) < 1 || length(argv) > 4 ) {
  print("Error: Usage:  histogram.r CSVFILE.txt [ USE_HEXVALUES ] [ EXACT_BREAKS ] ")
  quit(save="no")
} else {
  tmpdat <- read.csv(argv[1],header=FALSE)
  if( is.na(argv[2]) ) {
    hexdata <- FALSE
  } else {
    hexdata <- TRUE
  }

  if( is.na(argv[3]) ) {
    exactbreaks <- FALSE
  } else {
    exactbreaks <- TRUE
  }

  retval = ""
  for ( i in 1:(dim(tmpdat)[2]-1) ) {
    ## printf("i=%d\n",i)
    retval <- paste(retval, "\n\n", AIOQual( i, tmpdat[,i], hexdata , exactbreaks ),sep="" )
  }
  print(cat(retval))
}


# 4. faza: Analiza podatkov

# Napoved rasti premozenja najbogatejse osebe na svetu

#top_1 <- top %>% filter(ImePriimek == "Jeff Bezos") %>% select(-Vir)
#
#prileganje <- loess(formula = (Rast ~ Leto), data=top_1)
#leta <- data.frame(Leto=seq(2016, 2021, 1))
#napoved <- mutate(leta, Rast=predict(prileganje, leta))
#
#
#top_1 <- top_1 %>% rbind(napoved %>% filter(Leto==2021))
#
#top_1$ImePriimek[is.na(top_1$ImePriimek)] <- top_1$ImePriimek[1]
#top_1$Premozenje[is.na(top_1$Premozenje)] <- round((top_1$Premozenje[length(top_1$Premozenje)-1]) * (1 + top_1$Rast[length(top_1$Rast)]/100))
#
#ggTop_napoved <- ggplot(data=top_1, aes(x=Leto, y=Rast)) +
#  geom_point(na.rm = TRUE) +
#  geom_point(data = top_1 %>% filter(Leto==2021), aes(x=Leto, y=Rast, color="red", size=2), na.rm = TRUE) +
#  geom_text(data=top_1 %>% slice_tail(),
#            aes(label=Premozenje), nudge_y=5) + # napoved rasti in premoženja
#  labs(y="Rast (%)") +
#  geom_smooth(method="loess", formula =  y ~ x) +
#  ylab("Rast premoženja v %") +
#  labs(title = "Napoved rasti premoženja za leto 2021 - Jeff Bezos") +
#  theme(axis.ticks = element_line(color = "red"),
#        axis.ticks.length = unit(2, "mm"),
#        legend.position = "none")
#ggTop_napoved
#

#top_1 <- top %>% filter(ImePriimek == "Jeff Bezos") %>%
#  ungroup %>% select(-Vir, -ImePriimek)
#
#prileganje <- glm(data=top_1, Rast ~ Leto) # morda raje kvadratni model - glej zgoraj
#leta <- data.frame(Leto=seq(2016, 2021, 1))
#napoved <- leta %>% mutate(Rast=predict(prileganje, leta),
#                           Premozenje=c(NA, top_1$Premozenje) * (1+Rast/100))
#
#ggTop_napoved <- ggplot(data=napoved %>% filter(Leto == 2021) %>% rbind(top_1),
#                        aes(x=Leto, y=Rast)) +
#  geom_point(aes(color=(Leto == 2021)), na.rm=TRUE) +
#  geom_text(aes(label=ifelse(Leto == 2021, round(Premozenje, -3), "")), nudge_y=5) + # napoved rasti in premoženja
#  labs(y="Rast (%)") +
#  geom_smooth(data=top_1, method="glm", formula=y ~ x, fullrange=TRUE) +
#  ylab("Rast premoženja v %") +
#  labs(title="Napoved rasti premoženja za leto 2021 - Jeff Bezos") +
#  theme(axis.ticks=element_line(color="red"),
#        axis.ticks.length=unit(2, "mm"),
#        legend.position="none")
#ggTop_napoved
#

napoved_rast <- function(ime_priimek) {
  top_rast <- top %>% group_by(ImePriimek) %>%
    mutate(Rast = 100 * (Premozenje - lag(Premozenje))/lag(Premozenje)) %>%
    drop_na(Rast)
  top_1 <- top_rast %>% filter(ImePriimek == ime_priimek) %>%
    ungroup %>% select(-Vir, -ImePriimek)

  prileganje <- glm(data=top_1, Rast ~ Leto)
  leta <- data.frame(Leto=seq(2016, 2021, 1))
  napoved <- leta %>% mutate(Rast=predict(prileganje, leta),
                             Premozenje=c(NA, top_1$Premozenje) * (1+Rast/100))

  ggTop_napoved <- ggplot(data=napoved %>% filter(Leto == 2021) %>% rbind(top_1),
                          aes(x=Leto, y=Rast)) +
    geom_line(size=0.5) +
    geom_point(na.rm = TRUE) +
    geom_point(data = napoved %>% filter(Leto==2021), aes(x=Leto, y=Rast, color="red", size=2), na.rm = TRUE) +
    #geom_point(aes(color=(Leto == 2021)), na.rm=TRUE) +
    geom_text(aes(label=ifelse(Leto == 2021, round(Premozenje, -3), "")), nudge_y=10) + # napoved rasti in premoženja
    labs(y="Rast (%)") +
    geom_smooth(data=top_1, method="glm", formula=y ~ x, fullrange=TRUE) +
    ylab("Rast premoženja v %") +
    labs(title=paste("Napoved rasti premoženja za leto 2021", ime_priimek, sep=" - ")) +
    theme(axis.ticks=element_line(color="red"),
          axis.ticks.length=unit(2, "mm"),
          legend.position="none")
  print(ggTop_napoved)
}


install.packages("e1071")
library(e1071)

percentage_difference <- function(a, s) {
  ((s/a)-1) *100
}

yule <- function(x) {
  quantile_range = IQR(x)/2
  (quantile_range - median(x)) / quantile_range
}

quantiles_list <- function(x) {
  quantile(na.omit(x),probs=seq(0,1,.05))
}

OpenRevs <- read.csv("~/Downloads/OpenRevs/OpenReviewsPerQuarter.csv")
SimOpenRevs <- read.csv("~/Downloads/OpenRevs/OpenReviewscHRevPerQuarter.csv")
#OpenRevs <- read.csv("~/Downloads/NumReviewers/NumberOfReviewersQuarter.csv")

vioplot2log(
  na.omit(OpenRevs$CoreFX),
  na.omit(OpenRevs$CoreCLR),
  na.omit(OpenRevs$Roslyn),
  na.omit(OpenRevs$Rust),
  na.omit(OpenRevs$Kubernetes),
  side = 'left', col = 'white',
  names = c( "CoreFX","CoreCLR", "Roslyn", "Rust", "Kubernetes")
)

summary(OpenRevs)
summary(SimOpenRevs)

quantiles_list(na.omit(OpenRevs$CoreFX))
quantiles_list(na.omit(SimOpenRevs$CoreFX))

quantiles_list(na.omit(OpenRevs$CoreCLR))
quantiles_list(na.omit(SimOpenRevs$CoreCLR))

quantiles_list(na.omit(OpenRevs$Roslyn))
quantiles_list(na.omit(SimOpenRevs$Roslyn))

quantiles_list(na.omit(OpenRevs$Rust))
quantiles_list(na.omit(SimOpenRevs$Rust))

quantiles_list(na.omit(OpenRevs$Kubernetes))
quantiles_list(na.omit(SimOpenRevs$Kubernetes))

percentile = .50
percentage_difference(quantile(na.omit(OpenRevs$CoreFX) , percentile, names  = FALSE),quantile(na.omit(SimOpenRevs$CoreFX) , percentile, names  = FALSE))
percentage_difference(quantile(na.omit(OpenRevs$CoreCLR) , percentile, names  = FALSE),quantile(na.omit(SimOpenRevs$CoreCLR) , percentile, names  = FALSE))
percentage_difference(quantile(na.omit(OpenRevs$Roslyn) , percentile, names  = FALSE),quantile(na.omit(SimOpenRevs$Roslyn) , percentile, names  = FALSE))
percentage_difference(quantile(na.omit(OpenRevs$Rust) , percentile, names  = FALSE),quantile(na.omit(SimOpenRevs$Rust) , percentile, names  = FALSE))
percentage_difference(quantile(na.omit(OpenRevs$Kubernetes) , percentile, names  = FALSE),quantile(na.omit(SimOpenRevs$Kubernetes) , percentile, names  = FALSE))

plot(density(SimOpenRevs$Kubernetes))
plot(ecdf(1-SimOpenRevs$KubernetesSum))
hist(OpenRevs$Kubernetes)

kurtosis(na.omit(openA$CoreFX))
kurtosis(na.omit(OpenRevs$CoreFX))
kurtosis(na.omit(OpenRevs$CoreCLR))
kurtosis(na.omit(OpenRevs$Roslyn))
kurtosis(na.omit(OpenRevs$Rust))

kurtosis(na.omit(openA$Kubernetes))
kurtosis(na.omit(openOwnRec$Kubernetes))
kurtosis(na.omit(openWhoDo$Kubernetes))

skewness(na.omit(OpenRevs$CoreFX))
skewness(na.omit(OpenRevs$CoreCLR))
skewness(na.omit(OpenRevs$Roslyn))
skewness(na.omit(OpenRevs$Rust))
skewness(na.omit(OpenRevs$Kubernetes))

skewness(na.omit(SimOpenRevs$CoreFX))
skewness(na.omit(SimOpenRevs$CoreCLR))
skewness(na.omit(SimOpenRevs$Roslyn))
skewness(na.omit(SimOpenRevs$Rust))
skewness(na.omit(SimOpenRevs$Kubernetes))

percentage_difference(skewness(na.omit(OpenRevs$CoreFX)),skewness(na.omit(SimOpenRevs$CoreFX)))
percentage_difference(skewness(na.omit(OpenRevs$CoreCLR)),skewness(na.omit(SimOpenRevs$CoreCLR)))
percentage_difference(skewness(na.omit(OpenRevs$Roslyn)),skewness(na.omit(SimOpenRevs$Roslyn)))
percentage_difference(skewness(na.omit(OpenRevs$Rust)),skewness(na.omit(SimOpenRevs$Rust)))
percentage_difference(skewness(na.omit(OpenRevs$Kubernetes)),skewness(na.omit(SimOpenRevs$Kubernetes)))

percentage_difference(kurtosis(na.omit(OpenRevs$CoreFX)),kurtosis(na.omit(SimOpenRevs$CoreFX)))
percentage_difference(kurtosis(na.omit(OpenRevs$CoreCLR)),kurtosis(na.omit(SimOpenRevs$CoreCLR)))
percentage_difference(kurtosis(na.omit(OpenRevs$Roslyn)),kurtosis(na.omit(SimOpenRevs$Roslyn)))
percentage_difference(kurtosis(na.omit(OpenRevs$Rust)),kurtosis(na.omit(SimOpenRevs$Rust)))
percentage_difference(kurtosis(na.omit(OpenRevs$Kubernetes)),kurtosis(na.omit(SimOpenRevs$Kubernetes)))

#only looks at Q1 to Q3 and compares with Q2, so misses the outliers
percentage_difference(yule(na.omit(OpenRevs$CoreFX)),yule(na.omit(SimOpenRevs$CoreFX)))
percentage_difference(yule(na.omit(OpenRevs$CoreCLR)),yule(na.omit(SimOpenRevs$CoreCLR)))
percentage_difference(yule(na.omit(OpenRevs$Roslyn)),yule(na.omit(SimOpenRevs$Roslyn)))
percentage_difference(yule(na.omit(OpenRevs$Rust)),yule(na.omit(SimOpenRevs$Rust)))
percentage_difference(yule(na.omit(OpenRevs$Kubernetes)),yule(na.omit(SimOpenRevs$Kubernetes)))


library(tmvtnorm)

# t-Stutdet parameters
Mu = c(9, 8, 7, 6)
Sigma = matrix(c(16, -2, -1, -3,
                 -2,  9, -4, -1,
                 -1, -4,  4,  1,
                 -3, -1,  1,  1),
               nrow=4, ncol=4)
lower_bound = 5
upper_bound = 12

# Generate scenarios
data <- rtmvt(n=10000, mean=mu, sigma=sigma, df=5, lower=rep(lower_bound, 4), upper=rep(upper_bound, 4))
write.table(format(data, digits=15, drop0trailing=F), "data10000.txt", quote=F, sep="\t", eol="\n\t", col.names = F, row.names = T)
mean <- colMeans(data)

E <- function(idx, Mu, Sigma, v, alfa, beta) {
  mu = Mu[idx]
  sigma = Sigma[idx, idx]
  a = (alfa - mu)/sigma
  b = (beta - mu)/sigma
  nom = gamma((v-1)/2) *
        ((v+a^2)^(-1*(v-1)/2) -
         (v+b^2)^(-1*(v-1)/2)) *
        v^(v/2)
  den = 2 * (pt(b, v) - pt(a, v)) * gamma(v/2) * gamma(1/2)
  return (mu + sigma*(nom/den))
}

ER1 <- E(1, Mu, Sigma, 5, 5, 12)
ER2 <- E(2, Mu, Sigma, 5, 5, 12)
ER3 <- E(3, Mu, Sigma, 5, 5, 12)
ER4 <- E(4, Mu, Sigma, 5, 5, 12)
ER <- c(ER1, ER2, ER3, ER4)
write.table(ER, "ER.txt", sep="\t", col.names=F, row.names=F)


#' Generate data
#'
#'@description{
#' The generated responses are discretized and truncated from a latent exponential
#' generalized linear model with natural parameter exp(X b)
#'  }
#'
#' @param X An n x p design matrix
#' @param b A vector of p regression coefficients
#' @param d A scalar controlling the coarseness of the support, where d = 1
#'  means integer support (see details)
#' @param ymax An upper bound on the observable response (see details)
#'
#' @return A matrix with n rows and 2 columns; the first is the lower endpoint
#'  of the observed interval and the second the upper endpoint (see details)
#'
#' @details{
#'   Data are generated by (i) draw y ~ Exp(exp(X b)), (ii) replace y by floor(y
#'   / d) * d, and (iii) replace every element of y greater than ymax by ymax;
#'   this gives the lower endpoint of the interval. Observe that the operation
#'   floor(y / d) * d sets y to the nearest smaller multiple of d.
#'
#'   The upper endpoint of the observed interval is yupp = y + d, unless y =
#'   ymax in which case yupp = Inf.
#'  }
#'
#' @export
generate_ee <- function(X, b, d = 1, ymax = 10){
  # Do argument checking
  stopifnot(is.matrix(X))
  p <- ncol(X)
  n <- nrow(X)
  stopifnot(is.numeric(b), length(b) == p)
  stopifnot(is.numeric(d), length(d) == 1, d > 0)
  stopifnot(is.numeric(ymax), length(ymax) == 1, ymax >= 0)

  eta <- X %*% b
  y <- stats::rexp(n = nrow(X), rate = exp(X %*% b))
  y <- floor(y / d) * d
  y <- pmin(y, ymax)
  yupp <- y + d
  yupp[y == ymax] <- Inf
  return(cbind(y, yupp))
}

#' Evaluate objective function and its derivatives
#'
#' @description{The objective function is that of an elastic net-penalized negative
#'  log-likelihood corresponding to a latent exponential generalized linear model
#'  with natural parameter exp(X b).
#' }
#'
#' @param y A vector of n observed responses (see details in fit_ee)
#' @param X An n x p matrix of predictors
#' @param b A vector of p regression coefficients
#' @param yupp A vector of n upper endpoints of intervals corresponding to y
#'   (see details in fit_ee)
#' @param lam A scalar penalty parameter
#' @param alpha A scalar weight for elastic net (1 = lasso, 0 = ridge)
#' @param pen_factor A vector of coefficient-specific penalty weights; defaults
#' to 0 for first element of b and 1 for the remaining.
#' @param order An integer where 0 means only value is computed; 1 means both value
#'   and sub-gradient; and 2 means value, sub-gradient, and Hessian (see details)
#' @return A list with elements "obj", "grad", and "hessian" (see details)
#'
#' @details{
#'  When order = 0, the gradient and Hessian elements of the return list are set
#'  to all zeros, and similarly for the Hessian when order = 1.
#'
#'  The sub-gradient returned is that obtained by taking the sub-gradient of the
#'  absolute value to equal zero at zero. When no element of b is zero, this is
#'  the usual gradient. The Hessian returns is that of the smooth part of the
#'  objective function that is, the average negative log-likelihood plus the L2
#'  penalty only. When no element of b is zero, this is the Hessian of the
#'  objective function
#' }
#' @export
obj_diff <- function(y, X, b, yupp, lam = 0, alpha = 1, pen_factor = c(0, rep(1,
  ncol(X) - 1)), order){
  # Do argument checking
  stopifnot(is.matrix(X))
  p <- ncol(X)
  n <- nrow(X)
  stopifnot(is.numeric(b), length(b) == p)
  stopifnot(is.numeric(y), is.null(dim(y)), length(y) == n)
  stopifnot(is.numeric(yupp), is.null(dim(yupp)), length(yupp) == n)
  stopifnot(is.numeric(lam), length(lam) == 1)
  stopifnot(is.numeric(alpha), length(alpha) == 1,
            alpha >= 0, alpha <= 1)
  stopifnot(is.numeric(pen_factor), is.null(dim(pen_factor)),
            length(pen_factor) == p)
  stopifnot(is.numeric(order), length(order) == 1, order %in% 0:2)

  obj_diff_cpp(y, X, b, yupp, lam1 = alpha * lam * pen_factor, lam2 = (1 -
  alpha) * lam * pen_factor, order)
}


#' Takes a power spectrum and makes it noisy, by adding white noise to
#' its amplitude, and introducing random, uniformly distributed
#' phases.
#'
#' \deqn{A(f) \sim \mathcal{N}(PSD(f), \sigma^2)}
#' \deqn{\phi(f) \sim \mathcal{U}(0, 2\pi)}
#' \deqn{z(f) = A(f) \exp(i \phi(f))}
#'
#' @param power Power spectral density.
#' @param sd Standard deviation of white noise.
#'
#' @return Power with noise added.
#'
#' @export
noisy.power.spectrum <- function(power, sd = 1.0) {
    A   <- rnorm(power, mean = power, sd = sd)
    phi <- runif(power, min = 0, max = 2*pi)

    A * exp(1i * phi)
}


# Run VAMF with 10 percent subset data
## Load VAMF and useful
library(vamf)
library(useful)
## Read in subset matrix. Because duplicate row names exist, set row.names = NULL first (R will create the row names column using numbers)
S <- read.table("10percentCellSubset_allgenes.txt", header=TRUE, quote = "\"'", row.names = NULL)
## Check corners of the table
corner(S)
## Make the gene count mask for gene filtering
geneCountsSum <- rowSums(S[,2:ncol(S)]) # the 1st column still carries gene names, and need to be skipped for row sum calc
## Remove genes (rows) with no expression
S <- S[geneCountsSum != 0,]
## Keep genes only when it is detected in more than 10 cells
Sfilter <- S[rowSums(S[,2:1331] > 0) > 10, ]
## Check the dimension post filtering
dim(Sfilter) # Here for this subset is (15665, 1331)
## Set gene names column as row names for the table, then remove the column with names from the table
rownames(Sfilter) <- Sfilter$row.names
Sfilter <- Sfilter[,2:ncol(Sfilter)]
## Check the type of table, and change its type to matrix prior processing
typeof(Sfilter) # Should be "list"
Smtx <- as.matrix(Sfilter)
typeof(Smtx) # Should be "integer"
## Calculate PCA, and export factors to file
pca <- prcomp(t(Smtx), center=TRUE, scale=TRUE)
pca_factor <- pca$x
write.table(pca_factor, file = "subset_pca_factor.txt", quote=FALSE, sep="\t")
## Calculate VAMF factors, and export to file
vamf <- vamf(Smtx,10,nrestarts=2,log2trans=TRUE)
vamf_factor <- vamf$factors
## Save vamf_factor to file
write.table(vamf_factor, file="subset_vamf_factor.txt", quote=FALSE, sep="\t")
## Combine cell metadata with the two factor file in command line (join)
## Read in joined file and plot
pcacol <- read.table("subset_pca_factor_w_meta.txt", header = FALSE, sep = '\t')
pcacol$cols <- as.numeric(as.factor(pcacol$V2))
legend.cols <- unique(pcacol$V2)
plot(pcacol[,3:4], col=pcacol$cols)
legend("topleft", legend=unique(pcacol$V2), pch=16, col=legend.cols)
## Same for VAMF
vamfcol <- read.table("subset_vamf_factor_w_meta.txt", header = FALSE, sep = '\t')
plot(vamfcol[,4:5], col = as.numeric(as.factor(vamfcol$V2)))
legend("bottomright", legend=unique(vamfcol$V2), pch=16, col=unique(vamfcol$V2))
## Calculate percentage explained in each component. Require the entire object created by prcomp()
eigs <- pca$sdev^2
perexplain <- rbind(
    SD = sqrt(eigs),
   Proportion = eigs/sum(eigs),
   Cumulative = cumsum(eigs)/sum(eigs))
perexplain
## Same for VAMF. As mentioned in the paper, used dimension learning instead
barplot(colNorms(vamf$factors),xlab="Dimension",ylab="L2 norm", main="Dimension Learning")
## Are PCs correlated with detection rate? Following VAMF example workflow. pca calculation part can be replaced by above.
### Using their defined functions rm_zero_rowcol(), pca()
rm_zero_rowcol<-function(Y){
     #remove all rows and columns containing all zeros
     Y<-Y[rowSums(Y>0)>0,] #remove rows with zeros all the way across
     Y<-Y[,colSums(Y>0)>0]
     Y
}
pca<-function(Y,L=2,center=TRUE,scale=TRUE){
  Y<-rm_zero_rowcol(Y)
   #if(scale) Y<-scale(Y)
     factors<-prcomp(as.matrix(t(Y)),center=center,scale=scale)$x
     factors<-factors[,1:L]
     colnames(factors)<-paste0("dim",1:L)
     as.data.frame(factors)
}
### Calculate first 2 principal components
factors <- pca(Smtx,2)
### Combine metadata and store in ref
ref <- pcacol[,1:2]
colnames(ref) <- c("id","batch") # The function defined requires the column name of ref as id and batch
### Calculate detection rate for each cell (column)
cens_rates_obj <- Matrix::colMeans(Smtx==0)
factors$detection_rate<-1-cens_rates_obj
### Plot! Use batch as group color label, and set transparency to 0.5 in alpha. Use gradient rainbow color palette.
ggplot(cbind(factors,ref),aes(x=detection_rate,y=dim1,color=batch))+geom_point(size=3, alpha = 0.5) + theme_classic()+ggtitle("PC1 vs. cell-specific detection")+labs(x="Detection Rate",y="Dimension 1") + theme(legend.position="top") + scale_colour_gradientn(colours=rainbow(6))
## Are VAMF dimensions correlated with detection rate?
### Plot vamf using similar work flow. Extract first 2 dimensions.
factors <- vamf_factor[,1:2]
factors$detection_rate <- 1-cens_rates_obj
ggplot(cbind(factors,ref),aes(x=detection_rate,y=dim1,color=batch))+geom_point(size=3, alpha = 0.5) + theme_classic()+ggtitle("Dim1 vs. cell-specific detection")+labs(x="Detection Rate",y="Dimension 1") + theme(legend.position="top") + scale_colour_gradientn(colours=rainbow(6))

## For Olga's subset, using cell meta data in R directly. (This step follows the factor saving steps of both PCA and VAMF)
## Read in cell meta data
cellmeta <- read.csv("rawmtx/Olga_10pctSubset_cell_metadata.csv", header=TRUE)
## Set cell column as row names
rownames(cellmeta) <- cellmeta$cell
## Remove cell column from cellmeta
cellmeta <- cellmeta[,2:ncol(cellmeta)]
## Merge meta data with factor matrix by row names
pca_meta <- merge(cellmeta, pca_factor, by = "row.names")
vamf_meta <- merge(cellmeta, vamf_factor, by = "row.names")
## Save both merged data to file
write.table(pca_meta, file = "Olga_10pct_subset_pca_wmeta.txt", quote=FALSE)
write.table(vamf_meta, file = "Olga_10pct_subset_vamf_wmeta.txt", quote=FALSE)
## Plotting PCAs
pca_meta$cols <- as.numeric(as.factor(pca_meta$group))
legend.cols <- unique(pca_meta$group)
plot(pca_meta$PC1, pca_meta$PC2, col=pca_meta$cols)
legend("topleft", legend=unique(pca_meta$group), pch=16, col=legend.cols)
## Plotting VAMFs
vamf_meta$cols <- as.number(as.factor(vamf_meta$group))
plot(vamf_meta$dim1, vamf_meta$dim2, col=vamf_meta$cols)
legend("bottomleft", legend=unique(vamf_meta$group), pch=16, col=legend.cols)
plot(vamf_meta$dim1, vamf_meta$dim3, col=vamf_meta$cols)

## Calculate Spearman Correlations
cens_rates_obj <- Matrix::colMeans(Smtx==0)
DR <- <-1-cens_rates_obj
cor(vamf_meta$dim1, vamf_meta$DR, method = "spearman")

"""
[102217 version]
## Calculate PCA factors, and export to file
pca_factor <- prcomp(t(Smtx), center=TRUE, scale=TRUE)$x
write.table(pca_factor, file = "subset_pca_factor.txt", quote=FALSE, sep="\t")
## Calculate VAMF factors, and export to file
vamf_factor <- vamf(Smtx,10,nrestarts=2,log2trans=TRUE)$factors
## Save vamf_factor to file
write.table(vamf_factor, file="Group1_vamf_factor.txt", quote=FALSE, sep="\t")
## In shell, join cell metadata with the PCA matrix. Assign colors to them by using metadata column as factor
###pca_factors <- read.table("subset_pca_factor_w_meta.txt", header=FALSE, sep = "\t")
###plot(pca_factors[,2:3] , col=pca_factors$V1)
###legend("topleft", legend=levels(pca_factors$V1), pch=16, col=unique(pca_factors$V1))
## Similarly, join cell metadata with VAMF matrix
with(vamf_factors,plot(dim1,dim2, col=))
"""


# import ggplot2
require(ggplot2)

wd        <- "~/dev/r/exploring-data-visually-r"
setwd(wd)

# set variable for the diamond prices
dp <-  diamonds$price

# ========================================
# charts using rbase
hist(dp)
hist(dp, breaks = 10)
hist(dp, freq = F)

# ========================================
# charts with lattice
require(lattice)
lattice::histogram(~ price, diamonds)
lattice::histogram(~ price, diamonds, breaks = 30)
# histograms accross different categorical variables on top of price
lattice::histogram(~ price | cut, diamonds)

# plot density plots
# plot one graph for each category
lattice::densityplot(~ price | cut,
                     data = diamonds,
                     plot.points = F,
                     ref = T)

# plot all categories in one plot
lattice::densityplot(~ price,
                     data   = diamonds,
                     groups = cut,
                     plot.points = F,
                     ref = T,
                     auto.key = list(columns = 3))

# ========================================
# plotting with ggplot2
# histogram
ggplot(diamonds, aes(x = price)) +
    ggplot2::geom_histogram()

# density
ggplot(diamonds, aes(x = price)) +
    ggplot2::geom_density()

# both combined
ggplot(diamonds, aes(x = price)) +
    ggplot2::geom_histogram(
        aes(y = ..density..),
        binwidth = 1000,
        colour   = "black",
        fill     = "white") +
    ggplot2::geom_density(
        alpha = .25,
        fill  = "#FF6666" )


ISLMPlot <- function(input,output,values){
  prod = seq(0,input$ymax,length.out = 1000)
  to_plot = data.frame(revenu = prod)
  fig = plot_ly(to_plot, x = ~revenu)

  fig = fig %>% add_trace(y = ((1-input$alpha-input$iy)*prod+input$alpha*input$t-input$cpi-input$id*input$D/values$p-input$bari-input$g)/input$ir,
                          type = "scatter", mode = "lines", name = "$$IS_1$$", line = list(color = "#ff0000"),
                          hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_trace(y = lm_curve(input$lr, input$Ms, values$p, input$ly, prod, input$rmin),
                          type = "scatter", mode = "lines", name = "$$LM_1$$", line = list(color = "#007bff"),
                          hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

  fig = fig %>% add_segments(0,values$eq$r,values$eq$y,values$eq$r,
                             line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$y,0,values$eq$y,values$eq$r,
                             line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

  if(values$shock){
    for(i in 1:2){
      if(!is.na(input[[paste0("new_value_",i)]])){
        if(input[[paste0("shocked_var_",i)]] %in% choicesIS){
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = ((1-alpha-iy)*prod+alpha*t-cpi-id*input$D/p-bari-g)/ir,
                               type = "scatter", mode = "lines",
                               name = paste0("$$IS_2^",i,"$$"), line = list(color = paste0("#",i+7,"a0000")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
        } else if(input[[paste0("shocked_var_",i)]] %in% choicesLM){
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = lm_curve(lr,Ms,p,ly,prod,input$rmin),
                               type = "scatter", mode = "lines",
                               name = paste0("$$LM_2^",i,"$$"), line = list(color = paste0("#0234",3+i^2,"b")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
        } else if(input[[paste0("shocked_var_",i)]] == "p"){
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = ((1-alpha-iy)*prod+alpha*t-cpi-id*input$D/p-bari-g)/ir,
                               type = "scatter", mode = "lines",
                               name = paste0("$$IS_2^",i,"$$"), line = list(color = paste0("#",i+7,"a0000")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
          fig = with(values[[paste0("shocked_params_",i)]],
                     add_trace(fig, y = lm_curve(lr,Ms,p,ly,prod,input$rmin),
                               type = "scatter", mode = "lines",
                               name = paste0("$$LM_2^",i,"$$"), line = list(color = paste0("#0234",3+i^2,"b")),
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>")))
        }

        fig = fig %>% add_segments(0,values[[paste0("new_eq_",i)]]$r,values[[paste0("new_eq_",i)]]$y,values[[paste0("new_eq_",i)]]$r,
                                   line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                   hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
        fig = fig %>% add_segments(values[[paste0("new_eq_",i)]]$y,0,values[[paste0("new_eq_",i)]]$y,values[[paste0("new_eq_",i)]]$r,
                                   line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                   hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

        islm_new_eq = list(
          x = values[[paste0("new_eq_",i)]]$y,
          y = values[[paste0("new_eq_",i)]]$r,
          text = paste0("y*=",round(values[[paste0("new_eq_",i)]]$y), ", r*=",round(values[[paste0("new_eq_",i)]]$r,4))
        )
        fig = fig %>% layout(annotations = islm_new_eq)
      }
    }
  } else{
    islm_eq = list(
      x = values$eq$y,
      y = values$eq$r,
      text = paste0("y*=",round(values$eq$y), ", r*=",round(values$eq$r,4))
    )
    fig = fig %>% layout(annotations = islm_eq)
  }

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  revenu <- list(
    title = "Revenu, y",
    titlefont = f
  )
  interest <- list(
    title = "Taux d'intérêt, r",
    titlefont = f,
    range = c(0,10)
  )
  fig = fig %>% layout(xaxis = revenu, yaxis = interest)
  return(fig)
}


library("vroom")
library("DescTools")

df <- vroom(here::here("data-raw", "data", "rt", "prevalence-samples.csv")) %>%
  filter(county %in% c("pilot", "non-pilot")) %>%
  select(county, sample,
         pred_prev1 = "2020-10-31", pred_prev2 = "2020-11-07") %>%
  nest(samples = c(sample, pred_prev1, pred_prev2))

data("ms.tst")

uncertain_saRR <- function(x1, n1, x2, n2, samples,
                           quantiles = c(0.025, 0.5, 0.975)) {
  x1_sum <- sum(x1)
  n1_sum <- sum(n1)
  x2_sum <- sum(x2)
  n2_sum <- sum(n2)

  samples_sum <- bind_rows(samples) %>%
    group_by(sample) %>%
    summarise_all(sum)

  ## take beta sample
  samples_sum$cprev1 <-
    rbeta(length(unique(samples_sum$sample)), x1_sum, n1_sum - x1_sum)
  samples_sum$cprev2 <-
    rbeta(length(unique(samples_sum$sample)), x2_sum, n2_sum - x2_sum)

  ratios <- samples_sum %>%
    group_by(sample) %>%
    summarise(cratio = (cprev2 / cprev1),
              pred_ratio = (pred_prev2 / pred_prev1), .groups = "drop") %>%
    ungroup() %>%
    mutate(sarr = cratio / pred_ratio) %>%
    summarise(sarr = quantile(sarr, quantiles), quantile = quantiles,
              cratio = quantile(cratio, quantiles), quantile = quantiles,
              pred_ratio = quantile(pred_ratio, quantiles), quantile = quantiles,
              .groups = "drop")

  return(list(ratios))
}

sarr_by_pilot <- ms.tst %>%
  filter(!is.na(attendance_3)) %>%
  simplify_names() %>%
  mutate(county =
           if_else(simple_name %in%
                   c("tvrdosin", "namestovo", "dolny_kubin", "bardejov"),
                   "pilot", "non-pilot")) %>%
  group_by(county) %>%
  summarise_if(is.numeric, sum, na.rm = TRUE) %>%
  ungroup() %>%
  left_join(df, by = "county") %>%
  group_by(county) %>%
  summarise(sapr = uncertain_saRR(positive_2, attendance_2,
                                  positive_3, attendance_3, samples),
            .groups = "drop") %>%
  unnest(cols = c(sapr))

sarr_total <- ms.tst %>%
  filter(!is.na(attendance_3)) %>%
  simplify_names() %>%
  group_by(county) %>%
  mutate(county =
           if_else(simple_name %in%
                   c("tvrdosin", "namestovo", "dolny_kubin", "bardejov"),
                    "pilot", "non-pilot")) %>%
  group_by(county) %>%
  summarise_if(is.numeric, sum, na.rm = TRUE) %>%
  left_join(df, by = "county") %>%
  ungroup() %>%
  summarise(sapr = uncertain_saRR(positive_2, attendance_2,
                                  positive_3, attendance_3, samples),
            .groups = "drop") %>%
  unnest(cols = c(sapr))


toKilo <- function(x) (x/1024)
toMega <- function(x) (toKilo(toKilo(x)))
toGiga <- function(x) (toMega(toKilo(x)))
fromKilo <- function(x) (x*1024)
fromMega <- function(x) (fromKilo(fromKilo(x)))
fromGiga <- function(x) (fromMega(fromKilo(x)))

# Calculate the Cloudfront cost per month, based on the number of uniques and number of events per month

cfCostPerMonth <- function(events, uniques){
	# Assume sp.js is served once per unique per month (because of caching)
	# Assume that i is served once for every event
	requests <- events + uniques
	gigabytesServed <- events * sizeOfIPixel + uniques * sizeOfSpJs

	cfCostPerMonthRaw(gigabytesServed, requests)
}

# Calculate the Cloudfront cost per month, based on the monthly volume transferred out and number of requests
# Assumptions:
# * 10% of requests are HTTPS
# * all requests served to users in the US
# * < 10TB served per month
cfCostPerMonthRaw <- function(gigabytesServed, requests){
	dataTransferRatePerGigabytes <- 0.120
	dataTransferPrice <- dataTransferRatePerGigabytes * gigabytesServed

	httpRequestPricePerTenThousand <- 0.0075
	httpsRequestPricePerTenThousand <- 0.0100

	httpRequests <- 0.9 * requests
	httpsResquests <- 0.1 * requests
	requestPrice <- httpRequests * httpRequestPricePerTenThousand / 10000 + httpsResquests * httpsRequestPricePerTenThousand / 10000

	# Return the total Cloudfront cost
	dataTransferPrice + requestPrice
}

# i pixel is 37 bytes
sizeOfIPixel <- toGiga(37)

# sp.js is 32 kilobytes
sizeOfSpJs <- fromKilo(toGiga(32))


#data preprocess

#Importing the dataset
dataset = read.csv('Data.csv')

# Replacing missing value in Age column with AVG of entire column
dataset$Age = ifelse(is.na(dataset$Age),
                     ave(dataset$Age, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Age)

# Replacing missing value in Salary column with AVG of entire column
dataset$Salary = ifelse(is.na(dataset$Salary),
                     ave(dataset$Salary, FUN = function(x) mean(x, na.rm = TRUE)),
                     dataset$Salary)

# Encoding categorical data
dataset$Country = factor(dataset$Country,
                         levels = c('France', 'Spain', 'Germany'),
                         labels = c(1, 2, 3))

dataset$Purchased= factor(dataset$Purchased,
                         levels = c('No', 'Yes'),
                         labels = c(0,1))

# Split the dataset into the Training set and test set
library(caTools)
set.seed(123)
split = sample.split(dataset$Purchased, SplitRatio = 0.8)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Featured Scaling
training_set[, 2:3] = scale(training_set[, 2:3])
test_set[, 2:3] = scale(test_set[, 2:3])

Machine Learning A-Z Template Folder/Part one - Data Preprocessing/preprocess.r


##########################

# helper functions for R script

# on TREEWEB synthesis

##############

##### compute bayesian R2 for single function
bayes_R2 <- function(obs,pred,summary = TRUE){
  e <- -1 * sweep(pred,2,obs)
  var_ypred <- apply(pred,1,var)
  var_e <- apply(e,1,var)
  if(summary){
    return(quantile(var_ypred / (var_ypred + var_e),probs=c(0.1,0.5,0.9)))
  }
  else{
    return(var_ypred / (var_ypred + var_e))
  }
}
#apply this across the functions
#sapply(1:K,function(k) bayes_R2(dat_std[,(k+1)],ypred[,,k]))

#### function to generate positive definite matrix (covariance)
Posdef <- function (n, ev = runif(n, 0, 10))
{
  Z <- matrix(ncol=n, rnorm(n^2))
  decomp <- qr(Z)
  Q <- qr.Q(decomp)
  R <- qr.R(decomp)
  d <- diag(R)
  ph <- d / abs(d)
  O <- Q %*% diag(ph)
  Z <- t(O) %*% diag(ev) %*% O
  return(Z)
}

##### function to help initialization
init_fn <- function(){
  list(L_omega = chol(Posdef(K)))
}

######## function to plot ternary graphs
make_ind_gg <- function(predicted, fun = "Predation",fragm="Low", pal=viridis(10)){
  subs <- subset(predicted,Function==fun & Fragm==fragm)
  out <-   ggtern(subs,aes(fsyl,qrob,qrub))+
    theme_bw()+
    theme_nomask() +
    #facet_wrap(~Function) +

    geom_tri_tern(bins=4,fun=mean,aes(value=Med_real,fill=..stat..)) +
    stat_tri_tern(bins=4,fun=mean,geom="text",aes(value=Med_real,
                                                  label=sprintf("%.2f",..stat..)),
                  color="darkorange3",size=3,centroid=TRUE) +
    annotate(geom = "text",x=0.5,y=0.9,z=-0.3,label=fun) +
    scale_fill_gradientn(colours = pal) +
    theme(legend.position = "none")
  return(out)
}

###### function to make custom correlation graphs
##### modifying code from corrr::network_plot

network_df <- function(rdf,
                       min_cor = .30,
                       legend = TRUE,
                       colours = c("indianred2", "white", "skyblue1"),
                       repel = TRUE,
                       curved = TRUE,
                       colors) {

  require(dplyr)
  require(ggplot2)

  if (min_cor < 0 || min_cor > 1) {
    stop ("min_cor must be a value ranging from zero to one.")
  }

  if (!missing(colors))
    colours <- colors

  rdf %>%
    as_matrix(diagonal = 1) -> rdf
  distance <- sign(rdf) * (1 - abs(rdf))

  # fixed position of variables in 4 different columns
  points <- data.frame(x = c(rep(-0.5,6),rep(-0.17,7),rep(0.17,5),rep(0.5,6)),y=c(seq(-0.5,0.5,length=6),
                                                                                seq(-0.5,0.5,length=7),
                                                                                seq(-0.5,0.5,length=5),
                                                                                seq(-0.5,0.5,length=6)),id=nice_name)
  #points$id <- rownames(points)

  # Create a proximity matrix of the paths to be plotted.
  proximity <- abs(rdf)
  proximity[upper.tri(proximity)] <- NA
  diag(proximity) <- NA
  proximity[proximity < min_cor] <- NA

  # Produce a data frame of data needed for plotting the paths.
  n_paths <- sum(!is.na(proximity))
  paths <- matrix(nrow = n_paths, ncol = 6) %>% data.frame()
  colnames(paths) <- c("x", "y", "xend", "yend", "proximity", "sign")
  path <- 1
  for(row in 1:nrow(proximity)) {
    for(col in 1:ncol(proximity)) {
      path_proximity <- proximity[row, col]
      if (!is.na(path_proximity)) {
        path_sign <- sign(distance[row, col])
        x    <- points$x[row]
        y    <- points$y[row]
        xend <- points$x[col]
        yend <- points$y[col]
        paths[path, ] <- c(x, y, xend, yend, path_proximity, path_sign)
        path <- path + 1
      }
    }
  }

  plot_ <- list(
    # For plotting paths
    if (curved) geom_curve(data = paths,
                           aes(x = x, y = y, xend = xend, yend = yend,
                               alpha = proximity, size = proximity,
                               colour = proximity*sign)),
    if (!curved) geom_segment(data = paths,
                              aes(x = x, y = y, xend = xend, yend = yend,
                                  alpha = proximity, size = proximity,
                                  colour = proximity*sign)),
    scale_alpha(limits = c(0, 1)),
    scale_size(limits = c(0, 1)),
    scale_colour_gradientn(limits = c(-1, 1), colors = colours),
    # Plot the points
    #geom_point(data = points,
    #           aes(x, y),
    #           size = 3, shape = 19, colour = "white"),
    # Plot variable labels
    if (repel) ggrepel::geom_text_repel(data = points,
                                        aes(x, y, label = id),
                                        fontface = 'bold', size = 5,
                                        segment.size = 0.0,
                                        segment.color = "white"),
    if (!repel) geom_text(data = points,
                          aes(x, y, label = id),
                          fontface = 'bold', size = 5,color="grey90"),
    # expand the axes to add space for curves
    expand_limits(x = c(min(points$x) - .1,
                        max(points$x) + .1),
                  y = c(min(points$y) - .1,
                        max(points$y) + .1)
    ),
    # Theme and legends
    theme_void(),
    guides(size = "none", alpha = "none"),
    if (legend)  labs(colour = NULL),
    if (!legend) theme(legend.position = "none")
  )

  ggplot() + plot_ + theme(plot.background = element_rect(fill="grey70"))

}


is.perf <- function(n){
	if (n==0|n==1) return(FALSE)
	s <- seq (1,n-1)
	x <- n %% s
	m <- data.frame(s,x)
	out <- with(m, s[x==0])
	return(sum(out)==n)
}
# Usage - Warning High Memory Usage
is.perf(28)
sapply(c(6,28,496,8128,33550336),is.perf)


#### testing ####

pts <- list(point(0,0), point(10,0), point(10,10), point(0,10),
            point(2.5,2.5), point(7.5,2.5), point(7.5,7.5), point(2.5,7.5),
            point(0,5), point(10,5),
            point(3,0), point(7,0), point(7,10), point(3,10))

polygons <-
  list(
       square = createPolygon(pts, list(c(1,2), c(2,3), c(3,4), c(4,1))),
       squarehole = createPolygon(pts, list(c(1,2), c(2,3), c(3,4), c(4,1), c(5,6), c(6,7), c(7,8), c(8,5))),
       exagon = createPolygon(pts, list(c(11,12), c(12,10), c(10,13), c(13,14), c(14,9), c(9,11)))
      )

testpoints <-
  list(
       point(5,5), point(5, 8), point(-10, 5), point(0,5), point(10,5),
       point(8,5), point(9.9,9.9)
      )

for(p in testpoints) {
  for(polysi in 1:length(polygons)) {
    cat(sprintf("point (%lf, %lf) is %s polygon (%s)\n",
                  p$x, p$y, point_in_polygon(polygons[[polysi]], p), names(polygons[polysi])))
  }
}


#####################################################################
# CS671: Machine Learning
# Copyright 2015 Pejman Ghorbanzade <pejman@ghorbanzade.com>
# More info: https://github.com/ghorbanzade/beacon
#####################################################################

# load dataset
letters <- read.csv("dat/letter.csv", header=TRUE, sep=",")

# show summary of loaded dataset on console
# str(letters)
# alternatively, to view the dataset in RStudio
# View(letters)

# R packages specialized in SVM are Kernlab, svmlight, libsvm, e1071
# We begin with kernlab
# Make sure kernlab package is installed
# list(sort(.packages(all.available = TRUE)))
# pkg <- select.list(sort(.packages(all.available = TRUE)))
# if(nchar(pkg)) library(pkg, character.only=TRUE)
library(kernlab)

# Select first 16000 samples as training dataset
letters_train <- letters[1:16000, ]

# Select the remaining 4000 samples as test dataset
letters_test <- letters[16001:20000, ]

# Build a classifer using a linear kernel function
letter_classifier <- ksvm(lettr~., data=letters_train, kernel="vanilladot")

# show classifier properties
# letter_classifier

# apply classifier on the test dataset
letter_prediction <- predict(letter_classifier, letters_test)

# show header
head(letter_prediction)

# show confusion matrix
table(letter_prediction, letters_test$lettr)

# show number of correct and incorrect recognitions
agreement <- letter_prediction == letters_test$lettr
table(agreement)


N <- 10000 # Games per run
M <- 10    # Runs

rewards <- matrix(nrow=M, ncol=N)
fracs1 <- matrix(nrow=M, ncol=N)
fracs2 <- matrix(nrow=M, ncol=N)
for (j in 1:M) {
  for (i in 1:N) {
    coin <- 1
    coins <- vector()

    # Play the St. Petersburg game
    while(coin) {
      coin <- sample(c(0, 1), 1)
      coins <- c(coins, coin)
    }

    rewards[j,i] <- 2**(sum(coins)+1)
    if (i == 1) {
      fracs1[j,i] = 0
      fracs2[j,i] = 0
    } else {
      fracs1[j,i] =
        sum(rewards[j,1:i])/(i*log2(i))
      fracs2[j,i] =
        sum(rewards[j,1:i])/(i*log2(i*log2(i)))
    }
  }
}

# Plot the results
svg(filename="Figures/petersburgslow.svg")
plot(1:N, fracs1[1,1:N], type='l',
     ylim=c(min(fracs1[,1000:N]), max(fracs1[,1000:N])),
     xlab='Trials (n)', ylab='S_n/(n*log_2(n))')
for (j in 2:M) {
  lines(1:N, fracs1[j,1:N])
}
lines(1:N, rep(1,N), col='red')
dev.off()
svg(filename="Figures/petersburgfast.svg")
plot(1:N, fracs2[1,1:N], type='l',
     ylim=c(min(fracs1[,1000:N]), max(fracs1[,1000:N])),
     xlab='Trials (n)', ylab='S_n/(n*log_2(n*log_2(n)))')
for (j in 2:M) {
  lines(1:N, fracs2[j,1:N])
}
lines(1:N, rep(1,N), col='red')
dev.off()


function (d, sj=1, wsz=38)
{
	#Given crazy-beliefs data, a subject number, and a window size, this function estimates
	#the location of the category boundary from the subject's responses over the window
	#beginning with the initial grid test and running through the multi-source learning trials
	#d = data list of the form generated by get.data
	#sj = subject index number (ie, the element of d containing the subject's data)
	#wsz = window size, by default set to the number of trials in the initial grid estimate
	g1 <- d[[sj]][[2]][, c(10, 11, 13)]  #Get data for first test grid
	g1 <- g1[order(g1[,1]),2:3]          #order by trial number
    tmp <- d[[sj]][[3]][, c(10, 11, 13)] #get data from multi-source trials
    tmp <- tmp[order(tmp[, 1]), 2:3]     #order by trial number
    tmp <- rbind(g1,tmp)                 #ajoin grid 1 and multi-source trials
    npts <- dim(tmp)[1] - wsz            #Number of data point taking window size into account
    out <- rep(0, times = npts)	         #initialize output vector
    for (i1 in c(1:npts)) {              #for each windows
        tmprange <- c(i1:(i1 + wsz))     #pull out data
        is <- glm(acc ~ Pic, family = "binomial", data = tmp[tmprange,
            ])$coef                      #fit logistic model
        out[i1] <- -(is[1]/is[2])        #compute boundary and store in output vector
    }
    out
}