vect=c(1,10:15)
vect

vect1=c(1:3,letters[1.:10])
vect1

intVec=c(1:5)
charVec=c(letters[1:5])
logicVec=c(TRUE,FALSE)

combVec=c(intVec,charVec,logicVec)
combVec

names(combVec)=LETTERS[1:12]
combVec

seq(1,5,by=0.1)

mat=matrix(c(1:9),3,3,byrow=TRUE)
mat

singVec=c(2)
mat=singVec*mat
mat

mat2=matrix(c(11:19),3,3,byrow = TRUE)
matAdd=mat+mat2
matAdd

matMult=mat%*%mat2
matMult

matT=t(matMult)
matT

matUnit=matrix(1,3,1)
matUnit

zeroMat=matrix(0,3,2)
zeroMat

diagMatVec=diag(mat)
diagMatVec

digMat=diag(diagMatVec)
digMat

rownames(mat)=c("a","b","c")
mat

colnames(mat)=c("d","e","f")
mat

mat[3,1,drop=FALSE]

mat
mat[3,2]
mat2
rownames(mat2)=c("a","b","c")
colnames(mat2)=c("p","q","r")
mat2

mat2=rbind(mat2,c(20,21,22))
mat2

rownames(mat2)=c("a","b","c","d")
mat2

multiList=list(eno=c(1:3),ename=c("a","b","c"))
multiList

multiList[[1]][2]

names(multiList)=c("eno","ename")
multiList

fact=1
print("Enter a number")
no=as.integer(readline())

for(i in 1:5)
{
  fact=fact*i
}
fact

matAir=matrix(AirPassengers,12,12,byrow = TRUE)
matAir
rownames(matAir)=c(1949:1960)
colnames(matAir)=c(month.abb)
matAir[2:12,1:12,drop=FALSE]

mat1 = matrix(1:9,3,3)
for(i in seq_len(nrow(mat1)))
{
  for(j in seq_len(ncol(mat1))){
    print(mat1[i,j])
  }
}


# https://www.hackerrank.com/challenges/s10-multiple-linear-regression/problem

library(magrittr)

f <- file("R:/R_WD/GitHub/MiscRScripts/input/input00.txt")
input <- scan(f)
m <- input[1]
input <- input[-1]
n <- input[1]
input <- input[-1]
y <- c()
toRemove <- c()
for(i in 1:n){
	index <- i*(m + 1)
	y <- c(y, input[index])
	toRemove <- c(toRemove, index)
}
input <- input[-toRemove]

x <- input[1:(m*n)] %>% matrix(ncol = m, byrow = T)
x2 <- input[-c(1:(m*n))]
q <- x2[1]
x2 <- x2[-1]
x2 <- x2 %>% matrix(ncol = m, byrow = T)
X <- cbind(c(rep(1,dim(x)[1])), x)
X2 <- cbind(c(rep(1,dim(x2)[1])), x2)

fm1 <- solve(t(X) %*% X) %*% t(X) %*% y
ans <- X2 %*% fm1

ans <- ans %>% round(digits= 2)

for(i in seq_along(ans)){
	cat(ans[i], "\n")
}


dat = read.csv(file="pctgrowth.csv", header=TRUE)

boxplot(y ~ grp, data=dat)

library("rjags")

# place priors on mean and SD of gamma distribution, using informative priors

mod_string = " model {
for (i in 1:length(y)) {
  y[i] ~ dnorm(pheta[grp[i]], prec)
}

for (j in 1:max(grp)) {
  pheta[j] ~ dnorm(mu, prec_tau)
}

mu ~ dnorm(0.0, 1.0/1.0e6)
prec ~ dgamma(1.0, 1.0)
prec_tau ~ dgamma(0.5, 3.0/2.0)

sig = 1.0 / prec
tau = 1.0 / prec_tau

} "

set.seed(113)

data_jags = as.list(dat)

params = c("pheta","tau", "mu", "sig")

mod = jags.model(textConnection(mod_string), data=data_jags, n.chains=3)
update(mod, 1e3)

mod_sim = coda.samples(model=mod,
                       variable.names=params,
                       n.iter=5e3)
mod_csim = as.mcmc(do.call(rbind, mod_sim))

## convergence diagnostics
plot(mod_sim)

gelman.diag(mod_sim)
autocorr.diag(mod_sim)
autocorr.plot(mod_sim)
effectiveSize(mod_sim)

## compute DIC
dic = dic.samples(mod, n.iter=1e3)

## observation level residuals
(pm_params = colMeans(mod_csim))

yhat = rep(pm_params[1:5], each=30)
resid = dat$y - yhat
plot(resid)

means_anova = tapply(dat$y, INDEX=dat$grp, FUN=mean)

means_anova


library(CreditMetrics)
set.seed(1)

RatingClasses <- c("AAA", "AA", "A", "BBB", "BB", "B", "CCC", "D")
TransitionMatrix <- matrix(c(90.710,	8.340,	0.710,	0.075,	0.095,	0.025,	0.022,	0.023,
                             0.710,	90.550,	7.810,	0.720,	0.060,	0.120,	0.020,	0.010,
                             0.092,	2.220,	91.250,	5.420,	0.720,	0.230,	0.011,	0.057,
                             0.020,	0.420,	5.890,	85.880,	5.290,	1.190,	1.140,	0.170,
                             0.036,	0.124,	0.670,	7.730,	80.590,	8.790,	1.010,	1.050,
                             0.011,	0.119,	0.230,	0.440,	6.510,	83.440,	4.060,	5.190,
                             0.220,	0.000,	0.230,	1.330,	2.360,	11.210,	64.830,	19.820,
                             0, 0, 0, 0, 0, 0, 0, 100
)/100, 8, 8, dimnames = list(RatingClasses, RatingClasses), byrow = TRUE)
TransitionMatrix

library(markovchain)

MCModel <- new("markovchain", transitionMatrix = TransitionMatrix, states=RatingClasses, byrow = TRUE, name="MarkovChainModel")
MCModel

MCModel@states

transitionProbability(MCModel,"AAA","AA")

#CREDIT SPREAD

LGD <- 0.40

CreditRiskSpread<-cm.cs(TransitionMatrix, LGD)
CreditRiskSpread

# reference value
Rating <- c("B", "BB", "CCC")
EAD <- c(4000, 10000, 500000)
Rindex <- 0.02

RefValue<-cm.ref(TransitionMatrix, LGD, EAD, Rindex, Rating)

RefValue$constVal
RefValue$constPV

absorbingStates(MCModel)


## R script for model with all inputs
## Data: https://modeanalytics.com/benn/reports/72c16eaaeefc

tracts <- read.csv("model_inputs.csv")
trim_tracts <- subset(tracts, distance_in_miles >= 3)
trim_tracts <- subset(trim_tracts, distance_in_miles <= 4)

##  By white population percent
full <- lm(trips ~ median_income + population + white_percent + distance_in_miles,data=trim_tracts)
summary(full)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)       -654.57923 5803.44673  -0.113    0.911
##  median_income        0.10032    0.01571   6.386 2.41e-07 ***
##  population           0.23538    0.16398   1.435    0.160
##  white_percent      498.61848 2576.73840   0.194    0.848
##  distance_in_miles -829.45905 1573.32651  -0.527    0.601
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 2599 on 35 degrees of freedom
##  Multiple R-squared:  0.7304,	Adjusted R-squared:  0.6996
##  F-statistic: 23.71 on 4 and 35 DF,  p-value: 1.501e-09

##  By black population percent
black_only <- lm(trips ~ median_income + population + black_percent + distance_in_miles,data=trim_tracts)
summary(black_only)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)       -1.287e+03  5.765e+03  -0.223    0.825
##  median_income      9.784e-02  1.163e-02   8.409 6.41e-10 ***
##  population         2.355e-01  1.621e-01   1.453    0.155
##  black_percent     -1.938e+03  2.107e+03  -0.920    0.364
##  distance_in_miles -4.121e+02  1.623e+03  -0.254    0.801
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 2570 on 35 degrees of freedom
##  Multiple R-squared:  0.7365,	Adjusted R-squared:  0.7064
##  F-statistic: 24.46 on 4 and 35 DF,  p-value: 1.015e-09

##  With nightime trips as dependent varible
after_8 <- lm(after_8_trips ~ median_income + population + white_percent + distance_in_miles,data=trim_tracts)
summary(after_8)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)        1.083e+03  1.812e+03   0.598    0.554
##  median_income      3.059e-02  4.905e-03   6.236 3.78e-07 ***
##  population         5.583e-02  5.119e-02   1.091    0.283
##  white_percent     -4.654e+02  8.045e+02  -0.579    0.567
##  distance_in_miles -5.498e+02  4.912e+02  -1.119    0.271
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 811.5 on 35 degrees of freedom
##  Multiple R-squared:  0.6857,	Adjusted R-squared:  0.6498
##  F-statistic: 19.09 on 4 and 35 DF,  p-value: 2.08e-08

##  With nightime trips as dependent varible
after_8_black_only <- lm(after_8_trips ~ median_income + population + black_percent + distance_in_miles,data=trim_tracts)
summary(after_8_black_only)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)        8.294e+02  1.821e+03   0.456    0.652
##  median_income      2.756e-02  3.675e-03   7.501 8.73e-09 ***
##  population         5.658e-02  5.119e-02   1.105    0.277
##  black_percent     -3.785e+02  6.655e+02  -0.569    0.573
##  distance_in_miles -4.579e+02  5.124e+02  -0.894    0.378
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 811.6 on 35 degrees of freedom
##  Multiple R-squared:  0.6856,	Adjusted R-squared:  0.6496
##  F-statistic: 19.08 on 4 and 35 DF,  p-value: 2.091e-08


# An introduction to R programming!
# NDSU Analysis of Ecosystems
# Devan Allen McGranahan (devan.mcgranahan@ndsu.edu)

# Lesson 1: Introduction to R
  # Basic functions for loading, evaluating, and managing data

# Remember ?functionname and ??functionname for getting help!

## R as a calculator:
	2+2 # R should return 4
	2*2 # R will return 4
	2*2+6 # R will return 10
	6+2*2 # R will return 10, it knows the order of operations
	6+(2*2) # R also recognizes parentheses

	# R is "object-oriented" - define an object and R will remember it:
	answer <- 2+(20*2)
	answer
	answer*2
	new.answer <- answer*2
	new.answer

	# Introducing functions
	# Researchers often want to find the mean of data:

	(24 + 13 + 12 + 22 + 15) / 5

	data <- c(24, 13, 12, 22, 15)
	data

	data / 5
	sum(data) / 5

	length(data)
	sum(data) / length(data)
	mean(data)

	Meaner <- function(x) { sum(x) / length(x) }

	Meaner(data)

	Meaner <- function(x) {
	  m <- sum(x) / length(x)
	  m1 <- noquote(paste(m, "!", sep="") )
	  return(m1)
	}
	Meaner(data)

## Some housekeeping

# Setting working directories
	# Working directories help pull data from, and save to, specific files.
	# You can always see what your current working directory is:
		getwd() # print the current working directory (cwd)
		ls()    # list the objects in the current workspace

	# You can change the working directory:
		setwd("E:/R/")  # ~!~ note: use / or \\ instead of \ in windows ~!~

	# Saving things
		# Save specific objects.
		# Always a good idea: after importing and manipulating data, save specific objects
		save(file.name, file="./file.name.Rdata") # saves to cwd
		load("./file.name.Rdata") # Bring R objects into the workspace from cwd.

		# load() is only for .Rdata objects.
		# Many other functions import (read) file types into R.
		# .csv is a common file type to go from a spreadsheet to R:

		mtcars.origins <- read.csv(file="./data/mtcars_origins.csv")

		# or if you don't know the path (but you should know the path!):

		mtcars.origins <- read.csv(file=file.choose())

		# R studio also has a clicky import feature but I strongly recommend hard-coding
		# to your data files with the appropriate read.xx() function.

		# Save workspace: at the end of your session, you can save everything on the current workspace.
		# But there are parties who believe strongly against this practice:
		# https://www.r-bloggers.com/using-r-dont-save-your-workspace/
		save.image()

	# Types of R objects
	 	# Libraries/packages are how the R community shares extended functionality
		# Hundreds are available "officially" through r-cran (the preferred way to access and reference)
		# Many more functions are available on github and personal and academic websites
		install.packages("permute") # prompts a download procedure. You need to select a source.
		library(permute) # Loads the library/package. Necessary each time R is restarted
		                # & included functions desired.
		data(jackal) # Calls up some data available in the permute package.

# Some diagnostic functions

		# Evaluate an entire R object

		dim(cars)  	  # Dimensions of the object
		names(cars)	  # Displays column headings
		head(mtcars)	# Displays top six lines of the data
		tail(cars)    # Displays bottom six lines
		class(cars)	  # Data frame, matrix, etc.

	 # Evaluate specific columns

		head(cars) # Top six rows of both columns
		head(cars$speed) # Top six rows of column "speed"
		head(cars[1]) # Top six rows of column "speed"

	  # Evaluate specific rows and cells

		cars[1,] # Display row 1
		cars[1:3,] # Display rows 1 through 3
		cars[3:5,] # Display rows 3 through 5
		cars[5,2] # Display component located in row 5, column 2

# Classes within objects

		class(cars$speed) # Returns class of specific column
		str(cars)         # Provides all evaluation info
		                  # of object and components

		str(mtcars)       # A more complex dataset?

		# Changing component classes with as. functions

		mtcars$cyl <- as.factor(mtcars$cyl)
		mtcars$vs <- as.factor(mtcars$vs)
		mtcars$gear <- as.factor(mtcars$gear)
		mtcars$carb <- as.factor(mtcars$carb)
		str(mtcars)

		# Wait, what the heck is "am" anyway? Go to help:
		?mtcars

		# Change column data to something more useful
		pacman::p_load(plyr)  # Note :: pulls a function (rhs)
		                      # from a package (lhs) without loading
		                      # package. Can help avoid conflicts.

		mtcars$am <- revalue(as.factor(mtcars$am), c("0"="Automatic",
		                                             "1"="Manual"))

	# Adding variables

		# First, the mtcars dataset is a tad wonky.
		# Notice how the makes and models for the cars isn't actually
		# a variable column (info isn't in str(mtcars)), but is rather
		# assigned to the names of the rows:

		rownames(mtcars)

		# We can assign row names to a new column called make.model:

		mtcars$make.model <- factor(rownames(mtcars) )

		# This gives us a reference point to automatically look up
		# a variable from one data.frame in another data.frame
		# using the merge function (similar to HLOOKUP in Excel)

		mtcars2 <- merge(x=mtcars.origins, y=mtcars,
		                 by.x="make.model", by.y="make.model")

		# Add a variable using a logical string.
		# ifelse reads as "if X, then Y; otherwise Z (because not X)"

		mtcars2[,"origin"] <- with(mtcars2, ifelse(country=="USA",
		                                            "domestic", "foreign"))
		head(mtcars2)

		# although ifelse first appears either/or, ifelse statements
		# can be nested to add a series of options:

		mtcars2[,"continent"] <- with(mtcars2, ifelse((country=="USA"),
		                                           "North America",
		                                           ifelse((country=="Japan"),
		                                                  "Asia", "Europe")))
		head(mtcars2)

#
#   T I D Y V E R S E
#
		# The tidyverse offers a totally different way to do this:
		pacman::p_load(tidyverse)

		mtcars2 <- mtcars2 %>% mutate(continent = case_when(
              		                  country == "USA" ~ "North America",
              		                  country == "Japan" ~ "Asia",
              		                  TRUE ~ "Europe" ))
		head(mtcars2)

		# Note the pipe operator: %>%
		# It pours R objects along through a chain of functions
		# in one run with no intermediate objects.
		# The advantage is that many manipulations can be made at once
		# using the tidyverse "grammar" and its many functions ("verbs"):

		mtcars.origins %>%
		  full_join(mtcars, by = "make.model") %>%
		    mutate(origin = ifelse(country=="USA", "domestic", "foreign"),
		           continent = case_when(
    		             country == "USA" ~ "North America",
    		             country == "Japan" ~ "Asia",
    		             TRUE ~ "Europe" )) %>%
          arrange(make.model) -> mtcars3 # ooh look, he named the object
    		                                 # at the **end** of the pipe!

		str(mtcars3) # tibble object
		str(mtcars2) # regular old data.frame
		mtcars3 # tibble objects automatically give a tidy preview

		# After all that work - make sure to save!

		getwd()
		save(mtcars2, file="./data/mtcars2.Rdata")
		# or
		save(mtcars2, file=file.choose())
		# or
		write.csv(mtcars2, file="./data/mtcars2.csv")

Analysis of Ecosystems/01 - Intro to R/1-1_intro-R_basic-functions.r


fib <- function(n) {
  if (n < 2) n else Recall(n - 1) + Recall(n - 2)
}

fibLinear <- function(n) {
  fibs <- c(0, 1)
  while (n > 0) {
    temp <- fibs[2]
    fibs[2] <- sum(fibs)
    fibs[1] <- temp
    n <- n - 1
  }
  fibs[1]
}

fibFormula <- function(n) {
  round(((5 ^ 0.5 + 1) / 2) ^ n / 5 ^ 0.5)
}

fibTailRecursive <- function(n, prevFib = 0, fib = 1) {
  if (n == 0) prevFib else Recall(n - 1, fib, prevFib + fib)
}

fibFastDoubling <- function(n) {
  fibFastAuxiliary <- function(n) {
    if (n == 0) return(list(0, 1))

    fibs <- Recall(floor(n / 2))
    prevFib <- fibs[[1]]
    fib <- fibs[[2]]
    a <- prevFib * (fib * 2 - prevFib)
    b <- prevFib * prevFib + fib * fib
    if (n %% 2 == 0) list(a, b) else list(b, a + b)
  }
  fibFastAuxiliary(n)[[1]];
}

args = commandArgs(trailingOnly=TRUE)
input = if (length(args) > 0) as.numeric(args[1]) else 29
print(fibFastDoubling(input))


#Intro
png("#45_confidence_interval_around_model.png" , width = 480, height = 480 )
par(mar=c(2,2,1,1))

# We create 2 vectors x and y. It is a polynomial function.
x <- runif(300,  min=-30, max=30)
y <-  -1.2*x^3 + 1.1 * x^2 - x + 10 + rnorm(length(x),0,100*abs(x))

# Basic plot of x and y :
plot(x,y,col=rgb(0.4,0.4,0.8,0.6), pch=16 , cex=1.3 , xlab="" , ylab="")

# Can we find a polynome that fit this function ?
model=lm(y ~ x + I(x^2) + I(x^3))

# I can get the features of this model :
summary(model)
model$coefficients
summary(model)$adj.r.squared

#For each value of x, I can get the value of y estimated by the model, and the confidence interval around this value.
myPredict <- predict( model , interval="predict" )

#Finally, I can add it to the plot using the line and the polygon function with transparency.
ix <- sort(x,index.return=T)$ix
lines(x[ix], myPredict[ix , 1], col=2, lwd=2 )
polygon(c(rev(x[ix]), x[ix]), c(rev(myPredict[ ix,3]), myPredict[ ix,2]), col = rgb(0.7,0.7,0.7,0.4) , border = NA)

dev.off()


#Copyright (c) 2016 Riccardo Francescato
p = 5 # number of rows
N = p^2
alpha = .05
RawLatin=c("A","B","C","D","E",
  			"B","C","D","E","A",
  			"C","D","E","A","B",
  			"D","E","A","B","C",
  			"E","A","B","C","D")
RawData = c(-1,-5,-6,-1,-1,
  		   	-8,-1, 5, 2,11,
  		   	-7,13, 1, 2,-4,
  		   	 1, 6, 1,-2,-3,
  		   	-3, 5,-5, 4, 6)

data = matrix(RawData,nrow=p,ncol=p,byrow = TRUE)
latin = matrix(RawLatin,nrow=p,ncol=p,byrow = TRUE)

SStot = sum(data^2) - sum(data)^2/N

SSrows = 0
for(i in 1:p){
	SSrows = SSrows + sum(data[i,])^2
}
SSrows = SSrows *(1/p) - sum(data)^2/N

SScol = 0
for(i in 1:p){
	SScol = SScol + sum(data[,i])^2
}
SScol = SScol *(1/p) - sum(data)^2/N

TreatTot = vector(,p)
for(i in 1:p){
	TreatTot[i]=0
}

for(i in 1:N){
	if(RawLatin[i]=="A") TreatTot[1]=TreatTot[1]+RawData[i]
	if(RawLatin[i]=="B") TreatTot[2]=TreatTot[2]+RawData[i]
	if(RawLatin[i]=="C") TreatTot[3]=TreatTot[3]+RawData[i]
	if(RawLatin[i]=="D") TreatTot[4]=TreatTot[4]+RawData[i]
	if(RawLatin[i]=="E") TreatTot[5]=TreatTot[5]+RawData[i]
}

SStreat=0
for(i in 1:p){
	SStreat = SStreat + TreatTot[i]^2
}
SStreat = SStreat *(1/p) - sum(data)^2/N

SSerr = SStot - SSrows - SScol - SStreat

MStreat = SStreat/(p-1)
MSrows = SSrows/(p-1)
MScols = SScol/(p-1)
MSerr = SSerr/((p-2)*(p-1))

F0 = MStreat/MSerr
Fa = qf(alpha,df1=p-1,df2=((p-2)*(p-1)),lower.tail=F)

if(F0 > Fa) print(paste0(" reject H0 ", F0)) else print(paste0(" Accept H0 ", F0))
cat(paste0(" Treatments  SS: ",SStreat," Df: ", p-1 ," MS: ",MStreat, " F0: ",F0,
		"\n Rows  SS: ",SSrows," Df: ", p-1 ," MS: ",MSrows,
		"\n Cols  SS: ",SScol," Df: ", p-1 ," MS: ",MScols,
		"\n Error  SS: ",SSerr," Df: ", (p-2)*(p-1) ," MS: ",MSerr,
		"\n Total  SS: ",SStot," Df: ", (p^2)-1))

delivery.df = data.frame(
  Opersators = c(rep("O1", p), rep("O2", p), rep("O3", p), rep("O4", p), rep("O5", p)),
  Batches = c(rep(c("B1", "B2", "B3", "B4","B5"), p)),
  Formulation = RawLatin,
  Data = RawData
)

delivery.mod1 = lm(Data ~ Formulation+Batches+Opersators, delivery.df)
anova(delivery.mod1)


### 判別分析の例
### - 企業別の利益データ (2007-2012年度)

## データの読み込み ("jpcompany.csv"を用いる)
raw <- read.csv(file="data/jpcompany.csv",row.names=1) # データの読み込み
scan(file="data/jpcompany.txt",what=character(),sep=";") # 説明の表示

## データの内容を表示
## print(raw)    # 全データの表示
head(raw,n=3) # 最初の3個を表示
## tail(raw,n=3) # 最後の3個を表示

## 判別分析のためにデータを整形
## class: 2011年から2012年に掛けて営業利益が増収(pos)/減収(neg)
## 特徴量: 売上高に占める各利益の割合
mydata <- data.frame(class=ifelse(raw[,26]-raw[,22]>0,"pos","neg"))
for (k in 1:5){
    mydata <- data.frame(mydata,raw[,(4*k+1)+(1:3)]/raw[,4*k+1])
}
names(mydata)[2:ncol(mydata)] <- # 特徴量の名前
    paste(rep(c("営業利益率","経常利益率","純利益率"),5),
          rep((1:5)+2006,each=3),sep=".")
rownames(mydata) <- raw[,2]  # 各社の名前
mydata <- na.exclude(mydata) # 欠損(NA)の除去
head(mydata,n=3) # 最初の3個を表示

## データの一部とラベルの関係を図示
item <- c(1,5,8,11,14)
## print(names(mydata)[item]) # 項目名の表示
## データの散布図: 図(a)
ggpairs(mydata,
        columns=item, mapping=aes(colour=class)) +
    theme(text=element_text(family="HiraMaruProN-W4"))
## ## ggscatmat を用いる場合 (class以外が表示される)
## ggscatmat(mydata,
##           columns=item, color="class", alpha=.5) +
##     theme(text=element_text(family="HiraMaruProN-W4"))

## データ全体で判別式を作成
model <- lda(class ~ ., data=mydata)
table(true=mydata$class,predict=predict(model)$class)

## 線形判別関数の値の分布をクラス毎に表示
predict.tr <- predict(model)
res.tr <- data.frame(x=as.vector(predict.tr$x),
                    class=mydata$class,
                    d=c(neg=0,pos=1)[mydata$class])
## 判別関数の値の分布: 図(b)
ggplot(res.tr, aes(x)) +
    geom_histogram(aes(fill=class)) +
    facet_grid(class ~ .) + theme(legend.position="none")

## 全体を用いると判別があまり良好でないので
## 2011年の経常利益率で層別に調べてみる
## (業種別に調べると良いかもしれないが各業種のデータが少ない)
conditions <- c("経常利益率.2011<0.05",
                "経常利益率.2011>0.05&経常利益率.2011<0.1",
                "経常利益率.2011>0.1&経常利益率.2011<0.2",
                "経常利益率.2011>0.2")
for(i in 1:4){
    subdata <- subset(mydata, subset=eval(parse(text=conditions[i])))
    submodel <- lda(class ~ ., data=subdata)
    tbl <- table(true=subdata$class,predict=predict(submodel)$class)
    print(conditions[i])
    print(tbl)
    ## 線形判別関数の値の分布をクラス毎に表示
    predict.tr <- predict(submodel)
    res.tr <- data.frame(x=as.vector(predict.tr$x),
                         class=subdata$class,
                         d=c(neg=0,pos=1)[subdata$class])
    ## 層別の判別関数の値の分布: 図(c)-(f)
    gg <- ggplot(res.tr, aes(x)) +
        geom_histogram(aes(fill=class)) +
        facet_grid(class ~ .) +
        theme(text=element_text(family="HiraMaruProN-W4"),
              legend.position="none") +
        labs(title=conditions[i])
    print(gg)
}


# load the dataset
library(dslabs)
data(heights)

# make a table of category proportions
prop.table(table(heights$sex))

# define x as vector of male heights
library(tidyverse)
library(dslabs)
data(heights)
index <- heights$sex=="Male"
x <- heights$height[index]

# calculate the mean and standard deviation manually
average <- sum(x)/length(x)
SD <- sqrt(sum(x - average)^2)/length(x)

# built-in mean and sd functions
average <- mean(x)
SD <- sd(x)
c(average = average, SD = SD)

# calculate standard units
z <- scale(x)

# calculate proportion of values within 2 SD of mean
mean(abs(z) < 2)


#' @aliases getpolar,numeric,numeric-method
#' @rdname getpolar
#' @export
#' @examples
#' # getpolar(c(1,1),c(0,0),deg=TRUE) # should result 45.
setMethod( "getpolar", signature =c("numeric", "numeric"),
	function(n0=c(0,0),n1,...){
	    li<- list(...)

	    if(length(n0)!=2){stop(paste("Argument n0 is not as expected of length 2. (Obtained:",length(n0),")",sep=""))}
		if(length(n1)!=2){stop(paste("Argument n1 is not as expected of length 2. (Obtained:",length(n1),")",sep=""))}

		x1 <- n1[1]
		x0 <- n0[1]
	    y1 <- n1[2]
		y0 <- n0[2]
	    value<-NULL

	    if(is.null(li$deg)) {
	    	li$deg = FALSE
		}else{
			if(!class(li$deg) == "logical")
				stop("Parameter deg must be of type logical (boolean)")
		}
	    if(is.null(li$nonnegative)) {
	    	li$nonnegative = TRUE
	    }else{
			if(!class(li$nonnegative) == "logical")
				stop("Parameter nonnegative must be of type logical (boolean)")
		}
	    if(is.null(li$offset)) {
	    	li$offset <- 0
		}else{
			li$offset <- as.numeric(li$offset)
		}
	    if(is.null(li$log)) {
	    	li$log = FALSE
		}else{
			if(!class(li$log) == "logical")
				stop("Parameter log must be of type logical (boolean)")
		}
		if(li$log) cat("calculating angle: (x-x0)/(y-y0):(",x1,"-",x0,")/(",y1,"-",y0,")=")
	    x<-x1-x0
		y<-y1-y0
		if(x==0){
			if(y>0){
				value<-pi/2
			}else{
				if(y<0){
					value<- 3*pi/2
				}else{
					warning("Angle can't be calculated because both coordinates are the same. Returning NA.")
					return(NA)
				}
			}
		}else{
			value<-atan(y/x)
			if(x<0){
				value<-value+pi
			}
		}
		if(li$log) cat(((x-x0)/(y-y0))," --> ", value,"\n")

		value <- value - li$offset
		if(li$log & li$offset !=0) cat("\tSubtracting offset: (",li$offset,")= ", value, "\n")
		if(li$nonnegative){
			while(TRUE){
				if(value>=0) break
				value<-value+2*pi
				if(li$log ) cat("\tadding 2pi: ",value,"\n")
			}
		}

		if(li$deg){
			value<-value/pi*180
			if(li$log ) cat("\tconverting to degrees: ",value,"\n")
		}
	    return(value)
	}
)


wdbc <- read.csv('c:\\Projects\\StatisticalLearning\\datasets\\wpbc.csv', header = F)
features <- c("radius", "texture", "perimeter", "area", "smoothness", "compactness", "concavity", "concave_points", "symmetry", "fractal_dimension")
names(wdbc) <- c("id", "diagnosis", paste0(features,"_mean"), paste0(features,"_se"), paste0(features,"_worst"))
wdbc.pr <- prcomp(wdbc[c(3:32)], center = TRUE, scale = TRUE)
summary(wdbc.pr)
screeplot(wdbc.pr, type = "l", npcs = 15, main = "Screeplot of the first 10 PCs")
abline(h = 1, col="red", lty=5)
legend("topright", legend=c("Eigenvalue = 1"), col=c("red"), lty=5, cex=0.6)
cumpro <- cumsum(wdbc.pr$sdev^2 / sum(wdbc.pr$sdev^2))
plot(cumpro[0:15], xlab = "PC #", ylab = "Amount of explained variance", main = "Cumulative variance plot")
abline(v = 6, col="blue", lty=5)
bline(h = 0.88759, col="blue", lty=5)
abline(h = 0.88759, col="blue", lty=5)
legend("topleft", legend=c("Cut-off @ PC6"), col=c("blue"), lty=5, cex=0.6)


# Grouped mutates and window functions

# A. Grouped mutates
# 1. Finding the year each name is most common
# Calculate the fraction of people born each year with the same name
babynames %>%
  group_by(year) %>%
  mutate(year_total = sum(number)) %>%
  ungroup() %>%
  mutate(fraction = number / year_total) %>%
  # Find the year each name is most common
  group_by(name) %>%
  top_n(1, fraction)

# 2. Add total and maximum for each name
babynames %>%
  # Add columns name_total and name_max for each name
  group_by(name) %>%
  mutate(name_total = sum(number),
         name_max = max(number)) %>%
  # Ungroup the table
  ungroup() %>%
  # Add the fraction_max column containing the number by the name maximum
  mutate(fraction_max = number / name_max)

# 3. Visualizing the normalized change. Taking the data from the previous step and storing in variable (names_normalized)
names_filtered <- names_normalized %>%
  # Filter for the names Steven, Thomas, and Matthew
  filter(name %in% c('Steven', 'Thomas', 'Matthew'))

# Visualize these names over time
ggplot(names_filtered, aes(x = year, y = fraction_max, color = name)) +
geom_line()

# B. Window functions
# 1. Using ratios to describe the frequency of a name
babynames_fraction %>%
  # Arrange the data in order of name, then year
  arrange(name, year) %>%
  # Group the data by name
  group_by(name) %>%
  # Add a ratio column that contains the ratio of fraction between each year
  mutate(ratio = fraction / lag(fraction))

# 2. Biggest jumps in a name
babynames_ratios_filtered %>%
  # Extract the largest ratio from each name
  top_n(1, ratio) %>%
  # Sort the ratio column in descending order
  arrange(desc(ratio)) %>%
  # Filter for fractions greater than or equal to 0.001
  filter(fraction >= 0.001)


do.sim <- function(mix.par=0.2,mu1=5,sigma1=4,mu2=5,df=4,n=30,
                 alpha.vec=c(0,0.1,0.2), M=1000) {
#Purpose:
# Runs a simulation to compute the RMSEs for trimmed means from
#  samples taken from a 2 point normal and t mixture model
#Inputs:
# mix.par - mixture parameter of the distribution (range 0-1)
# mu1 - mean of the normal component of the mixture
# sigma1 - sd of the normal component of the mixture
# mu2 - mean of the t component of the mixture
# df - degrees of freedom for the t component
# n - size of samples to generate in simulation
# alpha.vec - vector of trimming levels to try (0=no trim i.e. mean,
#   0.5=trim 50th quantile above and below - i.e., median)
# M - number of simultions to run
#Output: List containing elements:
# MSE - vector of the MSEs at each trim level
# ests - matrix with M rows and length(alpha.vec) columns containing the raw estimates
# mu - the true mean of the input distribution

#initialize matrix of outputs
  est.matrix <- matrix(NA,M,length(alpha.vec))
#run simulation
  for(simulation in 1:M) {
    temp <- mix.dist(n,mix.par,mu1,sigma1,mu2,df)
    est.matrix[simulation, ] <- estimate.mean(temp,alpha.vec)
  }

#work out the expected value of the input distribution
  E.Z <- get.expectation(mix.par,mu1,mu2)

#Calculate MSEs
  mean.square.error <- mean.square.error(est.matrix,E.Z)

  return(list(MSE=mean.square.error, ests=est.matrix, mu=E.Z))

}


lst <- list(2)

checkIfPrime <- function(x) {
    for (elem in lst) {
       if (x %% elem == 0) {
           return (FALSE)
       }
    }
    lst <<- append(lst, x)
    return (TRUE)
}

findPrimes <- function(x) {
    ptr <- 3
    while (length(lst) < x) {
        checkIfPrime(ptr)
        ptr <- ptr+1
    }
    return (ptr)
}

l <- findPrimes(10001)
print(l)


# Q1

char_vec = c(letters)
char_vec

vowel_vec = char_vec[c(1,5,9,15,21)]
vowel_vec

consonant_vec = char_vec[-c(1,5,9,15,21)]
consonant_vec

# Q2

num_vec = c(1:20)
num_vec

even_vec = num_vec[seq(1:10)*2]
even_vec

odd_vec = num_vec[-seq(1:10)*2]
odd_vec

prime_vec = num_vec[c(2,3,5,7,11,13,17,19)]
prime_vec

# Q3

common_vec = intersect(odd_vec,prime_vec)
common_vec

# Q4

Scores = c(36, 42, 31, 85, 22, 90, 72, 68, 42, 85, 25)
Scores
min(Scores)
max(Scores)

# Q5

n_val = readline(prompt="Value of n: ")
n_val = as.integer(n_val)
n_val

Desc_Scores = sort.int(Scores, decreasing=TRUE)
Desc_Scores

if(n_val < length(Desc_Scores)) {
  nth_max = Desc_Scores[n_val]
} else {
  nth_max = -1
}
nth_max

# Q6

descending_scores = sort.int(Scores, decreasing=TRUE)
ascending_scores = sort.int(Scores, decreasing=FALSE)

descending_scores
ascending_scores

# Q7

marks = readline(prompt="Enter marks: ")
marks = as.integer(marks)
marks
Scores
match(marks, Scores)

# Q8

new_marks = readline(prompt="Enter new marks: ")
new_marks = as.integer(new_marks)
new_marks
index = match(new_marks, Scores)
if(is.na(index)) {
  index = -1
}
index

# Q9

Scores
unique_scores = unique(Scores)
unique_scores

# Q10

Scores
reverse_scores = rev(Scores)
reverse_scores

# Q11

my_vector <- c (28, 29, NA, 75, NA, 55, 67)
my_vector

# 11.a

length_of_my_vector = length(my_vector)
length_of_my_vector

# 11.b

my_vector[!is.na(my_vector)]

# 11.c

replace(my_vector, is.na(my_vector), 12)

# 11.d

length(which(is.na(my_vector)))

# 12

Name=c("Rohan", "ANMOL", "RAMYA", "Sai", "KESHAV")
Subject1 = c(34, NA, 21, 56, 57)
Subject2 = c(NA, 52, 46, 44, 20)

my_df <- data.frame(Name, Subject1, Subject2,stringsAsFactors=FALSE)
my_df

my_df[complete.cases(my_df[ , 1:2]),]

# 13

na.omit(my_df)


library(deSolve)
library(ggplot2)
library(RColorBrewer)
library(pracma)
library(reshape2)

set.seed(106745)

## external files
#################################################################################

stoc_spa_sir_file 	<- paste(getwd(), "../../sir-functions", "StocSSIR.r", sep = "/")
dewdrop_file 		<- paste(getwd(), "dewdrop.r", sep = "/")
source(stoc_spa_sir_file)
source(dewdrop_file)

## parameters
#################################################################################

T 		<- 100
N 		<- 500
i_infec <- 5
nloc  	<- 10
steps   <- 7
sigma   <- 10

pars <- c(	R0 	 = 3.0, # new infected people per infected person
          	r 	 = 0.1, # recovery rate
          	N 	 = 500, # population size
          	eta  = 0.5, # geometric random walk
          	berr = 0.5, # Beta geometric walk noise
          	phi  = 0.1) # degree of interconnectivity

## Simulate data
#################################################################################

initcond <- matrix(NA, nloc, 3)
colnames(initcond) <- c("S","I","R")

## default (everyone susceptible)
initcond[,"S"] <- N
initcond[,"I"] <- 0
initcond[,"R"] <- 0

## one region infected
initcond[2,] <- c(N - i_infec, i_infec, 0);

## set up number of neighbors vector and neighbor index matrix

## ring topology:
neinum <- rep(2,nloc)
neibmat <- matrix(NA, nloc, 3)
neibmat[,1] <- c( ((0:(nloc-1)-1)%%nloc)+1 )
neibmat[,2] <- c( ((0:(nloc-1)+1)%%nloc)+1 )

ssdeout <- StocSSIR(initcond, pars, T, steps, neinum, neibmat)

infec_counts <- ssdeout[,'I',] + matrix(rnorm(nloc*(T+1), 0, sigma), nloc, T+1)
infec_counts <- ifelse(infec_counts < 0, 0, infec_counts)

## Plot and save data
#################################################################################

df <- data.frame(time = 0:T, loc = t(ssdeout[,'I',]))
plotdata <- melt(df, id = "time")

## full
q <- qplot(data = plotdata, x = time, y = value, geom = "line", color = variable, xlab = "Time", ylab = "Infection Count") +
		scale_color_grey() +
		theme_bw()

ggsave(q, filename="dataplot.pdf", height=4, width=6.5)

## S-map
#################################################################################

## parameters
##

E <- 10
theta <- 3
stepsAhead <- 10

## comform data

Tlim <- 50
smapdata <- ssdeout[,'I',1:(Tlim + 1)]

## run S-map
##

predictions <- dewdrop(smapdata, E, theta, stepsAhead)

qp <- qplot(0:(Tlim+stepsAhead), c(smapdata[2,], rep(NA, stepsAhead)), geom = "line") +
		geom_line(aes(y = c(rep(NA, Tlim+1),predictions[2,])), linetype = "dashed") +
		theme_bw()

#p <- qplot(0:(T+stepsAhead), c(infec_counts, rep(NA, stepsAhead)), geom = "line", xlab = "Time", ylab = "Infection count") +
#		geom_line(aes(y = c(rep(NA, T+1), predictions)), linetype = "dotted") +
#		theme_bw()

#print(p)
#ggsave(p, filename="smap-project.pdf", height=4, width=6.5)


.kernel.squared.exponential <- function(x1, x2, l) {
    factor <- -1.0 / (2 * l * l)
    if (is.matrix(x1)) {
        sigma <- matrix(0, nrow(x1), nrow(x2))
        for (i in 1:nrow(sigma)) {
            v <- t(x1[i,] - t(x2))
            rsq <- apply(v * v, 1, sum)
            sigma[i,] <- exp(factor * rsq)
        }
    } else {
        sigma <- matrix(0, length(x1), length(x2))
        for (i in 1:nrow(sigma)) {
            v <- x1[i] - x2
            sigma[i,] <- exp(factor * v * v)
        }
    }

    return(sigma)
}

.kernel.se.integral <- function(alpha, l, D) {
    d <- sqrt((2*pi*l*l)^D)
    integral <- sum(d * alpha)
    return(integral)
}

.kernel.matern32 <- function(x1, x2, l) {
    if (is.matrix(x1)) {
        sigma <- matrix(0, nrow(x1), nrow(x2))
        for (i in 1:nrow(sigma)) {
            v <- t(x1[i,] - t(x2))
            rsq <- apply(v * v, 1, sum)
            y <- sqrt(3) * sqrt(rsq) / l
            sigma[i,] <- (1 + y) * exp(-y)
        }
    } else {
        sigma <- matrix(0, length(x1), length(x2))
        for (i in 1:nrow(sigma)) {
            v <- x1[i] - x2
            y <- sqrt(3) * sqrt(v * v) / l
            sigma[i, ] <- (1 + y) * exp(-y)
        }
    }

  return(sigma)
}

.kernel.matern32.integral <- function(alpha, l, D) {
  d <- 2 * (1+D) * (l * sqrt(pi/3)) ^ D * gamma(D) / gamma(D / 2)
  integral <- sum(d * alpha)
  return(integral)
}

.gp.log.marginal.likelihood <- function(l, b1, b2, result, verbose) {
  kxx <- result$kernel(result$x, result$x, l) + result$sigman * diag(result$n)

  return_value <- try(L <- chol(kxx), silent = !verbose)
  if (inherits(return_value, "try-error")) {
    return(NA)
  }

  if (is.null(result$meanfn)) {
    mean_sub <- rep(NA, length(result$p))
    for (i in 1:length(result$p)) {
      mean_sub[i] <- result$p[i] - b1 - b2 * (result$xcentered[i,] %*% result$xcentered[i,])
    }
    p1 <- sum(backsolve(L, mean_sub, transpose = T) ^ 2)
  } else {
    p1 <- sum(backsolve(L, result$pmean_sub, transpose = T) ^ 2)
  }
  logdet <- 2.0 * sum(log(diag(L)))
  logml <- -0.5 * p1 - 0.5 * logdet - 0.5 * result$n * log(2*pi)
  if (verbose) {
    cat(c("l:", l, "b1:", b1, "b2:", b2, "logml:",logml, "\n"))
  }
  return(logml)
}

.gp.log.marginal.likelihood.optiml <- function(x, result, verbose) {
  return(.gp.log.marginal.likelihood(x, result$b1, result$b2, result, verbose))
}
.gp.log.marginal.likelihood.optimb1 <- function(x, result, verbose) {
  return(.gp.log.marginal.likelihood(result$l, x, result$b2, result, verbose))
}

.gp.cv.optimize2 <- function(par, result, verbose) {
  result$sigman <- par[2]
  .gp.cv.optimize(par[1], result, verbose)
}

.gp.cv.optimize <- function(l, result, verbose) {
  nfolds <- 5
  n <- result$n
  if (is.matrix(result$x)) {
    D <- ncol(result$x)
  } else {
    D <- 1
  }

  sse <- rep(NA, nfolds)
  for (fi in 1:nfolds) {
    foldsize <- n / nfolds
    test_ix <- (fi - 1) * foldsize + 1:foldsize
    #test_ix <- sample(n, foldsize)
    train_ix <- setdiff(1:n, test_ix)

    if (is.matrix(result$x)) {
      xtrain <- result$x[train_ix,]
      xtest <- result$x[test_ix,]
    } else {
      xtrain <- result$x[train_ix]
      xtest <- result$x[test_ix]
    }
    nt <- length(train_ix)
    K <- result$kernel(xtrain, xtrain, l)

    return_value <- try(L <- chol(K + result$sigman * diag(nt)), silent = !verbose)
    if (inherits(return_value, "try-error")) {
      return(Inf)
    }

    alpha <- backsolve(L, backsolve(L, result$p[train_ix], transpose = T))

    ntest <- length(test_ix)
    ktest <- result$kernel(xtest, xtrain, l)

    integral <- result$kernel.integral(alpha, l, D)
    f <- abs(integral) * (ktest %*% alpha)
    f[f < 0] <- 0
    diff <- result$p[test_ix] - f
    sse[fi] <- sum(diff ^ 2)
    if (integral < 0) {
      # Heavily penalize negative integrals
      #sse[fi] <- sse[fi] * 1e10
    }

  }
  rmse <- sqrt(sum(sse) / n)

  if (verbose) {
    cat(c("l:", l, "sigman:", result$sigman, "rmse:", rmse, "\n"))
  }

  return(rmse)
}

#' Fit a Gaussian process density function.
#'
#' Fit a Gaussian process through the posterior density samples. The GP can optionally be normalized such that the predictive function integrates to 1.
#' The GP assumes a zero mean, and can use either a squared exponential or Matern-type covariance function. A single length scale parameter is used, which is
#' optimized by minimizing the RMSE in 5-fold cross validation.
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param p Probability density at the sample locations; does not have to be normalized. Note that the probabilities should not be log transformed.
#' @param kernel Which kernel to use, can be "se" or "matern32".
#' @param l If optimize == TRUE, this should be a vector of size two with the lower and upper bound for the length scale; if optimize == FALSE, this is the fixed length scale.
#' @param optimize Boolean specifying whether l (and possibly sigman) should be optimized.
#' @param normalize Boolean specifying whether to normalize the GP such that it integrates to 1.
#' @param sigman Can be either a fixed sigman or, if optimize == TRUE, this can also be a vector of size two specifying the lower and upper bound, and in this case sigman will be optimized along with l.
#' @param verbose Display progress during the optimization of l.
#' @export
fit.gp <- function(x, p, kernel, l = 1.0, optimize = T, normalize = T, sigman = 1e-12, verbose = F) {
    result <- list()
    result$type <- "gp"

    if (is.matrix(x)) {
        result$n <- nrow(x)
    } else {
        result$n <- length(x)
    }

    result$kernel.name <- kernel
    if (kernel == "squared.exponential" || kernel == "se") {
        result$kernel <- .kernel.squared.exponential
        result$kernel.integral <- .kernel.se.integral
    } else if (kernel == "matern32") {
        result$kernel <- .kernel.matern32
        result$kernel.integral <- .kernel.matern32.integral
    }

    result$x <- x
    result$p <- p
    result$log <- FALSE

    if (optimize) {
      stopifnot(length(l) > 1)
      options <- nloptr::nl.opts(list(ftol_rel = 1e-6))
      if (length(sigman) > 1) {
          opt <- nloptr::sbplx(c(mean(l), mean(sigman)), .gp.cv.optimize2, c(l[1], sigman[1]), c(l[2], sigman[2]), result = result, verbose = verbose, control=options)
          result$l <- opt$par[1]
          result$sigman <- opt$par[2]
      } else {
          result$sigman <- sigman
          # opt <- optimize(.gp.cv.optimize, l, result = result, verbose = verbose)
          # result$l <- opt$minimum
          opt <- nloptr::sbplx(mean(l), .gp.cv.optimize, l[1], l[2], result = result, verbose = verbose, control=options)
          result$l <- opt$par[1]
      }
    } else {
        result$l <- l
        result$sigman <- sigman
    }

    result$kxx <- result$kernel(result$x, result$x, result$l) + result$sigman * diag(result$n)
    L <- chol(result$kxx)
    result$alpha <- backsolve(L, backsolve(L, p, transpose = TRUE))

    if (normalize) {
        if (is.matrix(result$x)) {
            D <- ncol(result$x)
        } else {
            D <- 1
        }
        integral <- result$kernel.integral(result$alpha, result$l, D)
        result$s <- 1.0 / integral
    } else {
        result$s <- 1.0
    }

    return(structure(result, class = "mvd.density"))
}

#' Evaluate a Gaussian process density function
#'
#' description
#' @param fit mvd.density object
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @export
evaluate.gp <- function(fit, x, log) {
    stopifnot(fit$type == "gp")

  if (log) {
    if (fit$log) {
      kxsx <- fit$kernel(x, fit$x, fit$l)
      f <- kxsx %*% fit$alpha
      return(fit$s * f)
    } else {
      kxsx <- fit$kernel(x, fit$x, fit$l)
      f <- kxsx %*% fit$alpha
      p <- abs(fit$s) * f
      p[p < 0] <- 0
      return(log(p))
    }
  } else {
    if (fit$log) {
      kxsx <- fit$kernel(x, fit$x, fit$l)
      f <- kxsx %*% fit$alpha
      return(exp(fit$s * f))
    } else {
      kxsx <- fit$kernel(x, fit$x, fit$l)
      f <- kxsx %*% fit$alpha
      p <- abs(fit$s) * f
      p[p < 0] <- 0
      return(p)
    }
  }
}


# Author: Luis, Brent Ian
# Lab Section: CMSC 150 B-5L
# December 1, 2016

# implements Simplex method
Simplex <- function(matrix, numberOfRows, numberOfColumns){
  iterations = 0
  hasNegative = TRUE

  while(hasNegative){
    # selects the pivot column
    pivotColumn = 0
    for(i in seq(1, numberOfColumns-1)) {
      if(matrix[numberOfRows, i] < 0){  # checks negative elements in the last row
        if(pivotColumn == 0){
          pivotColumn = i
        } else if(matrix[numberOfRows, i] < matrix[numberOfRows, pivotColumn]){
          pivotColumn = i
        }# else if
      }# if
    }# for

    # selects the pivot row
    pivotRow = 0
    for(i in seq(1, numberOfRows-1)) {
      if(matrix[i, pivotColumn] > 0) {
        if(pivotRow == 0){
          pivotRow = i
        } else if(matrix[i, numberOfColumns] / matrix[i, pivotColumn] >= 0 && matrix[i, numberOfColumns] / matrix[i, pivotColumn] < matrix[pivotRow, numberOfColumns] / matrix[pivotRow, pivotColumn]){ # computes test ratio: solution column divided by the pivot column
          pivotRow = i
        }# else if
      }# if
    }# if

    # normalizes pivot row
    pivotElement = matrix[pivotRow, pivotColumn]
    matrix[pivotRow, ] = matrix[pivotRow, ] / pivotElement

    # implements Gauss-Jordan Elimination
    for(i in seq(1, numberOfRows)) {
      # retains only pivot row
      if(i != pivotRow){
        matrix[i, ] = matrix[i, ] - (matrix[pivotRow, ] * matrix[i, pivotColumn])
      }# if
    }# for

    # checks last row if it has negative
    hasNegative = FALSE
    for(i in matrix[numberOfRows, ]) {
      if(i < 0){
        hasNegative = TRUE
      } # if
    }# for

    # prints each iteration
    iterations = iterations + 1
    cat("Iteration: ", iterations, "\n")
    print(matrix)
  }# while
}# Simplex

# initializes the main function
Main <- function () {
  # reads input file as a matrix
  input <- read.csv(file="C:\\Users\\Brent Ian Luis\\Desktop\\luis_project\\test cases\\test case 1.csv", header=TRUE, sep=",")
  matrix <- as.matrix(input)

  # gets matrix dimensions
  numberOfRows = nrow(matrix)
  numberOfColumns = ncol(matrix)

  # prints initial tableau
  cat("Initial Tableau:\n")
  print((matrix))

  Simplex(matrix, numberOfRows, numberOfColumns)
}# Main


PCAplot.eset <- function(eset=NULL, categories=NULL, title=NULL, colorpalette=NULL, alpha=1, numcomponents=4){
  alpha <- sprintf("%x", ceiling(alpha*255))
  colorpalette <- paste(colorpalette, alpha, sep="")
  eset.core <- exprs(eset)
  myPca.core <- prcomp(t(eset.core))
  tmpPCAData.core <- as.data.frame(myPca.core$x[,1:numcomponents])
  pd <- pData(eset)
  colors <- colorpalette[factor(as.character(unlist(pd[,categories])))]
  legend_values=unique(cbind(colors, as.character(pd[,categories])))
  pairs(tmpPCAData.core, bg=colors, col="#606060", cex=2, pch=21, main=title, oma=c(8,5,5,14))
  legend("right", cex=0.7, col="#606060", pt.bg=legend_values[,1], pt.cex=1.5, legend=legend_values[,2],  pch=21, bty="n", x.intersp=1)
}

####################################
PCAplot.df <- function(df=NULL, meta.df=NULL, categories=NULL, title=NULL, colorpalette=NULL, alpha=1, numcomponents=6){
  alpha <- sprintf("%x", ceiling(alpha*255))
  colorpalette <- paste(colorpalette, alpha, sep="")
  myPca.core <- prcomp(t(df))
  tmpPCAData.core <- as.data.frame(myPca.core$x[,1:numcomponents])
  # SD of components
  colors <- colorpalette[factor(as.character(unlist(meta.df[,categories])))]
  legend_values=unique(cbind(colors, as.character(meta.df[,categories])))
  pairs(tmpPCAData.core, bg=colors, col="#606060", cex=2, pch=21, main=title, oma=c(8,5,5,14))
  legend("right", cex=0.7, col="#606060", pt.bg=legend_values[,1], pt.cex=1.5, legend=legend_values[,2],  pch=21, bty="n", x.intersp=1)
}

####################################
PCAplot.sd.eset <- function(eset=NULL,  title=NULL){
  eset.core <- exprs(eset)
  myPca.core <- prcomp(t(eset.core))
  # SD of components
  sdevdf <- data.frame(cbind(as.numeric(myPca.core$sdev),c(1:length(myPca.core$sdev))))
  sdevdf$prop <-  sdevdf$X1/sum(sdevdf$X1)
  sdevdf$cum <- cumsum(sdevdf$prop)
  ggplot(sdevdf, aes(x=X2, y=prop)) +
    geom_point(size=4, color="red") +
    scale_x_continuous('Component') +
    scale_y_continuous('Standard Deviation') +
    ggtitle(title) +
    geom_line(data=sdevdf, aes(x=X2, y=cum))
}

####################################
PCAplot.sd.df <- function(eset=NULL, title=NULL){
  myPca.core <- prcomp(t(df))
  # SD of components
  sdevdf <- data.frame(cbind(as.numeric(myPca.core$sdev),c(1:length(myPca.core$sdev))))
  sdevdf$prop <-  sdevdf$X1/sum(sdevdf$X1)
  sdevdf$cum <- cumsum(sdevdf$prop)
  ggplot(sdevdf, aes(x=X2, y=prop)) +
    geom_point(size=4, color="red") +
    scale_x_continuous('Component') +
    scale_y_continuous('Standard Deviation') +
    ggtitle(title) +
    geom_line(data=sdevdf, aes(x=X2, y=cum))
}


#----------------------------------------------------------------------#
# Function to calculate Fisher's Classification coefficients           #
# This code follows the formulas in Legendre and Legendre's Numerical Ecology (1998)   #
#----------------------------------------------------------------------#
classfunc.lda <- function(x, groups){
  x.lda <- lda(groups ~ ., as.data.frame(x))

  gr <- length(unique(groups))   ## groups might be factors or numeric
  v <- ncol(x)                   ## variables
  m <- x.lda$means               ## group means

  w <- array(NA, dim = c(v, v, gr))

  tot.len <- nrow(x)
  subgr.len <- array(0, gr)

  for(i in 1:gr){
    tmp <- scale(subset(x, groups == unique(groups)[i]), scale = FALSE)
    w[,,i] <- t(tmp) %*% tmp
    subgr.len[i] <- nrow(tmp)
  }

  W <- w[,,1]
  for(i in 2:gr)
    W <- W + w[,,i]

  V <- W/(nrow(x) - gr)
  iV <- solve(V)

  class.func <- matrix(NA, nrow = v + 1, ncol = gr)

  colnames(class.func) <- rownames(m)
  rownames(class.func) <- c("constant", colnames(m) )

  for(i in 1:gr) {
    ni <- subgr.len[i]
    class.func[1, i] <- -0.5 * t(m[i,]) %*% iV %*% (m[i,]) + log(ni / tot.len)
    class.func[2:(v+1) ,i] <- iV %*% (m[i,])
  }

  x.lda$class.func <- class.func

  return(x.lda)
}


# we are using different libraries
library(corrplot)
library(purrr)
library(ggplot2)
library(hrbrthemes)
library(raster)
library(tidyverse)
library(viridis)

# loading in full dataset
fpath<-"housing.csv"
all_housing<-read.csv(fpath,header=TRUE,stringsAsFactors = FALSE)

# checking what the data is, how it looks like, and what does it include
dim(all_housing)
colnames(all_housing)
str(all_housing)
head(all_housing)
summary(all_housing)
View(all_housing)

levels(as.factor(all_housing$ocean_proximity))

# checking how many NULL values do we have in each column
colSums(is.na(all_housing))

# cleaning all the records with NULL values
cleaned <- all_housing[rowSums(is.na(all_housing)) == 0,]
colSums(is.na(cleaned))  # rechecking

# to calculate the correlation matrix we need to have only numeric columns
cleanedNumeric <- cleaned[ , purrr::map_lgl(cleaned, is.numeric)]
# calculating the correlation matrix
hcor <- cor(cleanedNumeric)

# plotting
corrplot(hcor, method='number')

"
The most interesting for us in the plotted matrix is the 'total_bedrooms'
row/column, because we need to find the most correlated column, so that we can
replace the NULL values. As we see, it is the 'households' column, which is
quite expected, as each household needs a few bedrooms, so the variables
are highly correlated with positive sign: more households -> more bedrooms

As a matter of fact, we don't need so correlated columns/features in our dataset
because if we were trying to create the regression model, it would influence
the accuracy significantly. It is always much better not to have strongly
correlated feature.

So we use this column below to define the missing values
"

# calculating correlation coefficient and plotting
brcor <- cor(cleaned$total_bedrooms, cleaned$households)
brcor  # ~0.98, it means the dependence is almost linear
windowsFonts(
  A=windowsFont("Arial")
)
# plotting to see the the dependence
pl <- ggplot(cleaned, aes(x=households, y=total_bedrooms)) +
  labs(title="Total Bedrooms / Households Dependence",
       x="Households", y="Total Bedrooms") +
  theme(plot.title=element_text(size=30, face="bold", family='sans'),
        axis.text.x=element_text(size=15, family='sans'),
        axis.text.y=element_text(size=15, family='sans'),
        axis.title.x=element_text(size=25, family='sans'),
        axis.title.y=element_text(size=25, family='sans')) +
  geom_point( color="#69b3a2" ) +
  theme_ipsum(base_family = 'sans')
pl
"
As the result we get 207 NULLs for the total_bedrooms column
I decided to replace them using regression model based on correlation with
households, it means that we create this model, and if we meet record with
NULL value, we replace it with the predicted value
"
bhmodel <- lm(total_bedrooms ~ households, cleaned)
bhmodel
summary(bhmodel)

qqnorm(bhmodel$residuals)
qqline(bhmodel$residuals)  # we have smth to do with this

shapiro.test(sample(bhmodel$residuals, 2000))

# plotting with regression model
pl2 <- ggplot(cleaned, aes(x=households, y=total_bedrooms)) +
  labs(title="Total Bedrooms / Households Dependence",
       x="Households", y="Total Bedrooms") +
  theme(plot.title=element_text(size=30, face="bold"),
        axis.text.x=element_text(size=15),
        axis.text.y=element_text(size=15),
        axis.title.x=element_text(size=25),
        axis.title.y=element_text(size=25)) +
  geom_point( color="#69b3a2" ) +
  geom_smooth(method=lm , color="darkorange", se=FALSE) +
  theme_ipsum()
pl2

# replacing the missing values with predictions of our model
all_housing$total_bedrooms[is.na(all_housing$total_bedrooms)] =
  predict(bhmodel, all_housing[is.na(all_housing$total_bedrooms), ])

# checking if the null values has left
colSums(is.na(all_housing))

"
So, we have to transform categorical values into numerical, and it would be
great to remove outliers, but again, we are not building a model for now, so
it is not neccessary, as they may be interesting for the statistical analysis.
"

# checking columns for categorical values
str(all_housing)

# we need to transform the 'ocean_proximity' column
# let's draw it first
states    <- c('California')
us <- getData("GADM",country="USA",level=1)
us.states <- us[us$NAME_1 %in% states,]
us.bbox <- bbox(us.states)
xlim <- c(min(us.bbox[1,1]),max(us.bbox[1,2]))
ylim <- c(min(us.bbox[2,1]),max(us.bbox[2,2]))

plot(us.states, xlim=xlim, ylim=ylim, family="sans", main="Ocean proximity")
points(all_housing$longitude[all_housing$ocean_proximity=="<1H OCEAN"],
       all_housing$latitude[all_housing$ocean_proximity=="<1H OCEAN"],
       col = "#F8756D", cex = .5)
points(all_housing$longitude[all_housing$ocean_proximity=="NEAR BAY"],
       all_housing$latitude[all_housing$ocean_proximity=="NEAR BAY"],
       col = "#00BE7D", cex = .5)
points(all_housing$longitude[all_housing$ocean_proximity=="INLAND"],
       all_housing$latitude[all_housing$ocean_proximity=="INLAND"],
       col = "#A3A500", cex = .5)
points(all_housing$longitude[all_housing$ocean_proximity=="ISLAND"],
       all_housing$latitude[all_housing$ocean_proximity=="ISLAND"],
       col = "#03B0F6", cex = .5)
points(all_housing$longitude[all_housing$ocean_proximity=="NEAR OCEAN"],
       all_housing$latitude[all_housing$ocean_proximity=="NEAR OCEAN"],
       col = "#E76AF3", cex = .5)
legend(legend = c("<1H OCEAN", "NEAR BAY", "INLAND", "ISLAND", "NEAR OCEAN"),
       fill = c("#F8756D", "#00BE7D", "#A3A500", "#03B0F6", "#E76AF3"),
       "topright")

"
There are different ways to treat categorical features:
  a) create n features instead of 1 and make them boolean (1hot);
  b) create the mapping function;
  c) etc..
Let's try to create the mapping function. The first prediction looking on the
map would be: INLAND -> <1H OCEAN -> NEAR BAY -> NEAR OCEAN -> ISLAND
But let's take a look at the medium house value for each category.
"

all_housing %>% ggplot(aes(x=ocean_proximity, y=median_house_value,
                               fill=ocean_proximity)) +
  geom_boxplot() +
  scale_fill_viridis(discrete = TRUE, alpha=0.6) +
  geom_jitter(color="darkorange", size=0.4, alpha=0.4) +
  theme_ipsum() +
  theme(
    legend.position="none",
    plot.title = element_text(size=20),
    axis.text.x=element_text(size=12),
    axis.text.y=element_text(size=12),
    axis.title.x=element_text(size=15),
    axis.title.y=element_text(size=15)
  ) +
  labs(title="Median House Value by the Ocean Proximity",
       x="Ocean Proximity", y='Median House Value')

"
So we see that our prediction was quite accurate. The exception to it is
that NEAR BAY and NEAR OCEAN are very close, but NEAR BAY median is bigger,
so we can flip them in our mapping. It can be caused because of the urbanization
of the bay coast. San Francisco, Berkley, Oakland, Richmond, Fremont, San Jose,
Silicon Valley, Sacramento is quite close to it. The whole coast is sprinkled
with big cities, so that's probably the reason of it.

We can also see how many outliers there are in the all proximity categories
except ISLAND. It is because of the data, the problem is that all the median
house values above 500k were inserted as 500k, so if the real distribution is X,
we get Y ~ min(X, 500k), and it seems that it is gonna affect our analysis,
so we must be aware of it, and potencially we could do some more data cleaning
to get rid of those values, but it needs to be done very carefully, as we can
affect the outcome very seriously.

The problem described above is telling us, that we went the right way by
comparing medians, not means, because Y's median is the same as the X's, but
mean is strongly affected. Median is always much more robust to the outliers.

By now, let's get back to Ocean Proximity and change its value using mapping:
INLAND -> 1, <1H OCEAN -> 2, NEAR OCEAN -> 3, NEAR BAY -> 4, ISLAND -> 5
"

fac <- factor(all_housing$ocean_proximity,
       levels=c('INLAND', '<1H OCEAN', 'NEAR OCEAN', 'NEAR BAY', 'ISLAND'))
# let's check the mapping
data.frame(levels = unique(fac), value = as.numeric(unique(fac)))

all_housing$ocean_proximity <- as.numeric(fac)

# checking if the changes were made
str(all_housing)
head(all_housing)

# everything is ok, let's save our cleaned data to another csv file
write.csv(all_housing, file="cleaned_housing.csv", sep=",",
          col.names=TRUE, row.names=FALSE)

lim <- max(all_housing$median_house_value)
lim
sum(all_housing$median_house_value == lim)

# cleaning all the variables created before
rm(list=ls())

# ---------------------------------------------------
# Cleaning finished. Let's start analyzing
library(corrplot)
library(purrr)
library(ggplot2)
library(hrbrthemes)
library(raster)
library(tidyverse)
library(viridis)
library(forcats)
library(dplyr)
library(ggpubr)
# libraries reloading
windowsFonts(
  A=windowsFont("Arial")
)

housing <- read.csv("cleaned_housing.csv", header=TRUE)
str(housing)
summary(housing)

# checking if the null values has left
colSums(is.na(housing))

corm <- cor(housing)
corrplot(corm, method='number')

# visualizing the distributions of each feature
density.plot.properties <- list(
  geom_density(fill="darkorange", color="darkorange", alpha=1),
  theme_ipsum_rc(grid='Y'),
  theme(
    legend.position="none",
    axis.title.x = element_blank(),
    axis.title.y = element_blank()
  ))

# longitude
pb1 <- housing %>%
  ggplot( aes(x=longitude)) + density.plot.properties

# latitude
pb2 <- housing %>%
  ggplot( aes(x=latitude)) + density.plot.properties

# housing_median_age
pb3 <- housing %>%
  ggplot( aes(x=housing_median_age)) + density.plot.properties

# total_rooms
pb4 <- housing %>%
  ggplot( aes(x=total_rooms)) + density.plot.properties

pb5 <- housing %>%
  filter(total_rooms < 10000) %>%
  ggplot( aes(x=total_rooms)) + density.plot.properties

# total_bedrooms
pb6 <- housing %>%
  ggplot( aes(x=total_bedrooms)) + density.plot.properties

pb7 <- housing %>%
  filter(total_bedrooms < 2000) %>%
  ggplot( aes(x=total_bedrooms)) + density.plot.properties

# population
pb8 <- housing %>%
  ggplot( aes(x=population)) + density.plot.properties

pb9 <- housing %>%
  filter(population < 5000) %>%
  ggplot( aes(x=population)) + density.plot.properties

# households
pb10 <- housing %>%
  ggplot( aes(x=households)) + density.plot.properties

pb11 <- housing %>%
  filter(households < 2000) %>%
  ggplot( aes(x=households)) + density.plot.properties

# median_income
pb12 <- housing %>%
  ggplot( aes(x=median_income)) + density.plot.properties

# median_house_value
pb13 <- housing %>%
  ggplot( aes(x=median_house_value)) + density.plot.properties

# ocean_proximity
pb14 <- housing %>%
  ggplot( aes(x=ocean_proximity)) + density.plot.properties

# drawing it all at one page
theme_set(theme_pubr())
ggarrange(pb1, pb2, pb3, pb4, pb5, pb6, pb7, pb8, pb9, pb10, pb11, pb12, pb13,
          pb14, ncol=4, nrow=4, font.label=list(size = 10, family='A'),
          labels=c('Longitude', 'Latitude', 'Median Age', 'Total Rooms',
                   'Total Rooms filtered (< 10k)', 'Total Bedrooms',
                   'Total Bedrooms filtered (< 2k)', 'Population',
                   'Population filtered (< 5k)', 'Households',
                   'Households filtered (< 2k)', 'Median Income',
                   'Median House Value', 'Ocean Proximity'))

"
As we see many of the features are right-tailed, so to effectively use it,
we should do something with them. Also we can see that they don't have the
best distributions, and the medium_house_value is very weakly correlated with
almost all the columns, so we should try to do something with it.
Let's try feature engineering!

Thinking of the features, we can imply that total_rooms, total_bedrooms don't
have any sense by only themselves. We should combine them with the other
features and see if the correlation grows.

So let's try out:
  bedrooms per rooms,
  rooms per household,
  bedrooms per person,
  rooms per person,
  bedrooms per household,
  people per household

We could have also tried to create features that consider distance to the
closest cities and their population and so on, but it would require lots of
analysis with the longitude and latitude, and that is not what we do want.
"

# creating new features
housing$bedrooms_per_rooms <- housing$total_bedrooms / housing$total_rooms
housing$rooms_per_household <- housing$total_rooms / housing$households
housing$bedrooms_per_person <- housing$total_bedrooms / housing$population
housing$rooms_per_person <- housing$total_rooms / housing$population
housing$bedrooms_per_household <- housing$total_bedrooms / housing$households
housing$people_per_household <- housing$population / housing$households

# checking the correlation
corfe <- cor(housing)
corrplot(corfe, method='number')

# bedrooms_per_rooms
pfe1 <- housing %>%
  ggplot( aes(x=bedrooms_per_rooms)) + density.plot.properties

# rooms_per_household
pfe2 <- housing %>%
  ggplot( aes(x=rooms_per_household)) + density.plot.properties

# bedrooms_per_person
pfe3 <- housing %>%
  ggplot( aes(x=bedrooms_per_person)) + density.plot.properties

# rooms_per_person
pfe4 <- housing %>%
  ggplot( aes(x=rooms_per_person)) + density.plot.properties

# people_per_household
pfe5 <- housing %>%
  ggplot( aes(x=people_per_household)) + density.plot.properties

# bedrooms_per_household
pfe6 <- housing %>%
  ggplot( aes(x=bedrooms_per_household)) + density.plot.properties

# drawing it all at one page
ggarrange(pfe1, pfe2, pfe3, pfe4, pfe5, pfe6,
          ncol=2, nrow=3, font.label=list(size = 12, family='A'),
          labels=c('Bedrooms per room', 'Rooms per household',
                   'Bedrooms per person', 'Rooms per person',
                   'People per household', 'Bedrooms per household'))

# let's filter them to get the better scope
# bedrooms_per_rooms
pfe1f <- housing %>%
  filter(bedrooms_per_rooms < 0.4) %>%
  ggplot( aes(x=bedrooms_per_rooms)) + density.plot.properties

# rooms_per_household
pfe2f <- housing %>%
  filter(rooms_per_household < 11) %>%
  ggplot( aes(x=rooms_per_household)) + density.plot.properties

# bedrooms_per_person
pfe3f <- housing %>%
  filter(bedrooms_per_person < 1) %>%
  ggplot( aes(x=bedrooms_per_person)) + density.plot.properties

# rooms_per_person
pfe4f <- housing %>%
  filter(rooms_per_person < 4) %>%
  ggplot( aes(x=rooms_per_person)) + density.plot.properties

# people_per_household
pfe5f <- housing %>%
  filter(people_per_household < 6) %>%
  ggplot( aes(x=people_per_household)) + density.plot.properties

# bedrooms_per_household
pfe6f <- housing %>%
  filter(bedrooms_per_household < 2) %>%
  ggplot( aes(x=bedrooms_per_household)) + density.plot.properties

# drawing it all at one page
ggarrange(pfe1f, pfe2f, pfe3f, pfe4f, pfe5f, pfe6f,
          ncol=2, nrow=3, font.label=list(size = 12, family='A'),
          labels=c('Bedrooms per room filtered', 'Rooms per household filtered',
                   'Bedrooms per person filtered', 'Rooms per person filtered',
                   'People per household filtered',
                   'Bedrooms per household filtered'))

"
As we can see bedrooms_per_person doesn't introduce anything new, and
bedrooms_per_room is much more better than total_bedrooms, so we replace
total_bedrooms with it.

The useful newly constructed feature for us would be rooms_per_person, as
the correlation between it and median_house_value is 0.21, so we
replace total_rooms with this new feature.

Another one not interesting in the terms of regression, but in the terms of the
correlation between other features and the distribution of itself is
people_per_household. As we know, we don't need strong correlation between
features based on which we predict the value of another one. So it helps us,
because population was strongly correlated with the old features.

Let's see what a new dataset looks like
"

housingf <- dplyr::select(housing, -c('total_rooms', 'population', 'total_bedrooms',
                                      'bedrooms_per_household', 'rooms_per_household',
                                      'bedrooms_per_person'))
str(housingf)

fedone <- cor(housingf)
corrplot(fedone, method='number')

"
We did a great work! We don't have strong not-needed correlation except
longitude-latitude (that's because of the California shape), and
bedrooms_per_rooms - median-income, but that's not gonna affect the model
strognly. And, by the way, we got a few features which have much better
correlation with the median_house_value.

> 500k, scales, tail-heavy described in the report
"
write.csv(housingf, file="fe_housing.csv", sep=",",
          col.names=TRUE, row.names=FALSE)

# cleaning all the variables created before
rm(list=ls())

# -----------------------------------------------
library(corrplot)
library(purrr)
library(ggplot2)
library(hrbrthemes)
library(raster)
library(tidyverse)
library(viridis)
library(forcats)
library(dplyr)
library(ggpubr)
library(psych)
library(moments)
library(reshape)
library(reshape2)
library(MASS)
library(pastecs)

# for future visualization
density.plot.properties <- list(
  geom_density(fill="darkorange", color="darkorange", alpha=1),
  theme_ipsum_rc(grid='XY', base_family = 'sans'),
  theme(
    legend.position="none",
    axis.title.x = element_blank(),
    axis.title.y = element_blank()
  ))

plot.properties <- list(
  theme_ipsum_rc(grid='XY', base_family = 'sans'),
  theme(
    legend.position="none",
    axis.title.x = element_blank(),
    axis.title.y = element_blank()
))

housing <- read.csv('fe_housing.csv', header=TRUE)

head(housing, 4)

summary(housing)

# all the decsriptive values (look at the skew and kurt, should see tail-heavy)
describeBy(housing)

# calculating all the moments
all.moments(housing)

# calculating all the central moments
all.moments(housing, central=TRUE)

# melting the data for convenient boxplotting
melted <- melt.data.frame(housing)
head(melted)

melted %>% ggplot(aes(x=variable, y=value,
                           fill=variable)) +
  geom_boxplot() +
  scale_fill_viridis(discrete = TRUE, alpha=0.6) +
  geom_jitter(color="darkorange", size=0.05, alpha=0.1) +
  theme_ipsum() +
  facet_wrap(~variable,scales="free",ncol=5, nrow=2) +
  theme(
    legend.position="none",
    plot.title = element_text(size=20),
    axis.text.x=element_text(size=12),
    axis.text.y=element_text(size=12),
    axis.title.x=element_blank(),
    axis.title.y=element_blank()
  ) +
  labs(title="Boxplots for each feature")

# replacing outliers with NAs to remove them while melting
outlier.replace <- function(x){
  quantiles <- quantile( x, c(.003, .997 ) )
  x[ x < quantiles[1] ] <- NA
  x[ x > quantiles[2] ] <- NA
  return(x)
}

no_outs <- housing
for(i in names(no_outs)){
  no_outs[[i]] <- outlier.replace(no_outs[[i]])
}

# outliers per column
colSums(is.na(no_outs))

# melting the 'no outliers' data
melted_outs <- melt.data.frame(no_outs, na.rm=TRUE)

melted_outs %>% ggplot(aes(x=variable, y=value,
                      fill=variable)) +
  geom_boxplot() +
  scale_fill_viridis(discrete = TRUE, alpha=0.6) +
  geom_jitter(color="darkorange", size=0.05, alpha=0.1) +
  theme_ipsum() +
  facet_wrap(~variable,scales="free",ncol=5, nrow=2) +
  theme(
    legend.position="none",
    plot.title = element_text(size=20),
    axis.text.x=element_text(size=12),
    axis.text.y=element_text(size=12),
    axis.title.x=element_blank(),
    axis.title.y=element_blank()
  ) +
  labs(title="Boxplots for each feature")

# density plots below
p1 <- no_outs %>% ggplot(aes(x=longitude)) + density.plot.properties
p2 <- no_outs %>% ggplot(aes(x=latitude)) + density.plot.properties
p3 <- no_outs %>% ggplot(aes(x=housing_median_age)) + density.plot.properties
p4 <- no_outs %>% ggplot(aes(x=households)) + density.plot.properties
p5 <- no_outs %>% ggplot(aes(x=median_income)) + density.plot.properties
p6 <- no_outs %>% ggplot(aes(x=median_house_value)) + density.plot.properties
p7 <- no_outs %>% ggplot(aes(x=ocean_proximity)) + density.plot.properties
p8 <- no_outs %>% ggplot(aes(x=bedrooms_per_rooms)) + density.plot.properties
p9 <- no_outs %>% ggplot(aes(x=rooms_per_person)) + density.plot.properties
p10 <- no_outs %>% ggplot(aes(x=people_per_household)) + density.plot.properties

# drawing it all at one page
ggarrange(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10,
          ncol=2, nrow=5, font.label=list(size = 12, family='sans'),
          labels=names(housing))

# analysing the types of distributions
# bedrooms_per_rooms -------------------------------------
gap <- IQR(no_outs$bedrooms_per_rooms, na.rm=TRUE) /
  (length(na.omit(no_outs$bedrooms_per_rooms)) ^ (1/3))

no_outs %>% ggplot(aes(x=bedrooms_per_rooms)) + plot.properties +
  geom_histogram(binwidth = gap) +
  labs(title='Bedrooms per rooms distribution')
# qqplot
no_outs %>% ggplot(aes(sample=bedrooms_per_rooms))+stat_qq() +
  labs(title='Bedrooms per rooms QQ-plot')
# qqplot for normal distribution
ggplot(data.frame(d = rnorm(1000)), aes(sample=d)) + stat_qq()

stat.desc(sample(no_outs$bedrooms_per_rooms, 150), norm=TRUE)

shapiro.test(sample(no_outs$bedrooms_per_rooms, 50))
shapiro.test(sample(no_outs$bedrooms_per_rooms, 50))
shapiro.test(sample(no_outs$bedrooms_per_rooms, 50))

# log10 distr (could be ln, but the difference is only the constant)
bprlog <- data.frame(d = log10(no_outs$bedrooms_per_rooms))

gap <- IQR(bprlog$d, na.rm=TRUE) / (length(na.omit(bprlog$d)) ^ (1/3))

bprlog %>% ggplot(aes(x=d)) + plot.properties +
  geom_histogram(binwidth = gap)
  labs(title='Bedrooms per rooms log10-distribution')
# qqplot
bprlog %>% ggplot(aes(sample=d))+stat_qq() +
  labs(title='Bedrooms per rooms log10-distribution QQ-plot')

stat.desc(sample(bprlog$d, 150), norm=TRUE)

shapiro.test(sample(bprlog$d, 50))
shapiro.test(sample(bprlog$d, 50))
shapiro.test(sample(bprlog$d, 50))

# it is non-normal distribution

# median_income ------------------------------------------
gap <- IQR(no_outs$median_income, na.rm=TRUE) /
  (length(na.omit(no_outs$median_income)) ^ (1/3))

no_outs %>% ggplot(aes(x=median_income)) + plot.properties +
  geom_histogram(binwidth = gap) +
  labs(title='Median Income distribution')
# qqplot
no_outs %>% ggplot(aes(sample=median_income))+stat_qq() +
  labs(title='Median Income QQ-plot')

shapiro.test(sample(no_outs$median_income, 2000))
shapiro.test(sample(no_outs$median_income, 100))
shapiro.test(sample(no_outs$median_income, 200))

# log10 distr (could be ln, but the difference is only the constant)
milog <- data.frame(d = log10(no_outs$median_income))

gap <- IQR(milog$d, na.rm=TRUE) / (length(na.omit(milog$d)) ^ (1/3))

milog %>% ggplot(aes(x=d)) + plot.properties +
  geom_histogram(binwidth = gap) +
  labs(title='Median Income log10-distribution')
# qqplot
milog %>% ggplot(aes(sample=d))+stat_qq() +
  labs(title='Median Income log10-distribution QQ-plot')

stat.desc(sample(milog$d, 150), norm=TRUE)

shapiro.test(sample(milog$d, 50))
shapiro.test(sample(milog$d, 50))
shapiro.test(sample(milog$d, 50))

# it is non-normal distribution, although the log10 distr can be described so

# median_house_value -------------------------------------
gap <- IQR(no_outs$median_house_value, na.rm=TRUE) /
  (length(na.omit(no_outs$median_house_value)) ^ (1/3))

no_outs %>% ggplot(aes(x=median_house_value)) + plot.properties +
  geom_histogram(binwidth = gap) +
  labs(title='Median House Value distribution')
# qqplot
no_outs %>% ggplot(aes(sample=median_house_value))+stat_qq() +
  labs(title='Median House Value QQ-plot')

shapiro.test(sample(no_outs$median_house_value, 2000))
shapiro.test(sample(no_outs$median_house_value, 100))
shapiro.test(sample(no_outs$median_house_value, 200))

# log10 distr (could be ln, but the difference is only the constant)
mhvlog <- data.frame(d = log10(no_outs$median_house_value))

mhvlog <- mhvlog %>% filter(d < 5.698)

gap <- IQR(mhvlog$d, na.rm=TRUE) / (length(na.omit(mhvlog$d)) ^ (1/3))

mhvlog %>% ggplot(aes(x=d)) + plot.properties +
  geom_histogram(binwidth = gap) +
  labs(title='Median House Value log10-distribution')
# qqplot
mhvlog %>% ggplot(aes(sample=d))+stat_qq() +
  labs(title='Median House Value log10-distribution QQ-plot')

shapiro.test(sample(mhvlog$d, 50))
shapiro.test(sample(mhvlog$d, 50))
shapiro.test(sample(mhvlog$d, 50))

# point and interval estimation of
# median_income, median_house_value and bedrooms_per_rooms

# !!! the code is not absolutely valid here, use the one from .rnw file

estimations <- data.frame(mean=double(),
                          meanlow=double(),
                          meanup=double(),
                          var=double(),
                          varlow=double(),
                          varup=double()
                          )

income = na.omit(no_outs$median_income)
n1 = length(income)
s1 = sd(income)
SE1 = s1/sqrt(n1)
E1 = qt(.975, df = n1 - 1) * SE1
mu1 = mean(income)
var1 = var(income)
newr1 <- data.frame(mu1, NA, NA, var1, NA, NA)
names(newr1) <- names(estimations)
estimations <- rbind(estimations, newr1)

house.value = na.omit(no_outs$median_house_value)
n2 = length(house.value)
s2 = sd(house.value)
SE2 = s2/sqrt(n2)
E2 = qt(.975, df = n2 - 1) * SE2
mu2 = mean(house.value)
var2 = var(house.value)
newr2 <- data.frame(mu2, NA, NA, var2, NA, NA)
names(newr2) <- names(estimations)
estimations <- rbind(estimations, newr2)

# var2*(n2-1)/qchisq(.975, n2-1),
# var2*(n2-1)/qchisq(.025, n2-1)

# mu3 - E3, mu3 + E3

bpr = na.omit(no_outs$bedrooms_per_rooms)
n3 = length(bpr)
s3 = sd(bpr)
SE3 = s3/sqrt(n3)
E3 = qt(.975, df = n3 - 1) * SE3
mu3 = mean(bpr)
var3 = var(bpr)
newr3 <- data.frame(mu3, NA, NA, var3, NA, NA)
names(newr3) <- names(estimations)
estimations <- rbind(estimations, newr3)

# 1 - median_income
# 2 - median_house_value
# 3 - bedrooms_per_room
estimations

# testing different hypotheses
# let's look at the correlation matrix to try to ask some questions
Mcor <- cor(housing)
corrplot(Mcor, method='number')

# how does ocean_proximity affect median_house_value? ANOVA / Kruskal-Wallis
krusktmpdata <- no_outs %>% filter(ocean_proximity != 5)

kruskal.test(median_house_value ~ ocean_proximity, data = krusktmpdata)

# how being 'near bay' and 'near ocean' affect median price?
whitntmpdata <- no_outs %>% filter(ocean_proximity == 3 || ocean_proximity == 4)

wilcox.test(whitntmpdata$median_house_value, whitntmpdata$ocean_proximity)

pairwise.wilcox.test(krusktmpdata$median_house_value,
                     krusktmpdata$ocean_proximity,
                     p.adjust.method = "BH")

# how does median_income affect median_house_value? regression + correlation test
cor.test(no_outs$median_house_value, no_outs$median_income, method = "spearman")

# how does rooms_per_person affect median_house_value? correlation test
cor.test(no_outs$median_house_value, no_outs$rooms_per_person, method = "spearman")

# regression model
model <- lm(median_house_value ~ median_income + ocean_proximity +
              bedrooms_per_rooms + rooms_per_person + latitude +
              housing_median_age, no_outs, na.action=na.omit)
summary(model)

gap <- IQR(model$residuals, na.rm=TRUE) /
  (length(na.omit(model$residuals)) ^ (1/3))

model %>% ggplot(aes(x=model$residuals)) + plot.properties +
  geom_histogram(binwidth = gap) +
  labs(title='Model residuals distribution')

mean(model$residuals)

cor(model$model, model$residuals)

l <- length(model$residuals)
model %>% ggplot(aes(x=1:l, y=model$residuals)) + plot.properties +
  geom_point() +
  labs(title='Model Residuals')

varcor <- cor(model$model)
corrplot(varcor, method='number')

model %>% ggplot(aes(sample=model$residuals))+stat_qq() +
  labs(title='Model Residuals QQ-plot')

shapiro.test(sample(model$residuals, 50))
shapiro.test(sample(model$residuals, 50))
shapiro.test(sample(model$residuals, 50))
shapiro.test(sample(model$residuals, 50))
shapiro.test(sample(model$residuals, 50))


=begin
[((<index-ja|URL:index-ja.html>))]
= Algebra::EuclidianRing

((*(G.C.D.計算モジュール)*))

((|divmod|)) から G.C.D(最大公約数)等を計算するモジュールです。
これは ((|Integer|)) や ((|Algebra::Polynomial|)) にインクルードされます。

== ファイル名:
* ((|euclidian-ring.rb|))

== メソッド:

--- gcd(other)
    ((|self|)) と ((|other|)) との最大公約数を返します。

--- gcd_all(other0 [, other1[, ...]])
    ((|self|)) と ((|other0|)), ((|other1|)),... との最大公約数を返します。

--- gcd_coeff(other)
    ((|self|)) と ((|other|)) との最大公約数と、それを表現する係数の
    配列を返します。

    例:
      require "polynomial"
      require "rational"
      P = Algebra.Polynomial(Rational, "x")
      x = P.var
      f = (x + 2) * (x**2 - 1)**2
      g = (x + 2)**2 * (x - 1)**3
      gcd, a, b = f.gcd_coeff(g)
      p gcd #=> 4x^3 - 12x + 8
      p a   #=> -x + 2
      p b   #=> x - 1
      p gcd == a*f + b*g #=> true

--- gcd_ext(other)
    ((<gcd_coeff>)) と同じです。

--- gcd_coeff_all(other0 [, other1[, ...]])
    ((|self|)) と ((|other0|)), ((|other1|)),... との最大公約数と、それ
    を表現する係数の配列を返します。

    例:
      require "polynomial"
      require "rational"
      P = Algebra.Polynomial(Rational, "x")
      x = P.var
      f = (x + 2) * (x**2 - 1)**2
      g = (x + 2)**2 * (x - 1)**3
      h = (x + 2) * (x + 1) * (x - 1)
      gcd, a, b, c = f.gcd_coeff_all(g, h)
      p gcd #=> -8x^2 - 8x + 16
      p a   #=> -x + 2
      p b   #=> x - 1
      p c   #=> -4
      p gcd == a*f + b*g + c*h #=> true

--- gcd_ext_all(other)
    ((<gcd_coeff_all>)) と同じです。

--- lcm(b)
    ((|self|)) と ((|other|)) との最小公倍数を返します。

--- lcm_all(other0 [, other1[, ...]])
    ((|self|)) と ((|other0|)), ((|other1|)),... との最小公倍数を返します。

=end


act <- c(0, 1, 1, 0, 0)
pred <- c(0.12, 0.45, 0.9, 0.3, 0.4)

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

## check eps and handling of absolute zero and one probabilities
expect_equal(mtr_mean_log_loss(act, act), 0)

## Metrics::logLoss(act, pred)
## 0.3798404
expect_equal(
    mtr_mean_log_loss(act, pred),
    0.3798404,
    tol = 1e-7
)

## Metrics::ll(act, pred)
## c(0.1278334, 0.7985077, 0.1053605, 0.3566749, 0.5108256)
expect_equal(
    mtr_log_loss(act, pred),
    c(0.1278334, 0.7985077, 0.1053605, 0.3566749, 0.5108256),
    tol = 1e-7
)

## Test error ------------------------------------------------------------------

## raise error if outcome is not binary class
expect_error(
    mtr_log_loss(c(0, 1, 2, 0, 1), pred)
)

## raise error if length of input vectors are not equal
expect_error(
    mtr_log_loss(act, pred[-1])
)


tanident_1( 1*atan(1/2)    +  1*atan(1/3) )
## [1] TRUE
tanident_1( 2*atan(1/3)    +  1*atan(1/7))
## [1] TRUE
tanident_1( 4*atan(1/5)    + -1*atan(1/239))
## [1] TRUE
tanident_1( 5*atan(1/7)    +  2*atan(3/79))
## [1] TRUE
tanident_1( 5*atan(29/278) +  7*atan(3/79))
## [1] TRUE
tanident_1( 1*atan(1/2)    +  1*atan(1/5)   +   1*atan(1/8) )
## [1] TRUE
tanident_1( 4*atan(1/5)    + -1*atan(1/70)  +   1*atan(1/99) )
## [1] TRUE
tanident_1( 5*atan(1/7)    +  4*atan(1/53)  +   2*atan(1/4443))
## [1] TRUE
tanident_1( 6*atan(1/8)    +  2*atan(1/57)  +   1*atan(1/239))
## [1] TRUE
tanident_1( 8*atan(1/10)   + -1*atan(1/239) +  -4*atan(1/515))
## [1] TRUE
tanident_1(12*atan(1/18)   +  8*atan(1/57)  +  -5*atan(1/239))
## [1] TRUE
tanident_1(16*atan(1/21)   +  3*atan(1/239) +   4*atan(3/1042))
## [1] TRUE
tanident_1(22*atan(1/28)   +  2*atan(1/443) +  -5*atan(1/1393) + -10*atan(1/11018))
## [1] TRUE
tanident_1(22*atan(1/38)   + 17*atan(7/601) +  10*atan(7/8149))
## [1] TRUE
tanident_1(44*atan(1/57)   +  7*atan(1/239) + -12*atan(1/682)  +  24*atan(1/12943))
## [1] TRUE
tanident_1(88*atan(1/172)  + 51*atan(1/239) +  32*atan(1/682)  +  44*atan(1/5357) + 68*atan(1/12943))
## [1] TRUE
tanident_1(88*atan(1/172)  + 51*atan(1/239) +  32*atan(1/682)  +  44*atan(1/5357) + 68*atan(1/12944))
## [1] FALSE


#Generate the sets
a = runif(10,min=0,max=1)
b = runif(100,min=0,max=1)
c = runif(1000,min=0,max=1)
d = runif(10000,min=0,max=1)

#Print out the set of 10 values
cat("a = ",a)

#Print out the Mean and Standard Deviations of each of the sets
cat("Mean of a : ",mean(a))
cat("Standard Deviation of a : ", sd(a))
cat("Mean of b : ",mean(b))
cat("Standard Deviation of b : ", sd(b))
cat("Mean of c : ",mean(c))
cat("Standard Deviation of c : ", sd(c))
cat("Mean of d : ",mean(d))
cat("Standard Deviation of d : ", sd(d))

#Plotting the histogram of d
hist(d)

#Following lines error out due to insufficient memory

cat("Mean of a trillion random values in the range [0,1] : ",mean(runif(10^12,min=0,max=1)))
cat("Standard Deviation of a trillion random values in the range [0,1] : ", sd(runif(10^12,min=0,max=1)))


closest.pairs.bruteforce <- function(x, y=NULL)
{
	if (!is.null(y))
	{
		x <- cbind(x,y)
	}
	d <- dist(x)
	cp <- x[combn(1:nrow(x), 2)[, which.min(d)],]
	list(p1=cp[1,], p2=cp[2,], d=min(d))
}

closest.pairs.dandc <- function(x, y=NULL)
{
	if (!is.null(y))
	{
		x <- cbind(x,y)
	}
	if (sd(x[,"x"]) < sd(x[,"y"]))
	{
		x <- cbind(x=x[,"y"],y=x[,"x"])
		swap <- TRUE
	}
	else
	{
		swap <- FALSE
	}
	xp <- x[order(x[,"x"]),]
	.cpdandc.rec <- function(xp,yp)
	{
		n <- dim(xp)[1]
		if (n <= 4)
		{
			closest.pairs.bruteforce(xp)
		}
		else
		{
			xl <- xp[1:floor(n/2),]
			xr <- xp[(floor(n/2)+1):n,]
			cpl <- .cpdandc.rec(xl)
			cpr <- .cpdandc.rec(xr)
			if (cpl$d<cpr$d) cp <- cpl else cp <- cpr
			cp
		}
	}
	cp <- .cpdandc.rec(xp)

	yp <- x[order(x[,"y"]),]
	xm <- xp[floor(dim(xp)[1]/2),"x"]
	ys <- yp[which(abs(xm - yp[,"x"]) <= cp$d),]
	nys <- dim(ys)[1]
	if (!is.null(nys) && nys > 1)
	{
		for (i in 1:(nys-1))
		{
			k <- i + 1
			while (k <= nys && ys[i,"y"] - ys[k,"y"] < cp$d)
			{
				d <- sqrt((ys[k,"x"]-ys[i,"x"])^2 + (ys[k,"y"]-ys[i,"y"])^2)
				if (d < cp$d) cp <- list(p1=ys[i,],p2=ys[k,],d=d)
				k <- k + 1
			}
		}
	}
	if (swap)
	{
		list(p1=cbind(x=cp$p1["y"],y=cp$p1["x"]),p2=cbind(x=cp$p2["y"],y=cp$p2["x"]),d=cp$d)
	}
	else
	{
		cp
	}
}

# Test functions
cat("How many points?\n")
n <- scan(what=integer(),n=1)
x <- rnorm(n)
y <- rnorm(n)
tstart <- proc.time()[3]
cat("Closest pairs divide and conquer:\n")
print(cp <- closest.pairs.dandc(x,y))
cat(sprintf("That took %.2f seconds.\n",proc.time()[3] - tstart))
plot(x,y)
points(c(cp$p1["x"],cp$p2["x"]),c(cp$p1["y"],cp$p2["y"]),col="red")
tstart <- proc.time()[3]
cat("\nClosest pairs brute force:\n")
print(closest.pairs.bruteforce(x,y))
cat(sprintf("That took %.2f seconds.\n",proc.time()[3] - tstart))


#биномно разпределение - n независими опита с вероятност за успех на всеки p и за провал 1-p=q
#dbinom - Р(X = x)
x <- seq(0,50,by=1)
y <- dbinom(x = x, size = 50, prob = 0.2) #вероятността да имаш x успешни опита от общо size опита с вероятност за усех prob
plot(x,y)
y <- dbinom(x = x, size = 50,prob = 0.5)
plot(x,y)

#pbinom - P(X <= x)
pbinom(q = 24, size = 50, prob = 0.5) #вероятността да имаш по-малко или равно на q успеха от общо size опита с вероятност за усех prob
pbinom(q = 25, size = 50, prob = 0.5, lower.tail = FALSE) #P(X>x) -> вероятността да имаш повече от q успеха от общо size опита с вероятност за усех prob

#qbinom - по зададена вероятност намира колко успеха от size опита с вероятност за успех prob е имало (обратното на dbinom)
qbinom(p = 0.4438624,size = 50, prob = 1/2)
qbinom(p = 0.5561376,size = 50, prob = 0.5)

#rbinom за генериране на n случайно разпределени величини от 0 до size с вероятноса за успех prob
rbinom(n = 5, size = 10, prob = 0.2)
rbinom(n = 5, size = 100,prob = 0.2)

#отрицателно биномно разпределение - колко неусеха да получаване на фиксиран брй успехи
#dnbinom - вероятността да има x неуспеха да получаването на size-тия успех с вероятност за успех prob
dnbinom(x = c(1:10), size = 5, prob = 0.5)

#pnbinom
pnbinom(q = 8, size = 3, prob = 0.2) #вероятността да има по-малко или равно на q неуспеха дo получаването на size-тия успех с вероятност за успех prob
pnbinom(q = 8, size = 3, prob = 0.2, lower.tail = FALSE) #повече от q неуспеха до получаването на size-тия успех с вероятност за успех prob

#qnbinom и rnbinom аналогични на qbinom и rbinom

#Хипергеометрично разпределение - N обекта, M от тях са маркирани, по случаен начин избираме n на брой. X - броят на маркираните, измежду тези които сме избрали случайно
#функцията hyper() с префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)
success=c(0:6)
dhyper(x = success, m = 6, n = 30, k = 6)

#Поасоново разпределение - биномно разпределение, което има много малка вероятност
#n->inf, p->0, np = lamda
#Функция pois() c префикси d,p,q,r за съответно плътност, разпределние, квантил и случайно разпределение(симулиране)
ppois(q = 16, lambda = 12)

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

#01
#биномно разпределение n=79, k=29, p=1/2
result = choose(79,29) * 1/(2^29) * 1/(2^50) #choose смята биномен коефициент
result.binom = dbinom(x = 29, size = 79, prob = 1/2)

#02
not.fixed = pbinom(q = 2, size = c(3,4,5,7,8), prob = 1/2) #по-малко или равно на size опита за изтегляне на 2 езита
fixed = dbinom(x = 2, size = c(3,4,5,7,8), prob = 1/2) #точно size опита за изтегляне на 2 езита

plot(x= c(3,4,5,7,8), y = not.fixed, type = "l", main = "Dstribution of two ezi", xlab = "Number of tries", ylab = "Probability")
lines(x= c(3,4,5,7,8), y = fixed, type = "p", col = "red")

#03
#оцелването на тройка е биномно разпределена случайна величина с вероятност за успех p = 0.7
n = qbinom(p = 1 - 0.18522, size = 3, prob = 0.7 ) + 3 #???

x = qbinom(p = 0.18522, size = c(3:10), prob = 0.7 ) #с вероятност 0.18522 проверяваме от 3 до няколко(10) опита на кой опит ще е уцелил три пъти
names(x) = c(3:10)
result = as.numeric(names(x[x == 3]))
# => на 5-ти и 6-ти опит ще е оцелил три тройки с вероятност 0.18522

#04
#вероятността да има <=35 жени в извадка от k = 100 човека, като жените са m = 40% от 600000 човека, а мъжете са n = 60% от 600000 човека
theoretical = phyper(q = 35, m = 0.4*600000, n = 0.6*600000, k = 100)
pop = rep(c(0,1),c(360000, 240000)) #симулираме 600000 човека -> 360000 нули за мъжете и 240000 единици за жените
res=sapply(c(0:1000), function(x) sum(sample(pop,100))) # 1000 елементен вектор с резултатите за общия брой жени в случайна извадка от 100 човека
empirical = sum(res<=35)/100

#05
#поасоново разпределение с ламда = 2 обаждания за минута
# => поасоново разпределенеи с ламда = 2*5 = 10 обаждания за 5 минути
exactly.2 = dpois(x = 2, lambda = 10) # P(X = 2)
less.than.2 = ppois(q = 1, lambda = 10) # P(X <= 1) = P(X < 2)
more.than.2 = ppois(q = 1, lambda = 10, lower.tail = FALSE) # P(X > 1) = P(X >= 2)

#06
#отрицателно биномно разпределение с вероятност за успех 4/52 (4 аса от 52 карти)
#търсим вероятността за 4 провала до първия успех => 5-тата изтеглена карта е асо
dnbinom(x = 4, size = 1, prob = 4/52)
dgeom(x = 4, prob = 4/52)


# ......................................................................................
# ..............................Exercise 4 - Random vector..............................
# he content of this script is only as a supplementary illustration to the exercise, it is not necessary to know at the exam. It is important to be able to calculate manually.**
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

#  Example ####
#
# Random vector $Z =(Y;X)^T$ has a probability function specified by the table </br>
#  ![Image.png](attachment:image.png)
#
# * a) Determine the missing value of the combined probability function, ####
#

data = c(0.01, 0.04, 0.12,
         0.02, 0.16, 0.07,
         0.03, 0,    0.06,
         0.25, 0.05, 0.01)
P = matrix(data , nrow=3, ncol=4) # possibly byrow=...
X = c(3, 5, 7)
Y = c(1, 2, 3, 4)
dimnames(P) = list(X,Y)
P

sum(P)

# do not run this cell twice, otherwise you will set the value back to 0,
# Do you know why?
p_5_3 = 1 - sum(P)
P["5","3"] = p_5_3
P

# * b) Specify the distribution function ####
#
# **Attention! The vector Z is $(Y,X)^T$ so the first parameter is the value Y and the
# second value X.**
#

# F(2.8; 7.1)
# P(Y<2.8, X<7.1)
P[X<7.1, Y<2.8]
sum(P[X<7.1, Y<2.8])

F = matrix(rep(0,4*5), nrow=4, ncol=5)
dimnames(F) = list(c('(-inf,3>', '(3,5>', '(5,7>', '(7,inf)'),
                   c('(-inf,1>', '(1,2>', '(2,3>', '(3,4>', '(4,inf)'))
F

# we go through the rows and columns, we always take one value
# from the relevant row or column
x_vals = c(3,5,7,8)
y_vals = c(1,2,3,4,5)
for(i in 1:4){
    for(j in 1:5){
        x = x_vals[i]
        y = y_vals[j]
        F[i,j] = sum(P[X<x, Y<y])
    }
}
F

# * c) Determine the marginal distribution ####
#

P_x = rowSums(P)
P_x

F_x = c(0, cumsum(P_x))
F_x

P_y = colSums(P)
P_y

F_y = c(0, cumsum(P_y))
F_y

# * d) Conditional probabilities and conditional probability functions $P(x|y), P(y|x)$ ####
#

# P(Y>2.1|X<5.3)
# P(Y>2.1 ∧ X<5.3)/P(X<5.3)
sum(P[X<5.3, Y>2.1])
sum(P[X<5.3,])
sum(P[X<5.3, Y>2.1])/sum(P[X<5.3,])

# P(X=5|Y=1)
# P(X=5 ∧ Y=1)/P(Y=1)
P['5','1']/sum(P[,'1'])
P['5','1']/sum(P_y['1'])

# **$P(x|y)=\frac{P(X=x,Y=y)}{P_Y(y)}$**
#

P_xy = P # it's the same size, so we'll steal the formatting
X_lab = c('3', '5', '7')
Y_lab = c('1', '2', '3', '4')
for(x in X_lab){
    for(y in Y_lab){
        P_xy[x, y] = P[x, y]/P_y[y]
    }
}
P_xy
colSums(P_xy)

# **$P(y|x)$**
#

P_yx = P # it's the same size, so we'll steal the formatting
for(x in X_lab){
    for(y in Y_lab){
        P_yx[x, y] = P[x, y]/P_x[x]
    }
}
P_yx
rowSums(P_yx)

# * e) basic characteristics of random variables X and Y ####
#

E_X = sum(X*P_x)
E_X
E_XX = sum(X*X*P_x)
D_X = E_XX - E_X^2
D_X

E_Y = sum(Y*P_y)
E_Y
E_YY = sum(Y*Y*P_y)
D_Y = E_YY - E_Y^2
D_Y

# * f) conditional mean E(X|Y=2) ####
#

# P(x|Y=2)
P_xy[,'2']
E_X_Y2 = sum(X*P_xy[,'2'])
E_X_Y2

# * g) covariance and correlation ####
#

X_Y = P # matrix where in each column is the value x * y
for(x in X){
    for(y in Y){
        X_Y[toString(x), toString(y)] = x*y
    }
}
X_Y

# or we can use matrix multiplication
X %*% t(Y)

# mean value of E(X * Y)
E_XY = sum(X_Y*P)
E_XY

# covariance
cov_XY = E_XY-E_X*E_Y
cov_XY

# correlation
cov_XY/sqrt(D_X*D_Y)


oes <-read_csv("~/oes")

#examine values
summary(oes)
glimpse(oes)

#####Using Hierachical Clustering

# Calculate Euclidean distance between the occupations
dist_oes <- dist(oes, method = "euclidean")

# Generate an average linkage analysis
hc_oes <- hclust(dist_oes, method = 'average')

# Create a dendrogram object from the hclust variable
dend_oes <- as.dendrogram(hc_oes)

# Plot the dendrogram
plot(dend_oes)

# Color branches by cluster formed from the cut at a height of 100000
dend_colored <- color_branches(dend_oes, h = 100000)

# Plot the colored dendrogram
plot(dend_colored)

dist_oes <- dist(oes, method = 'euclidean')
hc_oes <- hclust(dist_oes, method = 'average')

library(tibble)
library(tidyr)

# Use rownames_to_column to move the rownames into a column of the data frame
df_oes <- rownames_to_column(as.data.frame(oes), var = 'occupation')

# Create a cluster assignment vector at h = 100,000
cut_oes <- cutree(hc_oes, h = 100000)

# Generate the segmented the oes data frame
clust_oes <- mutate(df_oes, cluster = cut_oes)

####

# Create a tidy data frame by gathering the year and values into two columns
gathered_oes <- gather(data = clust_oes,
                       key = year,
                       value = mean_salary,
                       -occupation, -cluster)

# Use map_dbl to run many models with varying value of k (centers)
tot_withinss <- map_dbl(1:10,  function(k){
  model <- kmeans(x = oes, centers = k)
  model$tot.withinss
})

# Generate a data frame containing both k and tot_withinss
elbow_df <- data.frame(
  k = 1:10,
  tot_withinss = tot_withinss
)

# Plot the elbow plot
ggplot(elbow_df, aes(x = k, y = tot_withinss)) +
  geom_line() +
  scale_x_continuous(breaks = 1:10)

# Use map_dbl to run many models with varying value of k
sil_width <- map_dbl(2:10,  function(k){
  model <- pam(oes, k = k)
  model$silinfo$avg.width
})

# Generate a data frame containing both k and sil_width
sil_df <- data.frame(
  k = 2:10,
  sil_width = sil_width
)

# Plot the relationship between k and sil_width
ggplot(sil_df, aes(x = k, y = sil_width)) +
  geom_line() +
  scale_x_continuous(breaks = 2:10)


func <- function(x,y)
{
  func1 <- (-5*y) + 5*x^2 + 2*x
}

Euler <- function (x0, y0, h, n )
{
  x <- x0
  y <- y0

  for ( i in 1 : n )
  {
    y0 <- y0 + h * func ( x0, y0 )
    x0 <- x0 + h
    x <- c ( x, x0 )
    y <- c ( y, y0 )
  }

  return ( data.frame ( x = x, y = y ) )
}

Euler(0, 1/3, 0.1 ,10)


#' @title calcCbw
#'
#' @description Calculates the waterline block coefficient (\code{Cbw})
#' (dimensionless) using actual draft.
#'
#' @param Cb Maximum block coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCb}})
#' @param actualDraft Actual draft (vector of numericals, m)
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#'
#' @details
#' The block coefficient is the ratio of the vessel's displacement and its
#' volume, defined by its waterline length (\code{lwl}), breadth, and draft:
#' \deqn{Cb=\frac{displacement}{lwl*breadth*draft}}{Cb=displacement/(lwl*breadth*draft)}
#'
#' This function returns the  waterline block coefficient (\code{Cbw}), which
#' represents a loaded condition estimation using actual draft using the
#' Riddlesworth method. Actual draft is typically obtained from sources such as
#' AIS messages or ship records.
#'
#' NOTE: Technically, no block coefficient can be greater than 1. Even a
#' waterline block coefficient of 1 itself is extremely improbable and can cause
#' numerical errors elsewhere in the model. Therefore, the upper bound of the
#' waterline block coefficient is fixed at 0.99 in this function.
#'
#' @return \code{Cbw} (vector of numericals, dimensionless)
#'
#' @references
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#' @seealso \code{\link{calcCb}}
#'
#' @examples
#' calcCbw(c(0.82,0.66),c(12.48,11.09),c(13.57,11.49))
#' calcCbw(0.82,12.48,13.57)
#'
#' @export

calcCbw <- function(Cb,actualDraft,maxDraft){

  #ensure that: actualDraft < maxDraft
  actualDraft<-pmin(actualDraft,
                    maxDraft)

  Cbw<- pmin(0.99,
             1-(1-pmin(0.99,
                        Cb
                       )
                )*((maxDraft/actualDraft)^(1/3))
  )
  return(Cbw)
}


arr <- c(1,2,3,4,5)
result <- sum(arr^2)


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

rm(list = ls())

library(ggplot2)
library(MASS)

#
# 1)
# Importar los datos a SAS desde el fichero Olympic2016 v2.txt;
#

DATA <- read.csv('./../../../datasets/olympic-2016-v2.txt', header=TRUE)

A <- DATA[,1:10]
rownames(A) <- DATA[,12]

#
# 2)
# Efectuar mediante un ACP normado con los datos de las 10 pruebas.
#

X <- t((t(A) - colMeans(A)) / apply(A, 2, sd))
X_n <- dim(X)[1]
X_p <- dim(X)[2]

X_star <- (t(X) %*% X) / (X_n-1)

X_eig <- eigen(X_star)
X_lambda <- X_eig$values
X_u <- X_eig$vectors

#
# 3)
# Calcular los scores en las 10 componentes y comprobar que tienen media 0
# y varianza igual al autovalor correspondiente.
#

F <- X %*% X_u

ggplot(as.data.frame.matrix(F), aes(x=V1, y=V2)) +
  geom_point() +
  geom_text(label=rownames(F))

0 == round(colMeans(F), digits=4)
round(X_lambda, digits=4) == round(apply(F, 2, sd) ^ 2, digits=4)
sum(X_lambda)

#
# 4)
# Calcular las contribuciones absolutas y relativas de los puntos a las
# componentes y hacer la representación gráfica correspondiente.
#

X_ca <- t(t(F^2) / rowSums(t(F ^ 2)))
X_re <- (F^2) / rowSums(F ^ 2)

print(round(X_ca, digits = 4))
print(round(X_re, digits = 4))

#
# 5)
# Considerar ahora la nube de los puntos columna y calcular los autovalores y
# autovectores correspondientes. Comprobar las relaciones con los resultados
# de la nube de puntos fila.
#

X_v <- t(t(F) / sqrt(X_lambda * (X_n - 1)))

print(round(X_v, digits = 4))

G <- t(X) %*% X_v

print(G)

X_u_2 <- t(t(G) / sqrt(X_lambda * (X_n - 1)))

round(X_u_2, digits = 4) == round(X_u, digits = 4)

ggplot(as.data.frame.matrix(G), aes(x=V1, y=V2)) +
  geom_point() +
  geom_text(label=rownames(G))

#
# 6)
# Calcular las proyecciones de las variables (scores) en los nuevos ejes.
# Calcular sus medias, sus varianzas y la suma de sus cuadrados (dividida por n-1).
#

# Medias (nada)
round(colMeans(G), digits=4)

# Varianzas (Nada)
round(apply(G, 2, sd) ^ 2, digits=4)

# Suma de cuadrados dividida entre n-1 (lambdas o autovalores)
round(colSums(G^2)/(X_n -1), digits=4)

#
# 7)
# Reconstruir la matriz de datos original a partir de los autovalores y
# autovectores.
#

# Reconstrucción de la matriz de covarianzas
X_u %*% diag(X_lambda) %*% ginv(X_u)

# Reconstrucción de la matriz de datos
X
(X_v %*% diag(sqrt(X_lambda  * (X_n -1))) %*% t(X_u))

#
# 8)
# Reconstruir la matriz con las dos primeras componentes principales y valorar
# la pérdida.
#

# Ratio de distorsión por la reducción de dimensiones
1-sum(X_lambda[1:2]) / sum(X_lambda)

# Reconstrucción de la matriz de covarianzas
X_u[,1:2] %*% diag(X_lambda[1:2]) %*% ginv(X_u[,1:2])

# Reconstrucción de la matriz de datos
X_v[,1:2] %*% diag(sqrt(X_lambda[1:2] * (X_n -1))) %*% t(X_u[,1:2])