library(npowerPrioR)

scenario <- 4

source(paste("data_Bernoulli_scenario_", scenario, ".r", sep = ""))

bb.data <- list(
  N0 = N_0,
  y0 = y_0,
  c = cc,
  d = dd,
  a_0 = NA
)

get_l_a0_bernoulli <- function(y0, n0, cc, dd, a_0){
  ans <- lbeta(a_0 * y0 + cc, a_0 *(n0 -y0) + dd)-lbeta(cc, dd)
  return(ans)
}

l_a0 <- function(x) {
  get_l_a0_bernoulli(
    y0 = bb.data$y0,
    n0 = bb.data$N0,
    cc = bb.data$c,
    dd = bb.data$d,
    a_0 = x
  )
}
l_a0_p <- function(x) numDeriv::grad(l_a0, x)
l_a0_p <- Vectorize(l_a0_p)

l_a0_pp <- function(x) numDeriv::hessian(l_a0, x)
l_a0_pp <- Vectorize(l_a0_pp)

###
J <- 20
maxA <- 1

adaptive.ca0.estimates <- read.csv(paste("../../data/constant_data/Bernoulli_logCA0_scenario_", scenario,
                                                 "_J=", J, ".csv", sep = ""))

curve(l_a0_p, 0, maxA, lwd = 2, lty = 2, col = 2,  ylab = "",
      xlab = expression(a[0]), ylim = c(-200, 200), main = paste("Scenario", scenario))
abline(h = 0 , lwd = 2 , lty = 3)
curve(l_a0, 0, maxA, lwd = 2, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$lc_a0)
curve(l_a0_pp, 0, maxA, lwd = 2, col = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$second_deriv_lc, col = 3)
legend(x = "bottomright", legend = c("l(a_0)", "l'(a_0)", "l''(a_0)"), col = 1:3, lwd = 2, bty = 'n')
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$deriv_lc, col = 2)

######################################
midpoint_integrate_la0 <- function(x_preds, fit){
  ## takes a grid of values for the input and a fit object that gives predictions (GLM, GAM, etc) and
  ## Gives the integrated function
  n <- length(x_preds)
  delta <- (x_preds[2]-x_preds[1])
  midpoints <- 0.5*(x_preds[2:n] + x_preds[1:(n-1)])
  ans <-  cumsum(predict(fit, newdata = data.frame(a0 = midpoints))) * delta
  ans <- c(0, ans)
  return(ans)
}

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

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

preds.gam  <- get_band(fit.gam, xpred = pred_a0s)
deriv.preds <- midpoint_integrate_la0(pred_a0s, deriv.gam.fit)

true.lca0s <- l_a0(pred_a0s)

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

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

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

### Exporting

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

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

library(ggplot2)

dev_plot <- ggplot(data = forplot_ca0, aes(x = a0, y = dev, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  scale_x_continuous(expression(a[0])) +
  theme_bw(base_size = 16)
dev_plot

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

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

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


library(tidyverse)

total_test = function(long_df, all_normal = FALSE){
  if(all_normal){
    p = summary(aov(value ~ name, data = long_df))[[1]][["Pr(>F)"]]
  } else {
    p = kruskal.test(value ~ name, data = long_df)$p.value
  }
  return(p < 0.05)
}

pair_test = function(vec1, vec2, both_normal = FALSE){
  if(both_normal){
    p = t.test(vec1 , vec2, paired = FALSE, var.equal = TRUE)$p.value
  } else {
    p = wilcox.test(vec1 , vec2, paired = FALSE)$p.value
  }
  return(p < 0.05)
}

ab_test = function(df){

  # matrix of compares
  eq_mat = matrix(0, nrow = ncol(df), ncol = ncol(df))

  dsp = sapply(df, sd)
  if(sum(dsp == 0) > 0){

    cat('\n Element with zero dispersion! \n')
    cat('Means:\n')
    print(sapply(df, mean))
    cat('Standard dev.:\n')
    print(dsp)

    return(list(mat = eq_mat))
  }

  # convert to long format
  df2 = pivot_longer(df, cols = names(df)) %>% mutate(name = factor(name))

  g = ggplot(df2, aes(y = value, x = name)) + geom_boxplot() +
    labs(x = 'Group', title = 'Boxplots by groups') + theme_bw()
  print(g)

  # check normal distribution
  normals_vec = sapply(df, function(x) nortest::ad.test(x)$p.value > 0.05)

  # if there are global differences
  if(total_test(df2, sum(normals_vec) == length(normals_vec))){

  } else{
    cat('\n No difference \n')
    return(list(mat = eq_mat))
  }

  for(i in 1:(ncol(df)-1)){
    for(j in (i+1):ncol(df)){

      is_norm = normals_vec[i] & normals_vec[j]

      is_diff = pair_test(df[[i]], df[[j]], is_norm)

      if(is_diff){ # if stat. important

        if(mean(df[[i]]) > mean(df[[j]])){
          eq_mat[i,j] = 1
          eq_mat[j,i] = -1
        } else {
          eq_mat[i,j] = -1
          eq_mat[j,i] = 1
        }

      }

    }
  }

  cat('\n Comparing matrix: \n')
  print(eq_mat)

  # the rule for finding most less case
  counts = rowSums(eq_mat<1)
  min_res = (1:ncol(df))[counts == max(counts)]
  max_res = (1:ncol(df))[counts == min(counts)]

  cat('\n Minimal cats:')
  print(colnames(df)[min_res])

  cat('\n Maximal cats:')
  print(colnames(df)[max_res])

  return(list(mat = eq_mat))
}


#
# University: Universidad de Valladolid
# Degree: Grado en Estadística
# Subject: Análisis de Datos
# Year: 2017/18
# Teacher: Miguel Alejandro Fernández Temprano
# Author: Sergio García Prado (garciparedes.me)
# Name: Correspondence Analysis - Sport
#
#

rm(list = ls())

library(ggplot2)
suppressMessages(library(gdata))

DATA <- read.xls('./../../datasets/sport.xls')

N <- as.matrix.data.frame(DATA[,2:6])
rownames(N) <- DATA[,1]
N <- t(N)

F <- N / sum(N)
F

Dc <- diag( colSums(N) / sum(N))
Dc

Dr <- diag( rowSums(N) / sum(N))
Dr

Pc <- solve(Dc) %*% t(F)
Pc

Pr <- solve(Dr) %*% F
Pr

X <- t(F) %*% solve(Dr) %*% F %*% solve(Dc)

X_eigen <- eigen(X)
X_lambda <- X_eigen$values
X_u_1 <- X_eigen$vectors

X_u_norm <- diag(t(X_u_1) %*% solve(Dc) %*% X_u_1)

X_u <- t(t(X_u_1) / sqrt(X_u_norm))

fact <-solve(Dc) %*% X_u

Proyec_r <- Pr %*% fact
Proyec_c <- t(sqrt(X_lambda) * t(fact))

Proyec_r_df <- as.data.frame(Proyec_r)
rownames(Proyec_r_df) <- rownames(N)

Proyec_c_df <- as.data.frame(Proyec_c)
rownames(Proyec_c_df) <- colnames(N)

Proyec_df <- rbind(Proyec_r_df, Proyec_c_df)

ggplot(data=Proyec_df, aes(x=V2, y=V3)) +
  geom_point() +
  geom_text(label=rownames(Proyec_df))


suppressMessages(library(kazaam, quietly=TRUE))

source("./utils.r")
iris = read.iris("./iris.csv")$iris

svd = svd(iris)
u = svd$u
d = diag(svd$d)
vt = t(svd$v)

tol = sqrt(.Machine$double.eps)

test.local = isTRUE(all.equal(iris, u %*% d %*% vt, check.attributes=FALSE, tolerance=tol))
test = comm.all(test.local)
comm.print(test)

finalize()


########################################################################
########################################################################
# Logistic regression example
########################################################################
########################################################################

# install.packages("aod")
# install.packages("ggplot2")
# install.packages("vctrs")
# install.packages("VGAM")
# install.packages("quantreg")

library(knitr)
library(vctrs)
library(aod)
library(ggplot2)

# Graduate school admissions data from UCLA
mydata <- read.csv("https://stats.idre.ucla.edu/stat/data/binary.csv")
# Saved at: \Consulting\Public Code Samples\DataScience\Data
# Alternate URL:  https://1drv.ms/u/s!AgXALnk1NWLck4JA_01l6gpD6pZxpQ

## view the first few rows of the data
head(mydata)
# The admit variable is a binary response variable
# We will use gre, gpa, and rank as predictor variables.
# gre and gpa are continuous; while rank is a four-level factor

# Here are some examinations of the data:
summary(mydata)
sapply(mydata, sd)
xtabs(~admit + rank, data = mydata)

# Factor the rank variable and create a logistic regretion using glm() - Generalized Linear Model
mydata$rank <- factor(mydata$rank)
mylogit <- glm(admit ~ gre + gpa + rank, data = mydata, family = "binomial")

# See regression results using summary
summary(mylogit)

# We can create confidence levels by log likelihood
confint(mylogit)
# or based on the standard errors:
confint.default(mylogit)

# The wald test will give us the overall effect of the rank variable on admit:
wald.test(b = coef(mylogit), Sigma = vcov(mylogit), Terms = 4:6)

# The chi-squared test statistic of 20.9 indicates that rank *is* statistically significant in predicting admit

# Let's focus on Rank by taking the mean of the other variables, breaking up by each factor level
newdata1 <- with(mydata, data.frame(gre = mean(gre), gpa = mean(gpa), rank = factor(1:4)))

## view data frame
newdata1

# Let's use predict() to see if we can model the rank variable
newdata1$rankP <- predict(mylogit, newdata = newdata1, type = "response")
newdata1

# In the above output we see that the predicted probability of being accepted into a
# graduate program is 0.52 for students from the highest prestige undergraduate
# institutions (rank=1), and 0.18 for students from the lowest ranked institutions
# (rank=4), holding gre and gpa at their means. We can do something very similar to
# create a table of predicted probabilities varying the value of gre and rank.

# This is a technique for isolating the predictive effect of a single explanatory variable on the response

# We are going to plot these, so we will create 100 values of gre between 200 and 800,
# at each value of rank (i.e., 1, 2, 3, and 4).

newdata2 <- with(mydata, data.frame(gre = rep(seq(from = 200, to = 800, length.out = 100),
                                              4), gpa = mean(gpa), rank = factor(rep(1:4, each = 100))))

# The code to generate the predicted probabilities (the first line below) is
# the same as before, except we are also going to ask for standard errors so we
# can plot a confidence interval.

# We get the estimates on the link scale and back transform both the predicted values
# and confidence limits into probabilities.

newdata3 <- cbind(newdata2, predict(mylogit, newdata = newdata2, type = "link",
                                    se = TRUE))
newdata3 <- within(newdata3, {
  PredictedProb <- plogis(fit)
  LL <- plogis(fit - (1.96 * se.fit))
  UL <- plogis(fit + (1.96 * se.fit))
})

## view first few rows of final dataset
head(newdata3)

# Below we make a plot with the predicted probabilities, and 95% confidence intervals.
ggplot(newdata3, aes(x = gre, y = PredictedProb)) +
                  geom_ribbon(aes(ymin = LL, ymax = UL, fill = rank), alpha = 0.2) +
                  geom_line(aes(colour = rank),size = 1)

# Some methods to test fit below
with(mylogit, null.deviance - deviance)
with(mylogit, df.null - df.residual)
with(mylogit, pchisq(null.deviance - deviance, df.null - df.residual, lower.tail = FALSE))

# The chi-square of 41.46 with 5 degrees of freedom and an associated p-value of
# less than 0.001 tells us that our model as a whole fits significantly better
# than an empty model.

#To see the model's log likelihood
logLik(mylogit)

########################################################################
########################################################################
# Multinomial regression example
########################################################################
########################################################################

require(foreign)
require(nnet)
require(ggplot2)
require(reshape2)

# A data set showing occupational outcomes for vocational or academic educational paths
ml <- read.dta("https://stats.idre.ucla.edu/stat/data/hsbdemo.dta")
# Saved at: \Consulting\Public Code Samples\DataScience\Data\UCLAHighSchoolVocationalSurvey.dta
# Alternate URL:  https://1drv.ms/u/s!AgXALnk1NWLck4JDxYy1aZKct65nOw?e=7JBQzi

# Have a look at the data:
with(ml, table(ses, prog))
with(ml, do.call(rbind, tapply(write, prog, function(x) c(M = mean(x), SD = sd(x)))))

# Let's use relevel to create a new variable weighing the "academic" prog variable response
ml$prog2 <- relevel(ml$prog, ref = "academic")
test <- multinom(prog2 ~ ses + write, data = ml) # multinom() does not require reshaping like mlogit() does
summary(test)
# Test is a multinom() output of our model using the releveled program

# We run a couple of tests on the model:
z <- summary(test)$coefficients/summary(test)$standard.errors
z
# 2-tailed z test
p <- (1 - pnorm(abs(z), 0, 1)) * 2
p

## extract the coefficients from the model and exponentiate
exp(coef(test))

# Use predicted probabilities to help understand the model. Calculate predicted probabilities for each of
# the outcome levels using the fitted() function.
#
# We can start by generating the predicted probabilities for the observations in our dataset and viewing
# the first few rows:

  head(pp <- fitted(test))

# To examine the changes in predicted probability associated with one of our two
# variables, we can create small datasets varying one variable while holding the
# other constant. We will first do this holding write at its mean and examining
# the predicted probabilities for each level of ses.

dses <- data.frame(ses = c("low", "middle", "high"), write = mean(ml$write))
predict(test, newdata = dses, "probs")

dwrite <- data.frame(ses = rep(c("low", "middle", "high"), each = 41), write = rep(c(30:70), 3))

## store the predicted probabilities for each value of ses and write
pp.write <- cbind(dwrite, predict(test, newdata = dwrite, type = "probs", se = TRUE))

## calculate the mean probabilities within each level of ses
by(pp.write[, 3:5], pp.write$ses, colMeans)

## melt data set to long for ggplot2
lpp <- melt(pp.write, id.vars = c("ses", "write"), value.name = "probability")
head(lpp)  # view first few rows

# Plot the predicted probabilities against the writing score using the predictions generated
# for the pp.write object above by the level of ses for different levels of the outcome variable.

ggplot(lpp, aes(x = write, y = probability, colour = ses)) + geom_line() + facet_grid(variable ~ ., scales = "free")

########################################################################
########################################################################
# Poisson regression example (Zero Truncated)
########################################################################
########################################################################
install.packages("rlang")
install.packages("knitr")
install.packages("vctrs")
install.packages("ggplot2")
install.packages("VGAM")
require(foreign)
require(ggplot2)
require(VGAM)
require(boot)

# Import data from hospital tracking patients who have died
dat <- read.dta("https://stats.idre.ucla.edu/stat/data/ztp.dta")
# Saved at: \Consulting\Public Code Samples\DataScience\Data\HospitalDeathTracking.dta
# Alternate URL:  https://1drv.ms/u/s!AgXALnk1NWLck4JBKcMG9lGWFR8TEA?e=jZf1H7

# Convert a couple of the variables we'll be working with to factors
dat <- within(dat, {
  hmo <- factor(hmo)
  died <- factor(died)
})

summary(dat)

# To really get a sense for the data, let's plot some graphs:
# Length of stay with died in facets
ggplot(dat, aes(stay)) +
  geom_histogram() +
  scale_x_log10() +
  facet_grid(hmo ~ died, margins=TRUE, scales="free_y")

# Examine how stay looks across age groups:
ggplot(dat, aes(factor(age), stay)) +
  geom_violin() + # Violin plot is a great choice for this data spread
  geom_jitter(size=1.5) +
  scale_y_log10() +
  stat_smooth(aes(x = age, y = stay, group=1), method="loess")

# Look at live/die *by hmo*
ggplot(dat, aes(age, fill=died)) +
  geom_histogram(binwidth=.5, position="fill") +
  facet_grid(hmo ~ ., margins=TRUE)

# Now let's create a model predicting stay (a count variable) by the other variables in our set
m1 <- vglm(stay ~ age + hmo + died, family = pospoisson(), data = dat)
summary(m1)

# plot of residuals versus fitted values
output <- data.frame(resid = resid(m1), fitted = fitted(m1))
ggplot(output, aes(fitted, resid)) +
  geom_jitter(position=position_jitter(width=.25), alpha=.5) +
  stat_smooth(method="loess")

# Fit lines using quantile regression:
ggplot(output, aes(fitted, resid)) +
  geom_jitter(position=position_jitter(width=.25), alpha=.5) +
  stat_quantile(method="rq")

# Here we see the spread narrowing at higher levels. Let's cut the data into
# intervals and check box plots for each. We will get the breaks from the algorithm
# for a histogram.

output <- within(output, {
  broken <- cut(fitted, hist(fitted, plot=FALSE)$breaks)
})

ggplot(output, aes(broken, resid)) +
  geom_boxplot() +
  geom_jitter(alpha=.25)

# 1) Get the coefficients from our original model to use as start values for
# the model to speed up the time it takes to estimate.
# 2) Write a short function that takes data and indices as input and returns the parameters
# we are interested in.
# 3) Pass that to the boot function and do 1200 replicates,
#   using snow to distribute across four cores.

dput(round(coef(m1),3)) # Coefficients
f <- function(data, i) {
  require(VGAM)
  m <- vglm(formula = stay ~ age + hmo + died, family = pospoisson(),
            data = data[i, ], coefstart = c(2.436, -0.014, -0.136, -0.204))
  as.vector(t(coef(summary(m))[, 1:2])) #Original model coeffs as starting point
}

set.seed(10)
res <- boot(dat, f, R = 1200, parallel = "snow", ncpus = 4) # 1200 repeats, "snow" parallel option, and 4 cores

## print results
res

## basic parameter estimates with percentile and bias adjusted CIs
parms <- t(sapply(c(1, 3, 5, 7), function(i) {
  out <- boot.ci(res, index = c(i, i + 1), type = c("perc", "basic"))
  with(out, c(Est = t0, pLL = percent[4], pUL = percent[5],
              basicLL = basic[4], basicLL = basic[5]))
}))

## add row names
row.names(parms) <- names(coef(m1))
## print results
parms

## exponentiated parameter estimates with percentile and bias adjusted CIs
expparms <- t(sapply(c(1, 3, 5, 7), function(i) {
  out <- boot.ci(res, index = c(i, i + 1), type = c("perc", "basic"), h = exp)
  with(out, c(Est = t0, pLL = percent[4], pUL = percent[5],
              basicLL = basic[4], basicLL = basic[5]))
}))

## add row names
row.names(expparms) <- names(coef(m1))
## print results
expparms

# In order to better understand our results and model, let's plot some predicted values.
# Because all of our predictors were categorical (hmo and died) or had a small
# number of unique values (age) we will get predicted values for all possible
# combinations.

# First we create a new data set using the expand.grid function,
# then estimate the predicted values using the predict function, and finally plot them.

newdata <- expand.grid(age = 1:9, hmo = factor(0:1), died = factor(0:1)) # New Data
newdata$yhat <- predict(m1, newdata, type = "response") # Predict values with our m1 model

ggplot(newdata, aes(x = age, y = yhat, colour = hmo))  + # Plot the results
  geom_point() +
  geom_line() +
  facet_wrap(~ died)

## function to return predicted values
fpred <- function(data, i, newdata) {
  require(VGAM)
  m <- vglm(formula = stay ~ age + hmo + died, family = pospoisson(),
            data = data[i, ], coefstart = c(2.436, -0.014, -0.136, -0.204))
  predict(m, newdata, type = "response")
}

## set seed and run bootstrap with 1,200 draws
set.seed(10)
respred <- boot(dat, fpred, R = 1200, newdata = newdata,
                parallel = "snow", ncpus = 4)

## get the bootstrapped percentile CIs
yhat <- t(sapply(1:nrow(newdata), function(i) {
  out <- boot.ci(respred, index = i, type = c("perc"))
  with(out, c(Est = t0, pLL = percent[4], pUL = percent[5]))
}))

## merge CIs with predicted values
newdata <- cbind(newdata, yhat)
## graph with CIs
ggplot(newdata, aes(x = age, y = yhat, colour = hmo, fill = hmo))  +
  geom_ribbon(aes(ymin = pLL, ymax = pUL), alpha = .25) +
  geom_point() +
  geom_line() +
  facet_wrap(~ died)

# And voila!  A Poisson prediction model predicts how many deaths (count) to expect by age for HMO and non-HMO patients.


# Declaration of variables with raw data
rawData = c(7, 19, 9, 6, 0, 12, 10, 6, 0, 0)
femConditionRawData = c("With Lung Cancer", "Without Lung Cancer")
numOfCigsDailyRawData = c(1, 5, 15, 25, "50+")

# Creation of matrix
femSmokingRates <- matrix(rawData, ncol=5, nrow=2, byrow=TRUE)
rownames(femSmokingRates) <- femConditionRawData
colnames(femSmokingRates) <- numOfCigsDailyRawData

# Draw a barplot
barplot(femSmokingRates,
main = "Comparing female patients with and without lung cancer",
xlab = "Number of cigarettes daily",
ylab = "Number of patients",
col = c("red","blue")
)

legend('topright',
legend = femConditionRawData,
title = "Patient Condition",
fill = c("red","blue"),
)

#IMPORTANT!
# 2) Carry out a statistical test of the hypothesis that there is no difference in the frequency of smoking different numbers of cigarettes between female lung cancer and female control patients.
# NB think carefully about whether you want to use the data exactly as presented here or whether it makes sense to change the categories of numbers of cigarettes smoked for this analysis.
# COMPARING SMOKING RATES IN FEMALE PATIENTS. 1)
# SYNTHESIS


---
title: "matrix"
author: "lois"
date: "11/25/2021"
output: pdf_document
---

```{r}
x <- (1:4)
y <- (5:8)
q = rbind(x, y)
rownames <- x("a", "b", "c", "d")
colnames <- x("e", "f", "g", "h")
```
```{r}
x <- 1:20

length(x)

x<-seq(1,9, by = 2)

x <- 0:6
class(x)

as.numeric(x)
as.logical(x)
as.character(x)
```
```{r}
x <- matrix(nrow = 2, ncol = 3)
x
dim(x)
attributes(x)

m <- matrix(1:6,nrow=2, ncol=3)
m
m <- matrix(1:6,nrow=2, ncol=3, byrow = TRUE)
m

x <- c(1,2,3,4,5,6,7,8,9,10)
x

dim(x) <- c(2,5)
x
```

```{r}
x<-4:6
y<-1:3
cbind(x,y)

rbind(x,y)

m<-matrix(1:4, nrow=2, ncol=2)
colnames(m)<-c("a","b")
rownames(m)<-c("c","d")
m

```
```{r}
#Task 1
x<-(1:4)
y<-(5:8)

M<- cbind(x,y)
M
Q <-rbind(x,y)
Q

colnames(M)<-c("a","b")
rownames(M)<-c("c","d","e","f")
M

colnames(Q)<-c("a","b","c","d")
rownames(Q)<-c("e","f")
Q
```
```{r}
#List
m <- list(50, "b", TRUE, 1 + 4i)
m

x <- list(a = 1, b = "c", c = 3)
x
```
```{r}
#Factor
gender <- c("male","male","female","female","male","female","male")
gender

as.factor(gender)
class(gender)
is.na(gender)
is.nan(gender)
```
```{r}
#Data Frame
emp.data <- data.frame( emp_id = c (1:5),
emp_name = c("Rick","Dan","Michelle","Ryan","Gary"),
emp_gender = c("Male", "Male", "Female", "Male", "Male"),
emp_age = c(50, 40, 26, 38, 30),
salary = c(623.3,515.2,611.0,729.0,843.25))
subset(emp.data, emp_id==1)
emp.data[3,]
emp.data[which(emp.data$gender=="Female" & emp.data$age==26),]
subset(emp.data, emp_age>=40, select = c(emp_id, emp_gender, salary, emp_name))
```

```{r}
#Data Frame Two
natives <- data.frame(cohort = c(1:9),
cohort_name = c("one", "two", "three", "four", "five", "six", "seven", "eight", "nine"),
cohort_num_of_natives = c(30, 20, 40, 53, 27, 20, 22, 29, 39))
natives$cohort_name
```
```{r}
x<-5:7
names(x)
names(x)<-c("five","six","seven")
x
names(x)
```
```{r}
x<-c("a","b","c","d")
x[3]
x[x>"b"]

x<-matrix(1:6,2,3)
x[1,2]
x[1,]
x[,3]
```
```{r}
#Subsetting  matrix
x<-matrix(1:12,3,4)
x
x[2:3,2:4]
```
```{r}
#subsetting drop
x <- matrix(1:6, 2, 3)
x[1, 2]
x
x[1, 2, drop = FALSE]
```
```{r}
y <-matrix(1:12,4,4)
colnames(y)<- c("col_one", "col_two", "col_three", "col_four")
y
y[1,2]
y[3:4,1:3]

```

R Data Science Project/Intoduction to data science.r


getTable = function(data)

{

    histogram = hist(data, breaks = "Sturges", right = FALSE)

    intervalColumn = list()

    breaks = histogram$breaks
    frequencies = histogram$counts
    relativeFrequencies = round((frequencies/sum(frequencies)),3)
    relativeFrequenciesPercent = round(100*(frequencies/sum(frequencies)),3)

    for(i in 1:length(breaks)-1)

    {

        interval = paste(as.character(breaks[i]),"|-",as.character(breaks[i+1]))

        intervalColumn = append(intervalColumn,interval)

    }

    intervalColumn[1] = NULL

    df = data.frame("Intervals"=unlist(intervalColumn),"Absolute Frequency"=frequencies,
                "Relative Frequency"=relativeFrequencies,"Relative Frequency (%)"=relativeFrequenciesPercent)

    print(df)

}


# KOLEKTIVNI MODEL TVEGANJA IN PANJERJEV ALGORITEM
# Finančni praktikum 2020/21
# Mitja Mandić

library(actuar)
vzorec <- scan("vzorec4.txt")
hist(vzorec)
hist <- recordPlot()

parameter <- mde(vzorec, pweibull, measure = "CvM", start = list(shape = 10, scale = 10))
shape_ocena <- parameter$estimate[1]
scale_ocena <-parameter$estimate[2]

hist(vzorec, breaks = 20,probability = TRUE, ylab = "Gostota")
curve(dweibull(x,shape_ocena,scale_ocena), from=2,to=7, add=TRUE, col = "red")
graf_prva <- recordPlot()

#vzorčna in izračunana porazdelitvena funkcija

plot(ecdf(vzorec), col = "blue", main = "", ylab = " ")
curve(pweibull(x,shape_ocena,scale_ocena), add = TRUE)
title("Vzorčna in porazdelitvena funkcija")
vzorcna_in_porazdelitvena <- recordPlot()

#PORAZDELITEV VSOTE

pv.n <- 25 * 0.5
v.n <- 25 * 0.5 * 0.5

#paramteri weibullove

pv.w <- scale * gamma(1+1/shape)
v.w <- scale^2 * (gamma(1+2/shape)-(gamma(1+1/shape))^2)

e.s <- pv.n * pv.w
v.s <- v.w * pv.n + pv.w^2 * v.n

#DRUGA NALOGA

#druga a

dolzina <- 5
korak <- 1/10
diskretna <- discretize(pweibull(x, shape = shape_ocena , scale=scale_ocena), from = 0, to = 5,
                        step = korak)

#diskretna

#druga b

curve(pweibull(x, shape = shape, scale = scale), from = 0, to = dolzina, xname = "x",ylab = " ")
plot(stepfun(x = seq(0, dolzina - korak, korak),  y = diffinv(diskretna)),add = TRUE)
title("Diskretizacija Weibullove porazdelitve in CDF")

#druga c

panjer <- aggregateDist(method = "recursive", model.freq = "binomial",model.sev = diskretna, size = 25, prob = 0.5,
                      x.scale = korak, tol = 0.001, maxit = 100000)

#druga d
#disperzija in upanje kumulativne škode
skoki <- knots(panjer)

pricakovana_vrednost.panjer <- sum(knots(panjer) * diff(panjer))

pricakovana_vrednost_kvadrat.panjer <- sum(skoki ^ 2 * diff(panjer))

varianca.panjer <- pricakovana_vrednost_kvadrat.panjer - pricakovana_vrednost.panjer^2

#TRETJA NALOGA

#tretja a

#simulacija vsot
vzorec_bin <- rbinom(10000,25,0.5)
simulacije <- as.data.frame(vzorec_bin)
colnames(simulacije) <- "binomska"
simulacije['vsota'] <- 0

i = 1
for (i in 1:10000){
  simulacije[i,"vsota"] <- sum(rweibull(simulacije[i,1],shape_ocena,scale_ocena))
  #i = i + 1
}

#tretja b

simulirana_pv <- mean(simulacije[,"vsota"]) #simulirana vrednost: 29.651; waldov obrazec: 29.7
simulirana_var <- var(simulacije[,"vsota"]) #simulirana vrednost: 37.257; waldov obrazec: 37.3

#tretja c

"Simulirana porazdelitev in porazdelitev kumulativne škode"
plot(ecdf(simulacije[,'vsota']), main = "")
plot(panjer, sub = "", add = TRUE, col = "Blue")
title("Simulirana porazdelitev in porazdelitev kumulativne škode")


# Assignment 3

library(neuralnet)
library(gtools)
library(glue)
printf <- defmacro(str, expr = {print(glue(str))})

# Creating output variable
output = list()

# Part 1
set.seed(1234567890)
Var <- runif(500, 0, 10)
mydata <- data.frame(Var, Sin=sin(Var))
tr <- mydata[1:25,] # Training
te <- mydata[26:500,] # Test

# Random initialization of the weights in the interval [-1, 1]
winit <- runif(n = 10, min = -1, max = 1)
nn <- neuralnet(Sin ~ Var, data=tr, hidden = c(10), startweights=winit)
output$o3.1 = printf("start weights: {nn$startweights}")

plot(tr, cex=2)
points(te, col = "blue", cex=1)
points(te[,1],predict(nn,te), col="red", cex=1)
title("Prediction neural network 0 to 10")
legend("bottomleft",
       inset=.02,
       title="Datapoints",
       c("Training","Testing","Predicted"),
       col=c("black","blue","red"),
       lwd=1,
       lty=c(0,0),
       pch=c(1,1,1))

#part 2

h1 <- function(x) x
h2 <- function(x) ifelse(x > 0, x, 0)
h3 <- function(x) log(1 + exp(x))

nn.h1 = neuralnet(Sin ~ Var, data=tr, hidden = c(10), startweights = winit, act.fct = h1)
nn.h2 = neuralnet(Sin ~ Var, data=tr, hidden = c(10), startweights = winit, act.fct = h2)
nn.h3 = neuralnet(Sin ~ Var, data=tr, hidden = c(10), startweights = winit, act.fct = h3)

par(mfrow=c(2,2))
plot(te, col = "blue", cex=1)
points(te[,1],predict(nn.h1,te), col="red", cex=1)
title("Linear")
plot(te, col = "blue", cex=1)
points(te[,1],predict(nn.h2,te), col="red", cex=1)
title("ReLU")
plot(te, col = "blue", cex=1)
points(te[,1],predict(nn.h3,te), col="red", cex=1)
title("Softplus")
plot(NULL,xaxt='n',yaxt='n',bty='n',ylab='',xlab='', xlim=0:1, ylim=0:1)
legend("topleft",
       legend =c("Sample", "Predicted"),
       title="Datapoints",
       pch=1, pt.cex=2, cex=1,
       col = c("blue", "red"))
par(mfrow=c(1,1))

# part 3

Var2 <- runif(500, 0, 50)
mydata2 <- data.frame(Var=Var2, Sin=sin(Var2))

plot(mydata2[,1],predict(nn,mydata2),
     col="red", cex=1,
     xlab="Var", ylab="Sin")
points(mydata2, col = "blue", cex=1)
legend("bottomleft",
       y=-6,
       legend =c("Sample", "Predicted"),
       title="Datapoints",
       pch=1, pt.cex=2, cex=1,
       col = c("blue", "red"))

# part 4
predict(nn,mydata2)
plot(nn)

conv.prediction = predict(nn,data.frame(Var=1000))

conv.w.L1 = nn$weights[[1]][[1]][2,]
conv.mask <- 0 < c(1, conv.w.L1)
conv.w.L2 = nn$weights[[1]][[2]]

conv.calculation = sum(conv.mask * conv.w.L2)
output$o3.4 = printf("Convergence of nn
        Calculation : {conv.calculation}
        Prediction  : {conv.prediction}
        ")

# part 5

set.seed(1234567890)
Var3 <- runif(500, 0, 10)
mydata3 <- data.frame(Var=Var3, Sin=sin(Var3))

nn.SinPredictVar <- neuralnet(Var ~ Sin,
                              data=mydata3,
                              hidden = c(10),
                              startweights = winit,
                              threshold = 0.1)

plot(predict(nn.SinPredictVar,mydata3), mydata3[,2],
     col="red", cex=1,
     xlab = "Var", ylab = "Sin")
points(mydata3, col = "blue", cex=1)


# MLE function

library(COUNT)
library(stats4)
library(bbmle)
data(rwm1984)
attach(rwm1984)

### OPTIM() ###
LogLike1 <- function(par) {
  xb <- par[1] + par[2] * outwork + par[3] * age + par[4] * female + par[5] * married
  mu <- exp(xb)
  ll <- sum(log(exp(-mu) * (mu ^ docvis) / factorial(docvis)))
  return(-ll)
}
fit1 <- optim(rep(0, 5), LogLike1, hessian = TRUE, method = "BFGS")
std1 <- sqrt(diag(solve(fit1$hessian)))
est1 <- data.frame(beta = fit1$par, stder = stder1, z_values = fit1$par / stder1)

### MLE() ###
LogLike2 <- function(b0, b1, b2, b3, b4) {
  mu <- exp(b0 + b1 * outwork + b2 * age + b3 * female + b4 * married)
  -sum(log(exp(-mu) * (mu ^ docvis) / factorial(docvis)))
}
inits <- list(b0 = 0, b1 = 0, b2 = 0, b3 = 0, b4 = 0)
fit2 <- mle(LogLike2, method = "BFGS", start = inits)
std2 <- sqrt(diag(vcov(fit2)))
est2 <- data.frame(beta = coef(fit2), stder = std2, z_values = coef(fit2) / std2)

### BENCHMARKS ###
microbenchmark::microbenchmark(
  "optim" = {optim(rep(0, 5), LogLike1, hessian = TRUE, method = "BFGS")},
  "mle"   = {mle(LogLike2, method = "BFGS", start = inits)},
  "mle2"  = {mle2(LogLike2, method = "BFGS", start = inits)},
  times = 10
)


m35 = function(n) sum(unique(c(
    seq(3, n-1, by = 3), seq(5, n-1, by = 5))))
m35(1000)   # 233168


# Program to check if the input number is prime or not
# take input from the user
num = as.integer(readline(prompt="Enter a number: "))
flag = 0
# prime numbers are greater than 1
if(num > 1) {
# check for factors
flag = 1
for(i in 2:(num-1)) {
if ((num %% i) == 0) {
flag = 0
break
}
}
}
if(num == 2)    flag = 1
if(flag == 1) {
print(paste(num,"is a prime number"))
} else {
print(paste(num,"is not a prime number"))
}


# Goal: To do `moving window volatility' of returns.

library(zoo)

# Some data to play with (Nifty on all fridays for calendar 2004) --
p <- structure(c(1946.05, 1971.9, 1900.65, 1847.55, 1809.75, 1833.65, 1913.6, 1852.65, 1800.3, 1867.7, 1812.2, 1725.1, 1747.5, 1841.1, 1853.55, 1868.95, 1892.45, 1796.1, 1804.45, 1582.4, 1560.2, 1508.75, 1521.1, 1508.45, 1491.2, 1488.5, 1537.5, 1553.2, 1558.8, 1601.6, 1632.3, 1633.4, 1607.2, 1590.35, 1609, 1634.1, 1668.75, 1733.65, 1722.5, 1775.15, 1820.2, 1795, 1779.75, 1786.9, 1852.3, 1872.95, 1872.35, 1901.05, 1996.2, 1969, 2012.1, 2062.7, 2080.5), index = structure(c(12419, 12426, 12433, 12440, 12447, 12454, 12461, 12468, 12475, 12482, 12489, 12496, 12503, 12510, 12517, 12524, 12531, 12538, 12545, 12552, 12559, 12566, 12573, 12580, 12587, 12594, 12601, 12608, 12615, 12622, 12629, 12636, 12643, 12650, 12657, 12664, 12671, 12678, 12685, 12692, 12699, 12706, 12713, 12720, 12727, 12734, 12741, 12748, 12755, 12762, 12769, 12776, 12783), class = "Date"), frequency = 0.142857142857143, class = c("zooreg", "zoo"))

# Shift to returns --
r <- 100*diff(log(p))
head(r)
summary(r)
sd(r)

# Compute the moving window vol --
vol <- sqrt(250) * rollapply(r, 20, sd, align = "right")

# A pretty plot --
plot(vol, type="l", ylim=c(0,max(vol,na.rm=TRUE)),
     lwd=2, col="purple", xlab="2004",
     ylab=paste("Annualised sigma, 20-week window"))
grid()
legend(x="bottomleft", col=c("purple", "darkgreen"),
       lwd=c(2,2), bty="n", cex=0.8,
       legend=c("Annualised 20-week vol (left scale)", "Nifty (right scale)"))
par(new=TRUE)
plot(p, type="l", lwd=2, col="darkgreen",
     xaxt="n", yaxt="n", xlab="", ylab="")
axis(4)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/p4.r


rm(list=ls())

library('radolc')

#--- testing ADOLC's jacobian

fr <- function(x) {
  x1 <- x[[1]]
  x2 <- x[[2]]
  #Use create list to create adouble objects
  y<-adolc_createList(2,2.0)
  #y <- c(0.0,0.0)
  y[[1]] <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y[[2]] <- 100 * (x2 - x1 * x1)+ (x2 - x1 * x1) * (1 - x1)*(1 - x1)
  y[[3]] <- 100 * (x2 + x1 * x1)+ (x2 + x1 * x1) * (1 + x1)*(1 - x1)
  y}

trace_on(1)
x <- adolc_createList(2,2.0)
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

xx <- c(1.0,2.0)
vv <- c(3.0,5.5)
yy <- c(0.0,0.0,0)
jac_vec(1,3,2,xx,vv,yy);
# jac_vec(tag,m,n,x,v,z) #result z = F′(x)v
# tag: integer, tape identification
# m  : integer, number of dependents m
# n  : integer, number of independents n
# x[n]: independent vector x
# v[n]: vector
# z[m]: resulting Jacobian vector product

print(yy)

#Always detach the package
detach(package:radolc, unload=TRUE)


library(testthat)
library(sparsediscrim)

context("Generate multivariate normal variates with block-diagonal autocorrelation matrices")

test_that("Autocorrelation matrix is generated properly", {
  cov_matrix <- cov_autocorrelation(p=3, rho=0.9)
  cov_expected <- cbind(c(1, 0.9, 0.81), c(0.9, 1, 0.9), c(0.81, 0.9, 1))

  expect_equal(cov_matrix, cov_expected)
})

test_that("Block-diagonal covariance matrix with autocorrelated blocks is generated properly", {
  cov_matrix <- cov_block_autocorrelation(num_blocks=2, block_size=3, rho=0.9)

  autocorr_block <- cbind(c(1, 0.9, 0.81), c(0.9, 1, 0.9), c(0.81, 0.9, 1))
  zeros_matrix <- matrix(0, nrow=3, ncol=3)

  cov_expected1 <- cbind(autocorr_block, zeros_matrix)
  cov_expected2 <- cbind(zeros_matrix, autocorr_block)
  cov_expected <- rbind(cov_expected1, cov_expected2)

  expect_equal(cov_matrix, cov_expected, check.attributes=FALSE)
})

test_that("Generate MVN data set with block-diagonal autocorrelation matrices", {
  n <- c(10, 10, 10)
  means <- matrix(rep(1:3, each=6), ncol=3)
  cov_matrix <- cov_block_autocorrelation(num_blocks=2, block_size=3, rho=0.9)

  # Generated Data
  set.seed(42)
  data_gen <- generate_blockdiag(n=n, mu=means, num_blocks=2, block_size=3, rho=rep(0.9, 3))

  # Expected Data
  set.seed(42)
  x1 <- rmvnorm(n=n[1], mean=means[, 1], sigma=cov_matrix)
  x2 <- rmvnorm(n=n[2], mean=means[, 2], sigma=cov_matrix)
  x3 <- rmvnorm(n=n[3], mean=means[, 3], sigma=cov_matrix)
  x_expected <- rbind(x1, x2, x3)
  y_expected <- factor(rep(seq_along(n), n))

  expect_equal(data_gen$x, x_expected)
  expect_equal(data_gen$y, y_expected)
})


llr = function(k) {2 * sum(k) * (H(k) - H(rowSums(k)) - H(colSums(k)))}
H = function(k) {N = sum(k) ; return (sum(k/N * log(k/N + (k==0))))}

rootLLR = function(k) {sqrt(llr(k)) * ifelse(k[1,1] > (k[1,1] + k[1,2])/sum(k) * (k[1,1]+k[2,1]), 1, -1)}


model = "model
{
    # Prior for all the parameters
    beta0 ~ dnorm(0, pow(1E3, -2))
    beta1 ~ dnorm(0, pow(1E3, -2))
    log_sigma ~ dunif(-10, 10)
    sigma <- exp(log_sigma)

    # Likelihood
    for(i in 1:N)
    {
        y[i] ~ dnorm(beta0 + beta1*x[i], pow(sigma, -2))
    }

	y_new ~ dnorm(beta0 + beta1*90, pow(sigma, -2))
}
"

# Load data from file
data = source('data.txt')$value

# Variables to monitor
variable_names = c('beta0', 'beta1', 'sigma', 'y_new')

# How many burn-in steps?
burn_in = 10000

# How many proper steps?
steps = 5000

# Thinning?
thin = 10

# NO NEED TO EDIT PAST HERE!!!
# Just run it all and use the results list.

library('rjags')

# Write model out to file
fileConn=file("model.temp")
writeLines(model, fileConn)
close(fileConn)

if(all(is.na(data)))
{
	m = jags.model(file="model.temp", inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"))
} else
{
	m = jags.model(file="model.temp", data=data, inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"))
}
update(m, burn_in)
draw = jags.samples(m, steps, thin=thin, variable.names = variable_names)
# Convert to a list
make_list <- function(draw)
{
	results = list()
	for(name in names(draw))
	{
		# Extract "chain 1"
		results[[name]] = as.array(draw[[name]][,,1])

		# Transpose 2D arrays
		if(length(dim(results[[name]])) == 2)
			results[[name]] = t(results[[name]])
	}
	return(results)
}
results = make_list(draw)

# Save as a text file
chains = array(NA, dim=c(500, 3))
chains[,1] = draw$beta0
chains[,2] = draw$beta1
chains[,3] = draw$sigma
write.table(chains, 'chains.txt', row.names=FALSE, col.names=FALSE)
write.table(results$y_new, 'prediction.txt', row.names=FALSE, col.names=FALSE)


heights = c(178, 165, 168, 152, 175, 175, 165, 162, 164, 170, 169, 155, 153, 162, 168)
print("Heights data")
heights
print("Mean")
mean(heights)
print("Median")
median(heights)
print("Summary")
summary(heights)

sales<-c(15,20,25,10,30)
print(sales)

mean(sales)

median(sales)

summary(sales)

var(sales)

sd(sales)

age <- c(35,45,55,65,75)
bp <- c(114,124,143,158,166)
print(age)
print(bp)

plot(age, bp)

cor(age, bp)

variance <- sum((sales - mean(sales))^2)/length(sales)
print(variance)

s <- sqrt(variance)
print(s)

v <- sum((sales - mean(sales))^2)/(length(sales)-1)
print(v)

sv <- sqrt(v)
print(sv)

iris

hist(iris$Sepal.Length)

hist(iris$Sepal.Width)

hist(iris$Petal.Length)

hist(iris$Petal.Width)


# Master Thesis Project - Extreme Value Theory
# Getting the experimental data above the 95 %
# and fitting a GEV distribution to it

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

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("loadStockData_plain.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the five stocks then
# getting the LVMH and the Total data
df_plain <- loadStockData_plain(CHOICE)

# Getting the log-returns
data_bnp <- df_plain[[1]]
data_bnp <- diff(log(data_bnp))

data_carrefour <- df_plain[[2]]
data_carrefour <- diff(log(data_carrefour))

data_lvmh <- df_plain[[3]]
data_lvmh <- diff(log(data_lvmh))

data_sanofi <- df_plain[[4]]
data_sanofi <- diff(log(data_sanofi))

data_total <- df_plain[[5]]
data_total <- diff(log(data_total))

# Computing the 95 % - quantiles for each of the stocks
quantiles <- c(quantile(data_bnp,0.99), quantile(data_carrefour,0.995), quantile(data_lvmh,0.995),
					quantile(data_sanofi,0.995), quantile(data_total,0.995))

# Getting the data above the threshold
data_bnp <- data_bnp[data_bnp > quantiles[1]]
data_carrefour <- data_carrefour[data_carrefour > quantiles[2]]
data_lvmh <- data_lvmh[data_lvmh > quantiles[3]]
data_sanofi <- data_sanofi[data_sanofi > quantiles[4]]
data_total <- data_total[data_total > quantiles[5]]

# Plotting the above-threshold data
x_label <- ""
y_label <- "Stock price"
title1 <- "BNP Paribas log-returns"
title2 <- "Carrefour log-returns"
title3 <- "LVMH  log-returns"
title4 <- "Sanofi  log-returns"
title5 <- "Total  log-returns"
quartz()
png(file = "aboveThresholdData.png")
par(mfrow = c(3,2))
plot(data_bnp, pch = 1, col = "black", type = 'p', xlab = x_label, ylab = y_label, main = title1)
plot(data_carrefour, pch = 1, col = "blue", type = 'p', xlab = x_label, ylab = y_label, main = title2)
plot(data_lvmh, pch = 1, col = "green", type = 'p', xlab = x_label, ylab = y_label, main = title3)
plot(data_sanofi, pch = 1, col = "purple", type = 'p', xlab = x_label, ylab = y_label, main = title4)
plot(data_total, pch = 1, col = "red", type = 'p', xlab = x_label, ylab = y_label, main = title5)
dev.off()
graphics.off()

print("##################### BNP Paribas #####################")
quartz()
png(file = "gev.diag BNP Paribas")
gev.diag(gev.fit(data_bnp))
dev.off()
graphics.off()

print("##################### Carrefour #####################")
quartz()
png(file = "gev.diag Carrefour")
gev.diag(gev.fit(data_carrefour))
dev.off()
graphics.off()

print("##################### LVMH #####################")
quartz()
png(file = "gev.diag LVMH")
gev.diag(gev.fit(data_lvmh))
dev.off()
graphics.off()

print("##################### Sanofi #####################")
quartz()
png(file = "gev.diag Sanofi")
gev.diag(gev.fit(data_sanofi))
dev.off()
graphics.off()

print("##################### Total #####################")
quartz()
png(file = "gev.diag Total")
gev.diag(gev.fit(data_total))
dev.off()
graphics.off()

print("##################### LVMH 2 #####################")
data_lvmh <- diff(log(df_plain[[3]]))
data_lvmh <- data_lvmh[data_lvmh > quantile(data_lvmh,0.95)]

quartz()
png(file = "gev.diag LVMH2")
gev.diag(gev.fit(data_lvmh))
dev.off()
graphics.off()

print("##################### BNP 2 #####################")
data_bnp <- diff(log(df_plain[[1]]))
data_bnp <- data_bnp[data_bnp > quantile(data_bnp,0.99)]

quartz()
png(file = "gev.diag BNP2")
gev.diag(gev.fit(data_total))
dev.off()
graphics.off()

print("#################################################")
print("#################################################")
print("#################################################")
data_lvmh <- as.numeric((read.csv("daily_LVMH_table.csv", header = FALSE))[[3]])
quartz()
png(file = "LVMH_daily.png")
plot(1:length(data_lvmh), data_lvmh)
dev.off()
graphics.off()

lvmh_quant <- quantile(data_lvmh, 0.99)
data_lvmh <- data_lvmh[data_lvmh > lvmh_quant]
data_lvmh <- diff(log(data_lvmh))

quartz()
png(file = "LVMH_daily_99quant.png")
plot(1:length(data_lvmh), data_lvmh)
dev.off()
graphics.off()

quartz()
png(file = "gev.diag LVMH3")
gev.diag(gev.fit(data_lvmh))
dev.off()
graphics.off()


setwd("/home/vkg/IIT/CS422/lectures/clustering/")

library(cluster)
library(factoextra)

data("iris")

k <- kmeans(iris[1:4], centers=3, nstart=25) # The nstart paramater attemps to run
# multiple initial configurations and reports on the best one.  Here, it will
# run 25 configurations.

fviz_cluster(k, data=iris[1:4]) # If there are > 2 dimensions in the data,
# fviz_cluster() will run PCA on the dataset and plot the data points
# according to the first two PCs.

# What happens if we choose more clusters?
fviz_cluster(kmeans(iris[1:4], centers=4, nstart=25), data=iris[1:4])
# Is 4 enough?  Or 5?  Or 6?...
fviz_cluster(kmeans(iris[1:4], centers=5, nstart=25), data=iris[1:4])

# How many clusters?  A couple of means to visuzalize it.
fviz_nbclust(iris[1:4], kmeans, method="wss") # Elbow method minimizes total
# within-cluster sum of squares (wss).  Also called a "Scree" plot.

# Silhouette measures the quality of a cluster, i.e., how well each
# point lies within its cluster.
fviz_nbclust(iris[1:4], kmeans, method="silhouette") # But hey, what does it know?


#ex1

x=c(1, 8, 2, 6, 2, 8, 8, 5, 5, 5)
print(sum(x)/10)
log2(x)
max(x)-min(x)
y = (x - 5)/2.624669
print(y)
print(mean(y))
print(sd(y))

#ex2
factura = c(46, 33, 39, 37, 36, 30, 48, 32, 49, 35, 30, 48)
print(sum(factura))
print(min(factura))
print(max(factura))
nr_luni = length(factura[factura > 40])
print(nr_luni)
print(100 * nr_luni/length(factura))

#ex3
z<-scan()
print(min(z))
print(max(z))
print(mean(z))
print(median(z))
print(sd(z))
sort(z)
print(z)
norm = (z - mean(z))/sd(z)
print(norm)


 C02AFJ Example Program Results

 Example 1

 Degree of polynomial =    5

 Computed roots of polynomial

 z =  -2.4328E+01 -4.8555E+00*i
 z =   5.2487E+00 +2.2736E+01*i
 z =   1.4653E+01 -1.6569E+01*i
 z =  -6.9264E-03 -7.4434E-03*i
 z =   6.5264E-03 +7.4232E-03*i

 Example 2

 Degree of polynomial =    5

 Computed roots of polynomial     Error estimates
                                (machine-dependent)

 z =  -2.4328E+01 -4.8555E+00*i       5.7E-16
 z =   5.2487E+00 +2.2736E+01*i       1.5E-16
 z =   1.4653E+01 -1.6569E+01*i       4.8E-16
 z =  -6.9264E-03 -7.4434E-03*i       1.1E-16
 z =   6.5264E-03 +7.4232E-03*i       1.8E-16


#' Generate a vector of frequencies.
#'
#' @param N Number of elements in vector (must be even).
#' @param freq.max Value of largest frequency.
#'
#' @return Vector of frequencies.
#'
#' @examples
#' freq(10, freq.max = 5) # => c(-5, -4, -3, -2, -1, 1, 2, 3, 4, 5)
#'
#' @export
freq <- function(N, freq.max = 1/(2*pi)) {
    ## Input Validation ##

    if (N %% 2) {
        stop("'N' must be even")
    }

    ## Setup ##

    # Precompute N/2, which we know to be an integer.
    half.N <- N / 2
    # Increment between freq[i] and freq[i+1].
    freq.step <- freq.max / half.N

    ## Frequency Vectors ##

    # Obtain the positive frequencies by counting from the smallest
    # one to the maximum. Start counting from 'freq.step', which is
    # the increment between frequencies, as zero frequency is
    # undefined.
    freq.pos <- seq(from = freq.step,
                    to = freq.max,
                    length.out = half.N)
    # Obtain the negative frequencies by reversing the order on the
    # positive ones, and negating them.
    freq.neg <- -rev(freq.pos)
    # Concatenate the negative and positive frequencies to get the
    # full vector of frequencies.
    freq <- c(freq.neg, freq.pos)

    ## Return ##

    list(
      freq     = freq,
      freq.pos = freq.pos,
      freq.neg = freq.neg
    )
}


View(BikeData)
cor(BikeData$distance,BikeData$time)
#Error in cor(BikeData$distane, BikeData$time) : 'x' must be numeric
cor(BikeData$distance,BikeData$time)
plot(BikeData$distance,BikeData$time)
abline(lm(BikeData$time~BikeData$distance))
cor(BikeData$distance,BikeData$speed)
plot(BikeData$distance,BikeData$speed)
abline(lm(BikeData$speed~BikeData$distance))
cor(BikeData$time,BikeData$speed)
plot(BikeData$time,BikeData$speed)
abline(lm(BikeData$time~BikeData$speed))
k1=BikeData[,c(2,7:9)]
head(k1)
cor(k1)
abline(lm(y~x))

plot(BikeData$distance,BikeData$speed)
text(BikeData$distance~BikeData$speed,labels=BikeData$user_id,cex=0.4,offset=10)
plot(BikeData$distance,BikeData$speed)
text(BikeData$distance~BikeData$speed,labels=BikeData$user_id,cex=0.7,offset=10)
plot(BikeData$distance,BikeData$speed)
text(BikeData$distance~BikeData$speed,labels=BikeData$user_id,cex=0.9,offset=10)

result=corr(k1)

library(corrplot)

corrplot(result,method="circle",type="upper")
plot(BikeData$distance,BikeData$speed,col="red")
which(BikeData$speed==max(BikeData))
which(BikeData$speed==max(BikeData$speed))
s1=BikeData
s1=s1[-114,]
cor(BikeData$distance,BikeData$speed)
cor(s1$distance,s1$speed)
which(BikeData$speed==min(BikeData$speed))
table(BikeData$cyc_freq,BikeData$gender)

table(BikeData$cyc_freq)

table(BikeData$gender)

prop.table(table())

h

prop.table(h)

prop.table(h,1)


#ccc computes Lin's concordance correlation coefficient for the two vectors input
#returns a dataframe containing several parameters
#[1] ccc
#[2] mean-shift
#[3] var shift
#[4] pearson's correlation
ccc <- function(x,y)
  {
    #check vectors are same length
    if(length(x)!=length(y)) stop("Vectors must be same length")
    if(sum(c(x,y), na.rm=T)==0)
      {
        ccc <- 1
        u <- 0
        v <- 0
        p <- 1
      }
    else
      {
        m1 <- mean(x, na.rm=T)
        m2 <- mean(y, na.rm=T)
        v1 <- var(x, na.rm=T)
        v2 <- var(y, na.rm=T)
        sd1 <- sqrt(v1)
        sd2 <- sqrt(v2)

        u <- (m1-m2)/sqrt(sd1*sd2)
        v <- sd1/sd2
        Cb <- 1/((v+(1/v)+u^2)/2)

        p <- cor(x,y, use="complete.obs",method="pearson")

        B1 <- v*p
        B0 <- m1-(B1*m2)
        a <-(2*B1*v2)
        b <- v1+v2+(B0+(B1-1)*m2)^2
        ccc <- a/b
      }
    return(list(ccc=ccc, u=u, v=v, pearson=p))#, a=a, b=b, v1=v1, v2=v2, b0=B0, b1=B1, m2=m2))
  }


model_tavg <- function (tmin = 0.0,
         tmax = 0.0){
    #'- Name: Tavg -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Mean temperature  calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: It simulates the depth of snow cover and recalculate weather data
    #'- inputs:
    #'            * name: tmin
    #'                          ** description : current minimum air temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: tmax
    #'                          ** description : current maximum air temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'- outputs:
    #'            * name: tavg
    #'                          ** description : mean temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : degC
    #'                          ** uri :
    tavg <- (tmin + tmax) / 2
    return (list('tavg' = tavg))
}


<<<<<<< HEAD
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Neville Subproject: Using Random Forestes, Factor Analysis, and Logistic regression to Screen Variables for Imapcts on Public Health
## National Health and Nutrition Examination Survey: The R Project for Statistical Computing Script by DrewC!
# Detecting Prediabetes in those under 65

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code
library(skimr) # Library used for easy summary of data

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_nhanes = read.csv("_data/nhanes_1516_noRX_stage.csv") # Import dataset from _data folder

## Verify
dim(df_nhanes)

### Step 2: Prepare Data for Classificaiton

## Subset for outcome of interest
df_nhanes$outcome <- 0 # Add new outcome column and set value to 0
df_nhanes$outcome[df_nhanes$LBXGH >= 5.7 & df_nhanes$LBXGH < 6.4 ] <- 1 # Create new column based on conditions
df_nh = subset(df_nhanes, select = -c(SEQN, LBXGH, DIQ010))

## Resolve missing data
df_nev = df_nh[, -which(colSums(is.na(df_nh)) > 3646)] # Remove variables with high missing values
df_nev = subset(df_nev, select = -c(AUATYMTL, SLQ300, SLQ310, AUATYMTR)) # Remove variables with factor value types
df_nev = na.omit(df_nev) # Omit rows with NA from Data Frame
df_nev = df_nev[which(df_nev$RIDAGEYR < 65), ]

## Verify
dim(df_nev)
colnames(df_nev)

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_nev, outcome == 1) # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
df_fa = na.omit(df_fa)
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
cor_fa = cor(df_fa)
cor_fa[!is.finite(cor_fa)] <- 0
model_scree = fa.parallel(cor_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Scree Test Output to File
result = model_scree # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
write("Eigenvalues from Scree Test",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

## Idenitfy Loadings
factors = fa(r = cor_fa, nfactors = 10)
df_load = as.data.frame(unclass(factors$loadings))
df_ld = df_load[, which(apply(df_load, 2, max) > 0.5)] # Remove variables with high missing values
colnames(df_ld)

df_ld$factor1[df_ld$MR1 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor2[df_ld$MR2 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor3[df_ld$MR3 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor4[df_ld$MR4 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor5[df_ld$MR5 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor6[df_ld$MR6 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor7[df_ld$MR7 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor8[df_ld$MR8 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor9[df_ld$MR9 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor10[df_ld$MR10 > 0.5] <- 1 # Create new column based on conditions
df_ld = subset(df_ld, select = -c(MR1, MR2, MR3, MR4, MR5, MR6, MR7, MR8, MR9, MR10))

df_f1 = subset(df_ld, factor1 == 1) # Subset for outcome of interest
df_f1 = df_f1["factor1"]
df_f2 = subset(df_ld, factor2 == 1) # Subset for outcome of interest
df_f2 = df_f2["factor2"]
df_f3 = subset(df_ld, factor3 == 1) # Subset for outcome of
df_f3 = df_f3["factor3"]
df_f4 = subset(df_ld, factor4 == 1) # Subset for outcome of interest
df_f4 = df_f4["factor4"]
df_f5 = subset(df_ld, factor5 == 1) # Subset for outcome of interest
df_f5 = df_f5["factor5"]
df_f6 = subset(df_ld, factor6 == 1) # Subset for outcome of interest
df_f6 = df_f6["factor6"]
df_f7 = subset(df_ld, factor7 == 1) # Subset for outcome of interest
df_f7 = df_f7["factor7"]
df_f8 = subset(df_ld, factor8 == 1) # Subset for outcome of interest
df_f8 = df_f8["factor8"]
df_f9 = subset(df_ld, factor9 == 1) # Subset for outcome of interest
df_f9 = df_f9["factor9"]
df_f10 = subset(df_ld, factor10 == 1) # Subset for outcome of interest
df_f10 = df_f10["factor10"]

## Write Scree Test Output to File
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Factor Loadings",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(df_f1, file = file, append = TRUE) # write summary to file
capture.output(df_f2, file = file, append = TRUE) # write summary to file
capture.output(df_f3, file = file, append = TRUE) # write summary to file
capture.output(df_f4, file = file, append = TRUE) # write summary to file
capture.output(df_f5, file = file, append = TRUE) # write summary to file
capture.output(df_f6, file = file, append = TRUE) # write summary to file
capture.output(df_f7, file = file, append = TRUE) # write summary to file
capture.output(df_f8, file = file, append = TRUE) # write summary to file
capture.output(df_f9, file = file, append = TRUE) # write summary to file
capture.output(df_f10, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
df_rf = df_nev
forest = randomForest(formula = outcome ~ ., data = df_rf, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).

## Create Importance Variable Lists
df_rank = arrange(df_forest, desc(Gini)) # Descend by variable in data frame
df_rank = df_rank[which(df_rank$Gini > 0 & df_rank$MSE > 0), ]
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

### Summary Statistics of Model Variables
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Summary of Model Variables", file) # Insert title
write(" ", file) # Insert space below result
write("OHX19TC", file) # Insert space below title
capture.output(summary(df_nev$OHX19TC), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMDAVSAD", file) # Insert space below title
capture.output(summary(df_nev$BMDAVSAD), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INDFMMPI", file) # Insert space below title
capture.output(summary(df_nev$INDFMMPI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INQ080", file) # Insert space below title
capture.output(summary(df_nev$INQ080), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMXLEG", file) # Insert space below title
capture.output(summary(df_nev$BMXLEG), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXWBCSI", file) # Insert space below title
capture.output(summary(df_nev$LBXWBCSI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXRDW", file) # Insert space below title
capture.output(summary(df_nev$LBXRDW), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BPXDI3", file) # Insert space below title
capture.output(summary(df_nev$BPXDI3), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBDRFO", file) # Insert space below title
capture.output(summary(df_nev$LBDRFO), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 5: Liner Regression to Determine Direction of Impact

model_logistic <- glm(outcome~ OHX19TC + BMDAVSAD + INDFMMPI + INQ080 + BMXLEG + LBXWBCSI + LBXRDW + BPXDI3 + LBDRFO, data = df_nev)
summary(model_logistic)

## Write Model Output to File
result = summary(model_logistic) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write(" ", file) # Insert space below title
write("First Logistic Regression for Variable Direction",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Create Dichotomous Variables Based on 3rd Quartile

## Create New Variables
df_nh$V1 <- 0 # Add new outcome column and set value to 0
df_nh$V2 <- 0 # Add new outcome column and set value to 0
df_nh$V3 <- 0 # Add new outcome column and set value to 0
df_nh$V4 <- 0 # Add new outcome column and set value to 0
df_nh$V5 <- 0 # Add new outcome column and set value to 0
df_nh$V1[df_nh$OHX01TC == 4 | df_nh$OHX02TC == 4 | df_nh$OHX03TC == 4 | df_nh$OHX04TC == 4 | df_nh$OHX05TC == 4 | df_nh$OHX06TC == 4 | df_nh$OHX07TC == 4 | df_nh$OHX08TC == 4 | df_nh$OHX09TC == 4 | df_nh$OHX10TC == 4 | df_nh$OHX11TC == 4 | df_nh$OHX12TC == 4 | df_nh$OHX13TC == 4 | df_nh$OHX14TC == 4 | df_nh$OHX15TC == 4 | df_nh$OHX16TC == 4 | df_nh$OHX17TC == 4 | df_nh$OHX18TC == 4 | df_nh$OHX19TC == 4 | df_nh$OHX20TC == 4 | df_nh$OHX21TC == 4 | df_nh$OHX22TC == 4 | df_nh$OHX23TC == 4 | df_nh$OHX24TC == 4 | df_nh$OHX25TC == 4 | df_nh$OHX26TC == 4 | df_nh$OHX27TC == 4 | df_nh$OHX28TC == 4 | df_nh$OHX29TC == 4 | df_nh$OHX30TC == 4 | df_nh$OHX31TC == 4 | df_nh$OHX32TC == 4] <- 1 # Create new column based on conditions
df_nh$V2[df_nh$BMDAVSAD > 25.1] <- 1 # Create new column based on conditions
df_nh$V3[df_nh$INDFMMPI > 5] <- 1 # Create new column based on conditions
df_nh$V4[df_nh$INQ080 == 1] <- 1 # Create new column based on conditions
df_nh$V5[df_nh$BMXLEG < 41.58] <- 1 # Create new column based on conditions

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, V1, V2, V3, V4, V5)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

### Step 6: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_lon), size = floor(.50*nrow(df_lon)), replace = F) # Create training and testing dataset with 50% split
train = df_lon[sample, ] # Susbset data frame by sample
test = df_lon[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome~ V1 + V2 + V3 + V4 + V5, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_logistic)) # Save result df to variable
result2 = print(summary(model_back)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Training Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Stepwise Backwards Selection", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 7: Create Score and Verify

# Create new column based on conditions
test$score <- 0 # Add new outcome column and set value to 0
test$score = (20*test$V2) + (15*test$V4) + (10*test$V5)

## Final Model and AUC Score
model_score = glm(outcome~ score, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_score$y, model_score$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Risk Score Validation", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

=======
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Neville Subproject: Using Random Forestes, Factor Analysis, and Logistic regression to Screen Variables for Imapcts on Public Health
## National Health and Nutrition Examination Survey: The R Project for Statistical Computing Script by DrewC!
# Detecting Prediabetes in those under 65

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code
library(skimr) # Library used for easy summary of data

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_nhanes = read.csv("_data/nhanes_1516_noRX_stage.csv") # Import dataset from _data folder

## Verify
dim(df_nhanes)

### Step 2: Prepare Data for Classificaiton

## Subset for outcome of interest
df_nhanes$outcome <- 0 # Add new outcome column and set value to 0
df_nhanes$outcome[df_nhanes$LBXGH >= 5.7 & df_nhanes$LBXGH < 6.4 ] <- 1 # Create new column based on conditions
df_nh = subset(df_nhanes, select = -c(SEQN, LBXGH, DIQ010))

## Resolve missing data
df_nev = df_nh[, -which(colSums(is.na(df_nh)) > 3646)] # Remove variables with high missing values
df_nev = subset(df_nev, select = -c(AUATYMTL, SLQ300, SLQ310, AUATYMTR)) # Remove variables with factor value types
df_nev = na.omit(df_nev) # Omit rows with NA from Data Frame
df_nev = df_nev[which(df_nev$RIDAGEYR < 65), ]

## Verify
dim(df_nev)
colnames(df_nev)

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_nev, outcome == 1) # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
df_fa = na.omit(df_fa)
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
cor_fa = cor(df_fa)
cor_fa[!is.finite(cor_fa)] <- 0
model_scree = fa.parallel(cor_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Scree Test Output to File
result = model_scree # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
write("Eigenvalues from Scree Test",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

## Idenitfy Loadings
factors = fa(r = cor_fa, nfactors = 10)
df_load = as.data.frame(unclass(factors$loadings))
df_ld = df_load[, which(apply(df_load, 2, max) > 0.5)] # Remove variables with high missing values
colnames(df_ld)

df_ld$factor1[df_ld$MR1 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor2[df_ld$MR2 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor3[df_ld$MR3 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor4[df_ld$MR4 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor5[df_ld$MR5 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor6[df_ld$MR6 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor7[df_ld$MR7 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor8[df_ld$MR8 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor9[df_ld$MR9 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor10[df_ld$MR10 > 0.5] <- 1 # Create new column based on conditions
df_ld = subset(df_ld, select = -c(MR1, MR2, MR3, MR4, MR5, MR6, MR7, MR8, MR9, MR10))

df_f1 = subset(df_ld, factor1 == 1) # Subset for outcome of interest
df_f1 = df_f1["factor1"]
df_f2 = subset(df_ld, factor2 == 1) # Subset for outcome of interest
df_f2 = df_f2["factor2"]
df_f3 = subset(df_ld, factor3 == 1) # Subset for outcome of
df_f3 = df_f3["factor3"]
df_f4 = subset(df_ld, factor4 == 1) # Subset for outcome of interest
df_f4 = df_f4["factor4"]
df_f5 = subset(df_ld, factor5 == 1) # Subset for outcome of interest
df_f5 = df_f5["factor5"]
df_f6 = subset(df_ld, factor6 == 1) # Subset for outcome of interest
df_f6 = df_f6["factor6"]
df_f7 = subset(df_ld, factor7 == 1) # Subset for outcome of interest
df_f7 = df_f7["factor7"]
df_f8 = subset(df_ld, factor8 == 1) # Subset for outcome of interest
df_f8 = df_f8["factor8"]
df_f9 = subset(df_ld, factor9 == 1) # Subset for outcome of interest
df_f9 = df_f9["factor9"]
df_f10 = subset(df_ld, factor10 == 1) # Subset for outcome of interest
df_f10 = df_f10["factor10"]

## Write Scree Test Output to File
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Factor Loadings",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(df_f1, file = file, append = TRUE) # write summary to file
capture.output(df_f2, file = file, append = TRUE) # write summary to file
capture.output(df_f3, file = file, append = TRUE) # write summary to file
capture.output(df_f4, file = file, append = TRUE) # write summary to file
capture.output(df_f5, file = file, append = TRUE) # write summary to file
capture.output(df_f6, file = file, append = TRUE) # write summary to file
capture.output(df_f7, file = file, append = TRUE) # write summary to file
capture.output(df_f8, file = file, append = TRUE) # write summary to file
capture.output(df_f9, file = file, append = TRUE) # write summary to file
capture.output(df_f10, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
df_rf = df_nev
forest = randomForest(formula = outcome ~ ., data = df_rf, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).

## Create Importance Variable Lists
df_rank = arrange(df_forest, desc(Gini)) # Descend by variable in data frame
df_rank = df_rank[which(df_rank$Gini > 0 & df_rank$MSE > 0), ]
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

### Summary Statistics of Model Variables
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Summary of Model Variables", file) # Insert title
write(" ", file) # Insert space below result
write("OHX19TC", file) # Insert space below title
capture.output(summary(df_nev$OHX19TC), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMDAVSAD", file) # Insert space below title
capture.output(summary(df_nev$BMDAVSAD), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INDFMMPI", file) # Insert space below title
capture.output(summary(df_nev$INDFMMPI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INQ080", file) # Insert space below title
capture.output(summary(df_nev$INQ080), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMXLEG", file) # Insert space below title
capture.output(summary(df_nev$BMXLEG), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXWBCSI", file) # Insert space below title
capture.output(summary(df_nev$LBXWBCSI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXRDW", file) # Insert space below title
capture.output(summary(df_nev$LBXRDW), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BPXDI3", file) # Insert space below title
capture.output(summary(df_nev$BPXDI3), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBDRFO", file) # Insert space below title
capture.output(summary(df_nev$LBDRFO), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 5: Liner Regression to Determine Direction of Impact

model_logistic <- glm(outcome~ OHX19TC + BMDAVSAD + INDFMMPI + INQ080 + BMXLEG + LBXWBCSI + LBXRDW + BPXDI3 + LBDRFO, data = df_nev)
summary(model_logistic)

## Write Model Output to File
result = summary(model_logistic) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write(" ", file) # Insert space below title
write("First Logistic Regression for Variable Direction",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Create Dichotomous Variables Based on 3rd Quartile

## Create New Variables
df_nh$V1 <- 0 # Add new outcome column and set value to 0
df_nh$V2 <- 0 # Add new outcome column and set value to 0
df_nh$V3 <- 0 # Add new outcome column and set value to 0
df_nh$V4 <- 0 # Add new outcome column and set value to 0
df_nh$V5 <- 0 # Add new outcome column and set value to 0
df_nh$V1[df_nh$OHX01TC == 4 | df_nh$OHX02TC == 4 | df_nh$OHX03TC == 4 | df_nh$OHX04TC == 4 | df_nh$OHX05TC == 4 | df_nh$OHX06TC == 4 | df_nh$OHX07TC == 4 | df_nh$OHX08TC == 4 | df_nh$OHX09TC == 4 | df_nh$OHX10TC == 4 | df_nh$OHX11TC == 4 | df_nh$OHX12TC == 4 | df_nh$OHX13TC == 4 | df_nh$OHX14TC == 4 | df_nh$OHX15TC == 4 | df_nh$OHX16TC == 4 | df_nh$OHX17TC == 4 | df_nh$OHX18TC == 4 | df_nh$OHX19TC == 4 | df_nh$OHX20TC == 4 | df_nh$OHX21TC == 4 | df_nh$OHX22TC == 4 | df_nh$OHX23TC == 4 | df_nh$OHX24TC == 4 | df_nh$OHX25TC == 4 | df_nh$OHX26TC == 4 | df_nh$OHX27TC == 4 | df_nh$OHX28TC == 4 | df_nh$OHX29TC == 4 | df_nh$OHX30TC == 4 | df_nh$OHX31TC == 4 | df_nh$OHX32TC == 4] <- 1 # Create new column based on conditions
df_nh$V2[df_nh$BMDAVSAD > 25.1] <- 1 # Create new column based on conditions
df_nh$V3[df_nh$INDFMMPI > 5] <- 1 # Create new column based on conditions
df_nh$V4[df_nh$INQ080 == 1] <- 1 # Create new column based on conditions
df_nh$V5[df_nh$BMXLEG < 41.58] <- 1 # Create new column based on conditions

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, V1, V2, V3, V4, V5)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

### Step 6: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_lon), size = floor(.50*nrow(df_lon)), replace = F) # Create training and testing dataset with 50% split
train = df_lon[sample, ] # Susbset data frame by sample
test = df_lon[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome~ V1 + V2 + V3 + V4 + V5, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_logistic)) # Save result df to variable
result2 = print(summary(model_back)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Training Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Stepwise Backwards Selection", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 7: Create Score and Verify

# Create new column based on conditions
test$score <- 0 # Add new outcome column and set value to 0
test$score = (20*test$V2) + (15*test$V4) + (10*test$V5)

## Final Model and AUC Score
model_score = glm(outcome~ score, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_score$y, model_score$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Risk Score Validation", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

>>>>>>> 321eaea894d29a3f212ee3e111b86695f46cf6db


#' @title pvalue.rsquare
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
	pvalue.rsquare = function( M ) {
		# R^2 = SSDmodel/(SSDmodel+SSDres)
		# F = DFres/DFmodel*SSDmodel/SSDres
	  # 1/R^2 = 1 + 1/F*DFmodel/DFres
		# or,
		# F = 1/(1/R^2 - 1)*DFres/DFmodel = R^2/(1-R^2)*DFres/DFmodel
			#
		# Actually, R^2 itself has a beta distribution and you could use pbeta
		# directly, but then you'd need to figure out (or recall) what the
		# relation between the DF and the shape parameters of the beta
		# distribution are. By my reckoning, this should do it:
		# pbeta(Rsq, 1/2, (N-2)/2, lower.tail=FALSE)
		#
		# Residual standard error: 1.143 on 8 degrees of freedom
		# Multiple R-Squared: 0.0004207, Adjusted R-squared: -0.1245
		# F-statistic: 0.003367 on 1 and 8 DF, p-value: 0.9552
		# pbeta(0.0004207, 1/2, 8/2, lower=F)
		# >[1] 0.9551511

		dfres = df.residual(M)
		dfmod = sum( df.terms(M))
		rsq = summary(M)$r.squared
		Fval = 1/(1/ rsq - 1)*dfres/dfmod

		out = list(
			rsquare=rsq,
			dfmod = dfmod,
			dfres = dfres,
			Fval = Fval,
			pvalF = pf(Fval, sum( df.terms(M)) , df.residual(M), lower.tail=FALSE),
			pvalB = pbeta( rsq, dfmod/2, dfres/2,  lower.tail=FALSE )
		)
		return (out)

	}


#!/usr/bin/R -q -f
#
# R script to calculate cosine distance
#
# Objective: To calculate the friend relationship distance using Cosine Distance
#
# Input : 'qw476-ranking-data.txt'
#         it is a CSV format file that contains the X and Y values for a list of names
#
# Output: STDOUT, with an add-on column for the cosine distance between friends
#

# We use dplyr package to filter and clean the data
library(dplyr)

# Load the CSV data(qw476-ranking-data.txt) into a data frame
data <- read.csv('qw476-ranking-data.txt', header = FALSE, col.names = c('Friend', 'x', 'y'))

# Verify the loaded data
str(data)
head(data)
tail(data)

# JOIN the data frame
merge(data, data, by = NULL) %>%

# Remove the lines with same Known and Unknown friend name
filter(Friend.x != Friend.y) %>%

# Change column names to a more user-friendly and recognizable ones
select(Known = Friend.x, Unknown = Friend.y, x1 = x.x, y1 = y.x, x2 = x.y, y2 = y.y) %>%

# Calculate cosine distance and add a column for it
mutate(cosine = round((x1*x2 + y1*y2)/(sqrt(x1^2 * y1^2)*sqrt(x2^2 * y2^2)),2)) %>%

# Sort by Known friend name and display the data frame
arrange(Known)


DS <-function(train_X,train_Y){
  n_row <- nrow(train_X)
  Region <- function(s_rm,s_lstat){
    # Variables for finding our RSS for lstat and rm
    sum_lessthan_rm <-0
    sum_grtrthan_rm <-0
    sum_lessthan_lstat <-0
    sum_grtrthan_lstat <-0

    n_lessthan_rm <-0
    n_grtrthan_rm <-0
    n_lessthan_lstat <-0
    n_grtrthan_lstat <-0

    mean_Y_lessthan_rm <-0
    mean_Y_grtrthan_rm <-0
    mean_Y_lessthan_lstat <-0
    mean_Y_grtrthan_lstat <-0

    sum_grtrthan_sqr_rm <-0
    sum_lessthan_sqr_rm <-0
    sum_grtrthan_sqr_lstat <-0
    sum_lessthan_sqr_lstat <-0

    # Getting Regions for all S
    for(i in 1:n_row){
      if(train_X$rm[i] < s_rm){
        sum_lessthan_rm = sum_lessthan_rm + train_Y[i]
        n_lessthan_rm = n_lessthan_rm + 1
      }
      else{
        sum_grtrthan_rm = sum_grtrthan_rm + train_Y[i]
        n_grtrthan_rm = n_grtrthan_rm + 1
      }
      if(train_X$lstat[i] < s_lstat){
        sum_lessthan_lstat = sum_lessthan_lstat + train_Y[i]
        n_lessthan_lstat = n_lessthan_lstat + 1
      }
      else{
        sum_grtrthan_lstat = sum_grtrthan_lstat + train_Y[i]
        n_grtrthan_lstat = n_grtrthan_lstat + 1
      }
    }
    mean_Y_lessthan_rm = sum_lessthan_rm/n_lessthan_rm
    mean_Y_grtrthan_rm = sum_grtrthan_rm/n_grtrthan_rm
    mean_Y_lessthan_lstat = sum_lessthan_rm/n_lessthan_lstat
    mean_Y_grtrthan_lstat = sum_grtrthan_rm/n_grtrthan_lstat

    for(i in 1:n_row){
      if(train_X$rm[i] <s_rm){
        sum_lessthan_sqr_rm <- sum_lessthan_sqr_rm + (train_Y[i] - mean_Y_lessthan_rm)^2
      }
      else{
        sum_grtrthan_sqr_rm <- sum_grtrthan_sqr_rm + (train_Y[i] - mean_Y_grtrthan_rm)^2
      }
      if(train_X$lstat[i] <s_lstat){
        sum_lessthan_sqr_lstat <- sum_lessthan_sqr_lstat + (train_Y[i] - mean_Y_lessthan_lstat)^2
      }
      else{
        sum_grtrthan_sqr_lstat <- sum_grtrthan_sqr_lstat + (train_Y[i] - mean_Y_grtrthan_lstat)^2
      }
    }
    RSS_lstat <- sum_grtrthan_sqr_lstat+sum_lessthan_sqr_lstat
    RSS_rm <- sum_grtrthan_sqr_rm+sum_lessthan_sqr_rm
    return(c(RSS_lstat,RSS_rm))
  }

  Rss_arr_rm <- matrix(nrow = n_row,ncol=1,byrow= TRUE)
  Rss_arr_lstat <- matrix(nrow = n_row,ncol=1,byrow= TRUE)
  for(i in 1:n_row){
    srm <- train_X$rm[i]
    slstat <- train_X$lstat[i]
    output <- Region(srm,slstat)
    #print(output)
    Rss_arr_rm[i] <- output[1]
    Rss_arr_lstat[i] <- output[2]
  }
  returnArray = c()
  sumlessthan <- numlessthan <-numgreaterthan<-sumgreaterthan<-meanYlessthan<-meanYgreatethan <- 0
  if(min(Rss_arr_lstat[1,]) > min(Rss_arr_rm[1,])){
    s_id = which.min(Rss_arr_rm)
    S <- train_X$rm[s_id]
    #caclulating regions R
    for(i in 1:n_row){
      #computing in each possible s
      if (train_X$rm[i] < S)
      {
        sumlessthan = sumlessthan+ train_Y[i]
        numlessthan =numlessthan+1
      }
      else{
        sumgreaterthan = sumgreaterthan+ train_Y[i]
        numgreaterthan = numgreaterthan+1
      }

    }
    meanYlessthan <- sumlessthan/numlessthan
    meanYgreatethan <- sumgreaterthan/numgreaterthan
    returnArray =c("rm",S,meanYlessthan,meanYgreatethan)
    return(returnArray)
  }
  else{
    sIndex =which.min(Rss_arr_lstat)
    S<- train_X$lstat[sIndex]
    #caclulating regions R
    for(i in 1:253){
      #computing in each possible s
      if (train_X$lstat[i] < S)
      {
        sumlessthan = sumlessthan+ train_Y[i]
        numlessthan =numlessthan+1
      }
      if(train_X$lstat[i] >S){
        sumgreaterthan = sumgreaterthan+ train_Y[i]
        numgreaterthan = numgreaterthan+1
      }

    }
    meanYlessthan <- sumlessthan/numlessthan
    meanYgreatethan <- sumgreaterthan/numgreaterthan
    returnArray= c("lstat",S,meanYlessthan,meanYgreatethan)
    return(returnArray)

  }
}

library(MASS)
data("Boston")
set.seed(0911)
n_row = nrow(Boston)
dt <- sample(1:n_row,n_row/2)
train <- Boston[dt,]
test <- Boston[-dt,]
train_Y <- train$medv;

dec_stmp = DS(train,train_Y)
y_hat = matrix(nrow=1, ncol=nrow(test))

test_sum_less_sqr <-0
test_sum_grtr_sqr <-0
if(dec_stmp[1]=="lstat"){
  for(i in 1:nrow(test)){
    if(test$lstat[i] <as.numeric(dec_stmp[2])){
      y_hat[i]=as.numeric(dec_stmp[3])
      test_sum_less_sqr = test_sum_less_sqr + (test$medv[i] - as.numeric(dec_stmp[3]))^2
    }
    else{
      y_hat[i]=as.numeric(dec_stmp[4])
      test_sum_grtr_sqr = test_sum_grtr_sqr + (test$medv[i] - as.numeric(dec_stmp[4]))^2
    }
  }
}
if(dec_stmp[1]=="rm"){
  for(i in 1:nrow(test)){
    if(test$rm[i] <as.numeric(dec_stmp[2])){
      y_hat[i]=as.numeric(dec_stmp[3])
      test_sum_less_sqr = test_sum_less_sqr + (test$medv[i] - as.numeric(dec_stmp[3]))^2
    }
    else{
      y_hat[i]=as.numeric(dec_stmp[4])
      test_sum_grtr_sqr = test_sum_grtr_sqr + (test$medv[i] - as.numeric(dec_stmp[4]))^2
    }
  }
}

test_mse <- (test_sum_grtr_sqr + test_sum_less_sqr)/nrow(test)
print(test_mse)

BDS <- function(B){
  DS_B<-matrix(nrow=B,ncol=4,byrow=TRUE)
  f_hat<-matrix(nrow=B,ncol=nrow(train),byrow=TRUE)
  for(i in 1:B){
    DS_B[i,]<-DS(train,train_Y)
    for(j in 1:nrow(train)){
      if(DS_B[i,1]=="lstat"){
        lstat_S <-as.numeric(DS_B[i,2])
        lstat_avg_less <-as.numeric(DS_B[i,3])
        lstat_avg_grtr <- as.numeric(DS_B[i,4])
        if(train$lstat[j] < lstat_S){
          f_hat[i,j] <- lstat_avg_less

        }else{
          f_hat[i,j] <- lstat_avg_grtr
        }

      }
      else if(DS_B[i,1]=="rm"){
        rm_S <- as.numeric(DS_B[i,2])
        rm_avg_less <-as.numeric(DS_B[i,3])
        rm_avg_grtr <- as.numeric(DS_B[i,4])
        if(train$rm[j] < rm_S){
          f_hat[i,j] <- rm_avg_less

        }else{
          f_hat[i,j] <- rm_avg_grtr
        }

      }
      ###
      train_Y[j] <- train_Y[j]-0.01*f_hat[i,j]

    }
  }
  #MSE
  sqrDiff <- 0
  for(i in 1:nrow(test)){
    predictionRule = sum(0.01*f_hat[,i])
    #print(phat[,i])
    sqrDiff <- sqrDiff+(test$medv[i]- (predictionRule))^2
  }
  print(c("test MSE:" ,sqrDiff/(nrow(test))))
  return(sqrDiff/(nrow(test)))
}

bds_1000=BDS(1000)


# Simple linear regression for machine learning.
#
# This file demonstrate knowledge of linear regression. By using
# conventional libraries.The idea of linear regression is to take continuous
# data and find the best fit of it to a line.
#
# Simple linear regression just refers to the fact that the features only
# includes one column. So the label is composed by just one variable and one
# constant.

# Importing the data set
dataset = read.csv('Salary_Data.csv')

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
set.seed(123) # choose random number, only same number for debugging
split = sample.split(dataset$Salary, SplitRatio = 2/3)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Fitting the Training set with Simple Linear regression model.
# Salary is propotional to YearsExperience and model built on training_set
regressor = lm(formula = Salary ~ YearsExperience, data = training_set)

# Predicting the Test set results
label_pred = predict(regressor, newdata = test_set)

# Visualising the regression line and training set
# install.packages("ggplot2")
# library(ggplot2)
ggplot() +
  geom_point(aes(x=training_set$YearsExperience, y=training_set$Salary),
             colour = 'red') +
  geom_line(aes(x=training_set$YearsExperience, y=predict(regressor, newdata = training_set)),
            colour = 'blue') +
  ggtitle('Experience vs Salary (Training set)') +
  xlab('Years of experience') +
  ylab('Salary')

# Visualising the regression line and test set
ggplot() +
  geom_point(aes(x=test_set$YearsExperience, y=test_set$Salary),
             colour = 'red') +
  geom_line(aes(x=training_set$YearsExperience, y=predict(regressor, newdata = test_set)),
            colour = 'blue') +
  ggtitle('Experience vs Salary (test set)') +
  xlab('Years of experience') +
  ylab('Salary')


# Chapter 6 Lab 1: Subset Selection Methods

# This code is quoted from
# http://faculty.marshall.usc.edu/gareth-james/ISL/code.html

# Best Subset Selection

library(ISLR)
fix(Hitters)
names(Hitters)
dim(Hitters)
sum(is.na(Hitters$Salary))
Hitters=na.omit(Hitters)
dim(Hitters)
sum(is.na(Hitters))
library(leaps)
regfit.full=regsubsets(Salary~.,Hitters)
summary(regfit.full)
regfit.full=regsubsets(Salary~.,data=Hitters,nvmax=19)
reg.summary=summary(regfit.full)
names(reg.summary)
reg.summary$rsq
par(mfrow=c(2,2))
plot(reg.summary$rss,xlab="Number of Variables",ylab="RSS",type="l")
plot(reg.summary$adjr2,xlab="Number of Variables",ylab="Adjusted RSq",type="l")
which.max(reg.summary$adjr2)
points(11,reg.summary$adjr2[11], col="red",cex=2,pch=20)
plot(reg.summary$cp,xlab="Number of Variables",ylab="Cp",type='l')
which.min(reg.summary$cp)
points(10,reg.summary$cp[10],col="red",cex=2,pch=20)
which.min(reg.summary$bic)
plot(reg.summary$bic,xlab="Number of Variables",ylab="BIC",type='l')
points(6,reg.summary$bic[6],col="red",cex=2,pch=20)
plot(regfit.full,scale="r2")
plot(regfit.full,scale="adjr2")
plot(regfit.full,scale="Cp")
plot(regfit.full,scale="bic")
coef(regfit.full,6)

# Forward and Backward Stepwise Selection

regfit.fwd=regsubsets(Salary~.,data=Hitters,nvmax=19,method="forward")
summary(regfit.fwd)
regfit.bwd=regsubsets(Salary~.,data=Hitters,nvmax=19,method="backward")
summary(regfit.bwd)
coef(regfit.full,7)
coef(regfit.fwd,7)
coef(regfit.bwd,7)

# Choosing Among Models

set.seed(1)
train=sample(c(TRUE,FALSE), nrow(Hitters),rep=TRUE)
test=(!train)
regfit.best=regsubsets(Salary~.,data=Hitters[train,],nvmax=19)
test.mat=model.matrix(Salary~.,data=Hitters[test,])
val.errors=rep(NA,19)
for(i in 1:19){
   coefi=coef(regfit.best,id=i)
   pred=test.mat[,names(coefi)]%*%coefi
   val.errors[i]=mean((Hitters$Salary[test]-pred)^2)
}
val.errors
which.min(val.errors)
coef(regfit.best,10)
predict.regsubsets=function(object,newdata,id,...){
  form=as.formula(object$call[[2]])
  mat=model.matrix(form,newdata)
  coefi=coef(object,id=id)
  xvars=names(coefi)
  mat[,xvars]%*%coefi
  }
regfit.best=regsubsets(Salary~.,data=Hitters,nvmax=19)
coef(regfit.best,10)
k=10
set.seed(1)
folds=sample(1:k,nrow(Hitters),replace=TRUE)
cv.errors=matrix(NA,k,19, dimnames=list(NULL, paste(1:19)))
for(j in 1:k){
  best.fit=regsubsets(Salary~.,data=Hitters[folds!=j,],nvmax=19)
  for(i in 1:19){
    pred=predict(best.fit,Hitters[folds==j,],id=i)
    cv.errors[j,i]=mean( (Hitters$Salary[folds==j]-pred)^2)
    }
  }
mean.cv.errors=apply(cv.errors,2,mean)
mean.cv.errors
par(mfrow=c(1,1))
plot(mean.cv.errors,type='b')
reg.best=regsubsets(Salary~.,data=Hitters, nvmax=19)
coef(reg.best,11)

# Chapter 6 Lab 2: Ridge Regression and the Lasso

x=model.matrix(Salary~.,Hitters)[,-1]
y=Hitters$Salary

# Ridge Regression

library(glmnet)
grid=10^seq(10,-2,length=100)
ridge.mod=glmnet(x,y,alpha=0,lambda=grid)
dim(coef(ridge.mod))
ridge.mod$lambda[50]
coef(ridge.mod)[,50]
sqrt(sum(coef(ridge.mod)[-1,50]^2))
ridge.mod$lambda[60]
coef(ridge.mod)[,60]
sqrt(sum(coef(ridge.mod)[-1,60]^2))
predict(ridge.mod,s=50,type="coefficients")[1:20,]
set.seed(1)
train=sample(1:nrow(x), nrow(x)/2)
test=(-train)
y.test=y[test]
ridge.mod=glmnet(x[train,],y[train],alpha=0,lambda=grid, thresh=1e-12)
ridge.pred=predict(ridge.mod,s=4,newx=x[test,])
mean((ridge.pred-y.test)^2)
mean((mean(y[train])-y.test)^2)
ridge.pred=predict(ridge.mod,s=1e10,newx=x[test,])
mean((ridge.pred-y.test)^2)
ridge.pred=predict(ridge.mod,s=0,newx=x[test,],exact=T,x=x[train,],y=y[train])
mean((ridge.pred-y.test)^2)
lm(y~x, subset=train)
predict(ridge.mod,s=0,exact=T,type="coefficients",x=x[train,],y=y[train])[1:20,]
set.seed(1)
cv.out=cv.glmnet(x[train,],y[train],alpha=0)
plot(cv.out)
bestlam=cv.out$lambda.min
bestlam
ridge.pred=predict(ridge.mod,s=bestlam,newx=x[test,])
mean((ridge.pred-y.test)^2)
out=glmnet(x,y,alpha=0)
predict(out,type="coefficients",s=bestlam)[1:20,]

# The Lasso

lasso.mod=glmnet(x[train,],y[train],alpha=1,lambda=grid)
plot(lasso.mod)
set.seed(1)
cv.out=cv.glmnet(x[train,],y[train],alpha=1)
plot(cv.out)
bestlam=cv.out$lambda.min
lasso.pred=predict(lasso.mod,s=bestlam,newx=x[test,])
mean((lasso.pred-y.test)^2)
out=glmnet(x,y,alpha=1,lambda=grid)
lasso.coef=predict(out,type="coefficients",s=bestlam)[1:20,]
lasso.coef
lasso.coef[lasso.coef!=0]

# Chapter 6 Lab 3: PCR and PLS Regression

# Principal Components Regression

library(pls)
set.seed(2)
pcr.fit=pcr(Salary~., data=Hitters,scale=TRUE,validation="CV")
summary(pcr.fit)
validationplot(pcr.fit,val.type="MSEP")
set.seed(1)
pcr.fit=pcr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV")
validationplot(pcr.fit,val.type="MSEP")
pcr.pred=predict(pcr.fit,x[test,],ncomp=7)
mean((pcr.pred-y.test)^2)
pcr.fit=pcr(y~x,scale=TRUE,ncomp=7)
summary(pcr.fit)

# Partial Least Squares

set.seed(1)
pls.fit=plsr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV")
summary(pls.fit)
validationplot(pls.fit,val.type="MSEP")
pls.pred=predict(pls.fit,x[test,],ncomp=2)
mean((pls.pred-y.test)^2)
pls.fit=plsr(Salary~., data=Hitters,scale=TRUE,ncomp=2)
summary(pls.fit)


# FUNCTIONS

sum_of_squares <- function(vec) {
    sum(vec ^ 2)
}

square_of_sum <- function(vec) {
    sum(vec) ^ 2
}

# SCRIPT

ten <- 1:10
hundred <- 1:100

stopifnot(sum_of_squares(ten) == 385)
stopifnot(square_of_sum(ten) == 3025)
stopifnot(square_of_sum(ten) - sum_of_squares(ten) == 2640)

cat(square_of_sum(hundred) - sum_of_squares(hundred), "\n")