library(MASS)
library(dplyr)
library(ggplot2)
library(FNN)
library(mgcv)
library(rpart)
library(klaR)

options(width=80)

## Import datasets needed for chapter 5
PSDS_PATH <- file.path('~', 'statistics-for-data-scientists')

loan3000 <- read.csv(file.path(PSDS_PATH, 'data', 'loan3000.csv'))
loan_data <- read.csv(file.path(PSDS_PATH, 'data', 'loan_data.csv'))
loan_data$outcome <- ordered(loan_data$outcome, levels=c('paid off', 'default'))
full_train_set <- read.csv(file.path(PSDS_PATH, 'data', 'full_train_set.csv'))
full_train_set$outcome <- ordered(full_train_set$outcome, levels=c('paid off', 'default'))

## Naive Bayes
naive_model <- NaiveBayes(outcome ~ purpose_ + home_ + emp_len_,
                          data = na.omit(loan_data))
naive_model$table

new_loan <- loan_data[147, c('purpose_', 'home_', 'emp_len_')]
row.names(new_loan) <- NULL
new_loan

predict(naive_model, new_loan)

## example not in book
less_naive <- NaiveBayes(outcome ~ borrower_score + payment_inc_ratio +
                           purpose_ + home_ + emp_len_, data = loan_data)
less_naive$table[1:2]

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

stats <- less_naive$table[[1]]
ggplot(data.frame(borrower_score=c(0,1)), aes(borrower_score)) +
  stat_function(fun = dnorm, color='blue', linetype=1,
                arg=list(mean=stats[1, 1], sd=stats[1, 2])) +
  stat_function(fun = dnorm, color='red', linetype=2,
                arg=list(mean=stats[2, 1], sd=stats[2, 2])) +
  labs(y='probability')
dev.off()

#
## Code for LDA
loan_lda <- lda(outcome ~ borrower_score + payment_inc_ratio,
                data=loan3000)
loan_lda$scaling

## Code snippet 4.2
pred <- predict(loan_lda)
head(pred$posterior)

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

pred <- predict(loan_lda)
lda_df <- cbind(loan3000, prob_default=pred$posterior[,'default'])

x <- seq(from=.33, to=.73, length=100)
y <- seq(from=0, to=20, length=100)
newdata <- data.frame(borrower_score=x, payment_inc_ratio=y)
pred <- predict(loan_lda, newdata=newdata)
lda_df0 <- cbind(newdata, outcome=pred$class)

ggplot(data=lda_df, aes(x=borrower_score, y=payment_inc_ratio, color=prob_default)) +
  geom_point(alpha=.6) +
  scale_color_gradient2(low='white', high='blue') +
  scale_x_continuous(expand=c(0,0)) +
  scale_y_continuous(expand=c(0,0), lim=c(0, 20)) +
  geom_line(data=lda_df0, col='green', size=2, alpha=.8) +
  theme_bw()

dev.off()

## Logistic regression
logistic_model <- glm(outcome ~ payment_inc_ratio + purpose_ +
                        home_ + emp_len_ + borrower_score,
                      data=loan_data, family='binomial')
logistic_model
summary(logistic_model)

p <- seq(from=0.01, to=.99, by=.01)
df <- data.frame(p = p ,
                 logit = log(p/(1-p)),
                 odds = p/(1-p))
## Figure 5-2

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0502.png'),  width = 5, height=4, units='in', res=300)
ggplot(data=df, aes(x=p, y=logit)) +
  geom_line() +
  labs(x = 'p', y='logit(p)') +
  theme_bw()
dev.off()

## Figure 5-3
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0503.png'),  width = 5, height=4, units='in', res=300)
ggplot(data=df, aes(x=logit, y=odds)) +
  geom_line() +
  labs(x = 'log(odds ratio)', y='odds ratio') +
  ylim(1, 100) +
  xlim(0, 5) +
  theme_bw()
dev.off()

pred <- predict(logistic_model)
summary(pred)

prob <- 1/(1 + exp(-pred))
summary(prob)
#

logistic_gam <- gam(outcome ~ s(payment_inc_ratio) + purpose_ +
                      home_ + emp_len_ + s(borrower_score),
                    data=loan_data, family='binomial')
logistic_gam

terms <- predict(logistic_gam, type='terms')
partial_resid <- resid(logistic_gam) + terms
df <- data.frame(payment_inc_ratio = loan_data[, 'payment_inc_ratio'],
                 terms = terms[, 's(payment_inc_ratio)'],
                 partial_resid = partial_resid[, 's(payment_inc_ratio)'])

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

ggplot(df, aes(x=payment_inc_ratio, y=partial_resid, solid = FALSE)) +
  geom_point(shape=46, alpha=.4) +
  geom_line(aes(x=payment_inc_ratio, y=terms),
            color='red', alpha=.5, size=1.5) +
  labs(y='Partial Residual') +
  xlim(0, 25) +
  theme_bw()

dev.off()

# Confusion matrix
pred <- predict(logistic_gam, newdata=loan_data)
pred_y <- as.numeric(pred > 0)
true_y <- as.numeric(loan_data$outcome=='default')
true_pos <- (true_y==1) & (pred_y==1)
true_neg <- (true_y==0) & (pred_y==0)
false_pos <- (true_y==0) & (pred_y==1)
false_neg <- (true_y==1) & (pred_y==0)
conf_mat <- matrix(c(sum(true_pos), sum(false_pos),
                     sum(false_neg), sum(true_neg)), 2, 2)
colnames(conf_mat) <- c('Yhat = 1', 'Yhat = 0')
rownames(conf_mat) <- c('Y = 1', 'Y = 0')
conf_mat

# precision
conf_mat[1,1]/sum(conf_mat[,1])
# recall
conf_mat[1,1]/sum(conf_mat[1,])
# specificity
conf_mat[2,2]/sum(conf_mat[2,])

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

idx <- order(-pred)
recall <- cumsum(true_y[idx]==1)/sum(true_y==1)
specificity <- (sum(true_y==0) - cumsum(true_y[idx]==0))/sum(true_y==0)
roc_df <- data.frame(recall = recall, specificity = specificity)
ggplot(roc_df, aes(x=specificity, y=recall)) +
  geom_line(color='blue') +
  scale_x_reverse(expand=c(0, 0)) +
  scale_y_continuous(expand=c(0, 0)) +
  geom_line(data=data.frame(x=(0:100)/100), aes(x=x, y=1-x),
            linetype='dotted', color='red') +
  theme_bw()

dev.off()

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

ggplot(roc_df, aes(specificity)) +
  geom_ribbon(aes(ymin=0, ymax=recall), fill='blue', alpha=.3) +
  scale_x_reverse(expand=c(0, 0)) +
  scale_y_continuous(expand=c(0, 0)) +
  labs(y='recall') +
  theme_bw()

dev.off()

## AUC calculation
sum(roc_df$recall[-1] * diff(1-roc_df$specificity))
head(roc_df)

## Code for Undersampling
mean(full_train_set$outcome=='default')

full_model <- glm(outcome ~ payment_inc_ratio + purpose_ +
                    home_ + emp_len_+ dti + revol_bal + revol_util,
                  data=full_train_set, family='binomial')
pred <- predict(full_model)
mean(pred > 0)

## Code for oversampling/up weighting
wt <- ifelse(full_train_set$outcome=='default', 1/mean(full_train_set$outcome == 'default'), 1)
full_model <- glm(outcome ~ payment_inc_ratio + purpose_ +
                    home_ + emp_len_+ dti + revol_bal + revol_util,
                  data=full_train_set, weight=wt, family='quasibinomial')
pred <- predict(full_model)
mean(pred > 0)

## SMOTE example (data generation); code not in book. This no longer works for some reason
library(unbalanced)
loan_data_samp <- sample_frac(full_train_set, .05)
smote_data <- ubSMOTE(loan_data_samp, loan_data_samp$outcome,
                      perc.over = 2000, k = 5, perc.under = 100)

# Code for Figure 5-8: comparison of methods
loan_tree <- rpart(outcome ~ borrower_score + payment_inc_ratio,
                   data=loan3000,
                   control = rpart.control(cp=.005))

lda_pred <- lda_df0[, c('borrower_score', 'payment_inc_ratio')]
lda_pred$method = 'LDA'

tree_pred <- data.frame(borrower_score = c(0.375, 0.375, 0.525, 0.525, 0.625, 0.625),
                        payment_inc_ratio = c(0, 9.732,  9.732, 8.772, 8.772, 20),
                        method = rep('Tree', 6))

glm0 <- glm(outcome ~ (payment_inc_ratio) +  (borrower_score),
            data=loan3000, family='binomial')
y <- seq(from=0, to=20, length=100)
x <- (-glm0$coefficients[1] - glm0$coefficients[2]*y)/glm0$coefficients[3]
glm0_pred <- data.frame(borrower_score=x, payment_inc_ratio=y, method='Logistic')

gam1 <- gam(outcome ~ s(payment_inc_ratio) +  s(borrower_score),
            data=loan3000, family='binomial')
# newdata = gam0_pred

gam_fun <- function(x){
  rss <- sum(predict(gam1, newdata=data.frame(borrower_score=x, payment_inc_ratio=y))^2)
}
est_x <- nlminb(newdata$borrower_score, gam_fun )
gam1_pred <- data.frame(borrower_score=est_x$par, payment_inc_ratio=y, method="GAM")

loan_fits <- rbind(lda_pred,
                   tree_pred,
                   glm0_pred,
                   gam1_pred)

## Code for Figure 5-8
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0508.png'),  width = 6, height=4, units='in', res=300)
ggplot(data=loan_fits, aes(x=borrower_score, y=payment_inc_ratio, color=method, linetype=method)) +
  geom_line(size=1.5) +
  theme(legend.key.width = unit(2,"cm")) +
  guides(linetype = guide_legend(override.aes = list(size = 1)))
dev.off()

###############################################################
# JUNK
ggplot(roc_df, aes(specificity)) +
  geom_ribbon(aes(ymin=0, ymax=recall), fill='blue', alpha=.3) +
  scale_x_reverse(expand=c(0, 0)) +
  scale_y_continuous(expand=c(0, 0)) +
  labs(y='recall') +
  theme_bw()

dev.off()
##

loan_tree <- rpart(outcome ~ borrower_score + payment_inc_ratio,
                   data=loan3000,
                   control = rpart.control(cp=.005))

loan_all_data <- loans[loans$status %in% c('Charged Off', 'Current', 'Fully Paid'),]
loan_all_data$outcome <- ifelse(loan_all_data$outcome=='default', 1, 0)
loan_all_data$outcome <- factor(loan_all_data$outcome, levels=0:1, labels=c('good', 'default'))

wt <- mean(loan_all_data$outcome == 'default')
wt

loan_tree <- rpart(outcome ~ borrower_score + payment_inc_ratio,
                   data=loan3000,
                   control = rpart.control(cp=.005))

                  #control = tree.control(nrow(loan_data), minsize=500))
#plot(loan_tree, type='uniform')

png(filename="/Users/andrewbruce1/book/loan_tree_model.png", width = 400, height = 300)

plot(loan_tree, uniform=TRUE, margin=.05)
text(loan_tree, cex=.75)

dev.off()

loan_tree

r_tree <- data_frame(x1 = c(0.525, 0,     0.375, 0.525, 0.625),
                     x2 = c(0.525, 0.525, 0.375, 1,     0.625),
                     y1 = c(0,     9.732, 0,     8.772, 8.772),
                     y2 = c(25,    9.732, 9.732, 8.772, 25),
                     rule_number = factor(c(1, 2, 4, 3, 5)))
r_tree <- as.data.frame(r_tree)

labs <- data.frame(x=c(.375/2, .45, 1.525/2, 1.625/2, .575, .525/2),
                   y=c(8.772/2, 8.772/2, 9.732/2,
                      9.732 + (25 - 9.732)/2, 9.732 + (25 - 9.732)/2, 9.732 + (25 - 8.772)/2),
                   decision = factor(c('default', 'paid off', 'paid off', 'paid off', 'default', 'default')))

png(filename="/Users/andrewbruce1/book/loan_rpart.png", width = 300, height = 400)

ggplot(data=loan3000, aes(x=borrower_score, y=payment_inc_ratio)) +
  geom_point( aes(color=outcome, shape=outcome), alpha=.5) +
  scale_color_manual(values=c('blue', 'red')) +
  scale_shape_discrete(solid=FALSE) +
  geom_segment(data=r_tree, aes(x=x1, y=y1, xend=x2, yend=y2, linetype=rule_number), size=1.5, alpha=.7) +
  guides(colour = guide_legend(override.aes = list(size=1.5)),
         linetype = guide_legend(keywidth=3, override.aes = list(size=1))) +
  scale_x_continuous(expand=c(0,0)) +
  scale_y_continuous(expand=c(0,0), limits=c(0, 25)) +
  geom_label(data=labs, aes(x=x, y=y, label=decision)) +
  theme(legend.position='bottom')

dev.off()

info <- function(x){
  info <- ifelse(x==0, 0, -x * log2(x) - (1-x) * log2(1-x))
  return(info)
}
x <- 0:50/100
plot(x, info(x) + info(1-x))

gini <- function(x){
  return(x * (1-x))
}
plot(x, gini(x))

impure <- data.frame(p = rep(x, 3),
                     impurity = c(2*x,
                                  gini(x)/gini(.5)*info(.5),
                                  info(x)),
                     type = rep(c('Accuracy', 'Gini', 'Entropy'), rep(51,3)))

png(filename="/Users/andrewbruce1/book/impurity.png", width = 300, height = 300)

ggplot(data=impure, aes(x=p, y=impurity, linetype=type, color=type)) +
  geom_line(size=1.5) +
  guides( linetype = guide_legend( keywidth=3, override.aes = list(size=1))) +
  scale_x_continuous(expand=c(0,0.01)) +
  scale_y_continuous(expand=c(0,0.01)) +
  theme(legend.position='bottom', legend.title=element_blank())

dev.off()

###################################################
# ensemble models: random forest

set.seed(50505021)
loan3000 <- loan_data[sample(nrow(loan_data), 3000),
                      c("outcome", "purpose_", "dti", "borrower_score", "payment_inc_ratio")]
loan_data$purpose <- factor(loan_data$purpose_)

save(loan3000, file="/Users/andrewbruce1/book/loan300.rdata")

library(randomForest)

rf <- randomForest(outcome ~ borrower_score + payment_inc_ratio,
                   data=loan3000)
#control = tree.control(nrow(loan_data), minsize=500))
#plot(loan_tree, type='uniform')

png(filename="/Users/andrewbruce1/book/rf_accuracy.png", width = 300, height = 250)

error_df = data.frame(error_rate = rf$err.rate[,'OOB'],
                      num_trees = 1:rf$ntree)
ggplot(error_df, aes(x=num_trees, y=error_rate)) +
  geom_line()

dev.off()

png(filename="/Users/andrewbruce1/book/loan_random_forest.png", width = 300, height = 340)

pred <- predict(loan_lda)
rf_df <- cbind(loan3000, pred_default=pred[,'default']>.5, prob_default=pred[, 'default'])

ggplot(data=rf_df, aes(x=borrower_score, y=payment_inc_ratio,
                       color=pred_default, shape=pred_default)) +
  geom_point(alpha=.6, size=2) +
  scale_shape_manual( values=c( 46, 4)) +
  scale_x_continuous(expand=c(0,0)) +
  scale_y_continuous(expand=c(0,0), lim=c(0, 20)) +
  theme(legend.position='bottom')

dev.off()

# A nice plot showing a gradient of predictions but not as illustrative as the prior plot
ggplot(data=rf_df, aes(x=borrower_score, y=payment_inc_ratio, color=prob_default)) +
  geom_point(alpha=.6) +
  scale_color_gradient2(low='blue', mid='white', high='red', midpoint=.5) +
  scale_x_continuous(expand=c(0,0)) +
  scale_y_continuous(expand=c(0,0), lim=c(0, 20)) +
  theme(legend.position='bottom') +
  geom_line(data=lda_df0, col='green', size=2, alpha=.8)

nrow(nan.omit(loan_data))

rf_all <- randomForest(outcome ~ ., data=loan_data, importance=TRUE)

varImpPlot(rf_all, type=1)

imp1 <- importance(rf_all, type=1)
imp2 <- importance(rf_all, type=2)
idx <- order(imp1[,1])
nms <- factor(row.names(imp1)[idx], levels=row.names(imp1)[idx])
imp <- data.frame(Predictor = rep(nms, 2),
                  Importance = c(imp1[idx, 1], imp2[idx, 1]),
                  Type = rep( c('Accuracy Decrease', 'Gini Decrease'), rep(nrow(imp1), 2)))

png(filename="/Users/andrewbruce1/book/loan_var_imp.png", width = 300, height = 450)

ggplot(imp) +
  geom_point(aes(y=Predictor, x=Importance), size=2, stat="identity") +
  facet_wrap(~Type, ncol=1, scales="free_x") +
  theme(
    panel.grid.major.x = element_blank() ,
    panel.grid.major.y = element_line(linetype=3, color="darkgray") )

dev.off()

loan_data1 <- loan_data0[,-which(names(loan_data0) %in% 'emp_length')]
loan_data1$term = factor(loan_data1$term)
loan_data1$emp_length = factor(loan_data1$emp_length>1)

params <- data.frame(nodesize = c(5, 15, 25, 5, 10, 25),
                     mtry = c(3, 3, 3, 5, 5, 5))
rf_list <- vector('list', 6)
for(i in 1:nrow(params)){
  rf_list[[i]] <- randomForest(outcome ~ ., data=loan_data, mtry=params[i, 'mtry'],
                               nodesize = params[i,'nodesize'], ntree=100)
}

rf_list[[1]]$confusion

varImpPlot(rf_all, type=1)

library(xgboost)
predictors <- data.matrix(loan3000[, c('borrower_score', 'payment_inc_ratio')])
label <- as.numeric(loan3000[,'outcome'])-1
xgb <- xgboost(data=predictors, label=label, objective = "binary:logistic",
               params=list(subsample=.63, eta=0.1), nrounds=100)

pred <- predict(xgb, newdata=predictors)
xgb_df <- cbind(loan3000, pred_default=pred>.5, prob_default=pred)

png(filename="/Users/andrewbruce1/book/loan_xgboost.png", width = 300, height = 340)

ggplot(data=xgb_df, aes(x=borrower_score, y=payment_inc_ratio,
                       color=pred_default, shape=pred_default)) +
  geom_point(alpha=.6, size=2) +
  scale_shape_manual( values=c( 46, 4)) +
  scale_x_continuous(expand=c(.03, 0)) +
  scale_y_continuous(expand=c(0,0), lim=c(0, 20)) +
  theme(legend.position='bottom')

dev.off()

seed <- 400820
predictors <- data.matrix(loan_data[,-which(names(loan_data) %in% 'outcome')])
label <- as.numeric(loan_data$outcome)-1
test_idx <- sample(nrow(loan_data), 10000)

test_set <- loan_data[idx,]
train_set <- loan_data[-idx,]

xgb_default <- xgboost(data=predictors[-test_idx,], label=label[-test_idx],
                   objective = "binary:logistic", nrounds=250)
pred_default <- predict(xgb_default, predictors[test_idx,])
error_default <- abs(label[test_idx] - pred_default) > 0.5
xgb_default$evaluation_log[250,]
mean(error_default)

xgb_penalty <- xgboost(data=predictors[-test_idx,],
                       label=label[-test_idx],
                       params=list(eta=.1, subsample=.63, lambda=1000),
                       objective = "binary:logistic", nrounds=250)
pred_penalty <- predict(xgb_penalty, predictors[test_idx,])
error_penalty <- abs(label[test_idx] - pred_penalty) > 0.5
xgb_penalty$evaluation_log[250,]
mean(error_penalty)

error_default <- rep(0, 250)
error_penalty <- rep(0, 250)
for(i in 1:250)
{
  pred_default <- predict(xgb_default, predictors[test_idx,], ntreelimit = i)
  error_default[i] <- mean(abs(label[test_idx] - pred_default) > 0.5)
  pred_penalty <- predict(xgb_penalty, predictors[test_idx,], ntreelimit = i)
  error_penalty[i] <- mean(abs(label[test_idx] - pred_penalty) > 0.5)
}

errors <- rbind(xgb_default$evaluation_log,
                xgb_penalty$evaluation_log,
                data.frame(iter=1:250, train_error=error_default),
                data.frame(iter=1:250, train_error=error_penalty))
errors$type <- rep(c('default train', 'penalty train',
                     'default test', 'penalty test'), rep(250, 4))

png(filename="/Users/andrewbruce1/book/xgboost_error.png", width = 300, height = 340)

ggplot(errors, aes(x=iter, y=train_error, group=type)) +
  geom_line(aes(linetype=type, color=type), size=1.5) +
  theme(legend.position='bottom', legend.key.width = unit(1.5,"cm")) +
  labs(x="Iterations", y="Error") +
  guides(colour = guide_legend(override.aes = list(size=1)))

dev.off()
dev.set(2)

N <- nrow(loan_data)
fold_number <- sample(1:5, N, replace = TRUE)
params <- data.frame(eta = rep(c(.1, .5, .9), 3),
                     max_depth = rep(c(3, 6, 12), rep(3,3)))
rf_list <- vector('list', 9)
error <- matrix(0, nrow=9, ncol=5)
for(i in 1:nrow(params)){
  for(k in 1:5){
    cat('Fold', k, 'for model', i, '\n')
    fold_idx <- (1:N)[fold_number == k]
    xgb <- xgboost(data=predictors[-fold_idx,], label=label[-fold_idx],
                   params = list(eta = params[i, 'eta'],
                                 max_depth = params[i, 'max_depth']),
                   objective = "binary:logistic", nrounds=100, verbose=0)
    pred <- predict(xgb, predictors[fold_idx,])
    error[i, k] <- mean(abs(label[fold_idx] - pred) >= 0.5)
  }
}

avg_error <- 100 * round(rowMeans(error), 4)
cbind(params, avg_error)


setwd('../../Matrices/')

install.packages("Matrix")
library(Matrix)

######################################
############ PMI Function ############
PMI<-function(x){
	m <- log10(Matrix(1, dim(x)[1], dim(x)[2]))+log10((rowSums(x)+ dim(x)[2]))
	cat("Done with the rows add\n")

	n <- t(log10(t(Matrix(1, dim(x)[1], dim(x)[2])))+log10((colSums(x)+ dim(x)[1])))
	cat("Done with the columns add\n")

	pmi<-log10(((x+1)*(sum(x)+dim(x)[1]*dim(x)[2])))-(m+n)
	return(pmi)
}
######################################

######################################
##### Matrix Normalizer Function #####
MatrixNorm<-function(m){
	m_rs <- 1/(sqrt(rowSums(m*m)))
	v <- Diagonal(n= length(m_rs), m_rs)
	out <- v%*%m
	return(out)
}
######################################

######################################
### Load MEDLINE first order and BP definition matrices
FOC <- readMM(file='First_Order_Matrix.mtrx') ###  WARNING: make sure your matrix is for R not MATLAB
FOC <- FOC + t(FOC)	### Converts a bigram matrix to a co-occurrence matrix

BP_DEF <- readMM(file='BP_Definition_Matrix.mtrx') ###  WARNING: make sure your matrix is for R not MATLAB
### Initial matrices are loaded now!
######################################

######################################
### Here we start to build SOC matrix for BP
SOC <- BP_DEF%*%FOC;
a <- rowSums(M)
a <- 1/a
D <- Diagonal(n= length(a), a)
SOC <- D%*%SOC
SOC <- SOC[,colSums(SOC)!=0]
rm (D, a, FOC, BP_DEF)
### Now we have SOC matrix for BP
######################################

######################################
### Here we apply PMI on BP SOC matrix
PMI_on_SOC <- PMI(SOC)
rm (SOC)
### PMI applied on BP SOC matrix
######################################

######################################
### Applying cut-off threshold to find better features
DOWN_CUT <- 0;	### change this value for differet cutt-off points from down
TOP_CUT <- 100;	### change this value for differet cutt-off points from top
PMI_on_SOC[which(PMI_on_SOC < DOWN_CUT)] <- 0;
PMI_on_SOC[which(TOP_CUT < PMI_on_SOC)] <- 0;
PMI_on_SOC <- PMI_on_SOC[,colSums(PMI_on_SOC)!=0]
### Cut-off applied on the BP PMI_on_SOC matrix
######################################

######################################
### Compute semantic similarity of BP GO terms (cosine similarity)
PMI_on_SOC <- MatrixNorm(PMI_on_SOC)
simDEF <- PMI_on_SOC%*%(t(PMI_on_SOC)) ### Now we have semantic similarity of BP GO terms
### simDEF is now ready to be used or examined
######################################


=begin
  # sample-quotientfield03.rb

  require "algebra"

  F13 = ResidueClassRing(Integer, 13)
  F = AlgebraicExtensionField(F13, "a") {|a| a**2 - 2}
  a = F.var
  RF = RationalFunctionField(F, "x")
  x = RF.var

  p( (a/4*x + RF.unity/2)/(x**2 + a*x + 1) +
    (-a/4*x + RF.unity/2)/(x**2 - a*x + 1) )
  #=> 1/(x**4 + 1)
((<_|CONTENTS>))
=end


data("mtcars")

print(nrow(mtcars))
print(ncol(mtcars))

head(mtcars)
hist(mtcars$hp)
hist(mtcars$wt)

scatter.smooth(mtcars$hp,mtcars$wt)
scatter.smooth(mtcars$gear,mtcars$carb)


options(scipen=999)

data <- c()
line <- readline()
while (line != "") {
  data[length(data) + 1] <- as.numeric(line)
  line <- readline()
}

invalid <- -1
for (i in 26:length(data)) {
  found <- FALSE
  for (s1 in (i-25):(i-1)) {
    for (s2 in (i-25):(i-1)) {
      if (!found && s1 != s2 && data[s1] + data[s2] == data[i]) {
        found <- TRUE
      }
    }
  }
  if (!found) {
    invalid <- data[i]
  }
}

for (idx in seq_along(data)) {
  i <- idx
  smallest <- .Machine$double.xmax
  largest <- 0
  sum <- 0
  while (sum < invalid && i <= length(data)) {
    sum <- sum + data[i]
    if (data[i] < smallest) {
      smallest <- data[i]
    }
    if (data[i] > largest) {
      largest <- data[i]
    }
    i <- i + 1
  }
  if (sum == invalid) {
    print(smallest + largest)
    break
  }
}


## 1. Introduction to Data Structure: Generating Vectors ##

vector_1 <- rep(4, times = 10)
vector_2 <- 1:12
vector_3 <- seq(from = 2.0, to = 5.50, by = 0.25)

## 2. Creating a Vector Using Known Values ##

math_grades <- c(92L, 87L, 85L)
exam_grades <- c(92, 90, 84, 95, 77, 92, 85)
is_stem_classes <- c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)

## 3. Indexing Vectors by Position ##

math_grades <- c(92L, 87L, 85L)
exam_grades <- c(92, 90, 84, 95, 77, 92, 85)
# Add your code below
math_exam_grade <- math_grades[1]
desired_exam_grades <- exam_grades[c(2, 3, 6)]
non_stem_exam_grades <- exam_grades[c(3:7)]

## 4. Indexing Vectors using logicals ##

is_stem_classes <- c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)
# Add your code below
homework_grades <- c(87, 81, 95, 86, 85, 90, 88)
preffered_homework_grades <- homework_grades[is_stem_classes]

## 5. Modifying Elements in a Vector ##

math_grades <- c(92L, 87L, 85L)
exam_grades <- c(92, 90, 84, 95, 77, 92, 85)
is_stem_classes <- c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)
# Add your code below
math_grades[2] <- 80L
exam_grades[is_stem_classes] <- 92

## 6. Appending Elements To a Vector ##

is_stem_classes_classes <- c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)
# Add your code below
extra_is_stem_classes  <- c(TRUE, FALSE, FALSE)
new_is_stem_classes_end <- c(is_stem_classes, is_stem_classes_classes)
new_is_stem_classes_start <- c(extra_is_stem_classes, is_stem_classes)

## 7. Removing Elements from a Vector ##

math_grades <- c(92L, 87L, 85L)
exam_grades <- c(92, 90, 84, 95, 77, 92, 85)
# Add your code below
math_without_exam_grades <- math_grades[-1]
above_90_exam_grades <- exam_grades[c(-3, -5, -7)]

## 8. Performing Operations with Vectors ##

exam_grades <- c(92, 90, 84, 95, 77, 92, 85)
homework_grades <- c(87, 81, 95, 86, 85, 90, 88)
project_grades <- c(85, 92, 79, 93, 90, 91, 95)
# Add your code below
class_scores_sum <- exam_grades + homework_grades + project_grades
class_scores_avg <- class_scores_sum / 3

## 9. Vector Recycling ##

exam_grades <- c(92, 90, 84)
homework_grades <- c(87, 81, 95, 86, 85, 90, 88)
project_grades <- c(85, 92, 79, 93, 90, 91, 95)
# Add your code below
class_scores_sum_recycled <- exam_grades + homework_grades + project_grades
class_scores_avg_recycled <- class_scores_sum / 3

## 10. Vectors Using Names ##

exam_grades <- c(92, 90, 84, 95, 77, 92, 85)
homework_grades <- c(87, 81, 95, 86, 85, 90, 88)
project_grades <- c(85, 92, 79, 93, 90, 91, 95)
# Add your code below
names(exam_grades) <- class_names
names(homework_grades) <- class_names
names(project_grades) <- class_names

Data Analyst in R/Step 1 - Introduction to R/2. Data Structures in R/1. Vectors in R.r


#Create data
Ixos=rnorm(4000 , 100 , 30)
Primadur=rnorm(4000 , 200 , 30)

#Represent separately
png("#2two_hist_melt_colors_step1.png" ,  width = 480, height = 480)
par(mfrow=c(1,2))
hist(Ixos, breaks=30 , xlim=c(0,300) , col=rgb(1,0,0,0.5) , xlab="height" ,
     ylab="nbr of plants" , main="" )
hist(Primadur, breaks=30 , xlim=c(0,300) , col=rgb(0,0,1,0.5) , xlab="height" ,
     ylab="nbr of plants" , main="")
dev.off()

#But it is hard to visualize differences in the distribution. It would be more interesting to have both distribution on the same graph, with transparency permitting to see the whole distribution :
png("#2two_hist_melt_colors_step2.png" ,  width = 480, height = 480)
hist(Ixos, breaks=30, xlim=c(0,300), col=rgb(1,0,0,0.5), xlab="height",
     ylab="nbr of plants", main="distribution of height of 2 durum wheat varieties" )
hist(Primadur, breaks=30, xlim=c(0,300), col=rgb(0,0,1,0.5), add=T)
legend("topright", legend=c("Ixos","Primadur"),
      col=c(rgb(1,0,0,0.5), rgb(0,0,1,0.5)), pt.cex=2, pch=15 )
dev.off()


# The sequence of the epsilons in a random walk
# A vector of size n, the elements are generated
# at random : +1 with probability 0.5 and -1 with
# probability 0.5
# 23-04-2015
# Killian Martin--Horgassan

Epsilon_is = function(n) {

	# The vector of the Epsilon_is, they are uniformly distributed on {-1,+1}
	vect <- sample(x = c(-1,1), size = n, replace = TRUE, prob = c(0.5,0.5))

	return(vect)
}


#' @title calcAt
#'
#' @description Estimate transom area (\code{At}) (m^2) using method in Rakke
#' (2016).
#'
#' @param Cm Midship area coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCm}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#'
#' @return \code{At}
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'\href{http://hdl.handle.net/11250/2410741}{Rakke, S. G. 2016. "Ship Emissions
#'Calculation from AIS." NTNU}
#'
#' @seealso \code{\link{calcCm}}
#'
#' @examples
#'calcAt(0.98, 32, 10)
#'calcAt(c(0.98,0.99), c(32,45.5), c(10,15.5))
#'
#' @export

calcAt <-function(Cm, breadth, maxDraft){

  At<- 0.051*Cm*breadth*maxDraft

  return(At)
}


#' @title calcHMCa
#'
#'@description Calculate incremental hull (roughness) resistance coefficient
#'(\code{Ca}) (dimensionless), which describes the effect of hull roughness and
#' still-air resistance, using the Holtrop & Mennen method.
#'
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#' @param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#'  (see \code{\link{calcCbw}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param forwardDraft Forward draft (deviation from actual draft indicates trim)
#'  (vector of numericals, m)
#' @param Abt Traverse bulb area (vector of numericals, m^2) (see
#'  \code{\link{calcAbt}})
#' @param hb Center of bulb area above keel line (vector of numericals, m) (see
#'  \code{\link{calchb}})
#'
#' @return \code{Ca} (vector of numericals, dimensionless)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcAbt}}
#'\item \code{\link{calchb}}
#'}
#'
#' @family Holtrop-Mennen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcHMCa(c(13.57,11.49),c(218.7500,209.2518),c(0.81,0.65),c(32.25,32.20),c(13.57,11.49),
#' c(25.09,55.86),c(5.43,4.6))
#'
#'calcHMCa(13.57,218.7500,0.81,32.25,13.57,25.0880,5.428)
#'
#' @export

calcHMCa<-function(maxDraft,lwl,Cbw,breadth,forwardDraft,Abt,hb){

Ca<-
  ifelse(forwardDraft/lwl<=0.04,#case 1
  0.006*((lwl+100)^-0.16)-0.00205+0.003*sqrt(lwl/7.5)*Cbw^4*
  (#c2
    exp(-1.89*sqrt(
    #c3
    0.56*Abt^1.5/(breadth*maxDraft*(
      0.31*sqrt(Abt)+forwardDraft-hb
    ))
  ))
  )*
  (0.04-
     (#c4
      forwardDraft/lwl
     ))
 ,#case 2
    0.006*((lwl+100)^-0.16)-0.00205+0.003*sqrt(lwl/7.5)*Cbw^4*
      (#c2
        exp(-1.89*sqrt(
          #c3
          0.56*Abt^1.5/(breadth*maxDraft*(
            0.31*sqrt(Abt)+forwardDraft-hb
          ))
        ))
      )*
      (0.04-
         (#c4
           0.04
         ))
  )

return(Ca)
}


esbi <- function(i, a){(1-exp(-a))/(1-exp(-a/i))}
esbia <- function(i, a){(1-exp(-a))/(i*(1-exp(-a/i)))}
esbib <- function(i, a){1-esbia(i, a)}

n <- 1000
a <- 1

x <- seq(0, n, by=1)
plot(x, x, type="l", ylim=c(0, n))
lines(x, log(x), col="green")
lines(x, esbi(x, 1), col="red")
lines(x, esbi(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, x*x, type="l", ylim=c(0, n*n))
lines(x, x*log(x), col="green")
lines(x, x*esbi(x, 1), col="red")
lines(x, x*esbi(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, x*x, type="l", ylim=c(0, n*n))
lines(x, x*log(x), col="green")
lines(x, x^2*esbia(x, 1), col="red")
lines(x, x^2*esbia(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, log(x)*x, type="l", ylim=c(0, log(n)*(n-log(n))))
lines(x, rep(0, length(x)), col="green")
lines(x, x*log(x)*esbib(x, 1), col="red")
lines(x, x*log(x)*esbib(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, x*x+log(x)*x, type="l", ylim=c(0, n*n+log(n)*(n-log(n))))
lines(x, x*log(x)+log(x)*log(x), col="green")
lines(x, x^2*esbia(x, 1)+x*log(x)*esbib(x, 1), col="red")
lines(x, x^2*esbia(x, 10)+x*log(x)*esbib(x, 10), col="blue")

x <- seq(0, n, by=1)
plot(x, esbi(x, a)/x, type="l")

x <- seq(0, n, by=1)
plot(x, exp(-1*x/n), type="l", ylim=c(0, 1))
lines(x, exp(-10*x/n), type="l", col="red")
lines(x, exp(-15*x/n), type="l", col="green")


##CTE534_Clasificación_No_Superisada=group
##Imagen=raster
##Banda=number 1
##Centros=number 10
##Iteracciones=number 500
##Inicio=number 5
##Cluster= output raster
##Algortimo=selection HartiganWong;Lloyd;Forgy;MacQueen
##showplots

nr <- getValues(Imagen[[Banda]])
set.seed(99)

if (Algortimo == 0) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="Hartigan-Wong")
} else if (Algortimo == 1) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="Lloyd")
} else if (Algortimo == 2) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="Forgy")
} else if (Algortimo == 3) {
cluster <- kmeans(na.omit(nr),
                  centers = Centros,
                  iter.max = Iteracciones,
                  nstart = Inicio,
                  algorithm="MacQueen")
}

Cluster <- setValues(Imagen[[Banda]], cluster$cluster)

par(mfrow =c(1,2))
plot(Imagen[[Banda]],
     col =rev(terrain.colors(Centros)),
     main = names(Imagen[[Banda]]))
plot(Cluster, main = 'Clasificación No Supervisada \n (Kmeans)')


subroutine triar(x0,y0,x1,y1,x2,y2,area)

# Calculate the area of a triangle with given
# vertices, in anti clockwise direction.
# Called by delout.

implicit double precision(a-h,o-z)
half = 0.5d0

area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0))
return
end


# This R environment comes with all of CRAN preinstalled, as well as many other helpful packages
# The environment is defined by the kaggle/rstats docker image: https://github.com/kaggle/docker-rstats
# For example, here's several helpful packages to load in

library(ggplot2) # Data visualization
library(readr) # CSV file I/O, e.g. the read_csv function
library("ggpubr")

# Input data files are available in the "../input/" directory.
# For example, running this (by clicking run or pressing Shift+Enter) will list the files in the input directory

#system("ls ../input")

# Any results you write to the current directory are saved as output.

my.data <- read.csv('../input/train.csv')
my.data
variable <- colnames(my.data)
variable

# Try to see Correlation using pair (SalePrice, SalePrice)
cor1 <- cor(my.data$SalePrice, my.data$LotArea)

cor.test(my.data$SalePrice, my.data$LotArea, method = "pearson", alternative = "two.sided")

ggscatter(my.data, x = "LotArea", y = "SalePrice",
          add = "reg.line", conf.int = TRUE,
          cor.coef = TRUE, cor.method = "pearson",
          xlab = "Lot Area", ylab = "Housing Price in US Dollar")

# From graph, it seems that these two variables are not related. So maybe won't use this in prediction
# Need to do this to all variables


library(mathart)
library(ggforce)
library(Rcpp)
library(tidyverse)

draw <- function(seed, sample, k, n) {
	set.seed(seed)

	df <- lissajous(a = runif(1, 0, 2), b = runif(1, 0, 2), A = runif(1, 0, 2), B = runif(1, 0, 2), d = 200) %>%
	sample_n(sample) %>%
	k_nearest_neighbour_graph(k)

	p <- ggplot() +
	geom_segment(aes(x, y, xend = xend, yend = yend), df, size = 0.03) +
	coord_equal() +
	theme_blankcanvas(margin_cm = 0)

	file = paste("./output/lissajous-", n, ".png", sep="")
	ggsave(file, width = 20, height = 20, units = "cm", dpi = 320)
}

draw(14, 1000, 40, 1)
draw(2, 1000, 40, 2)
draw(3, 1000, 40, 3)
draw(15, 1000, 40, 4)
draw(5, 1000, 40, 5)
draw(16, 1000, 40, 6)
draw(12, 1000, 40, 7)
draw(18, 1000, 40, 8)
draw(25, 1000, 40, 9)


# Goodness of fit (r2), predicción.
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

#################################################################
# Motivacion
#################################################################

# Sabemos interpretar los coeficientes, sabemos cuando los coeficientes
# son significativos (estadisticamente hablando). Lo que no hemos
# hablado hasta el momento, es como evaluamos distintos modelos: como podemos
# saber que modelo interpreta mejor la realidad?

# Matematicamente, queremos saber cuan bien nuestra linea se acerca/aleja
# de nuestros datos. Mientras nuestra linea de regresion se acerque mas,
# mejor nuestro modelo.

# DEMOSTRAR EN LA PIZARRA.

# El estadistico que ocupamos para tener una idea de cuan bien nuestro
# modelo interpreta la realidad, es el r-cuadrado, o r2.

#################################################################
# r2: Definicion y Significado
#################################################################

# El r-cuadrado es un porcentaje, que obviamente va de 0 a 1. Mientras
# mas cercano a 1, nuestro modelo mejora.

# Usualmente, se interpreta como el % de la varianza que es explicada
# por nuestro modelo. Por ej., un "r2 = 0.3" significa que nuestras variables
# explican el 30% de nuestros datos.

# (1) Es eso "suficientemente bueno"?
# (2) Que % nos da la "tranquilidad" de que tenemos un buen modelo?

# Por que es importante el r2? Bueno, asi podemos comparar que modelo
# explica mas la realidad. Imaginate que tenemos dos modelos, m1 y m2.
# Si r2(m1) > r2(m2), debieramos quedarnos con el m1. Por que?
# Porque el set de variables de m1 explica mas varianza (mas datos)
# al compararlo con el m2.

#################################################################
# r2: Viendo el r2
#################################################################

# Cargar paquete para cargar bases que no son de R.
# install.packages("foreign")
library(foreign) # significa "foraneo"
options(scipen = 1000000) # apagar notacion cientifica.
dat = read.dta("https://github.com/hbahamonde/OLS/raw/master/Datasets/obama.dta")

# Base
head(dat) # Base sobre preferencias politicas: Obama.

#
dat$Obamafav <- as.numeric(jitter(dat$Obamafav, factor=2, amount = 1))
dat$ideology <- as.numeric(jitter(dat$ideology, factor=2, amount = 1))

# Modelo 1
options(scipen = 1000000) # apagar notacion cientifica.
modelo.entero = lm(Obamafav ~ income + education + age + sex + ideology, dat)
summary(modelo.entero)

# obtener el r2 de "modelo.entero"
summary(modelo.entero)$r.squared # Atencion: al summary le podemos pedir una parte especifica usando "$".

# Modelo 2
modelo.parcial = lm(Obamafav ~ ideology, dat)
summary(modelo.parcial)

# obtener el r2 de "modelo.parcial"
summary(modelo.parcial)$r.squared

# Modelo 3: este es un "mal" modelo
modelo.mediocre = lm(Obamafav ~ age, dat)
summary(modelo.mediocre)
summary(modelo.mediocre)$r.squared # Pesimo...

# (1) Que podemos concluir de los r2 respectivos de "modelo.entero" y "modelo.parcial"?
# (2) Con que modelo nos quedamos? Costo-beneficio, teniendo en cuenta la parsimonia.
# (*) Este es el tipo de decisiones que podemos tomar usando el estadiatico r2.

# Graficos
## Grafiquemos nuestro "fit", es decir, cuan "en forma" esta nuestro modelo.

layout(matrix(1:3, nrow = 1)) # modifiquemos el plano donde graficamos.
# Aqui le decimos a R que "haga espacio" para 3 graficos, y que los ordene
# en una sola fila. Asi podremos poner tres graficos, uno por cada modelo.

# Los siguientes graficos, pondran en el eje-X el "fitted" es decir, el predicho.
# El eje-y tendra el observado.

plot(dat$Obamafav, fitted(modelo.entero), col = "gray", main = "Modelo Entero"); curve((x), col = "blue", add = TRUE)
plot(dat$Obamafav, fitted(modelo.parcial), col = "gray", main = "Modelo Parcial"); curve((x), col = "blue", add = TRUE)
plot(dat$Obamafav, fitted(modelo.mediocre), col = "gray", main = "Modelo Mediocre"); curve((x), col = "blue", add = TRUE)

# (1) Notar que puse ";" en la misma linea.
# (2) Que podemos concluir de esto?

#################################################################
# r2: Formula Estadistica
#################################################################

# Hablemos de la formula del r2.
# r2 = 1- (Errores Cuadrados del Residuo / Errores Cuadrados Totales)

# Errores Cuadrados del Residuo: Por cada fila, tomamos la diferencia entre
# predicho y observado. Eso al cuadrado, y despues sumamos todo. Despues, eso
# lo dividimos por los errores (o variabilidad) de la variable dependiente.
# Piensa que el valor esperado de "y" es su promedio. Entonces, el "error" en
# este caso es cuanto se aleja cada fila (observacion) del promedio de "y". Y
# finalmente, restamos 1 a ese numero final.

#################################################################
# r2: Matrices
#################################################################
options(scipen = 1000000) # apagar notacion cientifica.

# Saquemos el r2 del modelo.entero.

# Recuerda, este era nuestro modelo
#modelo.entero = lm(Obamafav ~ income + education + age + sex + ideology, dat)
summary(modelo.entero) # resumen
summary(modelo.entero)$r.squared # r2

# Formula del r2 en Matrices

## 1. Calcular los errores del modelo

## (a) Extraer "y" observado.
y.observado = dat$Obamafav

## (b) Extraer "y" predicho.
y.predicho = modelo.entero$fitted.values

## Calcular los errores del modelo
e.m = y.observado - y.predicho

### BONUS: Comparalo con el que esta dentro del objeto del modelo.
table(round(as.numeric(modelo.entero$residuals),8) == round(as.numeric(e.m), 8))

## 2. Calcular los errores de la variable dependiente (Errores del vector y)
y.m = y.observado - mean(y.observado) # round(mean(y, trim = 0.5), 3)

## Calcular r2
### 1- e'e/y'y
1 - t(e.m) %*% e.m / t(y.m) %*% y.m # Vemos que es igual a la tabla

# Ahora hagamos lo mismo, pero usando algebra "normal", no de matrices.

# Formula Estadistica
y_fit <- modelo.entero$fitted.values # Fitted es lo que predecimos

# Sum Square Error
SSE <- sum((y_fit - y.observado)^2) # Aqui restamos lo que predecimos ("y_fit") menos lo que observamos ("y), y despues sacamos el cuadrado de esos numeros, y despues sumamos todas esas diferencias cuadradas. Esta cantidad se llama "Sum Square Error", y es eso: la suma de todos los errores cuadrados.

# Sum Square Total
SST <- sum((y.observado - mean(y.observado))^2) # Despues calculamos el "Sum Square Total". Estos son los "errores" o desviaciones que tiene nuestra matriz "y", y tiene que ver con cuanto cada elemento en "y" se desvia del promedio de "y".

# r2
1-SSE/SST  # R^2, que es 1 menos SSE/SST
summary(modelo.entero)$r.squared # r2// Y que es esto mismo.

#################################################################
# r2: "Ajustado"
#################################################################

# Como dice King, el r2 es una funcion de los parametros (variables independientes).
# Mientras mas variables (o x's), mejor nuestro r2. Es por esto que
# es muy comun "mentir" en estadisticas: pones un monton de x's, y mejoras
# tu r2. Esto se ha llamado "kitchen-sink regression".

# Una manera de "arreglar" esto, es no mirar el r2, si no que el r2-ajustado.
# Este estadistico nos dice lo mismo que el r2, pero "ajusta" por el numero
# de x's que calculamos. En otras palabras, por cada parametro que calculamos,
# existe un "castigo".

# Recordemos nuestros r2's
summary(modelo.entero)$r.squared
summary(modelo.parcial)$r.squared
summary(modelo.mediocre)$r.squared

# Ahora calculemos el r(2)-ajustado
summary(modelo.entero)$adj.r.squared
summary(modelo.parcial)$adj.r.squared
summary(modelo.mediocre)$adj.r.squared

# Como ven, dice casi lo mismo, y el penalty es muy pequeno.

#################################################################
# Criticas al r2
#################################################################

# Sin embargo, pensemos por un momento en el r2 perfecto, y lo que
# tendriamos que hacer para lograrlo.

# (1) Que tendriamos que hacer para lograr un r2 = 1?
# (2) Es realmente bueno/posible?
# (3) Si no es el r2, que otra alternativa tenemos (paper de King)?


library(corrplot)
eates a mean table of a data_table, containing one column with the group
# and one ore more columns containg the data which should be averaged

#f_table= f_table_ori
f_table_ori = f_table
i_table =na.omit(f_table)
colnames(f_table)=c ("AA_id","AB_group","H_speeds","N_distance_traveled","M_#walks","D_angle_deviation","E_meander",
                     "F_thigmotaxis_moving", "G_thigmotasix_pause", "AC_stripe_deviation", "O_activitytime_DistT",
                     "K_act_bouts_DistT","C_pause_length_DistT","I_#pauses_DistT","P_activitytime_timeT",
                     "L_act_bouts_DtimeT","B_pause_length_timeT","J_#pauses_timeT","Z_linearity")
f_table2= f_table[,order(colnames(f_table))]

#f_table = f_table[1:(length(f_table)-9)]
h_table<-f_table2[,c(3:(length(f_table2)-1))]
rownames (h_table) = paste (c(1:length(f_table2[,1])),f_table2[,2])
#h_table<-f_table[,c(3:13,16:length(f_table))]
g_table <- na.omit(h_table)
 head(g_table)

cor.prob3 <- function(X, dfr = nrow(X) - 2) {
   R <- cor(X)
   T=R

   above <- row(R) < col(R)
   r2 <- R[above]^2
	 Fstat <- r2 * dfr / (1 - r2)
	 R[above] <-  pf(Fstat, 1, dfr)
   G = R[above]
   i = c(1:length(R[above]))
    G[i]=ifelse(R[above][i]>0.95 ,1,0)
    G[i]=ifelse(R[above][i]>0.99 ,1,G[i])
   R[above][i] =G[i]*T[above][i]
	 R
}

   #h_table<-f_table[,c(3:(length(f_table)))]
#rownames (h_table) = paste (c(1:length(f_table[,1])),f_table[,2])
##h_table<-f_table[,c(3:13,16:length(f_table))]
#g_table <- na.omit(h_table)

#f_table2 =na.omit(f_table2)

for(i in 1:length(levels((f_table2$AB_group)))){
  totest= f_table2[f_table2$AB_group==levels((f_table2$AB_group))[i],]
  totestdata= totest[,c(3:(length(totest)-1))]

  CORRMATRIX= cor.prob3 (totestdata)

  corrplot.number(CORRMATRIX, title=paste(levels((f_table2$AB_group))[i], "n=", nrow(totest)), diag=
    FALSE)
  corrplot.circle(CORRMATRIX, title=paste(levels((f_table2$AB_group))[i], "n=", nrow(totest)), diag=
    FALSE)

#   corrplot.circle(CORRMATRIX, title=paste(levels((f_table$group))[i]), diag=
#    FALSE)
  #CORRMATRIX2= cor (g_table[A:B,])
 # corrplot.circle(CORRMATRIX, title=paste("stripes",levels((f_table$group))[i]), order="alphabet")

}

#f_table= f_table_ori
#colnames(f_table)
#head(f_table)
#f_table_ori = f_table
f_table$thigmotaxisratio_total =NA
f_table$thigmotaxisratio_ditancetrav =NA
f_table= f_table[,c(1:7,9:10,12:17,19,21:length(f_table))]

#f_table = f_table[1:(length(f_table)-9)]
h_table<-f_table[,c(3:(length(f_table)))]
rownames (h_table) = paste (c(1:length(f_table[,1])),f_table[,2])
#h_table<-f_table[,c(3:13,16:length(f_table))]
g_table <- na.omit(h_table)

 head(g_table)
mydata.pca <- prcomp(g_table, retx= TRUE, center= TRUE, scale.=TRUE)

sd <- mydata.pca$sdev
loadings <- mydata.pca$rotation
rownames(loadings) <- colnames(g_table)
scores <- mydata.pca$x
PCA_res= data.frame(scores)

PCA_res$group = i_table[,2]

R <- cor(g_table)
myEig <- eigen(R)
sdLONG <- sqrt(myEig$values)
loadingsLONG <- myEig$vectors
rownames(loadingsLONG) <- colnames(g_table)
 standardize <- function(x) {(x - mean(x))/sd(x)}
 X <- apply(g_table, MARGIN=2, FUN=standardize)
# transforming data to zero mean and unit variance
 scoresLONG <- X %*% loadingsLONG
# calculating scores from eigenanalysis results

 range(sd - sdLONG)
 range(loadings - loadingsLONG)
 range(scores - scoresLONG)

#Plot PC1 and 2 info on one graph
PCA1to3 = data.frame(PCA_res$PC1,PCA_res$PC2,PCA_res$PC3,PCA_res$group)

Mean_PCA = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),1:2)

Mean_PCA2 = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),c(1,3))

 plot(scores[,1], scores[,2], xlab="PCA 1", ylab="PCA 2",
   type="n", main="distance biplot",xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
   ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))
   arrows(0,0,loadings[,1]*scalingfact,loadings[,2]*scalingfact, length=0.1,
   angle=20, col="red")
# note that this scaling factor of 10 may need to be changed,
# depending on the data set
 text(loadings[,1]*scalingfact*1.2,loadings[,2]*scalingfact*1.2,
   rownames(loadings), col="red", cex=0.7)
# 1.2 scaling insures that labels are plotted just beyond
# the arrows
# text(scores[,1],scores[,2], rownames(scores), col="blue",
#   cex=0.7)

plot(PCA_res$PC2~PCA_res$PC1, type= "n")
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	points(X$PC2~ X$PC1, col=i)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= i, bty="n", inset = c(0,i/30))
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,
#   cex=0.7)
   x=Mean_PCA$means$PCA_res.PC1[i]
y=Mean_PCA$means$PCA_res.PC2[i]
x2=Mean_PCA$ses$PCA_res.PC1[i]
y2=Mean_PCA$ses$PCA_res.PC2[i]
segments (x-x2,y,x+x2,y, col=i)
segments (x,y-y2,x,y+y2, col=i)
	}
	abline (v=0, h=0)

 plot(scores[,1], scores[,3], xlab="PCA 1", ylab="PCA 3",
   type="n", main="distance biplot",xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
   ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))
 arrows(0,0,loadings[,1]*scalingfact,loadings[,3]*scalingfact, length=0.1,
   angle=20, col="red")
# note that this scaling factor of 10 may need to be changed,
# depending on the data set
 text(loadings[,1]*scalingfact*1.2,loadings[,3]*scalingfact*1.2,
   rownames(loadings), col="red", cex=0.7)
# 1.2 scaling insures that labels are plotted just beyond
# the arrows
# text(scores[,1],scores[,2], rownames(scores), col="blue",
#   cex=0.7)

plot(PCA_res$PC3~PCA_res$PC1, type= "n")
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	points(X$PC3~ X$PC1, col=i)
	#legend(list(x=-6,y=-i/2+5), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,  cex=0.7)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= i, bty="n", inset = c(0,i/30))

   x=Mean_PCA2$means$PCA_res.PC1[i]
y=Mean_PCA2$means$PCA_res.PC3[i]
x2=Mean_PCA2$ses$PCA_res.PC1[i]
y2=Mean_PCA2$ses$PCA_res.PC3[i]
segments (x-x2,y,x+x2,y, col=i)
segments (x,y-y2,x,y+y2, col=i)
	}
	abline (v=0, h=0)

?symnum
cor.prob <- function(X, dfr = nrow(X) - 2) {
   R <- cor(X)
   above <- row(R) < col(R)
	 r2 <- R[above]^2
	 Fstat <- r2 * dfr / (1 - r2)
	 R[above] <-   pf(Fstat, 1, dfr)
	 R
}
cor.prob2 <- function(X, dfr = nrow(X) - 2) {
   R <- cor(X)
   T=R

	 above <- row(R) < col(R)
	 r2 <- R[above]^2
	 Fstat <- r2 * dfr / (1 - r2)
	 R[above] <-  pf(Fstat, 1, dfr)
   G = R[above]
   i = c(1:length(R[above]))
    G[i]=ifelse(R[above][i]>0.95 ,-0.5,0)
    G[i]=ifelse(R[above][i]>0.99 ,1,G[i])
   R[above] =G
	 R
}
cor.prob3 <- function(X, dfr = nrow(X) - 2) {
   R <- cor(X)
   T=R

   above <- row(R) < col(R)
	 r2 <- R[above]^2
	 Fstat <- r2 * dfr / (1 - r2)
	 R[above] <-  pf(Fstat, 1, dfr)
   G = R[above]
   i = c(1:length(R[above]))
    G[i]=ifelse(R[above][i]>0.95 ,1,0)
    G[i]=ifelse(R[above][i]>0.99 ,1,G[i])
   R[above][i] =G[i]*T[above][i]
	 R
}
#f_table= f_table_ori
   #h_table<-f_table[,c(3:(length(f_table)))]
#rownames (h_table) = paste (c(1:length(f_table[,1])),f_table[,2])
##h_table<-f_table[,c(3:13,16:length(f_table))]
#g_table <- na.omit(h_table)

scalingfact=75
X=0
for(i in 1:length(levels((i_table$group)))){
  A=X+1
  B=X+length(rownames(i_table[i_table$group==levels((i_table$group))[i],]))
  X=B
  CORRMATRIX= cor.prob3 (g_table[A:B,])
  mydata.pca <- prcomp(g_table[A:B,], retx= TRUE, center= TRUE, scale.=TRUE)
    sd <- mydata.pca$sdev
    loadings <- mydata.pca$rotation
    rownames(loadings) <- colnames(g_table[A:B,])
    scores <- mydata.pca$x
    PCA_res= data.frame(scores)

         plot(scores[,1], scores[,2], xlab="PCA 1", ylab="PCA 2",
      type="n", main=paste ("distance biplot",levels((f_table$group))[i] ),xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
      ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),axes = TRUE)
       for (k in c(1: nrow(loadings))){
  arrows(0,0,loadings[k,1]*scalingfact,loadings[k,2]*scalingfact, length=0.1,
      angle=20, col=k)
# note that this scaling factor of 10 may need to be changed,
# depending on the data set
      text(loadings[k,1]*scalingfact*1.2,loadings[k,2]*scalingfact*1.2,
      rownames(loadings)[k], col=k, cex=0.7)}

# 1.2 scaling insures that labels are plotted just beyond
# the arrows
# text(scores[,1],scores[,2], rownames(scores), col="blue",
#   cex=0.7)

     plot(scores[,1], scores[,3], xlab="PCA 1", ylab="PCA 3",
      type="n", main=paste ("distance biplot",levels((f_table$group))[i] ),xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
      ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))
  for (k in c(1: nrow(loadings))){
  arrows(0,0,loadings[k,1]*scalingfact,loadings[k,3]*scalingfact, length=0.1,
      angle=20, col=k)
# note that this scaling factor of 10 may need to be changed,
# depending on the data set
      text(loadings[k,1]*scalingfact*1.2,loadings[k,3]*scalingfact*1.2,
      rownames(loadings)[k], col=k, cex=0.7)
}
# 1.2 scaling insures that labels are plotted just beyond
# the arrows
# text(scores[,1],scores[,2], rownames(scores), col="blue",
#   cex=0.7)

  #corrplot.circle(CORRMATRIX, title=paste("stripes",levels((f_table$group))[i]), diag=
  #  FALSE)
  #CORRMATRIX2= cor (g_table[A:B,])
 # corrplot.circle(CORRMATRIX, title=paste("stripes",levels((f_table$group))[i]), order="hclust")

}
setwd(rgghome)

#########################################################
#######################################################
#setwd(outputpath)
#pdf("correlation3.pdf")

# ##old
# #f_table = f_table[1:(length(f_table)-9)]
# h_table<-f_table[,c(3:(length(f_table)))]
# rownames (h_table) = paste (c(1:length(f_table[,1])),f_table[,2])
# #h_table<-f_table[,c(3:13,16:length(f_table))]
# g_table <- na.omit(h_table)
#  head(g_table)
# mydata.pca <- prcomp(g_table, retx= TRUE, center= TRUE, scale.=TRUE)
#
#
#
# sd <- mydata.pca$sdev
# loadings <- mydata.pca$rotation
# rownames(loadings) <- colnames(g_table)
# scores <- mydata.pca$x
#
# R <- cor(g_table)
# myEig <- eigen(R)
# sdLONG <- sqrt(myEig$values)
# loadingsLONG <- myEig$vectors
# rownames(loadingsLONG) <- colnames(g_table)
#  standardize <- function(x) {(x - mean(x))/sd(x)}
#  X <- apply(g_table, MARGIN=2, FUN=standardize)
# # transforming data to zero mean and unit variance
#  scoresLONG <- X %*% loadingsLONG
# # calculating scores from eigenanalysis results
#
#  range(sd - sdLONG)
#  range(loadings - loadingsLONG)
#  range(scores - scoresLONG)
#
# scalingfact=80
# scalingaxis=7
# plot.new()
#  plot(scores[,1], scores[,2], xlab="PCA 1", ylab="PCA 2",
#    type="n", main="distance biplot",xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
#    ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))
#    arrows(0,0,loadings[,1]*scalingfact,loadings[,2]*scalingfact, length=0.1,
#    angle=20, col="red")
# # note that this scaling factor of 10 may need to be changed,
# # depending on the data set
#  text(loadings[,1]*scalingfact*1.2,loadings[,2]*scalingfact*1.2,
#    rownames(loadings), col="red", cex=0.7)
# # 1.2 scaling insures that labels are plotted just beyond
# # the arrows
# # text(scores[,1],scores[,2], rownames(scores), col="blue",
# #   cex=0.7)
#
#
#  plot(scores[,1], scores[,3], xlab="PCA 1", ylab="PCA 3",
#    type="n", main="distance biplot",xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
#    ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))
#  arrows(0,0,loadings[,1]*scalingfact,loadings[,3]*scalingfact, length=0.1,
#    angle=20, col="red")
# # note that this scaling factor of 10 may need to be changed,
# # depending on the data set
#  text(loadings[,1]*scalingfact*1.2,loadings[,3]*scalingfact*1.2,
#    rownames(loadings), col="red", cex=0.7)
# # 1.2 scaling insures that labels are plotted just beyond
# # the arrows
# # text(scores[,1],scores[,2], rownames(scores), col="blue",
# #   cex=0.7)
#
#
#
#  biplot(scores[,1:2], loadings[,1:2], xlab=rownames(scores),
#    ylab=rownames(loadings), cex=0.7, main="distance biplot using built-in biplot function")
# # using built-in biplot function : not working here??
#
# #correlation biplot
#
#  plot(scores[,1]/sd[1], scores[,3]/sd[3], xlab="PCA 1",
#    ylab="PCA 3", type="n", main ="correlation biplot")
#  arrows(0,0,loadings[,1]*sd[1],loadings[,3]*sd[3],
#
#    length=0.1, angle=20, col="red")
#  text(loadings[,1]*sd[1]*1.2,loadings[,3]*sd[3]*1.2,
#    rownames(loadings), col="red", cex=0.7)
#  text(scores[,1]/sd[1],scores[,3]/sd[3], rownames(scores),
#    col="blue", cex=0.7)
# # 1.2 scaling insures that labels are plotted just beyond
# # the arrows
#   plot(scores[,2]/sd[2], scores[,3]/sd[3], xlab="PCA 2",
#    ylab="PCA 3", type="n", main ="correlation biplot")
#  arrows(0,0,loadings[,2]*sd[2],loadings[,3]*sd[3],
#
#    length=0.1, angle=20, col="red")
#  text(loadings[,2]*sd[2]*1.2,loadings[,3]*sd[3]*1.2,
#    rownames(loadings), col="red", cex=0.7)
#  text(scores[,2]/sd[2],scores[,3]/sd[3], rownames(scores),
#    col="blue", cex=0.7)
# # 1.2 scaling insures that labels are plotted just beyond
# # the arrows
#
#  plot(scores[,1]/sd[1], scores[,2]/sd[2], xlab="PCA 1",
#    ylab="PCA 2", type="n", main ="correlation biplot")
#  arrows(0,0,loadings[,1]*sd[1],loadings[,2]*sd[2],
#
#    length=0.1, angle=20, col="red")
#  text(loadings[,1]*sd[1]*1.2,loadings[,2]*sd[2]*1.2,
#    rownames(loadings), col="red", cex=0.7)
#  text(scores[,1]/sd[1],scores[,2]/sd[2], rownames(scores),
#    col="blue", cex=0.7)
# # 1.2 scaling insures that labels are plotted just beyond
# # the arrows
#
#
#  biplot(mydata.pca, main ="using biplot pcaresult")
#
#  #analysis
# correlations <- cor(scores,g_table)
# plot(mydata.pca, main= "PCA analysis")
# plot(log(sd^2), xlab="principle component",
#    ylab="log(variance)", type="b", pch=16)
# # using a general plot, with variance on a log scale
#
#  newsd <- sd(scores)
#  max (sd - newsd)
# # finds maximum difference between the standard deviation form
# # prcomp and the standard deviation calculated longhand;
# # should be close to zero
#  eigenvalues <- sd^2
#  sum(eigenvalues)
# # should equal number of variables
# length(g_table)
# # number of variables
#
#
#
#
# PCA_res= data.frame(scores)
# class(PCA_res)
# PCA_res$PC1
# i_table =na.omit(f_table)
# PCA_res$group = i_table[,2]
#
# plot.new()
# #Plot PC1 and 2 info on one graph
# PCA1to3 = data.frame(PCA_res$PC1,PCA_res$PC2,PCA_res$PC3,PCA_res$group)
#
# Mean_PCA = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),1:2)
#
# Mean_PCA2 = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),c(1,3))
#
# setwd(outputpath)
# scalingfact=70
# scalingaxis=7


## Test correctness ------------------------------------------------------------

act <- seq(50)
pred <- act + 1

expect_equal(
    mtr_explained_variance(act, pred),
    target = 1
)

expect_equal(
    mtr_mean_squared_error(act, pred),
    target = 1
)

expect_equal(
    mtr_root_mean_squared_error(act, pred),
    target = 1
)

expect_equal(
    mtr_mean_squared_log_error(act, pred),
    mtr_mean_squared_error(log1p(act), log1p(pred))
)

expect_equal(
    mtr_mean_absolute_error(act, pred),
    target = 1
)

expect_equal(
    mtr_median_absolute_error(act, pred),
    target = 1
)

expect_equal(
    mtr_max_error(act, pred),
    target = 1
)

expect_equal(
    mtr_r2(act, pred),
    target = 0.9951981,
    tol = 1e-7
)

## Test exception --------------------------------------------------------------

expect_warning(mtr_r2(1, 0))


mad = function(x, constant=1.5, levels=c("low", "mid", "high")) {
    med = median(x, na.rm=TRUE)
    delta = stats::mad(x, constant=constant, na.rm=TRUE)
    re = factor(cut(x, c(-Inf, med-delta, med+delta, Inf)))
    levels(re) = levels
    re
}

quantile = function(x, levels=c("low", "mid", "mid", "high")) {
    probs = c(0, seq_along(levels)/length(levels))
    re = factor(cut(x, c(-Inf, stats::quantile(x, probs=probs, na.rm=TRUE))))
    levels(re) = c(levels[1], levels, levels[length(levels)])
    re
}

sd = function(x, constant=1, levels=c("low", "mid", "high")) {
    med = median(x, na.rm=TRUE)
    sd = stats::sd(x, na.rm=TRUE) * constant
    re = factor(cut(x, c(-Inf, med-sd, med+sd, Inf)))
    levels(re) = levels
    re
}


library(markovchain)

age<-seq(from = 30,  to = 50, by=1)
ProbA2U<-seq(0.0006,0.0060,length.out = 21)
ProbA2D<-seq(0.0005,0.0020,length.out = 21)
ProbA2A<-1-(ProbA2U+ProbA2D)
ProbU2A<-seq(0,0,length.out = 21)
ProbU2D<-seq(0.1219,0.1879,length.out = 21)
ProbU2U<-1-(ProbU2A+ProbU2D)
ProbD2A<-seq(0,0,length.out = 21)
ProbD2U<-seq(0,0,length.out = 21)
ProbD2D<-1-(ProbD2A+ProbD2U)
DecrementsTable<- data.frame(age,ProbA2A,ProbA2U,ProbA2D,ProbU2A,ProbU2U,ProbU2D,ProbD2A,ProbD2U,ProbD2D)

str(DecrementsTable)
summary(DecrementsTable)
head(DecrementsTable)

WorkesStates<-c("Active","Unable","Dead")

TransMatrix35<-matrix(as.numeric(DecrementsTable[DecrementsTable$age==35,2:10]),nrow = 3,ncol = 3, byrow = TRUE,
                      dimnames = list(WorkesStates, WorkesStates))

MCModel35<-new("markovchain", transitionMatrix = TransMatrix35, states = WorkesStates, name="MCModel35")

MCModel35

states(MCModel35)
dim(MCModel35)
str(MCModel35)
MCModel35@transitionMatrix
absorbingStates(MCModel35)

set.seed(5)

WorkerStatePred35<- rmarkovchain(n = 1000, object = MCModel35, t0 ="Active")
table(WorkerStatePred35)

TransMatrix50<-matrix(as.numeric(DecrementsTable[DecrementsTable$age==50,2:10]),nrow = 3,ncol = 3, byrow = TRUE,
                      dimnames = list(WorkesStates, WorkesStates))
MCModel50<-new("markovchain", transitionMatrix = TransMatrix50, states = WorkesStates, name="MCModel50")

WorkerStatePred50<- rmarkovchain(n = 1000, object = MCModel50, t0 ="Active")
table(WorkerStatePred50)

MCModelsList=list()
j=1
for(i in 30:50){
  TransMatrix<-matrix(as.numeric(DecrementsTable[DecrementsTable$age==i,2:10]),nrow = 3,ncol = 3, byrow = TRUE,
                           dimnames = list(WorkesStates, WorkesStates))

  MCModelsList[[j]]<-new("markovchain", transitionMatrix = TransMatrix, states = WorkesStates)
  j=j+1
}

MCList30to50<-new("markovchainList", markovchains = MCModelsList,name="MCList30to50")

StatesSequence<-rmarkovchain(n=10000, object=MCList30to50,t0="Active")
str(StatesSequence)
StatesOccurences<-table(StatesSequence$value)
ExpectedUnableOccurence<-StatesOccurences[3]/nrow(StatesSequence)
ExpectedUnableOccurence


# --- Видове данни
# - Категориини - цвят на коса, цват на очи, марка кола
# - Числови - разделят се на дискретни и непрекъснати
#    - Дискретни - годините на хората (20, 25, 30), колко тежиш и т.н.
#    - Непрекъснати - височината на хората - 1.60, 167, 170

# --- Методи за преглеждане на данните
# - Категориини данни
cars <- c('Audi', 'Mercedess', 'BMW', 'VW', 'Audi', 'Audi', 'VW', 'BMW')
table(cars)
prop.table(cars, 1)

# bar graphs
# pie charts

# - Числови данни
summary()
fivenum()

# ----
# Add new elements to vector
v12 = c(v1, v2)
v1other = c(v1, c(1, 2, 3))

# Check type of vector
str(c(1, 2, 'p'))
typeof(c(1, 2, 'p')) # casted all elements to character
typeof(c(1, 2)) # all elements are double

# Convert strings to dates
v3 = as.Date(c("2015-01-01", "2016-07-08"))

# Operations with matrices
# Which date frames ex2
# Чертаене на хистограма - ex2
# table и prop.table


library(nloptr)

fit = function(cases, window=7, lags=7, omega) {
  #Contructs de R with thompson method... (Cori et al)
  priorRate=2
  priorShape=1
  initialVector=cases[1:lags]

  omega_matrix=matrix(0,length(cases)-lags,lags)
  for(i in 1:length(cases)-lags){
    for(j in 1:lags){
      omega_matrix[i,j] = omega(i, j)
    }
  }

  infectPotential_T=matrix(0,length(cases)-lags,1)
  for(i in 1:dim(infectPotential_T)[1]){
    infectPotential_T[i]=sum(cases[i:(i+lags-1)]*rev(omega_matrix[i,]))
  }
  #Seriel interval times observed cases, there are lags values
  # computing denominatortofequation 4?
  casesMatrix=matrix(0,length(infectPotential_T)-(window-1),window)
  for(i in 1:dim(casesMatrix)[1]){
    casesMatrix[i,]=infectPotential_T[i:(i+window-1)]
  }
  #doble suma ecuacion 7
  infectPotential=casesMatrix%*%matrix(1,window,1)

  #Generate observation Matrix
  postcasesMatrix=matrix(0,length(cases)-(window-1),window)
  for(i in 1:dim(postcasesMatrix)[1]){
    postcasesMatrix[i,]=cases[i:(i+window-1)]
  }

  #suma iw(t) se supone esto es Poisson
  infectObservados=postcasesMatrix%*%matrix(1,window,1)

  betaParameteres=cbind(priorShape, priorRate)

  for(i in 1:dim(casesMatrix)[1]){
    shape1=priorShape+infectObservados[i]
    rate1=priorRate+infectPotential[i]
    betaParameteres=rbind(betaParameteres,cbind(shape1, rate1))
  }
  shape1=betaParameteres[-1,1]
  rate1=betaParameteres[-1,2]

  lb=qgamma(0.05, shape=shape1, rate=rate1)
  ub=qgamma(0.95, shape=shape1, rate=rate1)
  beta=((shape1-1)/rate1)
  for(i in 1:window){
    lb=c(lb[1],lb)
    ub=c(ub[1],ub)
    beta=c(beta[1],beta)
  }

  data=cbind(lb, beta,ub)
  data=as.data.frame(data)
  data$day=1:length(lb)
  print(data$beta)
  data$R=data$beta*sum(omega_matrix[1,])
  data$Rlb=data$lb*sum(omega_matrix[1,])
  data$Rub=data$ub*sum(omega_matrix[1,])

  #R_Caso
  lb=data$lb
  ub=data$ub
  beta=data$beta
  longCaseslb=c(rep(lb[1], length=lags-1),lb)
  longCasesub=c(rep(ub[1], length=lags-1),ub)
  longCasesbeta=c(rep(beta[1], length=lags-1),beta)

  data$R_c=data$beta*sum(omega_matrix[1,])
  data$R_clb=data$lb*sum(omega_matrix[1,])
  data$R_cub=data$ub*sum(omega_matrix[1,])

  for(i in 1:length(lb)){
    data$R_c[i]=sum(longCasesbeta[i:(i+lags-1)]*omega_matrix[1,])
    data$R_clb[i]=sum(longCaseslb[i:(i+lags-1)]*omega_matrix[1,])
    data$R_cub[i]=sum(longCasesub[i:(i+lags-1)]*omega_matrix[1,])
  }
  return(data)
}

fit2 = function(I, window=7, prior_shape, prior_rate, omega) {
  "
  Unvectorized model fitting.
  "
  steps = length(I)
  mode = rep(NaN, window + 1)
  lb = rep(NaN, window + 1)
  ub = rep(NaN, window + 1)
  for (t in (window + 1):steps) {
    shape = prior_shape + sum(I[(t - window):t])
    # solve rate iteratively
    rate = prior_rate
    for (t_prime in (t - window):t) {
      for (tau in 1:(t_prime - 1)) {
        rate = rate + (omega[tau] * I[t_prime - tau])
      }
    }
    mode = c(mode, (shape - 1)/rate)
    lb = c(lb, qgamma(0.05, shape=shape, rate=rate))
    ub = c(ub, qgamma(0.95, shape=shape, rate=rate))
  }
  R = list("mode"=mode, "lb"=lb, "ub"=ub)
  return(R)
}

fit3 = function(I, window=7, prior_shape, prior_rate, omega) {
  "
  Like fit2, but omega is a function of (t, tau).
  "
  steps = length(I)
  mode = rep(NaN, window)
  for (t in window:steps) {
    shape = prior_shape + sum(I[(t - window):t])
    # solve rate iteratively
    rate = prior_rate
    for (t_prime in (t - window):t) {
      for (tau in 1:(t_prime - 1)) {
        rate = rate + (omega(t, tau) * I[t_prime - tau])
      }
    }
    mode = c(mode, (shape - 1)/rate)
  }
  R = list("mode"=mode)
  return(R)
}


#' Calculates the match value of an input to a category.
#'
#' This function returns a value which represents the amount of match
#' between the given input and the given category.
#' @title ART_Calculate_Match
#' @param input Vector of size NumFeatures that contains the input signal into the network
#' @param weightVector Matrix of size NumFeatures which holds the weights of the network for a given category
#' @return Measure of the degree of match between the input and the current category
#' @details The length of the INPUT vector must equal the length of the WEIGHTVECTOR.
#'
ART_Calculate_Match = function(input, weightVector)
{
  # Initialize the local variables.
  match = 0;
  numFeatures = length(input);

  # Make sure the weight vector is appropriate for the input.
  if(numFeatures != length(weightVector))
  {
    stop('The input and weight vector lengths do not match.');
  }

  # Calculate the match between the given input and weight vector.
  # This is done according to the following equation:
  #       Match = |Input^WeightVector| / |Input|
  matchVector = pmin(input, weightVector);
  inputLength = sum(input);
  if(inputLength == 0)
  {
    match = 0;
  }
  else
  {
    match = sum(matchVector) / inputLength;
  }
  return (match);
}


#!/usr/bin/env Rscript

tms <- read.csv("benchmark/uri_counting_time.csv", header=T)
x <- tms$size
y <- tms$time/60
fit <- lm(y~x)
xx <- seq(0,260, length=100)

png("benchmark/cdx-transformation-analysis.png", height=600, width=800, pointsize=18)

plot(x,y, xlim=c(0, 260), ylim=c(0, 500), ylab="Time (Minutes)", xlab="CDX Size (GB)")
lines(xx, predict(fit, data.frame(x=xx)), col="red")

dev.off()

print(summary(fit))


#---------- Partie avec les graphes -------------#
temp_maximale=data_80_14$`Temp?rature maximale`
temp_moy=data_80_14$`Temp?rature moyenne`

#Corr?lation entre les 3 variables de temp?rature, pour l'?chantillon 1
plot(data_80_14$temp_minimale,
     type="l",
     # 2.
     main="Corr?lation entre les 3 variables statistiques",
     # 3.
     xlab="Nombre de mesures",
     ylab="Temp?rature (Farhenheit)",
     col="blue"
)
lines(temp_maximale, type="l",col="red")
lines(temp_moy, type="l",col="green")
legend("bottomleft", legend = c("Temp?rature minimale", "Temp?rature moyenne", "Temp?rature maximale"),
       col = c("blue", "green", "red"), lty = 1:2, cex = 0.8)

#Corr?lation entre les 3 variables de temp?rature, pour l'?chantillon 2
plot(data_15_19$temp_minimale,
     type="l",
     # 2.
     main="Corr?lation entre les 3 variables statistiques",
     # 3.
     xlab="Nombre de mesures",
     ylab="Temp?rature (Farhenheit)",
     col="blue"
)
lines(data_15_19$`Temp?rature maximale`, type="l",col="red")
lines(data_15_19$`Temp?rature moyenne`, type="l",col="green")
legend("bottomleft", legend = c("Temp?rature minimale", "Temp?rature moyenne", "Temp?rature maximale"),
       col = c("blue", "green", "red"), lty = 1:2, cex = 0.8)

#Comparaison des moyennes entre les 2 ?chantillons
plot(moy_min_1,
     type="b",
     # 2.
     main="Comparaison des moyennes entre les 2 ?chantillons",
     # 3.
     ylab="Temp?rature (Farhenheit)",
     col="red",
     ylim = c(10, 70)
)

lines(moy_moyenne_1, type="b",col="red")
lines(moy_max_1, type="b",col="red")
lines(moy_min_2, type="b",col="blue")
lines(moy_moyenne_2, type="b",col="blue")
lines(moy_max_2, type="b",col="blue")
legend("bottomleft", legend = c("Moyennes sur ?chantillon 1", "Moyennes sur ?chantillon 2"),
       col = c("red", "blue"), lty = 1:2, cex = 0.8)

#Comparaison des ?carts type entre les 2 ?chantillons
plot(sigma_min_1,
     type="b",
     # 2.
     main="Comparaison des ?carts type entre les 2 ?chantillons",
     # 3.
     ylab="Temp?rature (Farhenheit)",
     col="red",
     ylim = c(10, 20)
)

lines(sigma_moy_1, type="b",col="red")
lines(sigma_max_1, type="b",col="red")
lines(sigma_min_2, type="b",col="blue")
lines(sigma_moy_2, type="b",col="blue")
lines(sigma_max_2, type="b",col="blue")
legend("bottomleft", legend = c("Moyennes sur ?chantillon 1", "Moyennes sur ?chantillon 2"),
       col = c("red", "blue"), lty = 1:2, cex = 0.8)


## pvalue vs uniform

## from: https://genome.sph.umich.edu/wiki/Code_Sample:_Generating_QQ_Plots_in_R
## A Fancier QQ Plot by Matthew Flickinger
## sample usage
## qqunif.plot(my.pvalues) #these are the raw p-values, not log-transformed
library(lattice)
qqunif.plot<-function(pvalues,
                      should.thin=T, thin.obs.places=2, thin.exp.places=2,
                      xlab=expression(paste("Expected (",-log[10], " p-value)")),
                      ylab=expression(paste("Observed (",-log[10], " p-value)")),
                      draw.conf=TRUE, conf.points=1000, conf.col="lightgray", conf.alpha=.05,
                      already.transformed=FALSE, pch=20, aspect="iso", prepanel=prepanel.qqunif,
                      par.settings=list(superpose.symbol=list(pch=pch)), ...) {

  #error checking
  if (length(pvalues)==0) stop("pvalue vector is empty, can't draw plot")
  if(!(class(pvalues)=="numeric" ||
       (class(pvalues)=="list" && all(sapply(pvalues, class)=="numeric"))))
    stop("pvalue vector is not numeric, can't draw plot")
  if (any(is.na(unlist(pvalues)))) stop("pvalue vector contains NA values, can't draw plot")
  if (already.transformed==FALSE) {
    if (any(unlist(pvalues)==0)) stop("pvalue vector contains zeros, can't draw plot")
  } else {
    if (any(unlist(pvalues)<0)) stop("-log10 pvalue vector contains negative values, can't draw plot")
  }

  grp<-NULL
  n<-1
  exp.x<-c()
  if(is.list(pvalues)) {
    nn<-sapply(pvalues, length)
    rs<-cumsum(nn)
    re<-rs-nn+1
    n<-min(nn)
    if (!is.null(names(pvalues))) {
      grp=factor(rep(names(pvalues), nn), levels=names(pvalues))
      names(pvalues)<-NULL
    } else {
      grp=factor(rep(1:length(pvalues), nn))
    }
    pvo<-pvalues
    pvalues<-numeric(sum(nn))
    exp.x<-numeric(sum(nn))
    for(i in 1:length(pvo)) {
      if (!already.transformed) {
        pvalues[rs[i]:re[i]] <- -log10(pvo[[i]])
        exp.x[rs[i]:re[i]] <- -log10((rank(pvo[[i]], ties.method="first")-.5)/nn[i])
      } else {
        pvalues[rs[i]:re[i]] <- pvo[[i]]
        exp.x[rs[i]:re[i]] <- -log10((nn[i]+1-rank(pvo[[i]], ties.method="first")-.5)/(nn[i]+1))
      }
    }
  } else {
    n <- length(pvalues)+1
    if (!already.transformed) {
      exp.x <- -log10((rank(pvalues, ties.method="first")-.5)/n)
      pvalues <- -log10(pvalues)
    } else {
      exp.x <- -log10((n-rank(pvalues, ties.method="first")-.5)/n)
    }
  }

  #this is a helper function to draw the confidence interval
  panel.qqconf<-function(n, conf.points=1000, conf.col="gray", conf.alpha=.05, ...) {
    require(grid)
    conf.points = min(conf.points, n-1);
    mpts<-matrix(nrow=conf.points*2, ncol=2)
    for(i in seq(from=1, to=conf.points)) {
      mpts[i,1]<- -log10((i-.5)/n)
      mpts[i,2]<- -log10(qbeta(1-conf.alpha/2, i, n-i))
      mpts[conf.points*2+1-i,1]<- -log10((i-.5)/n)
      mpts[conf.points*2+1-i,2]<- -log10(qbeta(conf.alpha/2, i, n-i))
    }
    grid.polygon(x=mpts[,1],y=mpts[,2], gp=gpar(fill=conf.col, lty=0), default.units="native")
  }

  #reduce number of points to plot
  if (should.thin==T) {
    if (!is.null(grp)) {
      thin <- unique(data.frame(pvalues = round(pvalues, thin.obs.places),
                                exp.x = round(exp.x, thin.exp.places),
                                grp=grp))
      grp = thin$grp
    } else {
      thin <- unique(data.frame(pvalues = round(pvalues, thin.obs.places),
                                exp.x = round(exp.x, thin.exp.places)))
    }
    pvalues <- thin$pvalues
    exp.x <- thin$exp.x
  }
  gc()

  prepanel.qqunif= function(x,y,...) {
    A = list()
    A$xlim = range(x, y)*1.02
    A$xlim[1]=0
    A$ylim = A$xlim
    return(A)
  }

  #draw the plot
  xyplot(pvalues~exp.x, groups=grp, xlab=xlab, ylab=ylab, aspect=aspect,
         prepanel=prepanel, scales=list(axs="i"), pch=pch,
         panel = function(x, y, ...) {
           if (draw.conf) {
             panel.qqconf(n, conf.points=conf.points,
                          conf.col=conf.col, conf.alpha=conf.alpha)
           };
           panel.xyplot(x,y, ...);
           panel.abline(0,1);
         }, par.settings=par.settings, ...
  )
}

qqunif =
function(p,BH=T,CI=T,...)
{
  p=na.omit(p)
  nn = length(p)
  xx =  -log10((1:nn)/(nn+1))
  plot( xx,  -sort(log10(p)),
     xlab=expression(Expected~~-log[10](italic(p))),
        ylab=expression(Observed~~-log[10](italic(p))),
       cex.lab=1.4,mgp=c(2,1,0),
       ... )
  abline(0,1,col='gray')
  if(BH)
    {
      abline(-log10(0.05),1, col='red',lty=1)
      abline(-log10(0.10),1, col='orange',lty=2)
      abline(-log10(0.25),1, col='yellow',lty=3)
      legend('bottomright', c("FDR = 0.05","FDR = 0.10","FDR = 0.25"),
             col=c('red','orange','yellow'),lty=1:3, cex=1)
      abline(h=-log10(0.05/nn)) ## bonferroni
    }
  if(CI)
  {
    ## create the confidence intervals
    c95 <- rep(0,nn)
    c05 <- rep(0,nn)
    ## the jth order statistic from a
    ## uniform(0,1) sample
    ## has a beta(j,n-j+1) distribution
    ## (Casella & Berger, 2002,
    ## 2nd edition, pg 230, Duxbury)
    ## this portion was posted by anonymous on
    ## http://gettinggeneticsdone.blogspot.com/2009/11/qq-plots-of-p-values-in-r-using-ggplot2.html

    for(i in 1:nn)
    {
      c95[i] <- qbeta(0.95,i,nn-i+1)
      c05[i] <- qbeta(0.05,i,nn-i+1)
    }

    lines(xx,-log10(c95),col='gray')
    lines(xx,-log10(c05),col='gray')
  }
}

## to add other qqplots on top of current plot

qqpoints=
function(p,BH=T,...)
{
  nn = length(p)
  xx =  -log10((1:nn)/(nn+1))
  points( xx,  -sort(log10(p)), ... )
}

## to use with dplyr's pipes

qqunif.pipe = function(data,...){
  pval = data$pval
  qqunif(pval,...)
}

qqunif.compare = function(pvec1,pvec2,pthres=NULL,...)
{
  pvec1 = na.omit(pvec1)
  pvec2 = na.omit(pvec2)
  if(!is.null(pthres)) {pvec1 = pmax(pvec1,pthres); pvec2 = pmax(pvec2,pthres)}
  qqunif(pvec1,...)
  qqpoints(pvec2,col='blue',pch='+')
  abline(h=-log10(0.05/length(pvec2)),col='blue',lw=2)
}


#' Yang's network tomography data
#'
#' Simulated traffic counts on Yang's (1995) network. The aim is to sample the corresponding origin-destination traffic volumes that are consistent with those counts.
#' The dataset appears as a list prepared for that purpose.
#' Components of the list are A (the configuration matrix, which in this case is the link-path incidence matrix); y (observed traffic counts); lambda (assumed mean origin-destination traffic volumes);
#' and MarkovBasis (a matrix with columns corresponding to the vectors in full Markov basis for the resampling problem).
#'
#' @references Yang, H. (1995). Heuristic algorithms for the bilevel origin-destination matrix estimation problem. Transportation Research Part B: Methodological, 29(4), 231-242.
#'
#' @docType data
#'
#' @usage data(YangNetwork)
#' @export
#' @examples
#' data(YangNetwork)
#' Xsampler(A=YangNetwork$A,y=YangNetwork$y,lambda=YangNetwork$lambda,Model="Poisson",Method="Gibbs",tune.par=0.5,combine=TRUE)
"YangNetwork"


#RESUMEN R

#CLASE 9
#EJEMPLO DISEÑO WEB

diseweb <- read.csv("C:/Users/Milagros/Desktop/exp numerica/datos_ejemplo_disenoweb.csv")
head(diseweb)
# ANOVA es para comparar igualdad de medias para 2 o mas grupos
# antes que nada  se realiza barlett para comparar  la igualdad de varianzas
# porque ANOVA necesita igualdad de varianzas
# Cuando las varianzas son distintas se utiliza Kruskal para comparar medianas
# Sin embargo como son  muestras relacionadas kruskal no nos da buenos resultados para poder
# concluir diferencia en las medianas, Kruskal sirve para muestras independientes.
kruskal.test(puntuacion~tipodiseno,diseweb)
# entonces utilizamos friedman
friedman.test(puntuacion~tipodiseno|jurado,diseweb)

#EJERCICIO CAFE

f <- read.csv(choose.files())
f
head(f)
#hipotesis

# h0= las medianas de los distintos tipos de cafe son iguales
# h1= al menos una de las medianas es diferente
# quito la columna de expertos que solo es numeros
f<-f[,-1]
f
#creo una columna de expertos con etiquetas mas entendibles
paste0("Experto_", rownames(f));
#transformo el set de datos  para que sea una matriz  que pueda recibir el test
f2 <-reshape(f,ids=rownames(f),times=(names(f)),timevar="tipocafe",varying=list(names(f)),direction="long")
head(f2)
names(f2)<-c("tipocafe","puntuacion","experto")
#realizamos el test
friedman.test(puntuacion~tipocafe|experto,f2)
# conclusion:
# Como el p value es menor que el nivel de significancia (alpha)
# se rechaza la hipotesis nula
# podemos concluir que a un nivel de confianza de 0.95 se puede afirmar que al menos uno de los
# tipos de cafe tiene una puntuacion mediana diferente

#CAPITULO 11

# ejercicio Relajacion muscular

# diseño experimental: completamente al azar (DCA)
# unidad Experimental: Un paciente
# variable respuesta: tiempo de la duracion de la relajacion muscular
# factor en estudio: las distintas drogas
# niveles del factor: sin droga, innovar, droperidol, fentayl
# tratamientos:sin droga, innovar, droperidol, fentayl
# Factores: de bloqueo
# Covariable: No existe

# EJERCICIO DIETAS ANIMALES coagulacion
A <- c(62,60,63,59)
B <- c(63,67,71,64,65,66)
C <- c(68,66,71,67,68,68)
D <- c(56,62,60,61,63,64,63,59)

resultado <- c(A,B,C,D)
dietas <- c(rep("A",length(A)),
            rep("B",length(B)),
            rep("C",length(C)),
            rep("D",length(D)))

misdatos <- data.frame(dietas,resultado)
# un pequeño grafico
boxplot(resultado~dietas,misdatos, main="Tiempo de coagulaciÃ³n de la sangre segun dieta", ylab="Tiempo (segundos)")

# ANOVA Siempre se usa
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)
# se rechaza la hipotesis nula y acepto h1, entonces concluimos que almenos una tiene media diferente
# media general
mu.est <- mean(misdatos$resultado)
#aplicar media por grupos
mean_treatment <-  aggregate(resultado~dietas,misdatos,mean)
#diferencia media por grupos y media global
effect_treatment <-  aggregate(resultado~dietas,misdatos,function(x){mean(x)-mu.est})
mu.est
effect_treatment

# Treatment Effect with a reference Level
# mide los efectos respecto a un nivel, en este caso el nivel A
round(coefficients(anova1),2)

# Changing Reference Level
# en este caso el nivel B
misdatos$dietas <- relevel(misdatos$dietas,ref="B")
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)
round(coefficients(anova1),2)
# como se puede ver la media de tiempos del nivel a respecto al B es 5 minutos menos
# la media del nivel C es 2 minutos mas y la media del nivel D es 5 minutos menos

#EJERCICIO BACTERIA
res <- c(13,16,5,22,24,4,18,17,1,39,44,22)
factor <- c(1,2,3,1,2,3,1,2,3,1,2,3)
bloque <- c(1,1,1,2,2,2,3,3,3,4,4,4)

midata <- data.frame(factor,bloque,res)

#graficos
boxplot(res~factor,midata, main="Retardo en el crecimiento de bacterias",
        ylab="Tiempo (segundos)",
        xlab="Factor: Soluciones de lavado")
boxplot(res~bloque,midata, main="Retardo en el crecimiento de bacterias",
        ylab="Tiempo (segundos)",
        xlab="Bloques: Dias")

#graficos
interaction.plot(midata$factor,midata$bloque,midata$res,
                 xlab="Factor: Soluciones de lavado",
                 ylab="Tiempo (segundos)",
                 leg.legend="Bloque")

#Annova
anova3 <- aov(res~as.factor(factor)+as.factor(bloque),midata)
summary(anova3)

#reformulo la data con dos factores
midata <- data.frame(factor=as.factor(factor),bloque=as.factor(bloque),res)
anova1 <- aov(res~factor+bloque,midata)
summary(anova1)

# global Effect and Treatment Effect
#Ver diferencia de medias entre cada factor
mu.est <- mean(midata$res)
mean_treatment <-  aggregate(res~factor,midata,mean)
effect_treatment <-  aggregate(res~factor,midata,function(x){mean(x)-mu.est})
effect_block <-  aggregate(res~bloque,midata,function(x){mean(x)-mu.est})
mu.est
effect_treatment
effect_block

#Effects with control treatment
#Ver diferencias de medias respecto un nivel
round(coefficients(anova1),4)

#EJERCICIO GASOLINA
# h0 : T1=t2=T3=t4=t5=0
# h1 : al menos un Ti <>0

data5 <- read.csv(choose.files())
data5

anova4 <- aov(res~as.factor(factor)+as.factor(bloque),data5)
summary(anova4)

#Con un nivel de confianza del 95% se puede concluir que al menos
#un tipo de gasolina tienen un efecto distinto en el rendimiento del carro

#CAPITULO 12

#Ejercicio Voltaje

midata <- read.csv("C:/Users/Milagros/Desktop/exp numerica/datos_voltaje.csv")
midata$Temperatura <- as.factor(midata$Temperatura)
midata$material <- as.factor(midata$material)
anova <- aov(voltaje~Temperatura+material+Temperatura*material,midata)
summary(anova)

interaction.plot(midata$Temperatura,midata$material,midata$voltaje,
                 xlab="Factor: Temperatura",
                 ylab="Voltaje",
                 leg.legend="Material")

# Medias
tapply(midata$voltaje,midata$Temperatura, mean)
tapply(midata$voltaje,midata$material, mean)

#Estimacion
mean(midata$voltaje)
tapply(midata$voltaje,midata$Temperatura, mean) - mean(midata$voltaje)
tapply(midata$voltaje,midata$material, mean) - mean(midata$voltaje)

#combino medias--> las medias de la combinacion material temperatura
combinacion<-aggregate(voltaje~Temperatura+material,midata,mean)

unique(midata$Temperatura)
unique(midata$material)

dataframe <-data.frame()
for(i in unique(midata$Temperatura)){
  for(j in unique(midata$material)){
    media_ij <- mean(midata$voltaje[midata$Temperatura%in%c(i) & midata$material%in%c(j)])
    media_i <- mean(midata$voltaje[midata$Temperatura%in%c(i)])
    media_j <- mean(midata$voltaje[midata$material%in%c(j)])
    media_global <- mean(midata$voltaje)

    eff_ij <- media_ij - media_i - media_j + media_global

    dataframe <- rbind(dataframe,data.frame(i,j,eff_ij))

  }
}


##' Estimate parameters of a circle using Hough Circle Transform
##'
##' Uses a portion of the canny algorithm to find candidate edge points
##' and the direction of the gradient at those points, then uses
##' Hough Circle Transform to estimate circle parameters.
##'
##' @param im The image to find a circle in (a modulation estimate is best)
##' @param fw Size of Gaussian blur to smooth image
##' @param qt Threshold to accept strong edge candidate
##' @param excl Number of pixels to exclude around edge of frame as candidates
##' @param rmin Minimum circle radius
##' @param rmax Maximum circle radius
##' @param rstep step size in constructing lookup table
##' @param dtheta_max maximum assumed error in gradient direction
##' @param dtheta_step increment for dtheta
##' @param number of nearest neighbors for alternate calculation
##' @param plots plot?
##' @param details Return extra details?
##'
##' @details
##' The Hough transform section first creates a lookup table of candidate
##' radii and center points, then for each candidate edge point calculates
##' potential centers along a fan of rays near the gradient direction.
##' An inner join then finds matches in the lookup table and increments
##' an accumulator vector. Highest vote at the end wins.
##'
##' @return If details is FALSE a named list with the circle parameters
##'
##' @note
##' This is experimental and can be very slow. A good guess for the radius is very helpful.
##' Experimental feature: find the nn nearest neighbors of the selected trio of parameters
##' and calculate a vote weighted mean. This is returned as \code{rxy_alt} if details is TRUE.
##'
##' @seealso [circle.pars()], [pupil.pars()]
##'
##' @examples
##' example("psifit", package="zernike", ask=FALSE)
##' X11()
##' cp2 <- circle.hough(tfit$mod, rmin=round(tfit$cp$rx)-10, rmax=round(tfit$cp$rx)+10)
circle.hough <- function(im, fw=2, qt=0.995, excl=5,
                         rmin=min(dim(im))/4, rmax=min(dim(im))/2, rstep=1,
                         dtheta_max = 0.5, dtheta_step=0.05,
                         nn=7, plots=TRUE, details=FALSE) {
  require(data.table)
  nr <- nrow(im)
  nc <- ncol(im)
  if (fw > 0) {
    im <- gblur(im, fw)
  }
  if (excl < 1) {
    excl <- 1
  }
  kern.sobel <- rbind(c(-1,-2,-1),c(0,0,0),c(1,2,1))
  gx <- convolve2d(im, kern.sobel)
  gy <- convolve2d(im, t(kern.sobel))
  modg <- sqrt(gx^2+gy^2)
  modg <- modg/max(modg)
  dirg <- atan2(gy, gx)

  # round off directions to 45 degrees

  dir <- dirg
  dir[abs(dirg) < 7*pi/8] <- (round(dirg[abs(dirg) < 7*pi/8]*4/pi))
  dir[abs(dirg) >= 7*pi/8] <- 0
  dir[dir < 0] <- 4+dir[dir<0]

  # find local maxima

  maxima <- NULL

  for (i in 0:3) {
    ptsi <- which(dir==i, arr.ind=TRUE)
    ed <- which(ptsi[,1] <= excl)
    ed <- c(ed, which(ptsi[,1] >= nr-excl+1))
    ed <- c(ed, which(ptsi[,2] <= excl))
    ed <- c(ed, which(ptsi[,2] >= nc-excl+1))
    if (length(ed) > 0) {
      ptsi <- ptsi[-ed,]
    }
    nb <- switch(i+1, c(1,0), c(1,1), c(0,1), c(1, -1))
    ptsp <- t(t(ptsi)+nb)
    ptsm <- t(t(ptsi)-nb)
    lm <- which((modg[ptsi] > modg[ptsp]) & (modg[ptsi] > modg[ptsm]))
    maxima <- rbind(maxima, ptsi[lm,])
  }

  # the thinned edges consist of the local maxima in the direction of gradient

  thin <- matrix(0, nr, nc)
  thin[maxima] <- modg[maxima]
  ec <- which(modg[maxima] >= quantile(modg[maxima], probs=qt))
  maxima <- maxima[ec,]
  dir_edges <- dirg[maxima]

  if (plots) {
    image(1:nr, 1:nc, thin, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE)
    points(maxima[,1], maxima[,2], pch=20, col='green')
  }

  # Hough circle transform

  xc_min <- rmin
  xc_max <- nr-rmin
  yc_min <- rmin
  yc_max <- nc-rmin

  r_cand <- seq(rmin, rmax, by=rstep)
  xc_cand <- seq(xc_min, xc_max, by=rstep)
  yc_cand <- seq(yc_min, yc_max, by=rstep)
  rxy <- data.table(expand.grid(r_cand, xc_cand, yc_cand))
  rxy <- cbind(index=1:nrow(rxy), rxy)
  names(rxy) <- c("index", "r", "xc", "yc")
  dtheta <- seq(-dtheta_max, dtheta_max, by=dtheta_step)
  lt <- length(dtheta)
  acc <- numeric(nrow(rxy))

  for (i in 1:nrow(maxima)) {
    xc <- maxima[i,1] - as.vector(outer(r_cand, dir_edges[i]+dtheta, function(X,Y) X * cos(Y)))
    xc <- rstep * round(xc/rstep)
    yc <- maxima[i,2] - as.vector(outer(r_cand, dir_edges[i]+dtheta, function(X,Y) X * sin(Y)))
    yc <- rstep * round(yc/rstep)
    circles <- data.table(r=rep(r_cand, lt), xc=xc, yc=yc)
    matches <- dplyr::inner_join(rxy, circles, by=c("r", "xc", "yc"))
    acc[matches$index] = acc[matches$index] + 1
  }
  rxy_best <- rxy[which.max(acc),]
  cp <- list(xc = rxy_best$xc, yc=rxy_best$yc, rx=rxy_best$r, ry=rxy_best$r, obstruct=0)

  wtmean <- function(x, wt) sum(wt*x)/sum(wt)

  gets_vote <- as.vector(nabor::knn(rxy[,-1],rxy_best[,-1], k=nn)$nn.idx)
  rxy_alt <- list(r=wtmean(rxy$r[gets_vote],acc[gets_vote]), xc=wtmean(rxy$xc[gets_vote],acc[gets_vote]),
                  yc=wtmean(rxy$yc[gets_vote],acc[gets_vote]))

  if (plots) {
    points(rxy_best$xc, rxy_best$yc, col="red", pch=20)
    symbols(rxy_best$xc, rxy_best$yc, circles=rxy_best$r, inches=FALSE, add=TRUE, fg="red")
  }
  if (details) {
    list(cp=cp, thin=thin, maxima=maxima, dir_edges=dir_edges,
         rxy=rxy, acc=acc, rxy_best=rxy_best, rxy_alt=rxy_alt)
  } else {
    cp
  }
}


###################################
########## 군 집 분 석 ############
###################################
# install.packages("caret")
# install.packages("fastcluster")
library(caret)
library(fastcluster)

# 표준화
training_data <- scale(iris[ ,-5]) #Species 데이터 제거(숫자형변수x)
summary(training_data)

# 군집수 결정
## 패키지 사용 (최적의 combination을 통해 선택)
# install.packages("NbClust")
# library(NbClust)
#
# nc <- NbClust(training_data, min.nc=2, max.nc=15, method="kmeans")
# barplot(table(nc$Best.n[1,]),  xlab="Numer of Clusters", ylab="Number of Criteria", main="Number of Clusters Chosen")

## sum of squares 제일 작아 지는 지점 탐색
# wss <- NULL
# for(i in 1:7){
#   wss[i] = kmeans(training_data, centers=i)$tot.withinss
# }
# i=1:7
# plot(i,wss);lines(i,wss);

set.seed(100)
##### k-means (비계층적) 군집분석 ######
# 모델링 (군집개수-3개분류)
iris_kmeans <- kmeans(training_data, centers=3, iter.max=10000)
iris_kmeans$cluster <- as.factor(iris_kmeans$cluster) #Rownumber별 군집 매핑 값

table(iris_kmeans$cluster)
table(iris$Species, iris_kmeans$cluster) #virginica는 잘 분류해 내지만, 그 외는 변별력 약함.

plot(iris[c("Sepal.Length", "Sepal.Width")], col=iris_kmeans$cluster)

set.seed(0)
##### Hierarchical - hcluster (계층적) 군집분석 ######
# 모델링
hc <- hclust(dist(training_data), method="ave") #Row간 거리 계산

# plot(hc, hang=-1, labels=iris$Species)
# rect.hclust(hc, k=3)  #3개의 클러스터 표현

groups <- cutree(hc, k=3) #3개의 클러스터로 표현
table(groups)

table(iris$Species, groups) #setosa는 잘 분류해 내지만, 그 외는 변별력 약함.

###################################
########## D-TREE 분 석 ###########
###################################
# install.packages("party")
library(party)

set.seed(2)
# train / test 분할
ind <- sample(2, nrow(iris), replace=TRUE, prob=c(0.7,0.3))
trainData <- iris[ind==1, ]
testData <- iris[ind==2, ]

# 모델링
formula <- Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
iris_ctree <- ctree(formula, data=trainData)

plot(iris_ctree)

# test 예측
ctreepred <- predict(iris_ctree, newdata=testData)
table(testData$Species, ctreepred)

###################################
##### 로 지 스 틱 회 귀 분 석 #####
###################################
# install.packages("glm2")
library(glm2)

# target 변수 2개 범주로만 선택 (범주형변수로변환)
adj_iris <- iris
adj_iris$Species <- as.character(adj_iris$Species)
adj_iris <- subset(adj_iris, Species %in% c('versicolor', 'virginica'))
adj_iris$Species <- as.factor(adj_iris$Species)

set.seed(10)
# train / test 분할
ind <- sample(2, nrow(adj_iris), replace=TRUE, prob=c(0.7,0.3))
trainData <- adj_iris[ind==1, ]
testData <- adj_iris[ind==2, ]

# 모델링
formula <- Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
iris_logit <- glm(formula, data=trainData, family=binomial())
#일반선형모형(GLM)이 아닌 로지스틱 회귀를 실행하기 위해, R 프로그램에 family=binomial 이란 옵션을 설정해야 하는 것

# test 예측
#data.frame(adj_iris$Species, as.numeric(adj_iris$Species)-1) #versicolor=0, virginica=1

logitpred_a <- predict(iris_logit, newdata=testData, type="response")
logitpred <- ifelse(logitpred_a>=0.5, "virginica", "versicolor")

table(testData$Species , logitpred)

###################################
##### H2O Deeplearning 분 석 ######
###################################
# install.packages("h2o")
library(h2o)

h2o.init()

set.seed(4)
iris.hex <- as.h2o(iris)

# 모델링
iris_dl <- h2o.deeplearning(x = 1:4, y = 5, training_frame = iris.hex, activation = "Tanh", hidden = c(10, 10)) #x:인풋변수, y:타겟변수

# 예측
predictions <- h2o.predict(iris_dl, iris.hex)
predictions <- as.data.frame(predictions)

table(iris$Species, predictions$predict)

# ###################################
# ##### ANN (인공신경망) 분 석 ######
# ###################################
# # install.packages("nnet")
# library(nnet)
#
# set.seed(3)
# # train / test 분할
# ind <- sample(2, nrow(iris), replace=TRUE, prob=c(0.7,0.3))
# trainData <- iris[ind==1, ]
# testData <- iris[ind==2, ]
#
# # 모델링
# formula <- Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
# iris_nnet <- nnet(formula, data=trainData, size=3) #size : hidden layer
#
# # test 예측
# nnetpred <- predict(iris_nnet, newdata=testData, type="class")


# Use these 2 lines to set working directory as the current directory of the
# file. Tested on Rstudio @ Windows 10 OS.
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

library(rgdal)
epsg <- make_EPSG()
i <-grep("France", epsg$note, ignore.case=TRUE)

epsg[i[1:3], ]

###########

library(raster)
library(rgdal)
f <- system.file("external/lux.shp", package="raster")
p <- shapefile(f)
p

pp <- p
crs(pp) <- NA
crs(pp)

newcrs <- CRS("+proj=robin +datum=WGS84")

rob <- spTransform(p, newcrs)
rob

p2 <- spTransform(rob, CRS("+proj=longlat +datum=WGS84"))

###########

r <- raster(xmn=-110, xmx=-90, ymn=40, ymx=60, ncols=40, nrows=40)
r <- setValues(r, 1:ncell(r))
r
plot(r)

##########
newproj <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
pr1 <- projectRaster(r, crs=newproj)
crs(pr1)
pr3 <- projectExtent(r, newproj)
res(pr3) <- 200000
pr3 <- projectRaster(r, pr3)
pr3
plot(pr3)

###########################################
###########################################
f <- system.file("external/lux.shp", package="raster")
library(raster)
p <- shapefile(f)
p

par(mai=c(0,0,0,0))
plot(p)

d <- data.frame(p)
head(d)

g <- geom(p)
head(g)

p$NAME_2
p[, 'NAME_2']

set.seed(0)
p$new <- sample(letters, length(p))
p

p$new <- sample(LETTERS, length(p))
p

#####
z <- raster(p, nrow=2, ncol=2, vals=1:4)
names(z) <- 'Zone'
z <- as(z, 'SpatialPolygonsDataFrame')
z
z2 <- z[2,]
plot(p)
plot(z, add=TRUE, border='blue', lwd=5)
plot(z2, add=TRUE, border='red', lwd=2, density=3, col='red')

b <- bind(p, z)
head(b)
tail(b)

pa <- aggregate(p, by='NAME_1')
za <- aggregate(z)
plot(za, col='light gray', border='light gray', lwd=5)
plot(pa, add=TRUE, col=rainbow(3), lwd=3, border='white')

zag <- aggregate(z, dissolve=FALSE)
zag
plot(zag, col="light gray")
zd <- disaggregate(zag)
zd
e <- erase(p, z2)
e <- p - z2
plot(e)

###########################################
###########################################
library(raster)
x <- raster()
x
x <- raster(ncol=36, nrow=18, xmn=-1000, xmx=1000, ymn=-100, ymx=900)
res(x)
res(x) <- 100
res(x)
ncol(x)
ncol(x) <- 18
ncol(x)
res(x)
projection(x) <- "+proj=utm +zone=48 +datum=WGS84"
x
r <- raster(ncol=10, nrow=10)
ncell(r)
hasValues(r)
values(r) <- 1:ncell(r)

set.seed(0)
values(r) <- runif(ncell(r))
hasValues(r)
inMemory(r)
values(r)[1:10]
plot(r, main='Raster with 100 cells')


beta1=.2652
se=.1012
n=21
k=3
df=n-(k+1)
alpha=0.025
tvalue=qt(1-alpha,df)
print(tvalue)
left_i=beta1-tvalue*se
right_i=beta1+tvalue*se
print(" 95% confidence interval")
print(left_i)
print(right_i)