### 線形回帰分析(重回帰)の例
### - New York Air Quality Measurements

## パッケージの読み込み
require(tidyverse)
require(ggfortify)
require(GGally)

## データの読み込み ("datasets::airquality"を用いる)
data(airquality)   # データの読み込み
help(airquality)   # 内容の詳細を表示
str(airquality)    # データの構造を表示

## データの内容を表示
head(airquality,n=10) # 最初のnデータを表示
tail(airquality,n=10) # 最後のnデータを表示
## print(airquality) では表示が長すぎる

## データのプロット (pairs plot)
mydat <- airquality %>%
    mutate(Level=ifelse(Ozone>60,"high",ifelse(Ozone<20,"low","mid")))
mydensity <- function(data, mapping, ...) {
  ggplot(data = data, mapping = mapping) +
      geom_point(...,colour="gray50",size=1) +
      geom_density_2d(alpha=.8)
}
ggpairs(na.omit(mydat), columns=1:4,
        upper=list(continuous=mydensity),
        lower=list(continuous=wrap("smooth_loess"),
                   mapping=aes(colour=Level))) +
    theme(axis.title.x=element_text(size=10),
          axis.title.y=element_text(size=10)) # 文字の大きさを調整

## データの素性を確認
is.data.frame(airquality) # データフレームかどうか確認
names(airquality) # 各列の名称を調べる
dim(airquality)   # データフレームのサイズを調べる

## 回帰分析 (Ozoneを目的変数，Solar.R, Wind, Tempを説明変数)
model <- lm(Ozone ~ Solar.R + Wind + Temp, data=airquality)
summary(model) # 分析のまとめ

## モデルの計算結果を表示する関数群
coef(model)   # または coefficients(model): モデルの係数
resid(model)  # または residuals(model): 各データの残差
fitted(model) # または fitted.values(model): 各データの予測値
## これ以外にも以下が用意されている
## effects(model)
## deviance(model)
## df.residual(model)
## anova(model)
## モデルが保持している情報の要素名を調べるには
##  names(model)
## 各要素の表示を行うには
##  model$coefficients, model$residuals, model$fitted.values
## などとすればよい

## 当て嵌り具合を表示
mydat <- airquality %>%
    mutate(Date=as.Date(paste(Month,Day,"73",sep="/"),"%m/%d/%y"),
           Pred=predict(model, newdata=airquality))
ggplot(mydat, aes(Date)) +
    geom_line(aes(y=Ozone,colour="true"), size=1) +
    geom_line(aes(y=Pred, colour="predict"), size=1) +
    scale_colour_manual(values=c(predict="blue",true="red")) + # lineの色を指定
    theme(legend.position=c(.9,.9))  # 凡例の位置を指定

## 診断プロット (いろいろと問題の多いモデルであることがわかる)
autoplot(model)

## モデルの指定方法
## 風量(Wind) と 温度(Temp) で回帰
summary(lm(Ozone ~ Wind + Temp, data=airquality))
## 切片を0として Wind と Temp で回帰
summary(lm(Ozone ~ Wind + Temp - 1, data=airquality))
## Wind と Temp の積の効果まで入れて回帰
summary(lm(Ozone ~ Wind * Temp, data=airquality))
## Wind と Temp の積と Wind で回帰
summary(lm(Ozone ~ Wind * Temp - Temp, data=airquality))
## Wind の2次多項式で回帰
summary(lm(Ozone ~ Wind + I(Wind^2), data=airquality))
## Wind の2次直交多項式で回帰
summary(lm(Ozone ~ poly(Wind,2), data=airquality))

## 関数 update によるモデルの更新方法
## Wind のみで回帰
summary(model <- lm(Ozone ~ Wind, data=airquality))
## Solar.R を加える
summary(model <- update(model, . ~ . + Solar.R, data=airquality))
## Solar.R の積の効果を加える
summary(model <- update(model, . ~ . * Solar.R, data=airquality))
## 切片を 0 にする
summary(model <- update(model, . ~ . -1 , data=airquality))

## AICによる最適なモデルの自動探索
## 初期モデルの設定 (ここでは全ての相互作用を含むモデルを用いる)
summary(model <- lm(Ozone ~ Solar.R * Wind * Temp, data=airquality))
## AICの意味で最適なモデルを探索
summary(opt <- step(model))

## 当て嵌り具合を表示
mydat <- airquality %>%
    mutate(Date=as.Date(paste(Month,Day,"73",sep="/"),"%m/%d/%y"),
           Pred=predict(model, newdata=airquality))
ggplot(mydat, aes(Date)) +
    geom_line(aes(y=Ozone,colour="true"), size=1) +
    geom_line(aes(y=Pred, colour="predict"), size=1) +
    scale_colour_manual(values=c(predict="blue",true="red")) + # lineの色を指定
    theme(legend.position=c(.9,.9))  # 凡例の位置を指定

## 診断プロット (前モデルよりは改善されていることがわかる)
autoplot(model)

## 回帰式による予測
## 8月までのデータで回帰式を推定
summary(model <- lm(formula(opt), # 上で探索されたモデルを利用
            data=airquality, subset=(Month<9)))
## 9月のデータを予測
idx <- with(airquality,Month==9) # 9月のデータのindexを取得
pred <- predict(model,newdata=airquality[idx,], # 9月分を予測
                interval="prediction",level=0.7)
mydat <- data.frame(airquality[idx,], pred) # 9月のデータとその予測
ggplot(mydat, aes(Day)) +
    geom_ribbon(aes(ymin=lwr,ymax=upr), fill="red", alpha=0.2)+
    geom_line(aes(y=Ozone,colour="true"), size=1) +
    geom_line(aes(y=fit, colour="predict"), size=1) +
    theme(legend.position=c(.9,.9)) + # 凡例の位置を指定
    labs(title="Ozone Level Prediction (September; 70% pred. int.)",x="Day",y="Ozone")


library(Sleuth3)
case0601.aov<-aov(Score~Handicap,data=case0601)
anova(case0601.aov)
with(case0601,unlist(lapply(split(Score,Handicap),mean)))

with(case0601,unlist(lapply(split(Score,Handicap),length)))

SE<-sqrt(2.6665)*sqrt(1/14+1/14)
SE
qtukey(0.95,5,65)

M <- qtukey(0.95,5,65)/sqrt(2)
M
4.428571-5.921429 - M*SE
4.428571-5.921429 + M*SE

# Put the sample means in s.means.
s.means <- with(case0601,unlist(lapply(split(Score,Handicap),mean)))
# Put the sample sizes in s.size.
s.size <- with(case0601,unlist(lapply(split(Score,Handicap),length)))
# Get all 10 pairs i and j from 1,2,3,4,5.
ij <- combn(5,2)
# Calculate the 10 point estimates.
pt.ests <- s.means[ij[1,]]-s.means[ij[2,]]
# Calculate the 10 SEs. These will all be the same if the sample sizes are equal.
SEs <- sqrt(2.6665)*sqrt(1/s.size[ij[1,]]+1/s.size[ij[2,]])
# Calculate the lower bounds of the Tukey-Kramer 95% confidence intervals
LB <- pt.ests - qtukey(0.95,5,65)*SEs
# Calculate the upper bounds.
UB <- pt.ests + qtukey(0.95,5,65)*SEs
# Display the lower and upper bounds.
cbind(LB,UB)

library(multcomp)

# The function in the multcomp package assumes
# the control is the first level.
summary(case0601$Handicap) # Check the original ordering. "None" is the fourth group.
case0601$Handicap<-relevel(case0601$Handicap,"None") # Put "None" first.
summary(case0601$Handicap) # Check to make sure of the order.

case0601.aov <- aov(Score~Handicap,data=case0601)
case0601.glht<- glht(case0601.aov, linfct=mcp(Handicap="Dunnett"))
confint(case0601.glht)

qf(0.95,4,65)
M <- sqrt(4*qf(0.95,4,65))
M
SE<-sqrt(2.6665)*sqrt((0.5)^2/14+(0.5)^2/14+(0.5)^2/14+(0.5)^2/14)

(5.921429+5.342857 )/2 - (4.428571+4.05)/2 - M*SE
(5.921429+5.342857 )/2 - (4.428571+4.05)/2 + M*SE

alpha=0.05/3 # Set Bonferroni alpha to nominal alpha divided by k.
M <- qt(1-alpha/2,65)

pt.est <- 4.9 - (4.428571+5.921429+4.05+5.342857)/4
SE <- sqrt(2.6665)*sqrt(1/14 + 4*(0.25)^2/14)
pt.est - M*SE
pt.est + M*SE

qt(1-(0.05/10)/2,65)


rm(list=ls())
set.seed(34)

# sample size
N = 50

# explanatory variables
make_x = function(n=N, xmin=0, xmax=100){
  return (runif(n, xmin, xmax))
}

# define true model
b0 = 15
b1 = 0.5
f = function(x){
   return (b0 + b1 * x)
}

# generate disturbances
sd_e = 4
make_epsilon = function(n=N, mean=0, sd=sd_e){
  return (rnorm(n, mean, sd))
}

# make data generating process
dgp = function(){
  x = make_x()
  y = f(x)+make_epsilon()
  return (data.frame(x=x,y=y))
}

# estime by ols once and show results
df = dgp()

png('C:/Users/Евгений/Documents/GitHub/multiple-regression-revisited/ols_true_model.png')

plot(df$x,df$y, xlab = "x", ylab="y", main="Observations and true model y=15+.5x+e")
abline(a=b0,b=b1,col="green")

dev.off()

# TODO: make plot for distrubance term
# plot(make_x(), make_epsilon())

lm1 <- lm(y~x, data = df)
abline(lm1, col="red")
summary(lm1)

extract_b0  = function(lm_){
  return (coef(lm_)[1])
}

extract_b1  = function(lm_){
  return (coef(lm_)[2])
}

# repeat estimation
get_b1 = function(){extract_b1(lm(y~x, data = dgp()))}

n_experiments = 1000
b1_list = replicate(n_experiments, get_b1())

# plot estimator desities
b1_avg = mean(b1_list)
b1_sd = sd(b1_list)

png('C:/Users/Евгений/Documents/GitHub/multiple-regression-revisited/ols_b1.png')

h = hist(b1_list, breaks=40, freq=FALSE,
         main=paste("Distribution of b1 on", n_experiments,"experiments"),
         sub=paste("True value:", b1, "    ",
                   "Mean: ", round(b1_avg,4), "    ",
                   "SD: ", round(b1_sd,4)),
         xlab="b1",
         col="lightblue")
#curve(dnorm(x, mean=b1_avg, sd=b1_sd), add=TRUE, col="darkblue", lwd=2)
lines(density(b1_list), col="darkblue", lwd=2)
abline(v=b1, col ="green")
abline(v=b1_avg, col ="red")
dev.off()


1+1
x <- c(1,3,4,5,6)
x
print(x)
x*3
x+6
x/2
x^4
y <- seq(1:length(x))
x%*%y
drop(x%*%y)
z <- runif(100)
str(z)
head(z)
tail(z)
Z <- matrix(z, nrow=5, byrow=FALSE)
dim(Z)
str(Z)
x%*%Z
drop(x%*%Z)
x[2:3]
x[c(2:3,5)]
Z[,1]
Z[,2:3]
Z[1:2,2:4]
ps <- function(x, a=1) a*x^2
ps(2)
ps(5)
ps(4, 3)
ps <- function(x, a=1) {
  z <- a*x^2
  return(z)
}
ps(5)
ps(4, 3)
ps <- function(x, a=1) { z <- a*x^2; z }
ps(x=x, a=3)
ps(x=3, a=x)
ps <- function(x, a=1) {
  if (a >= 0) {
    z <- a*x^2
  } else {
    z <- a*x^3
  }
  return(z)
}
ps(4, 2)
ps(4, -2)
ps <- function(x, a=1) {
  z <- ifelse (a >= 0, a*x^2,  a*x^3)
  return(z)
}
ps(x, a=-2)
ps(x, a=2)
ps(x, a=c(-2, 2))

genere <- sample(c("M", "F"), size=170, replace=TRUE)
str(genere)
altezza <- rnorm(170, 170, 1)
str(altezza)
hist(altezza)
hist(altezza, xlab="Altezza (cm)", ylab="Frequenza", main="La vostra altezza")
boxplot(altezza)
table(genere)
boxplot(split(altezza, genere))


# Function to combine binned data based on the mean and standard deviation of the bins and their sample sizes.
# Based on: "Combining Multiple binmeand Data Points And Their Errors" by Ken Tatebe (http://docplayer.net/33088897-Combining-multiple-binmeand-data-points-and-their-errors.html)
# And: "Data Analyis Toolkit #12" by James Kirchner (http://seismo.berkeley.edu/~kirchner/Toolkits/Toolkit_12.pdf)
# Approach for combining more than two bins while weighting uncertainty and means by sample size and variance within the bin
# Worked out by Barbara Goudsmit (see SI document)

binmeans <- function(x, x_sd = NA, n = NA, verbose = FALSE, output = "All"){
    if(is.na(n)){
        n = rep(1, length(x)) # If no N are given, the bins are assumed to have equal sample sizes
    }
    if(is.na(x_sd)){
        x_sd = rep(1, length(x)) # If no SDs of the bins are given, the bins are assumed to have equal variance
    }
    if(length(n) == 1){
        N = n[1] # In case only one entry is provided, the mean and SD of the one entry are returned as the mean and SD of the result
        binmean = x[1]
        SD_bin = x_sd[1]
    }else{
        N <- sum(n) # Calculate total sample size
        binmean <- sum(x * n * x_sd ^ -2) / sum(n * x_sd ^ -2)  # Calculate weighted binmean (equation 16 in SI document)
        SD_bin <- sqrt(sum(n) / (sum(n) - 1) * sum((n - 1) + x_sd ^ -2 * n * (x - binmean) ^ 2) / sum(n * x_sd ^ -2)) # Calculate weighted standard deviation (equation 17 in SI document)
    }
    resultvec <- c(binmean, SD_bin, N)
    names(resultvec) <- c("binmean", "sd", "N")
    if(output == "SD"){
        return(resultvec[2])
    }else if(output == "mean"){
        return(resultvec[1])
    }else if(output == "All"){
        return(resultvec)
    }else{
        return("Error: output string not recognized")
    }
}


###############################################################################
# Exponential Regression
#------------------------------------------------------------------------------
# based on Lionel Hertzog code.
###############################################################################

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library("easynls")

#------------------------------------------------------------------------------
# Non-linear least squares approach (function nls in R)
#------------------------------------------------------------------------------

# simulate some data
set.seed(20160227)
x <- seq(0,50,1)
y <- ((runif(1,10,20)*x)/(runif(1,0,10)+x))+rnorm(51,0,1)

# Model -----------------------------------------------------------------------
# for simple models nls find good starting values for the parameters even if it
# throw a warning
m <- nls(y~a*x/(b+x))

# get some estimation of goodness of fit
cor(y,predict(m))

# Plot ------------------------------------------------------------------------
plot(x,y)
lines(x,predict(m),lty=2,col="red",lwd=3)

#------------------------------------------------------------------------------
# Find correct starting value
#------------------------------------------------------------------------------

# The best way to find correct starting value is to “eyeball” the data,
# plotting them and based on the understanding that you have from the equation
# find approximate starting values for the parameters.

# simulate some data, this without a priori knowledge of the parameter value
y <- runif(1,5,15)*exp(-runif(1,0.01,0.05)*x)+rnorm(51,0,0.5)

# visually estimate some starting parameter values
plot(x,y)

# from this graph set approximate starting values
a_start <- 8 #param a is the y value when x=0
b_start <- 2*log(2)/a_start #b is the decay rate

# Model -----------------------------------------------------------------------
m <- nls(y~a*exp(-b*x),start=list(a=a_start,b=b_start))

# get some estimation of goodness of fit
cor(y,predict(m))

# Plot ------------------------------------------------------------------------
lines(x,predict(m),col="red",lty=2,lwd=3)

#------------------------------------------------------------------------------
# Non-linear least squares approach (package easynls)
#------------------------------------------------------------------------------

# data represent weights of an Angus cow at ages from 8 to 108 months (Kaps and Lamberson, 2009)
weight=c(280,340,430,480,550,580,590,600,590,600)
age=c(8,12,24,36,48,60,72,84,96,108)
data1=data.frame(age, weight)
# linear
nlsfit(data1, model=1)
# quadratic
nlsfit(data1, model=2)
# linear plateau
nlsfit(data1, model=3)
# quadratic plateau
nlsfit(data1, model=4)
# two linear
nlsfit(data1, model=5, start=c(250,6,2,50))
# exponential
nlsfit(data1, model=6, start=c(250,0.05))
# logistic
nlsfit(data1, model=7, start=c(600,4,0.05))
# van bertalanffy
nlsfit(data1, model=8, start=c(600,2,0.05))
# brody
nlsfit(data1, model=9, start=c(600,4,0.05))
# gompertz
nlsfit(data1, model=10, start=c(600,4,0.05))
# describe the growth of Zagorje turkeys (Kaps and Lamberson, 2009)
weight=c(44,66,100,150,265,370,455,605,770)
age=c(1,7,14,21,28,35,42,49,56)
data2=data.frame(age,weight)
# two linear
nlsfit(data2, model=5, start=c(25,6,10,20))
# using segmented regression to estimate a plateau
# the requirement for the methionine will be estimated measurements of gain of turkey poults
#(Kaps and Lamberson, 2009)
methionine=c(80,85,90,95,100,105,110,115,120)
gain=c(102,115,125,133,140,141,142,140,142)
data3=data.frame(methionine, gain)
# linear
nlsfit(data3, model=1)
# quadratic
nlsfit(data3, model=2)
# linear plateau
nlsfit(data3, model=3)
# quadratic plateau
nlsfit(data3, model=4)
# lactation curve
milk=c(25,24,26,28,30,31,27,26,25,24,23,24,22,21,22,20,21,19,
18,17,18,18,16,17,15,16,14)
days=c(15,15,15,75,75,75,135,135,135,195,195,195,255,255,255,
315,315,315,375,375,375,435,435,435,495,495,495)
data4=data.frame(days,milk)
nlsfit(data4, model=11, start=c(16,0.25,0.004))
# ruminal degradation
time=c(2,6,9,24,48,72,96)
deg=c(20,33,46,55,66,72,76)
data5=data.frame(time,deg)
nlsfit(data5, model=12)
# logistic bi-compartmental (gas production)
time=c(0,12,24,36,48,60,72,84,96,108,120,144,168,192)
gas=c(0.002,3.8,8,14.5,16,16.5,17,17.4,17.9,18.1,18.8,
19,19.2,19.3)
data6=data.frame(time,gas)
nlsfit(data6, model=13, start=c(19,4,0.025,0.004,5))

# weights of an Angus cow at ages from 8 to 108 months (Kaps and Lamberson, 2009)
weight=c(280,340,430,480,550,580,590,600,590,600)
age=c(8,12,24,36,48,60,72,84,96,108)
data1=data.frame(age, weight)
# linear
nlsplot(data1, model=1)
# quadratic
nlsplot(data1, model=2)
# linear plateau
nlsplot(data1, model=3)
# quadratic plateau
nlsplot(data1, model=4)
# two linear
nlsplot(data1, model=5, start=c(250,6,2,50))
# exponential
nlsplot(data1, model=6, start=c(250,0.05))
# logistic
nlsplot(data1, model=7, start=c(600,4,0.05))
# van bertalanffy
nlsplot(data1, model=8, start=c(600,2,0.05))
# brody
nlsplot(data1, model=9, start=c(600,4,0.05))
# gompertz
nlsplot(data1, model=10, start=c(600,4,0.05))
# growth of Zagorje turkeys (Kaps and Lamberson, 2009)
weight=c(44,66,100,150,265,370,455,605,770)
age=c(1,7,14,21,28,35,42,49,56)
data2=data.frame(age,weight)
# two linear
nlsplot(data2, model=5, start=c(25,6,10,20))
# using segmented regression to estimate a plateau
# requirement for the methionine will be estimated measurements gain of turkey poults
#(Kaps and Lamberson, 2009)
methionine=c(80,85,90,95,100,105,110,115,120)
gain=c(102,115,125,133,140,141,142,140,142)
data3=data.frame(methionine, gain)
# linear
nlsplot(data3, model=1)
# quadratic
nlsplot(data3, model=2)
# linear plateau
nlsplot(data3, model=3)
# quadratic plateau
nlsplot(data3, model=4)
# lactation curve
milk=c(25,24,26,28,30,31,27,26,25,24,23,24,22,21,22,20,21,19,18,17,18,
18,16,17,15,16,14)
days=c(15,15,15,75,75,75,135,135,135,195,195,195,255,255,255,315,315,
315,375,375,375,435,435,435,495,495,495)
data4=data.frame(days,milk)
nlsplot(data4, model=11, start=c(16,0.25,0.004))
# ruminal degradation
time=c(2,6,9,24,48,72,96)
deg=c(20,33,46,55,66,72,76)
data5=data.frame(time,deg)
nlsplot(data5, model=12)
# logistic bi-compartmental (gas production)
time=c(0,12,24,36,48,60,72,84,96,108,120,144,168,192)
gas=c(0.002,3.8,8,14.5,16,16.5,17,17.4,17.9,18.1,18.8,19,19.2,19.3)
data6=data.frame(time,gas)
nlsplot(data6, model=13, start=c(19,4,0.025,0.004,5))

# I’ll take my NLS with weights, please…
# https://www.r-bloggers.com/ill-take-my-nls-with-weights-please/


library(ggplot2)

m = 1 #rotation order

phi = seq(0,2*pi,length.out = 100)
r = seq(0,1,length.out = 50)

real_filter = function(r,phi,m)exp(-r^2)*cos(phi*m)
img_filter = function(r,phi,m)exp(-r^2)*sin(phi*m)

df = expand.grid(phi = phi, r = r)
df$real_filter = real_filter(df$r,df$phi,m)
df$img_filter = img_filter(df$r,df$phi,m)

df$input = 0
df$input[df$phi > 0 & df$phi < pi/6 & df$r>0.48 & df$r<0.52] = 1
df$input[df$phi > pi/12-0.01 & df$phi < pi/12+0.01 & df$r>0.3 & df$r<0.7] = 1

p_in <- ggplot(df) + geom_tile(aes(phi,r,fill=input))+ coord_polar(direction = -1,start=3*pi/2)

# plot the original image on the polar coordinates
plot(p_in)

df$input_rotate = 0
df$input_rotate[df$phi > 0+pi/2 & df$phi < pi/6+pi/2 & df$r>0.48 & df$r<0.52] = 1
df$input_rotate[df$phi > pi/12+pi/2-0.01 & df$phi < pi/12+0.01+pi/2 & df$r>0.3 & df$r<0.7] = 1
p_in_rotate <- ggplot(df) + geom_tile(aes(phi,r,fill=input_rotate))+ coord_polar(direction = -1,start=3*pi/2)

# plot the rotated image on the polar coordinates (pi/2, counter-clockwise)
plot(p_in_rotate)

# kernel weights
p_real <- ggplot(df) + geom_tile(aes(phi,r,fill=real_filter))+ coord_polar(direction = -1,start=3*pi/2)
p_img <- ggplot(df) + geom_tile(aes(phi,r,fill=img_filter))+ coord_polar(direction = -1,start=3*pi/2)

# Real and imaginary part of the convolution operation, which resulted in a complex number
out_real = sum(df$input*df$real_filter)
out_img = sum(df$input*df$img_filter)

out_real_rotate = sum(df$input_rotate*df$real_filter)
out_img_rotate = sum(df$input_rotate*df$img_filter)

plot(0,0,type='n',xlim = c(-100,100),ylim = c(-100,100))
abline(h=0,lty = 2)
abline(v=0,lty = 2)
lines(c(0,out_real),c(0,out_img),col=2)
lines(c(0,out_real_rotate),c(0,out_img_rotate),col=3)


geometric_mean <- function (x) exp(mean(log(x)))


n = c(50,59,161,88,20,40,56,52,188,4,3,5,2,66,6)
E=c(67.5,67.5,135,37,37,74,74,74,148,3,3,6,18.5,18.5,37)
# test statistic
Xsquare = 0
i=1
while(i<=length( n)){
  Xsquare=Xsquare+(((n[i]-E[i])^2)/E[i])
  i=i+1
}
print(Xsquare)
# critical value
alpha = 0.001
X.alpha=qchisq(1-alpha,df=8)
# The computed value of xsquare is greater than x.alpha, so we reject the null hypothes


?swiss

swiss <- data.frame(swiss)
str(swiss)

hist(swiss$Fertility,col="Red")

fit <- lm(Fertility ~ Examination + Catholic, data = swiss)
summary(fit)

fit <- lm(Fertility ~ Examination * Catholic, data = swiss)
summary(fit)

confint(fit)

# trouble №1
x1 <- rnorm(50) # создадим случайную выборку из 50 элементов
x2 <- rnorm(50) # создадим случайную выборку из 50 элементов
y <- rnorm(50) # создадим случайную выборку из 50 элементов
na_index <- sample(1:30, runif(1,5,15)) # случайно сгенерируем количество и позиции NA в векторе y
y[na_index] <- NA # создадим NA в векторе y
my_df <- data.frame(x_1 = x1, x_2 = x2, y = y) # создадим dataframe

dfit <- lm(my_df$y~my_df$x_1+my_df$x_2)
my_df$y_full <- predict(dfit, newdata = my_df)

my_df

# trouble №2
str(mtcars)
df <- mtcars[c(1,3,4,5,6)]
dfit <- lm(wt~.,data=df)
summary(dfit)
step(dfit, direction = 'backward')
model <- lm(wt ~ mpg + disp + hp,data = df)

# trouble №3

ddf <- attitude
sddf <- lm(ddf$rating~ddf$complaints*ddf$critical)
summary(sddf)
sddf$coefficients

hist(swiss$Catholic)
swiss$religious <- ifelse(swiss$Catholic > 60, "Lots", "Few")
swiss$religious <- as.factor(swiss$religious)

fit3 <- lm(Fertility ~ Examination + religious, data = swiss)
summary(fit3)

fit4 <- lm(Fertility ~ Examination * religious, data = swiss)
summary(fit4)

ggplot(swiss, aes(x = Examination, y = Fertility, col=religious)) +
  geom_point()+
  geom_smooth(method = 'lm')

fit5 <- lm(Fertility ~ religious*Infant.Mortality*Examination, data = swiss)
summary(fit5)

# trouble №4,5

mtcars$am <- factor(mtcars$am, labels = c('Automatic', 'Manual'))

dfit <- lm(mpg~wt*am,data = mtcars)
summary(dfit)

# trouble №6
library(ggplot2)
my_plot <- ggplot(mtcars, aes(x=wt,y=mpg,col=factor(am)))+
  geom_smooth(method="lm")

my_plot


## ----author info, include=F----------------------------------------------
## Author:  Yanchang Zhao
## Email:   yanchang@RDataMining.com
## Website: http://www.RDataMining.com
## Date:    9 December 2018

## ----load libraries, include=F, echo=F-----------------------------------
## load required packages
library(fpc) # for dbscan, pamk and kmeansruns
library(cluster) # for pam, diana and clara

## ------------------------------------------------------------------------
str(iris)

## ------------------------------------------------------------------------
summary(iris)

## ------------------------------------------------------------------------
## set a seed for random number generation to make the results reproducible
set.seed(8953)
## make a copy of iris data
iris2 <- iris
## remove the class label, Species
iris2$Species <- NULL
## run kmeans clustering to find 3 clusters
kmeans.result <- kmeans(iris2, 3)

## ----eval=F--------------------------------------------------------------
## ## print the clusterng result
## kmeans.result

## ----echo=F--------------------------------------------------------------
kmeans.result

## ------------------------------------------------------------------------
table(iris$Species, kmeans.result$cluster)

## ----out.width=".8\\textwidth", out.height="0.8\\textheight", tidy=F, crop=T----
plot(iris2[, c("Sepal.Length", "Sepal.Width")],
     col = kmeans.result$cluster)
points(kmeans.result$centers[, c("Sepal.Length", "Sepal.Width")],
       col = 1:3, pch = 8, cex=2) # plot cluster centers

## ------------------------------------------------------------------------
library(fpc)
kmeansruns.result <- kmeansruns(iris2)
kmeansruns.result

## ------------------------------------------------------------------------
library(cluster)
# group into 3 clusters
pam.result <- pam(iris2, 3)
# check against actual class label
table(pam.result$clustering, iris$Species)

## ----eval=F--------------------------------------------------------------
## plot(pam.result)

## ----echo=F, fig.width=9, fig.height=4.5, out.width="\\textwidth", out.height="0.9\\textheight"----
layout(matrix(c(1,2),1,2)) # 2 graphs per page
plot(pam.result)
layout(matrix(1)) # change back to one graph per page

## ------------------------------------------------------------------------
library(fpc)
pamk.result <- pamk(iris2)
# number of clusters
pamk.result$nc
# check clustering against actual class label
table(pamk.result$pamobject$clustering, iris$Species)

## ----eval=F--------------------------------------------------------------
## plot(pamk.result)

## ----echo=F, fig.width=9, fig.height=6, out.width="\\textwidth", out.height="0.9\\textheight"----
layout(matrix(c(1,2),1,2)) # 2 graphs per page
plot(pamk.result$pamobject)
layout(matrix(1)) # change back to one graph per page

## ----fig.show='hide'-----------------------------------------------------
set.seed(2835)
# draw a sample of 40 records from the iris data, so that the clustering plot will not be over crowded
idx <- sample(1:dim(iris)[1], 40)
iris3 <- iris[idx,]
# remove class label
iris3$Species <- NULL
# hierarchical clustering
hc <- hclust(dist(iris3), method="ave")
# plot clusters
plot(hc, hang = -1, labels=iris$Species[idx])
# cut tree into 3 clusters
rect.hclust(hc, k=3)
# get cluster IDs
groups <- cutree(hc, k=3)

## ----echo=F, fig.width=8, fig.height=6, out.width="\\textwidth", out.height="\\textheight"----
plot(hc, hang = -1, labels=iris$Species[idx])
rect.hclust(hc, k=3) # cut tree into 3 clusters

## ------------------------------------------------------------------------
library(cluster)
diana.result <- diana(iris3)

## ----eval=F--------------------------------------------------------------
## plot(diana.result, which.plots=2, labels=iris$Species[idx])

## ----echo=F--------------------------------------------------------------
plot(diana.result, which.plots=2, labels=iris$Species[idx])

## ------------------------------------------------------------------------
library(fpc)
iris2 <- iris[-5] # remove class tags
ds <- dbscan(iris2, eps=0.42, MinPts=5)
ds

## ------------------------------------------------------------------------
# compare clusters with actual class labels
table(ds$cluster, iris$Species)

## ----out.width=".95\\textwidth", out.height=".95\\textheight"------------
plot(ds, iris2)

## ----out.width=".95\\textwidth", out.height=".95\\textheight"------------
plot(ds, iris2[, c(1,4)])

## ----out.width=".95\\textwidth", out.height=".95\\textheight"------------
plotcluster(iris2, ds$cluster)

## ----tidy=F--------------------------------------------------------------
# create a new dataset for labeling
set.seed(435)
idx <- sample(1:nrow(iris), 10)
# remove class labels
new.data <- iris[idx,-5]
# add random noise
new.data <- new.data + matrix(runif(10*4, min=0, max=0.2),
                              nrow=10, ncol=4)
# label new data
pred <- predict(ds, iris2, new.data)

## ------------------------------------------------------------------------
table(pred, iris$Species[idx]) # check cluster labels

## ----out.width=".95\\textwidth", out.height=".95\\textheight"------------
plot(iris2[, c(1,4)], col=1+ds$cluster)
points(new.data[, c(1,4)], pch="+", col=1+pred, cex=3)


# computing probabilties and quantiles in R

# computing T quantile for one d.f.
# arguments are probability, d.f.

qt(0.975, 10)

# can also provide many d.f. or probabilities

qt(0.975, c(10,20))

# going backward: computing probability from T value
# arguments are value, d.f.

pt(2, 10)

# and can apply to many

pt(2, c(10,20))

# same for Chi-square: only one indicated

qchisq(0.975,10)
pchisq(38.2,20)

# often want upper tail prob. (default is lower)
pchisq(38.2,20,lower=F)

# which is same as 1-pchisq(38.2,20)

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


N <- 1000
gamma <- 0.9
alpha <- 1
FinalState <- 6

RMatrix <- matrix(c(-1,50,1,-1,-1,-1,
                      -1,-1,-1,1,50,-1,
                      -1,-1,-1,1,-1,-1,
                      -1,-1,-1,-1,-1,100,
                      -1,-1,-1,50,-1,-1,
                      -1,-1,-1,-1,-1,100),nrow=6,byrow = TRUE)

print(RMatrix)

QMatrix <- matrix(rep(0,length(RMatrix)), nrow=nrow(RMatrix))

for (i in 1:N) {

  CurrentState <- sample(1:nrow(RMatrix), 1)

 repeat {

    AllNS <- which(RMatrix[CurrentState,] > -1)
    if (length(AllNS)==1)
      NextState <- AllNS
    else
      NextState <- sample(AllNS,1)

    QMatrix[CurrentState,NextState] <- QMatrix[CurrentState,NextState] + alpha*(RMatrix[CurrentState,NextState] + gamma*max(QMatrix[NextState, which(RMatrix[NextState,] > -1)]) - QMatrix[CurrentState,NextState])

    if (NextState == FinalState) break
    CurrentState <- NextState
  }
}

print(QMatrix)

RowMaxPos<-apply(QMatrix, 1, which.max)
ShPath <- list(1)
i=1
while (i!=6) {
 IndRow<- RowMaxPos[i]
 ShPath<-append(ShPath,IndRow)
 i= RowMaxPos[i]
}

print(ShPath)


## ----author info, include=F----------------------------------------------
## Author:  Yanchang Zhao
## Email:   yanchang@RDataMining.com
## Website: http://www.RDataMining.com
## Date:    9 December 2018

## ----cpi-data, out.width=".6\\textwidth", out.height=".6\\textheight"----
year <- rep(2008:2010, each = 4)
quarter <- rep(1:4, 3)
cpi <- c(162.2, 164.6, 166.5, 166.0,
         166.2, 167.0, 168.6, 169.5,
         171.0, 172.1, 173.3, 174.0)
plot(cpi, xaxt="n", ylab="CPI", xlab="")
# draw x-axis, where "las=3" makes text vertical
axis(1, labels=paste(year,quarter,sep="Q"), at=1:12, las=3)

## ------------------------------------------------------------------------
## correlation between CPI and year / quarter
cor(year,cpi)
cor(quarter,cpi)
## build a linear regression model with function lm()
fit <- lm(cpi ~ year + quarter)
fit

## ----tidy=F--------------------------------------------------------------
cpi2011 <- fit$coefficients[[1]] +
           fit$coefficients[[2]] * 2011 +
           fit$coefficients[[3]] * (1:4)
cpi2011

## ------------------------------------------------------------------------
attributes(fit)
fit$coefficients

## ------------------------------------------------------------------------
# differences between observed values and fitted values
residuals(fit)
summary(fit)

## ----3d-plot, out.width=".75\\textwidth", out.height=".75\\textheight"----
library(scatterplot3d)
s3d <- scatterplot3d(year, quarter, cpi, highlight.3d=T, type="h",
          lab=c(2,3)) # lab: number of tickmarks on x-/y-axes
s3d$plane3d(fit) # draws the fitted plane

## ----out.width=".65\\textwidth"------------------------------------------
data2011 <- data.frame(year=2011, quarter=1:4)
cpi2011 <- predict(fit, newdata=data2011)
style <- c(rep(1,12), rep(2,4))
plot(c(cpi, cpi2011), xaxt="n", ylab="CPI", xlab="",
     pch=style, col=style)
txt <- c(paste(year,quarter,sep="Q"),
         "2011Q1", "2011Q2", "2011Q3", "2011Q4")
axis(1, at=1:16, las=3, labels=txt)

## ----tidy=F--------------------------------------------------------------
data("bodyfat", package="TH.data")
myFormula <- DEXfat ~ age + waistcirc + hipcirc + elbowbreadth +
                      kneebreadth
bodyfat.glm <- glm(myFormula, family=gaussian("log"), data=bodyfat)
summary(bodyfat.glm)

## ----out.width=".8\\textwidth", out.height=".8\\textheight"--------------
pred <- predict(bodyfat.glm, type="response")
plot(bodyfat$DEXfat, pred, xlab="Observed", ylab="Prediction")
abline(a=0, b=1)

## ------------------------------------------------------------------------
str(iris)
# split data into two subsets: training (70%) and test (30%);
# set a fixed random seed  to make results reproducible
set.seed(1234)
ind <- sample(2, nrow(iris), replace=TRUE, prob=c(0.7, 0.3))
train.data <- iris[ind==1,]
test.data <- iris[ind==2,]

## ------------------------------------------------------------------------
library(party)
# myFormula <- Species ~ . # predict Species with all other variables
myFormula <- Species ~ Sepal.Length + Sepal.Width +
             Petal.Length + Petal.Width
iris.ctree <- ctree(myFormula, data=train.data)
# check the prediction
table(predict(iris.ctree), train.data$Species)

## ------------------------------------------------------------------------
print(iris.ctree)

## ----fig.width=14, fig.height=12, out.width=".9\\textwidth", out.height=".9\\textheight"----
plot(iris.ctree)

## ----fig.width=8, fig.height=6, out.width=".9\\textwidth", out.height=".9\\textheight"----
plot(iris.ctree, type="simple")

## ------------------------------------------------------------------------
# predict on test data
testPred <- predict(iris.ctree, newdata = test.data)
table(testPred, test.data$Species)

## ------------------------------------------------------------------------
data("bodyfat", package = "TH.data")
dim(bodyfat)
# str(bodyfat)
head(bodyfat, 5)

## ----rpart-training, tidy=F, fig.show='hide', results='hide'-------------
# split into training and test subsets
set.seed(1234)
ind <- sample(2, nrow(bodyfat), replace=TRUE, prob=c(0.7, 0.3))
bodyfat.train <- bodyfat[ind==1,]
bodyfat.test <- bodyfat[ind==2,]
# train a decision tree
library(rpart)
myFormula <- DEXfat ~ age + waistcirc + hipcirc + elbowbreadth +
                      kneebreadth
bodyfat.rpart <- rpart(myFormula, data = bodyfat.train,
                       control = rpart.control(minsplit = 10))
# print(bodyfat.rpart$cptable)
print(bodyfat.rpart)
plot(bodyfat.rpart)
text(bodyfat.rpart, use.n=T)

## ----echo=F--------------------------------------------------------------
print(bodyfat.rpart)

## ----echo=F, fig.width=10, fig.height=10---------------------------------
plot(bodyfat.rpart)
text(bodyfat.rpart, use.n=T)

## ----fig.show='hide'-----------------------------------------------------
# select the tree with the minimum prediction error
opt <- which.min(bodyfat.rpart$cptable[,"xerror"])
cp <- bodyfat.rpart$cptable[opt, "CP"]
# prune tree
bodyfat.prune <- prune(bodyfat.rpart, cp = cp)
# plot tree
plot(bodyfat.prune)
text(bodyfat.prune, use.n=T)

## ----echo=FALSE, fig.width=10, fig.height=10-----------------------------
plot(bodyfat.prune)
text(bodyfat.prune, use.n=T)

## ----out.width=".75\\textwidth"------------------------------------------
DEXfat_pred <- predict(bodyfat.prune, newdata=bodyfat.test)
xlim <- range(bodyfat$DEXfat)
plot(DEXfat_pred ~ DEXfat, data=bodyfat.test, xlab="Observed",
     ylab="Prediction", ylim=xlim, xlim=xlim)
abline(a=0, b=1)

## ----tidy=F--------------------------------------------------------------
# split into two subsets: training (70%) and test (30%)
ind <- sample(2, nrow(iris), replace=TRUE, prob=c(0.7, 0.3))
train.data <- iris[ind==1,]
test.data <- iris[ind==2,]
# use all other variables to predict Species
library(randomForest)
rf <- randomForest(Species ~ ., data=train.data, ntree=100,
                   proximity=T)

## ------------------------------------------------------------------------
table(predict(rf), train.data$Species)
print(rf)
attributes(rf)

## ----out.width=".9\\textwidth"-------------------------------------------
plot(rf, main="")

## ------------------------------------------------------------------------
importance(rf)

## ----out.width=".9\\textwidth"-------------------------------------------
varImpPlot(rf)

## ----fig.show='hide'-----------------------------------------------------
irisPred <- predict(rf, newdata=test.data)
table(irisPred, test.data$Species)
plot(margin(rf, test.data$Species))

## ----echo=F, out.width="\\textwidth"-------------------------------------
plot(margin(rf, test.data$Species))


#!/usr/bin/Rscript

# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

myprint = function(varname, var) {
    cat(paste0(varname, ':', '\n'))
    print(var)
    cat('\n')
}

number_of_generations = function() {
    iterations = 0
    repeat {
        u = runif(1, min=-1, max=1)
        v = runif(1, min=-1, max=1)

        iterations = iterations + 1

        r_sq = u^2 + v^2

        if (r_sq <= 1) {
            break;
        }
    }

    return(iterations)
}

numbers = replicate(10000, number_of_generations())
myprint('numbers', numbers)

average_number = mean(numbers)
myprint('average_number', average_number)

# Define the function again, this time it returns an actual data type
box_muller_alternative_1 = function() {
    repeat {
        u = runif(1, min=-1, max=1)
        v = runif(1, min=-1, max=1)

        s = u^2 + v^2

        if (s <= 1) {
            break;
        }
    }

    z = sqrt(- 2 * log(s) / s)
    x1 = z * u
    x2 = z * v

    return(c(x1, x2))
}

# Draw a bunch of samples
samples = matrix(replicate(10000, box_muller_alternative_1()), nrow=1)

# Make a quantile-quantile plot which the actual against the theoretical
# quantiles. That should quickly tell whether the resulting numbers are sampled
# from a normal distribution.
qqnorm(samples)
lines(c(-4, 4), c(-4, 4))
grid()


rm(list = ls()) #cleaning up
library(utils)
library(tidyverse)

data <- as.tibble(read.csv("demo.csv"))
model <- lm(GDP ~ FHouse, data=data)

ggplot(data, aes(x = FHouse, y = GDP)) +
  geom_point()+
  geom_smooth(method='lm')

predict(model, data.frame(FHouse=c(3)))
summary(model)

##### conditional expectations: E[GDP|FHouse=fh] ####
cond_exp <- c()
for(fh in c(sort(unique(data$FHouse)))){
  cond_exp <- c(cond_exp, mean(data$GDP[data$FHouse==fh]) )
}
cond_exp

#### plotting them
fh <- sort(unique(data$FHouse))
means <- data.frame(fh, cond_exp)
ggplot(data, aes(x = FHouse, y = GDP)) +
  geom_point()+
  geom_smooth(method='lm')+
  geom_point(data=means, aes(x=fh, y=cond_exp), color="green")

#### Change the model

model2 <- lm(GDP ~ FHouse + I(FHouse^2), data=data)

ggplot(data, aes(x = FHouse, y = GDP)) +
  geom_point()+
  geom_smooth(method='lm', formula= y ~ x + I(x^2))+
  geom_point(data=means, aes(x=fh, y=cond_exp), color="green")

predict(model2, data.frame(FHouse=c(3)))
summary(model2)

### differences
fh1 <- predict(model2, data.frame(FHouse=c(1)))
fh3 <- predict(model2, data.frame(FHouse=c(3)))

diff_fh_3_1 <- fh3 - fh1

fh4 <- predict(model2, data.frame(FHouse=c(4)))
fh6 <- predict(model2, data.frame(FHouse=c(6)))

diff_fh_6_4 <- fh6 - fh4


# Perceptron
PLA <- function(x, y, maxit = 1000, plotLn = FALSE, traceFlg = FALSE) {
  # Add in bias?
  x <- cbind(x, bias = rep(1, nrow(x)))
  # Initialize
  iter <- 0
  Cost <- 100
  w <- matrix(rep(0, ncol(x)), ncol=ncol(x))

  while(Cost > 0 & iter < maxit) {
    iter <- iter + 1
    # Predict
    h <- sign(x %*% t(w))

    misclassified <- which(h != y)
    Cost <- length(misclassified)

    if (Cost > 0) {
      # Update
      # hkReeves pointed out that sample(c(10),1) will give a random number between 1 and 10
      pickOne <- ifelse(Cost == 1, misclassified, sample(misclassified, 1))
      # Update weight vector
      # w <- w + t(y[pickOne]) %*% x[pickOne,]
      w <- w + y[pickOne] * x[pickOne,]
    }
    if(plotLn) abline(w[2], w[1], col = iter)
    if(traceFlg) print(paste("At iter", iter, "Cost ", Cost))
  }
  return(list(iter = iter, w = w))
}

# Pick which side of the line this should be on
chooseSide <- function(f, x) {
  m <- matrix(c(f[2,1] - f[1,1], x[1] - f[1,1],
                f[2,2] - f[1,2], x[2] - f[1,2]),
              byrow=TRUE, nrow=2)
  sign(det(m))
}

# Run many simulations
N <- 10
iterations = list()
for (runs in seq(1000)) {
  # Create linearly separable data
  # Choose a line in X^2 {-1, 1}
  f <- matrix(c(runif(2, min = -1, max = 1), -1, 1),
              nrow = 2)
  # Get uniformly distributed points in {-1, 1}
  x <- matrix(runif(2 * N, min=-1, max=1), ncol=2)
  # Figure out which side of our line they are on
  y <- apply(x, 1, function(z) chooseSide(f, z))

  # Fit perceptron model
  fit <- PLA(x, y, maxit=10000, plotLn=FALSE)
  iter <- fit$iter
  w <- fit$w
  iterations <- c(iterations, iter)
}

# Distribution of trials
summary(unlist(iterations))

# Test one
plot(x[,1], x[,2], pch = y+2, col = y+2)
lines(f, lwd = 3)

fit <- PLA(x, y, maxit=100, plotLn=FALSE, traceFlg=TRUE)

# Plot perceptron
abline(fit$w[2], fit$w[1], lty= 3)
title(paste("Perceptron at step", fit$iter))

# mydf <- as.data.frame(cbind(y, x))
# colnames(mydf) <- c("y", "x1", "x2")
#
# library(ggplot2)
# qplot(x1, x2, data = mydf, color=factor(y)) +
#   geom_abline(aes(intercept = w[2], slope = w[1]))


> sum(2,7,5)
[1] 14
> x
[1]  2 NA  3  1  4
> sum(x)    # if any element is NA or NaN, result is NA or NaN
[1] NA
> sum(x, na.rm=TRUE)    # this way we can ignore NA and NaN values
[1] 10
> mean(x, na.rm=TRUE)
[1] 2.5
> prod(x, na.rm=TRUE)
[1] 24


log1pexp <- function(x)
{
  ## taken from https://github.com/mfasiolo/qgam/blob/3bff42449b865a12c264c5b61438def5d74fdc70/R/log1pexp.R
  indx <- .bincode(x,
                   c(-Inf, -37, 18, 33.3, Inf),
                   right = TRUE,
                   include.lowest = TRUE)

  kk <- which(indx==1)
  if( length(kk) ){  x[kk] <- exp(x[kk])  }

  kk <- which(indx==2)
  if( length(kk) ){  x[kk] <- log1p( exp(x[kk]) ) }

  kk <- which(indx==3)
  if( length(kk) ){  x[kk] <- x[kk] + exp(-x[kk]) }

  return(x)
}
####

logPr <- function(x, n, rho0){
  -log1pexp(
    log1p(-rho0)-log(rho0) +
      n * log(2) +
      lbeta(x + 1, n -x +1)
  )
}

f_rho <- function(rho){
  exp(logPr(x = 5, n = 10, rho0 = rho))
}
f_rho <- Vectorize(f_rho)

curve(f_rho, xlab = expression(rho), ylab = "Posterior probability",
      main = "x = 5, n = 10")

f_x <- function(x){
  exp(logPr(x = x, n = 10, rho0 = 1/2))
}
f_x <- Vectorize(f_x)

curve(f_x, 0, 10,
      xlab = expression(rho), ylab = "Posterior probability",
      main = "x = 5, n = 10")


# Example : 4   Chapter : 8.3     Page No: 437
# Linear Algebra in Economy
A<-matrix(c(0.2,0.4,0.5,0.3,0.4,0.1,0.4,0.1,0.3),ncol=3)
lambda<-eigen(A)$values
print("Lambda max is ")
print(lambda[1])
I<-matrix(c(1,0,0,0,1,0,0,0,1),ncol=3)
A1<-solve(I-A)
print(A1)
#The answers may vary due to rounding off values


#  y has a normal distribution with mean =  160 and sd = 20.
#  the probability that a single blood pressure measurement will fail to detect that the patient has high blood pressure is <150
pnorm(150,mean =160,sd=20)
# If five blood pressure measurements are taken at various times during the day
sd <-20/sqrt(5)
 #  the probability that the average of the five measurements will be less than 150
pnorm(150,160,sd=8.94)
#  measurements would be required in a given day so that there
#is at most 1% probability of failing to detect that the patient has high blood pressure
standard_deviation=20
n=((-2.326*standard_deviation)/(150-160))^2
print(n)
# It would require at least 22 measurements in order to achieve
# the goal of at most a 1% chance of failing to detect high blood pressure.


Auto = read.csv("../../../data/Auto.csv", header = T, na.strings = "?")
Auto = na.omit(Auto)
summary(Auto)

lm.fit1 = lm(mpg ~ horsepower, data = Auto)
summary(lm.fit1)

predict(lm.fit1, data.frame(horsepower=c(98)), interval="confidence")

predict(lm.fit1, data.frame(horsepower=c(98)), interval="prediction")

plot(Auto$horsepower, Auto$mpg, main = "Scatterplot of mpg vs. horsepower", xlab = "horsepower", ylab = "mpg", col = "blue")
abline(lm.fit1, col = "red")

par(mfrow = c(2, 2))
plot(lm.fit1)

pairs(Auto)

cor(subset(Auto, select = -name))

lm.fit2 = lm(mpg ~ . - name, data = Auto)
summary(lm.fit2)

par(mfrow = c(2, 2))
plot(lm.fit2)

lm.fit3 = lm(mpg ~ .*., data = Auto[, 1:8])
summary(lm.fit3)

par(mfrow = c(2, 2))
plot(log(Auto$horsepower), Auto$mpg)
plot(sqrt(Auto$horsepower), Auto$mpg)
plot((Auto$horsepower)^2, Auto$mpg)

Carseats = read.csv("../../../data/Carseats.csv", header=T, na.strings="?")

summary(Carseats)

attach(Carseats)
lm.fit4 = lm(Sales ~ Price + Urban + US)
summary(lm.fit4)

lm.fit5 = lm(Sales ~ Price + US)
summary(lm.fit5)

confint(lm.fit5)

plot(predict(lm.fit5), rstudent(lm.fit5))

par(mfrow = c(2, 2))
plot(lm.fit5)

set.seed(1)
x = rnorm(100)
y = 2 * x + rnorm(100)

lm.fit6 = lm(y ~ x + 0)
summary(lm.fit6)

lm.fit7 = lm(x ~ y + 0)
summary(lm.fit7)

n = length(x)
t = sqrt(n - 1)*(x %*% y)/sqrt(sum(x^2) * sum(y^2) - (x %*% y)^2)
as.numeric(t)

lm.fit8 = lm(y ~ x)
summary(lm.fit8)

lm.fit9 = lm(x ~ y)
summary(lm.fit9)

set.seed(1)
x = 1:100
y = 2 * x + rnorm(100, sd = 0.1)
lm.fit10 = lm(y ~ x + 0)
summary(lm.fit10)

lm.fit11 = lm(x ~ y + 0)
summary(lm.fit11)

x = 1:100
y = 100:1
lm.fit12 = lm(y ~ x + 0)
summary(lm.fit12)

lm.fit13 = lm(x ~ y + 0)
summary(lm.fit13)

set.seed(1)
x = rnorm(100)

eps = rnorm(100, sd = 0.25)

y = -1 + 0.5 * x + eps
length(y)

plot(x, y)

lm.fit14 = lm(y ~ x)
summary(lm.fit14)

plot(x, y)
abline(lm.fit14, col = "red")
abline(-1, 0.5, col = "blue")
legend("topleft", c("Least square", "Regression"), col = c("red", "blue"), lty = c(1, 1))

lm.fit15 = lm(y ~ x + I(x^2))
summary(lm.fit15)

set.seed(1)
x = rnorm(100)
eps = rnorm(100, sd = 0.0025)
y = -1 + 0.5 * x + eps
plot(x, y)

lm.fit16 = lm(y ~ x)
summary(lm.fit16)

abline(lm.fit16, col = "red")
abline(-1, 0.5, col = "blue")
legend("topleft", c("Least square", "Regression"), col = c("red", "blue"), lty = c(1, 1))

set.seed(1)
x = rnorm(100)
eps = rnorm(100, sd = 2.5)
y = -1 + 0.5 * x + eps
plot(x, y)

lm.fit17 = lm(y ~ x)
summary(lm.fit17)

abline(lm.fit17, col = "red")
abline(-1, 0.5, col = "blue")
legend("topleft", c("Least square", "Regression"), col = c("red", "blue"), lty = c(1, 1))

confint(lm.fit14)

confint(lm.fit16)

confint(lm.fit17)

set.seed(1)
x1 = runif(100)
x2 = 0.5 * x1 + rnorm(100)/10
y = 2 + 2*x1 + 0.3*x2 + rnorm(100)

cor(x1, x2)

plot(x1, x2)

lm.fit18 <- lm(y ~ x1 + x2)
summary(lm.fit18)

lm.fit19 <- lm(y ~ x1)
summary(lm.fit19)

lm.fit20 <- lm(y ~ x2)
summary(lm.fit20)

x1 = c(x1, 0.1)
x2 = c(x2, 0.8)
y = c(y, 6)

lm.fit21 = lm(y ~ x1 + x2)
summary(lm.fit21)

lm.fit22 = lm(y ~ x1)
summary(lm.fit22)

lm.fit23 = lm(y ~ x2)
summary(lm.fit23)

par(mfrow=c(2,2))
plot(lm.fit21)

par(mfrow=c(2,2))
plot(lm.fit22)

par(mfrow=c(2,2))
plot(lm.fit23)

Boston = read.csv("../../../data/Boston.csv", header=T, na.strings="?")
Boston$chas <- factor(Boston$chas, labels = c("N","Y"))
summary(Boston)

attach(Boston)
lm.zn = lm(crim~zn)
summary(lm.zn) # yes

lm.indus = lm(crim~indus)
summary(lm.indus) # yes

lm.chas = lm(crim~chas)
summary(lm.chas) # no

lm.nox = lm(crim~nox)
summary(lm.nox) # yes

lm.rm = lm(crim~rm)
summary(lm.rm) # yes

lm.age = lm(crim~age)
summary(lm.age) # yes

lm.dis = lm(crim~dis)
summary(lm.dis) # yes

lm.rad = lm(crim~rad)
summary(lm.rad) # yes

lm.tax = lm(crim~tax)
summary(lm.tax) # yes

lm.ptratio = lm(crim~ptratio)
summary(lm.ptratio) # yes

lm.black = lm(crim~black)
summary(lm.black) # yes

lm.lstat = lm(crim~lstat)
summary(lm.lstat) # yes

lm.medv = lm(crim~medv)
summary(lm.medv) # yes

lm.all = lm(crim ~ ., data = Boston)
summary(lm.all)

# Simple regresion
x = c(coefficients(lm.zn)[2],
      coefficients(lm.indus)[2],
      coefficients(lm.chas)[2],
      coefficients(lm.nox)[2],
      coefficients(lm.rm)[2],
      coefficients(lm.age)[2],
      coefficients(lm.dis)[2],
      coefficients(lm.rad)[2],
      coefficients(lm.tax)[2],
      coefficients(lm.ptratio)[2],
      coefficients(lm.black)[2],
      coefficients(lm.lstat)[2],
      coefficients(lm.medv)[2])

# Multiple regresion
y = coefficients(lm.all)[2:14]

plot(x, y)

cor(Boston[-c(1, 4)])

lm.zn = lm(crim ~ poly(zn, 3))
summary(lm.zn) # 1, 2

lm.indus = lm(crim ~ poly(indus, 3))
summary(lm.indus) # 1, 2, 3

lm.nox = lm(crim ~ poly(nox, 3))
summary(lm.nox) # 1, 2, 3

lm.rm = lm(crim ~ poly(rm, 3))
summary(lm.rm) # 1, 2

lm.age = lm(crim ~ poly(age, 3))
summary(lm.age) # 1, 2, 3

lm.dis = lm(crim ~ poly(dis, 3))
summary(lm.dis) # 1, 2, 3

lm.rad = lm(crim ~ poly(rad, 3))
summary(lm.rad) # 1, 2

lm.tax = lm(crim ~ poly(tax, 3))
summary(lm.tax) # 1, 2

lm.ptratio = lm(crim ~ poly(ptratio, 3))
summary(lm.ptratio) # 1, 2, 3

lm.black = lm(crim ~ poly(black, 3))
summary(lm.black) # 1

lm.lstat = lm(crim ~ poly(lstat, 3))
summary(lm.lstat) # 1, 2

lm.medv = lm(crim ~ poly(medv, 3))
summary(lm.medv) # 1, 2, 3

notebooks/R/3 Linear Regression/3.7 Exercises.r


# OLS conditions violations: Heterscedasticity
# Based on:
# https://stats.stackexchange.com/questions/33028/measures-of-residuals-heteroscedasticity
# See also:
# https://stats.stackexchange.com/questions/258485/simulate-linear-regression-with-heteroscedasticity

set.seed(17)
n <- 500

make_x = function(){return (rgamma(n, shape=6, scale=1/2))}
make_e = function(x){return (rnorm(length(x), sd=abs(sin(x))))}
b = 2
f = function(x){return (b*x)}
dgp = function(){
  x <- make_x()
  y = f(x)+make_e(x)
  return (data.frame(x=x,y=y))
}

# single run
x <- make_x()
e <- make_e(x)
y_true = f(x)
y <- y_true + e
fit <- lm(y ~ x + 0)

# regression
png("C:/Users/Евгений/Documents/GitHub/multiple-regression-revisited/hsc1.png")
plot(x,y, main="Observations with heteroscedаsticity")
abline(0, b, col="green")
abline(fit, col="red")
dev.off()

# repeat estimation
extract_b0  = function(lm_){return (coef(lm_)[1])}
get_b = function(){coef(lm(y~x+0, data = dgp()))}
n_experiments = 1000
bs = replicate(n_experiments, get_b())

# plot estimator desities

png("C:/Users/Евгений/Documents/GitHub/multiple-regression-revisited/hsc2.png")

b_avg = mean(bs)
b_sd = sd(bs)
h = hist(bs, breaks=40, freq=FALSE,
         main=paste("Distribution of b on", n_experiments,"experiments"),
         sub=paste("True value:", b, "    ",
                   "Mean: ", round(b_avg,4), "    ",
                   "SD: ", round(b_sd,4)),
         xlab="b",
         col="lightblue")
# curve(dnorm(x, mean=b_avg, sd=b_sd), add=TRUE, col="darkblue", lwd=2)
lines(density(bs), col="darkblue", lwd=2)
abline(v=b, col ="green")
abline(v=b_avg, col ="red")

# from https://stackoverflow.com/questions/6973579/plotting-probability-density-mass-function-of-dataset-in-r
# hist(energy,probability=TRUE)
# lines(density(bs), col="darkblue", lwd=2)

dev.off()


hist_nw <- function(x, alpha=0.01, pvalue=0.99, breaks=NULL, suppress='no') {
    ## plot histogram, normal distribution, and Weibull distribution
    ## add lines for upper tolerance limits for given alpha and pvalue
    ## alpha  = 1 - confidence
    ## pvalue = coverage (tolerance interval only)

    ## normal distribution calculations
    tol_out <- normtol.int(x, alpha = alpha, P=pvalue, side=1)
    upper_tolerance_limit_norm <- tol_out$'1-sided.upper'

    ## Weibull distribution calculations
    tol_out <-  exttol.int(x, alpha=alpha, P=pvalue, side=1, dist="Weibull")
    shape   <- tol_out$'shape.1'
    scale   <- tol_out$'shape.2'
    upper_tolerance_limit_weib <- tol_out$'1-sided.upper'

    ## create vectors with density distributions
    xmin    <- min(x)
    xmax    <- max(x,upper_tolerance_limit_norm,upper_tolerance_limit_weib)
    chuncks <- (xmax-xmin)/1000
    xrange  <- seq(xmin,xmax,by=chuncks)
    xmean   <- mean(x)
    xsd     <- sd(x)
    xdensity_norm <- dnorm(xrange,xmean,xsd)
    xdensity_weib <- dweibull(xrange,shape=shape,scale=scale)
    maxdensity <- max(xdensity_norm, xdensity_weib)

    ## make histogram
    ## warning: xlim range can mess up x-axis
    ## obtain histogram parameters but suppress plot
    out <- hist(x, plot=FALSE)
    if (is.null(breaks)) breaks <- length(out$breaks)
    ymax <- max(out$density, maxdensity)
    ## create plot
    hist(x, breaks=breaks,
         xlim=c(xmin,xmax+(xmax-xmin)/breaks),
         ylim=c(0,maxdensity),
         freq=FALSE)

    ## add distributions
    lines(x=xrange, y=xdensity_norm, col='red', lty=1)
    lines(x=xrange, y=xdensity_weib, col='blue', lty=1)

    ## add lines for mean and upper 1-sided 99/99 tolerance limits
    abline(v=xmean,col="red")
    abline(v=upper_tolerance_limit_norm,col="red",lty=2)
    abline(v=upper_tolerance_limit_weib,col="blue",lty=2)

    ## print to screen
    if (suppress == 'no') {
        cat("Tolerance limit input parameters:\n")
        cat("   upper, 1-sided,", pvalue*100,"/",(1-alpha)*100,"\n")
        cat("\n")
        cat("Normal distribution (red):\n")
        cat("   mean               =",xmean,"\n")
        cat("   standard deviation =",xsd,"\n")
        cat("   tolerance limit    =",upper_tolerance_limit_norm,"\n")
        cat("\n")
        cat("Weibull distribution (blue):\n")
        cat("   shape              =",shape,"\n")
        cat("   scale              =",scale,"\n")
        cat("   tolerance limit    =",upper_tolerance_limit_weib,"\n")
    }
}
## hist_nw(mtcars$mpg)


library(pcalg)

## true DAG
## X1 -> X2 <- L -> X3 <- X4

set.seed(123)
n <- 10000
X1 <- rnorm(n, 0 , .5)
X4 <- rnorm(n, 0, 1.4)
L <- rnorm(n, 0, 0.7)
X2 <- rnorm(n, -1 + 0.8*X1 + 0.8*L, 1)
X3 <- rnorm(n, -1 + 2.2*X4 + 1.8*L, 1)

data <- cbind(X1,X2,X3,X4) ## L is not observed in data

indepTest <- gaussCItest ## specify the independence test
suffStat <- list(C = cor(data), n = n) ## using the correlation matrix

fci.est <- fci(suffStat, indepTest, alpha = 0.05, p = 4, verbose=TRUE) ## estimate a PAG
plot(fci.est)

pc.est <- pc(suffStat, indepTest, alpha = 0.05, p = 4, verbose=TRUE) ## estimate at CPDAG
plot(pc.est)

score <- new("GaussL0penObsScore", data) ## define a score function

ges.fit <- ges(score, verbose=TRUE) ## estimate at CPDAG with GES
plot(ges.fit$essgraph)

####

## True DAG: Z1 -> X <-- Z2 ; X --> Y <-- L ; possibly L -?-> X

set.seed(123)
n <- 10000
Z1 <- rnorm(n, 0, .5)
Z2 <- rnorm(n, 0 , 1.5)
L <- rnorm(n, 0, 1)
X <- rnorm(n, 0.8*Z1 + 0.8*Z2 + 0*L, 1) ## try adding a non-zero coefficient for L, see result change
Y <- rnorm(n, 1.6*X + 0.6*L, 1)

data <- cbind(Z1,Z2,X,Y) ## L is not observed in data

indepTest <- gaussCItest ## specify the independence test
suffStat <- list(C = cor(data), n = n) ## using the correlation matrix

fci.est <- fci(suffStat, indepTest, alpha = 0.05, labels = c("Z1","Z2","X","Y"), verbose=TRUE) ## estimate a PAG
plot(fci.est)

## try a random DAG

p <- 10
n <- 10000
myDAG <- randomDAG(p, prob = 0.4)
plot(myDAG)
data <- rmvDAG(n, myDAG, errDist = "normal")
data <- data[,-c(4,5)] ## "hide" two of the variables

indepTest <- gaussCItest ## specify the independence test
suffStat <- list(C = cor(data), n = n) ## using the correlation matrix

fci.est <- fci(suffStat, indepTest, alpha = 0.01, labels = c("1","2","3","6","7","8","9","10"), verbose=TRUE) ## estimate a PAG
plot(fci.est)

pc.est <- pc(suffStat, indepTest, alpha = 0.01, labels = c("1","2","3","6","7","8","9","10"), verbose=TRUE) ## estimate at CPDAG
plot(pc.est)

score <- new("GaussL0penObsScore", data) ## define a score function

ges.fit <- ges(score, verbose=TRUE) ## estimate a CPDAG with GES
plot(ges.fit$essgraph)


# Example : 2   Chapter : 2.5   Pageno : 82
# Inverse of an Elimination Matrix
E<-matrix(c(1,-5,0,0,1,0,0,0,1),ncol=3)
E1<-solve(E)
print("The inverse of the given elimination matrix is")
print(E1)


## Author: Sergio García Prado

rm(list = ls())

## a)
####

## Asymptotic distibution of (p1.hat, p2.hat) as parameters p1 of Bin(n, p1) and
## p2 of Bin(n, p2) independent of each other.
##
## (p1.hat, p2.hat) ~ N_2( (p1, p2) , [p1 * (1 - p1) / n, 0;
##                                     0, p2 * (1 - p2) / n] )
##

## b)
####
n1 <- 50
y1 <- 35

n2 <- 50
y2 <- 40

n <- c(n1, n2)
y <- c(y1, y2)

alpha <- 0.05

LogLikelihood <- function(p, y, n) {
  sum(y * log(p) + (n - y) * log(1 - p))
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(runif(2), NegativeLogLikelihood, y = y, n = n, hessian = TRUE,
              lower = rep(10e-3, 2), upper = rep(1 - 10e-3, 2), method = "L-BFGS-B")

(p.hat <- opt$par)
# 0.69999745777599 0.799999683303738

(p.hat.var <- solve(opt$hessian))
# 0.004199941	0.000000000
# 0.000000000	0.003199902

g.transform <- c(-2, 1)

(g.hat <- (g.transform %*% p.hat)[1])
# -0.59999999367853

(g.hat.var <- (g.transform %*% p.hat.var %*% g.transform)[1])
# 0.0199995879878169

## Wald's Confidence Interval at (1 - alpha)% level.
g.hat + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(g.hat.var)
# -0.87717790348746 -0.3228220838696

## b)
####
g.zero <- 0

(W <- (g.hat - g.zero) ^ 2 / g.hat.var)
# 18.0003059668258

(W.pvalue <- 1 - pchisq(W, df = 1))
# 2.20869627943765e-05

## b)
####

LogLikelihoodHZero <- function(pp, ...) {
  LogLikelihood(c(2 * pp, pp), ...)
}

NegativeLogLikelihoodHZero <- function(...) {
  - LogLikelihoodHZero(...)
}

opt.hzero <- optim(runif(1), NegativeLogLikelihoodHZero, y = y, n = n,
                   lower = 10e-3, upper = 0.5 - 10e-3, method = "L-BFGS-B" )

(LRT <- 2 * (LogLikelihood(p.hat, y, n) - LogLikelihoodHZero(opt.hzero$par, y, n)))
# 36.089146035026

(LRT.pvalue <- 1 - pchisq(LRT, df = 1))
# 1.88493831654313e-09


R Statastics

#SAMPLE
df <- data.frame(name = c('Jon', 'Bill', 'Maria'),
                 age = c(23, 41, 32)
                 )
print (df)

#MEAN
#create a vector
x <- c(12,7,3,4.2,18,2,54,-21,8,-5)

# Find Mean.
ans <- mean(x)
cat('The mean of vector x is', ans)

#Applying trim option
ans1 <- mean(x,trim = 0.3)
cat('The mean by applying trim is', ans)

#create a vector with NA value
x <- c(12,7,3,4.2,18,2,54,-21,8,-5, NA)

# Find Mean.
ans <- mean(x)
cat('The mean of vector x is', ans)

#find mean by dropping NA values
ans <- mean(x,na.rm = TRUE)
print(ans)

#MEDIAN
#create a vector
y <- c(12,7,3,4.2,18,2,54,-21,8,-5)

ans <- median(y)
cat('Meadian of x is', ans)

#MODE
#Create the function
getmode <- function(v)
    { unique_value <- unique(v)
     unique_value[which.max(tabulate(match(v,unique_value)))]

}

#Create the vector with numbers
v <- c(2,1,2,3,1,2,3,4,1,5,5,3,2,3)

#Create the mode using the user function
ans <- getmode(v)
cat("The mode of the given vector is ->", ans)

#Create teh vector with characters.
charv <- c("o","it","the","it","it")

ans <- getmode(charv)
cat("The mode of the given vector is ->", ans)

#Linear Regression

x <- c(151,174,138,186,128,136,179,163,152,131)
y <- c(63,81,56,91,47,57,76,72,62,48)

#Apply the lm() function.
relation <- lm(y~x)
print(relation)

relation <- lm(y~x)
print(summary(relation))

# Use of predict() Function

#The predictor vector.
x <- c(151,174,138,186,128,136,179,163,152,131)

# The responce vector.
y <- c(63,81,56,91,47,57,76,72,62,48)

#Apply the lm() function.
relation <- lm(y~x)
print(relation)

# Find wieght of a person with height 170
a <- data.frame(x = 170)
result <- predict(relation,a)
print(result)

#Visualizing the Regression Graphically

#create the predictor and responce variable.
x <- c(151,174,138,186,128,136,179,163,152,131)
y <- c(63,81,56,91,47,57,76,72,62,48)
relation <- lm(x~y)

#Give the chart file a name.
png(file ="Linearregression.png")

#plot the chart.
plot(y,x,col = "blue", main = "Height & weight regression", abline(lm(x~y)),
     cex = 1.3, pch = 16, xlab = "Wieght in KG", ylab = "Height")

# To save the file.
dev.off()


#break-even multiple products

# computing a value-weighted average

# product A, CM of $10
# product B, CM of $6

# for each 1 unit of A, 2 units of B are sold
volumes <- c(1, 2)
# contribution margins
CMs <- c(10, 6)

#make the volumes relative
vol_weights <- volumes / sum(volumes)
vol_weights
#[1] 0.3333333 0.6666667

# weighted CM
CM_weighted <- weighted.mean(  CMs, vol_weights )
CM_weighted
#[1] 7.333333

#if fixed costs are $10,000 then break-even is
beUnits <- 10000/CM_weighted
beUnits
#1363.636

#volumes
beUnits * vol_weights
#[1] 454.5455 909.0909
#454.5 units of A, 909 units of B (adds up to beUnits)


twostreaks=function(song){
# song is a vector of 0's and 1's that represents the hits (0) and
# misses (1) of the notes in order

  temp = diff(c(0,which(song == 1),length(song)+1))-1
  top2 = -sort.int(-temp,partial=1:min(2,length(temp)))[1:2]
  len_top2 = sum(top2,na.rm = T)

  # About these commands:
  # which(song == 1) returns a vector indicating which on which notes (indices) a miss occurs
  #                this is important for you because it will indicate the end of a streak
  # c(0,which(song == 1),length(song)+1) creates a vector starting with 0 (indicates the beginning of the song),
  #                 then the locations of misses, and then the length of the song + 1 (indicates when the song has ended)
  # By doing a partial sort of the above vector we can quickly find to longest streaks. However, since the sort.int function
  #   doesn't sort in decreasing order you need to first negate the vector of hit streaks so an
  #   increasing sort finds the correct streaks, then negate the results to obtain the actual values.
  #   While other methods could be used to obtain the same information (possibly by sorting the entire "temp" vector)
  #   this provides a nice illustration of how to use some of the more computationally efficient tools in R that may
  #   otherwise go unnoticed.
  #
  # The combination of min(2,length(temp)) and the na.rm = T in the sum are needed when only one hit streak occurs.

  return(len_top2)
}

# Hypothesis test based on the twostreaks method
twostreaks_test = function(song,B=1000){
    # song is a vector of 0's and 1's that represents the hits (0)
	# and misses (1) of the notes in order
	# B is the number of new samples to generate

	test_stat = twostreaks(song)
	n = length(song)
	tstar_b = numeric(B)
	for(b in 1:B){
		song_tmp = sample(song)  # for permutation test
#		song_tmp = sample(song,replace=T) # for non-parametric bootstrap
#		song_tmp = rbinom(n,1,mean(song)) # for parametric bootstrap
		tstar_b[b] = twostreaks(song_tmp)
	}

	# calculate the two-sided p-value from the sampling distribution
	pval = 2*min(sum(tstar_b >= test_stat),sum(tstar_b <= test_stat))/B
		# calculate a one sided p-value
#	pval = sum(tstar_b >= test_stat)/B
	return(pval)
}

# Examples using Songs A and B from Table 1

songA = c(1,0,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0)
twostreaks(songA)
twostreaks_test(songA,5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
twostreaks(songB)
twostreaks_test(songB,5000)


### 主成分分析の例
### - 県別の生活環境に関するデータ

## パッケージの読み込み
require(MASS)
require(tidyverse)
require(ggfortify)
require(GGally)

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

## データの整形
mydata <- raw[-1,-c(1,2)] # 不要な行・列を削除
names(mydata) <-  names(read.csv("data/jpamenityitem.csv")) # 変数名の略記
rownames(mydata) <- raw[-1,1] # 各行の名前を県名
areaname <- c("北海道","東北","関東","中部","近畿","中国","四国","九州")
area <- rep(areaname,c(1,6,7,9,7,5,4,8))

## データの内容を表示
## print(mydata) # 全データの表示
head(mydata)  # 最初の6個を表示
## tail(mydata)  # 最後の6個を表示

## データの散布図 (一部項目のみ): 図(a)
item <- c(1,7,8,18,19,20)
## print(names(mydata)[item])
ggscatmat(data.frame(mydata,area),
          columns=item, color="area", alpha=.5) +
    theme(text=element_text(family="HiraMaruProN-W4"))
## ## ggparis を用いる場合 (legendが付かない)
## ggpairs(data.frame(mydata,area),
##         columns=item, mapping=aes(colour=area)) +
##     theme(text=element_text(family="HiraMaruProN-W4"))

## 主成分分析
model <-princomp(mydata,cor=TRUE)
## model <-prcomp(mydata,scale.=TRUE) # prcompを使う場合

## 分析結果を表示
print(model)
## 寄与率 (正規化あり): 図(b)
plot(model)

## 主成分得点 (scale=1) [既定値]: 図(c)
autoplot(model, data=mydata, shape=FALSE,
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="県別の生活環境") +
    theme(text=element_text(family="HiraMaruProN-W4"))

## 中心部の拡大表示: 図(d)
autoplot(model, data=mydata, shape=FALSE,
         xlim=c(-.3,.3), ylim=c(-.3,.3),
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="県別の生活環境 (中心を拡大)") +
    theme(text=element_text(family="HiraMaruProN-W4"))

## 主成分得点 (scale=0): 図(e)
autoplot(model, data=mydata, scale=0, shape=FALSE,
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="scale=0での表示") +
    theme(text=element_text(family="HiraMaruProN-W4"))

## 主成分得点 (scale=1/2): 図(f)
autoplot(model, data=mydata, scale=1/2, shape=FALSE,
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="scale=1/2での表示") +
    theme(text=element_text(family="HiraMaruProN-W4"))


'''
A fast food franchise is test marketing 3 new
menu items. To find out if they have the same
popularity, 6 franchisee restaurants are
randomly chosen for participation in the study.
In accordance with the randomized block design,
each restaurant will be test marketing all
3 new menu items. Furthermore, a restaurant
will test market only one menu item per week,
and it takes 3 weeks to test market all menu
items. The testing order of the menu items
for each restaurant is randomly assigned as
well.

Suppose each row in the following table represents
the sales figures of the 3 new menu in a restaurant
after a week of test marketing. At .05 level of significance,
test whether the mean sales volume for the 3 new menu items
are all equal.
'''

library(readr)
dataset <- read_csv('fastfood-2.csv')
View(dataset)

#creamos un vector
r = c(t(as.matrix(df2)))

f = c("Item1", "Item2", "Item3")

k = 3
n = 6

#treatment factors
tm = gl(k, 1, n*k, factor(f))

#blocking factors
blk = gl(n, k, k*n)

av = aov(r ~ tm +blk)

summary(av)

'''
            Df Sum Sq Mean Sq F value Pr(>F)
tm           2    539     269    4.96  0.032 *
blk          5    560     112    2.06  0.155
Residuals   10    543      54

Como el p-value 0.032 es menor a la significancia .05, rechazamos la hipotesis
'''


nstreaks=function(song)
{
# song is a vector of 0's and 1's that represents the hits (0) and
# misses (1) of the notes in order

# determine the total number of hit streaks
  streaks = sum(diff(c(song,1)) == 1)

  # About these commands:
  # diff(c(song,1) calculates the difference between consecutive entries in this vector; we don't actually care about
  #			 the locations of the misses but how many hits occur between misses; we start the process of finding this
  #			 by finding the difference between consecutive indices in the vector.  The end of hit streaks are indicated
  # 		 by this difference being 1 (i.e., going from a hit of 0 to a miss of 1).  Attaching an additional 1 at
  # 		 the end of the song will ensure that if the song ends in a steak of hits it is included in the total.
  # sum( above vector == 1) counts the number of hit streaks

  return(streaks)
}

# Hypothesis test based on the nstreaks test method
nstreaks_test = function(song,B=1000){
    # song is a vector of 0's and 1's that represents the hits (0)
	# and misses (1) of the notes in order
	# B is the number of new samples to generate

	test_stat = nstreaks(song)
	n = length(song)
	tstar_b = numeric(B)
	for(b in 1:B){
		song_tmp = sample(song)  # for permutation test
#		song_tmp = sample(song,replace=T) # for non-parametric bootstrap
#		song_tmp = rbinom(n,1,mean(song)) # for parametric bootstrap
		tstar_b[b] = nstreaks(song_tmp)
	}

	# calculate the two-sided p-value from the sampling distribution
	pval = 2*min(sum(tstar_b >= test_stat),sum(tstar_b <= test_stat))/B
		# calculate a one sided p-value
#	pval = sum(tstar_b >= test_stat)/B
	return(pval)
}

# Examples using Songs A and B from Table 1

songA = c(1,0,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0)
nstreaks(songA)
nstreaks_test(songA,5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
nstreaks(songB)
nstreaks_test(songB,5000)


#задание 2
print ("task 2")
A <- matrix (c(-11,8,-7,0,14,-7,-1,-6,8,2,-3,8,-4,10,6,7,-4,-2,6,3,6,-4,-2,-5,10,-5,-14,9,7,9,2,-3,-8,-6,2,-9),6,6)
A
#определитель
det(A) # Определитель A

#задание 4
print ("task 4")
A <- matrix (c(-6,6,0,7,9,7,-9,-9,-9,-4,9,-5,6,-3,-7,-8,7,5,-1,3,3,9,-7,3,-3,-1,8,1,0,0,7,-8,2,-2,1,0),6,6)
A
B <- matrix (c(4,8,4,-5,9,-7,9,-8,-7,-7,5,3,-8,5,-1,7,-7,-10,11,7,-9,4,6,-7,1,-11,-1,0,-9,-9,-1,-6,-11,-4,-10,2),6,6)
B
x <- solve(A,B)
print ("x равен")
x
#проверка
y <- A%*%x
y

#задание 5
print ("5 task")
a <- c(3,3,-2,1,2,3,-4,0,-1,2,3,3)
b <- c(-2,3,3,1,1,1,0,-1,2,4,-4,2)
p <- c(4,2,2,2,5,1,3,3,0,-3,-2,-1)

fir <- ((3)*a)+(4*b)
print ("first answer")
fir
sec <- ((2)*as.numeric(a%*%b))*p+2*(norm(p, type="2"))*a
print ("second answer")
sec
thr <- 1*as.numeric(a%*%p)*b-2*as.numeric(b%*%p)*a-2*(norm(p, type="2"))*p
print ("third answer")
thr

#6 задание
print ("sixth task")
install.packages("lpSolveAPI") # Загружаем библиотеку
library(lpSolveAPI) # Активируем библиотеку линейного программирования
M <- make.lp(ncol= 2) # Объявляем количество неотрицательных переменных в M
name.lp(M, "Example") # Объявляем название "Example"для задачи(модели) М
colnames(M) <- c("X1", "X2") # Объявляем названия переменных в модели М
lp.control(M, sense = "min")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(10,5)) # Задаем целевую функцию:
add.constraint(M, c(2,4), ">=", 4) # Задаем ограничение:
add.constraint(M, c(4, 1), ">=",1) #
add.constraint(M, c(2, -3), "<=",6) #

rownames(M) <- c("A", "B","C") # Называем ограничения в модели М
M # Выводим модель M на экран
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M) # Достигнутый min
X1.opt<- get.variables(M)[1]; X1.opt # Оптимальное значение для X1
X2.opt<- get.variables(M)[2]; X2.opt # Оптимальное значение для X2
f.max<- get.objective(M); f.max# Значение целевой функции на оптимальном решении


# logit_to_prob ----
logit_to_prob <- function(logit){
  odds <- exp(logit)
  prob <- odds / (1 + odds)
  return(prob)
}


# Your friend investigates the three observations above 700 grams and discovers that she had ordered
# the incorrect meal on those dates.
# She removes these observations from the data set and proceeds with the analysis using n=27.
#
# She assumes a normal likelihood for the data with unknown mean μ and unknown variance σ2.
# She uses the model presented in Lesson 10.2 where, conditional on σ2,
# the prior for μ is normal with mean mmm and variance σ2/w.

# Next, the marginal prior for σ2 is Inverse-Gamma(a,b).
#
# Your friend's prior guess on the mean dish weight is 500 grams,
# so we set m=500. She is not very confident with this guess,
# so we set the prior effective sample size w=0.1. Finally, she sets a=3 and b=200.
#
# We can learn more about this inverse-gamma prior by simulating draws from it. If a random variable
# X follows a Gamma(a,b) distribution, then 1/X follows an Inverse-Gamma(a,b) distribution.
# Hence, we can simulate draws from a gamma distribution and take their reciprocals,
# which will be draws from an inverse-gamma.

# Simulate a large number of draws (at least 300) from the prior for σ2
# and report your approximate prior mean from these draws. It does not need to be exact.

m = 500
w = .1
alpha = 3
beta  = 200

n = 27

x_mean = 609.7
x_var  = 401.8

alpha_prim = 16.5
beta_prim  = 6022.9
m_prim     = 609.3

prior_var_1 = 1 / rgamma(10000, alpha, beta)

posterior_var_1  = 1 / rgamma(10000, alpha_prim, beta_prim)

posterior_mean_1 = rnorm(10000, m_prim, sqrt((posterior_var_1 / (w + n))))

quantile(posterior_mean_1, c(.025, .975))

# You complete your experiment at Restaurant A with n=30 data points,
# which appear to be normally distributed.
# You calculate the sample mean y¯= 622.8 and sample variance s2 = 403.1.

# Repeat the analysis from Question 9 using the same priors and draw samples from the
# posterior distribution of sigma_A^2 and μA (where the A denotes that these parameters are for Restaurant A).

# Treating the data from Restaurant A as independent from Restaurant B,
# we can now attempt to answer your friend's original question:
# is restaurant A more generous?

# To do so, we can compute posterior probabilities of hypotheses
# like μA > μB.
# This is a simple task if we have simulated draws for μA and μB.
# For i=1,…,N (the number of simulations drawn for each parameter),
# make the comparison μA > μB using the i-th draw for μA and μB.
# Then count how many of these return a TRUE value and divide by N, the total number of simulations.

n_A = 30

x_mean_A = 622.8
x_var_A  = 403.1

alpha_prim_A = alpha + (n_A / 2)
beta_prim_A  = beta + ((n_A - 1) / 2) * x_var_A + ((w * n_A) / (2 * (w + n_A))) * (x_mean_A - m)**2
m_prim_A     = (n_A * x_mean_A + w * m) / (w + n_A)

prior_var_A = 1 / rgamma(10000, alpha, beta)

posterior_var_A  = 1 / rgamma(10000, alpha_prim_A, beta_prim_A)

posterior_mean_A = rnorm(10000, m_prim_A, sqrt((posterior_var_A / (w + n_A))))

sum(posterior_mean_A > posterior_mean_1) / 10000


library(MASS)
# library(ISLR)

# fix(Boston)
data(Boston)
head(Boston)

names(Boston)

?Boston

lm.fit = lm(medv ∼ lstat)

lm.fit = lm(medv ~ lstat, data = Boston)

attach(Boston)
lm.fit = lm(medv ~ lstat)

lm.fit

summary(lm.fit)

names(lm.fit)

coef(lm.fit)

confint(lm.fit)

predict(lm.fit , data.frame (lstat = c(5, 10, 15)), interval = "confidence")

predict(lm.fit , data.frame (lstat = c(5, 10, 15)), interval = "prediction")

plot(lstat, medv)
abline(lm.fit)

plot(lstat, medv)
abline(lm.fit, lwd = 3)

plot(lstat, medv)
abline(lm.fit, lwd = 3, col = "red")

plot(lstat, medv, col ="red")

plot(lstat, medv, pch = 20)

plot(lstat, medv, pch = "+")

plot(1:20, 1:20, pch = 1:20)

par(mfrow = c(2, 2))
plot(lm.fit)

plot(predict(lm.fit), residuals(lm.fit))

plot(predict(lm.fit), rstudent(lm.fit))

plot(hatvalues(lm.fit))

which.max(hatvalues(lm.fit))

lm.fit = lm(medv ~ lstat + age, data = Boston)
summary(lm.fit)

lm.fit = lm(medv ~ ., data = Boston)
summary(lm.fit)

library(car)

vif(lm.fit)

lm.fit1 = lm(medv ~ . - age ,data = Boston)
summary(lm.fit1)

lm.fit1 = update(lm.fit, ~ . - age)

summary(lm(medv ~ lstat*age, data = Boston))

lm.fit2 = lm(medv ~ lstat + I(lstat^2))

summary(lm.fit2)

lm.fit = lm(medv ~ lstat)
anova(lm.fit, lm.fit2)

par(mfrow = c(2, 2))
plot(lm.fit2)

lm.fit5 = lm(medv ~ poly(lstat, 5))
summary(lm.fit5)

summary(lm(medv ~ log(rm), data = Boston))

# data(Carseats)
Carseats = read.csv("../../../data/Carseats.csv")

head(Carseats)

names(Carseats)

lm.fit = lm(Sales ~ . + Income:Advertising + Price:Age, data = Carseats)
summary(lm.fit)

attach(Carseats)
contrasts(ShelveLoc)

LoadLibraries

LoadLibraries()

LoadLibraries= function () {
  # library (ISLR )
  library (MASS )
  print (" The libraries have been loaded .")
}

LoadLibraries

LoadLibraries()

notebooks/R/3 Linear Regression/3.6 Lab - Linear Regression.r


## 1. Probability In Terms of Sets ##

coin_toss_omega <- length(c('HH', 'TT', 'HT', 'TH'))

## 2. Venn Diagrams ##

p_c <- 3/6
p_d <- 3/6
p_c_or_d <- 4/6
p_c_and_d <- 2/6

## 3. Unions and Intersections of Sets ##

operation_1 <- FALSE
operation_2 <- TRUE
operation_3 <- FALSE
operation_4 <- TRUE

## 4. Mutually Exclusive Events ##

mutual_exclusive_1 <- TRUE
mutual_exclusive_2 <- TRUE
mutual_exclusive_3 <- FALSE

## 5. The Addition Rule ##

p_heart_or_diamonds <- 13/52 + 13/52
p_face_card <- 3/52 + 3/52 + 3/52 + 3/52

## 6. A More General Addition Rule ##

p_f_or_t <- 0.26 + 0.11 - 0.03

Data Analyst in R/Step 5 - Probability and Statistics/3. Probability Fundamentals in R/2. Probability Rules.r


## Loss/cost functions and their gradients

## the least squares cost function - matrix operations
ls_cost_fn<-function(actual,prediction){
  n<-nrow(actual)
  (1/n)*t(prediction-actual)%*%(prediction-actual)
}

## least squares gradient - matrix operations
ls_gradient_fn<-function(w,X,y){
  if(is.null(dim(X)[2])){
    #single obs case - for stochastic alg
    X*(X%*%w-y)
  }else{
    #complete cases
    t(X)%*%(X%*%w-y)
  }
}

## Log loss function
ll_cost_fn<-function(actual, prediction) {
  epsilon <- .000000000000001
  yhat <- pmin(pmax(prediction, epsilon), 1-epsilon)
  logloss <- -mean(actual*log(yhat)
                   + (1-actual)*log(1 - yhat))
  return(logloss)
}

## -gradient of the log loss function
ll_gradient_fn<-function(w,X,y){
  n<-nrow(X)
  if(is.null(n)){
    n<-1
  }
  cost<-0
  for(i in 1:n){
    cost<-cost+(-(y*X*(1/(1+exp(X%*%w))) -
                       (1-y)*X*(1/(1+exp(-X%*%w)))))
  }
  cost/n
}


library(venneuler)

png("conditional_vs_intersection.png",width = 1400, height = 700)
venn <- venneuler(c(B = 5000,A = 5000,"A&B" = 1000))
par(mfrow = c(1,2), mar = c(0,3,3,0.5 ))
venn$colors <- c(0.3,0.7)
plot(venn)
par(xpd = TRUE)
rect(-0.1,0,1.05,1,border = "black",lwd = 3)
text(0.5,0.5,expression(A*intersect(B)))
text(0,1.025,  expression(Omega),cex = 2)
title(main = expression(paste(A*intersect(B)," = ",frac(A*intersect(B),1))))
mtext(side = 1,line = -1, text = expression(paste("Area we are considering is ", Omega)),cex = 2)

plot(venn)
text(0.5,0.5,expression(A*intersect(B)))
plotrix::draw.circle(venn$centers[1,1],venn$centers[1,2],venn$diameters[1]/2, lwd = 3)
title(main = expression(paste("A|B = ",frac(A*intersect(B),B))))
text(0.5,0.9, "We have extra information; we know B has happened.", cex = 2)
mtext(side = 1,line = -1, text = "Area we are considering is B ",cex = 2)
dev.off()


# TECOA166
#Sheetal Singh

ds_mean <- function(ds) {
  cat("\nMean:-\n")
  print(sapply(ds[,1:4], mean, na.rm = T)) # find mean deviation
}

getmode <- function(v) {
  uniqv <- unique(v)
  uniqv[which.max(tabulate(match(v, uniqv)))]  # Function to calulate mode
}

ds_mode <- function(ds) {
  cat("\nMode:-\n")
  cat("Sepal.Length: ",getmode(ds$Sepal.Length),"\n")
  cat("Sepal.Width: ",getmode(ds$Sepal.Width),"\n")
  cat("Petal.Length: ",getmode(ds$Petal.Length),"\n")
  cat("Petal.Width: ",getmode(ds$Petal.Width),"\n")
}

ds_median <- function(ds) {
  cat("\nMedian:-\n")
  print(sapply(ds[,1:4], median, na.rm = T)) # find median deviation
}

ds_standard_deviation <- function(ds) {
  cat("\nStandard deviation:-\n")
  print(sapply(dataset[,1:4],sd)) # find standard deviation
}

ds_varaition <- function(ds) {
  cat("\nVariance:-\n")
  print(sapply(dataset[,1:4],var)) # find variance
}

ds_skewness <- function(ds) {
  cat("\nSkewness:-\n")
  #install.packages ("moments")
  library (moments)
  print(sapply(ds[,1:4],skewness)) # find skewness
}

ds_kurtosis <- function(ds) {
  cat("\nKurtosis:-\n")
  #install.packages ("moments")
  library (moments)
  print(sapply(ds[,1:4],kurtosis)) # find kurtosis
}

ds_histogram<- function(ds) {
  hist(iris$Sepal.Width, col="yellow", ylim = c(0,40))
  hist(iris$Sepal.Length, col="pink", ylim = c(0,40))
  hist(iris$Petal.Width, col="lightblue", ylim = c(0,40))
  hist(iris$Petal.Length, col="darkorchid", ylim = c(0,40))
}

ds_boxplot<- function(ds) {
  irisVer <- subset(ds, Species == "versicolor")
  irisSet <- subset(ds, Species == "setosa")
  irisVir <- subset(ds, Species == "virginica")
  par(mfrow=c(1,3),mar=c(6,3,2,1))
  boxplot(irisVer[,1:4], main="Versicolor, Rainbow Palette",ylim = c(0,8),las=2, col=rainbow(4))
  boxplot(irisSet[,1:4], main="Setosa, Heat color Palette",ylim = c(0,8),las=2, col=heat.colors(4))
  boxplot(irisVir[,1:4], main="Virginica, Topo colors Palette",ylim = c(0,8),las=2, col=topo.colors(4))

}

ds_scatterplot<- function(ds) {
  my_cols <- c("#00AFBB", "#E7B800", "#FC4E07")
  pairs(ds[,1:4], pch = 19,  cex = 0.5,
        col = my_cols[iris$Species],
        lower.panel=NULL)
  #par(xpd = TRUE)
  #legend("topright", fill = unique(iris$Species), legend = c( levels(iris$Species)))
}

# Main Program Starts form here
dataset <- iris # load dataset
while (TRUE)
{
  # Display Menu
  cat("\n\nMenu:-
1. Find mean
2. Find mode
3. Find median
4. Find standard deviation
5. Find variance
6. Compute skewness
7. Compute kurtosis
8. Histogram
9. Boxplot
10. Scatter Plot
11.Exit\n\n")

  # Take input form user
  ch = as.integer(readline(prompt="Enter Your Choice: "))

  # Perform action specified by user
  switch(ch,ds_mean(dataset),ds_mode(dataset),
         ds_median(dataset), ds_standard_deviation(dataset),
         ds_varaition(dataset),ds_skewness(dataset),
         ds_kurtosis(dataset), ds_histogram(dataset),
         ds_boxplot(dataset),ds_scatterplot(dataset))

  if(ch==11){break}
}


#' Fitting Weibull-log-normal model to wave data
#'
#' @description
#' This function fits a Weibull-log-normal (\code{wln}) model to the given wave data, such that the wave height
#' \code{hs} follows a translated (or 3-parameter) Weibull distribution, and the wave period given the wave
#' follows a conditional log-normal distributuion with the location and scale parameters as functions
#' of the corresponding \code{hs} value.
#'
#' @param data the wave data in the form a \code{data.table} with wave height \code{hs} and wave period
#' \code{tp} as columns.
#'
#' @param npy the number of data points per year, usually estimated by the number of rows in the
#' supplied wave data divided by the total period of data coverage (in years).
#'
#' @param weibull_method the method for fitting the Weibull distribution to the \code{hs} column in the wave data. Choose
#' between \code{"lmom"} for L-moment or \code{"mle"} for maximum likelihood estimator. The default option
#' is \code{"lmom"}.
#'
#' @details
#' The input \code{data} must be a \code{data.table} object with \code{hs} and \code{tp} columns. This can be
#' generated by reading a CSV file using function \code{\link[data.table]{fread}}.
#'
#' The formulation of the conditional distribution is given by
#' \deqn{log(tp | hs=h) ~ N(\mu(h), \sigma(h)^2)}
#' where the mean and the standard deviation are
#' \deqn{\mu(h) = a_0 + a_1 h^a_2 and \sigma(h) = b_0 + b_1 exp(h * b_2)}
#'
#' A two-step regression-based estimation method is used for fitting the conditional distribution of
#' \code{tp} given \code{hs}. The conditonal means and standard deviations are
#' estimated over fixed-width bands of \code{hs} in the first step, and regressed onto the above
#' functions of \code{hs} in the second step.
#'
#' @return A joint distribution object of class \code{wln} containing the key information of a fitted
#' Weibull-log-normal model, including the three parameters of the Weibull distribution for \code{hs} (as a named
#' numeric vector) and the six parameters of the conditional log-normal distribution for \code{tp} given \code{hs}
#' (as an unamed numeric vector, in the order of \eqn{{a_0, a_1, a_2, b_0, b_1, b_2}}).
#'
#' It is possible to replace one or multiple \code{hs} or \code{tp} parameters in an existing \code{wln} object
#' (see the examples provided below). The current version of the package does not automatically check the
#' validity of these user-input parameters. Therefore users are advised to perform the check independently.
#'
#' @examples
#' # Load data
#' data(ww3_pk)
#'
#' # Fit Weibull-log-normal distribution
#' wln1 = fit_wln(data = ww3_pk, npy = nrow(ww3_pk)/10, weibull_method = "mle")
#'
#' # Fit Weibull-log-normal distribution using the alternative method
#' wln2 = fit_wln(data = ww3_pk, npy = nrow(ww3_pk)/10, weibull_method = "lmom")
#'
#' # Update the hs parameters for object wln1
#' wln3 = copy(wln1)
#' wln3$hs$par[["loc"]] = 0.66
#' wln3$hs$par[["scale"]] = 2.2
#' wln3$hs$par[["shape"]] = 1.8
#'
#' @references
#' Haver, Sverre & Winterstein, Steven. (2009). Environmental Contour Lines: A Method for Estimating Long
#' Term Extremes by a Short Term Analysis. Transactions - Society of Naval Architects and Marine Engineers. 116.
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{sample_jdistr}}
#'
#' @export
fit_wln = function(data, npy, weibull_method="lmom"){

  res = list()
  class(res) = "wln"
  res$npy = npy
  res$hs = .fit_weibull(data = data$hs, weibull_method = weibull_method)
  res$tp = .fit_iform_lnorm(hs = data$hs, tp = data$tp)
  return(res)
}

# Conditional log-normal used for IFROM -----------------------------------

.fit_iform_lnorm = function(hs, tp){

  input_data = data.table(hs, tp)[sort.list(-hs)]
  mod_data = input_data[, .(log_mean=mean(log(tp)), log_sd=sd(log(tp))), .(hs=round(hs/.hs_res)*.hs_res)]

  mod_mean = nls(
    formula = log_mean~.cond_norm_mean(hs, a0, a1, a2), data = mod_data,
    start = list(a0=1, a1=1, a2=.1), algorithm = "port", control = list(maxiter = 1e3, warnOnly=T))

  mod_sd = nls(
    formula = log_sd~.cond_norm_sd(hs, b0, b1, b2), data = mod_data, lower = c(0, 0, -Inf),
    start = list(b0=0.25, b1=0.1, b2=-0.1), algorithm = "port", control = list(maxiter = 1e3, warnOnly=T))

  res = list(par = c(coef(mod_mean), coef(mod_sd)))
  class(res) = "iform_lnorm"
  return(res)
}

.cond_norm_mean = function(hs, a0, a1, a2){
  a0+a1*hs^a2
}
.cond_norm_sd = function(hs, b0, b1, b2){
  b0+b1*exp(b2*hs)
}

# Weibull fit ----------------------------------------------------

.fit_weibull = function(data, weibull_method){
  res = list()

  if(weibull_method=="lmom"){
    out = as.numeric(lmom::pelwei(lmom::samlmu(data)))
    res$par = c(loc=out[1], scale=out[2], shape=out[3])
    res$conv = NA
  }else if(weibull_method=="mle"){
    theta0 = c(min(data-min(data))/2, sd(data), 1)
    op = nlminb(
      start = theta0,
      objective = .nll_weibull3, data = data,
      lower = c(.limit_zero, .limit_zero, .limit_zero),
      upper = c(min(data)-.limit_zero, .limit_inf, .limit_inf))
    res$par = c(loc=op$par[1], scale=op$par[2], shape=op$par[3])
    res$conv = op$convergence
  }else{
    stop("Only \"lmom\" and \"mle\" are supported.")
  }

  class(res) = "weibull"
  return(res)
}

.nll_weibull3 = function(theta, data) {
  if(theta[1]>=min(data) || theta[2]<=0 || theta[3]<=0){
    res = .limit_inf
  }else{
    nll = dweibull(data-theta[1], scale=theta[2], shape=theta[3], log = TRUE)
    res = -sum(nll)
  }
  return(res)
}


# ***************************** Neural Network ***************************
sigmoid <- function(z) {
  return(1/(1 + exp(-z)))
}

## Loss Function (Cross Entropy)
forward <- function(theta, X, y, lambda) {
  m <- length(y)
  return(1/m * sum(-y * log(sigmoid(X %*% theta)) - (1 - y) *
                     log(1 - sigmoid(X %*% theta))) + lambda/2/m * sum(theta[-1]^2))
}

## Gradient
gradient <- function(theta, X, y, lambda) {
  m <- length(y)
  return(1/m * t(X) %*% (sigmoid(X %*% theta) - y) + lambda/m *
           c(0, theta[-1]))
}

# expand 2-dimension to N dimensions: N = (degree + 1) * (degree + 2) / 2
mapFeature <- function(X1, X2, degree) {
  out <- rep(1, length(X1)) #for bias
  for (i in 1:degree) {
    for (j in 0:i) {
      out <- cbind(out, (X1^(i - j)) * (X2^j))
    }
  }
  return(out)
}

# ***************************** Parameter Optimizer ***************************

lambda <- 1
learningRate <- 1e-1
maxIteration <- 10000
tolerance <- 1e-6

mu <- 0.9
v <- NA
m <- NA
cache <- NA
decayRate <- 0.99
beta1 <- 0.9
beta2 <- 0.995

train <- function(dt, y, method){
  nPara <- ncol(dt)
  initialTheta <- rep(0, nPara)
  v <<- rep(0, nPara)
  m <<- rep(0, nPara)
  cache <<- rep(0, nPara)

  #sampling data from all train data: mini-batch
  #here, give all data (full batch)
  res <- paraOptim(dt, y, initialTheta, method)
}

TRACE_MODE <- TRUE
trace.log <- NULL
trace.level <- 10

paraOptim <- function(dt, y, theta, method){
  trace.df <- NULL

  #pre_loss <- NaN
  for(i in 0:maxIteration){
    loss <- forward(theta, dt, y, lambda)
    dx <- gradient(theta, dt, y, lambda)

    if(TRACE_MODE && (i %% trace.level == 0) ){
      trace.row <- c(epoch=i, loss=loss, theta=theta)
      trace.df <- rbind(trace.df, trace.row)
    }

    delta <- paraUpdate(method, dx, i+1)
    theta <- theta + delta

    if(sqrt(sum(delta ^ 2)) < tolerance) break
    #if((!is.nan(pre_loss)) && abs(pre_loss - loss) < tolerance) break
    #pre_loss <- loss
  }

  if(i %% maxIteration != 0){
    trace.row <- c(epoch=i, loss=loss, theta=theta)
    trace.df <- rbind(trace.df, trace.row)
  }

  converged <- if(i >= maxIteration) FALSE else TRUE
  trace.log <<- rbind(trace.log, list(method=method, final.loss=loss, final.iteration=i, converged=converged, trace=trace.df))

  print(theta)
  print(i)
  print(loss)

  return(list(theta=theta,loss=loss,iteration=i))
}

paraUpdate <- function(method, dx, t){
  if(method == "SGD"){ #Stochastic Gradient Descent
    delta <- -learningRate * dx
  }
  else if(method == "momentum"){
    v <<- mu * v - learningRate * dx
    delta <- v
  }
  else if(method == "NAG"){ #Nesterov Accelerated Gradient
    v_prev <- v
    v <<- mu * v - learningRate * dx
    delta <- -mu * v_prev + (1 + mu) * v
  }
  else if(method == "AdaGrad"){ #Duchi et al., 2011
    cache <<- cache + dx ^ 2
    delta <- -learningRate * dx / (sqrt(cache) + 1e-7)
  }
  else if(method == "RmsProp"){ #Geoff Hinton’s Coursera, 2012
    cache <<- cache * decayRate + dx ^ 2 * (1 - decayRate)
    delta <- -learningRate * dx / (sqrt(cache) + 1e-7)
  }
  else if(method == "Adam"){ #Kingma and Ba, 2014
    m <<- beta1 * m + (1-beta1) * dx
    v <<- beta2 * v + (1-beta2) * (dx ^ 2)
    if(t < 10){
      mb <- m / (1-beta1^t)
      vb <- v / (1-beta2^t)
    }
    else{
      mb <- m
      vb <- v
    }
    delta <- -learningRate * mb / (sqrt(vb) + 1e-7)
  }
  else{
    print("Error: No such optimization method!")
  }

  return(delta)
}

# ***************************** TEST Stage ***************************

data <- read.csv("ex2data2.txt", header = F) #from Andrew Ng Course

sampleSize <- 1000

randomSample <- function(sampleSize){
  data <- cbind(runif(sampleSize, -1, 1), runif(sampleSize, -1, 1), runif(sampleSize, -1, 1))
  data[,3] <- ifelse(data[,3] > 0, 1, 0)
  return(data)
}

#data <- randomSample(sampleSize) #generate random data

X <- as.matrix(data[,c(1,2)])
y <- data[,3]
X <- mapFeature(X[,1],X[,2], 3)
m <- nrow(X)
n <- ncol(X)

initialTheta <- rep(0, n)
#initialTheta <- rnorm(n) / sqrt(n) #Xavier initialization (Glorot et al., 2010)

trace.log <- NULL

train(X, y, "SGD")
train(X, y, "momentum")
train(X, y, "NAG")
train(X, y, "AdaGrad")
train(X, y, "RmsProp")
train(X, y, "Adam")

plotRes("epoch")
plotRes("position", paraX.ind=2, paraY.ind = 3) #para.ind = 1 is the bias parameter

res <- optim(initialTheta, forward, gradient, X, y, lambda, method = "BFGS", control = list(maxit = maxIteration, trace=3))
res$par
res$value
res$counts
res <- optim(initialTheta, forward, gradient, X, y, lambda, method = "L-BFGS-B", control = list(maxit = maxIteration, trace=6))
res$par
res$value
res$counts

# **************************** Visulization ****************************
maxEpoch <- 500
plotRes <- function(type, paraX.ind=2, paraY.ind=3) #show loss over paraX when set paraY.ind = 0
{
  #color_arr <- NULL;
  xrange <- NA
  yrange <- NA
  labels <- NULL;
  for(i in 1:nrow(trace.log)){
    col <- rgb(runif(5),runif(5),runif(5))
    #color_arr <- cbind(color_arr, col)

    labels <- c(labels, trace.log[[i,1]])

    xx <- trace.log[i,5]
    td <- as.data.frame(xx$trace)
    if(is.na(xrange)) {
      xrange <- c(min(td[,2+paraX.ind]),max(td[,2+paraX.ind]))
    }
    else{
      xrange = c(min(xrange[1], min(td[,2+paraX.ind])),max(xrange[2], max(td[,2+paraX.ind])))
    }

    if(is.na(yrange)){
      yrange <- c(min(td[,2+paraY.ind]),max(td[,2+paraY.ind]))
    }
    else{
      yrange = c(min(yrange[1], min(td[,2+paraY.ind])),max(yrange[2], max(td[,2+paraY.ind])))
    }
  }

  xx <- trace.log[1,5]
  td <- as.data.frame(xx$trace)
  if(type == "epoch"){
    px <- td$epoch
    py <- td$loss

    plot(x=px, y=py, col=color_arr[1], type="l", main="Convergence Performance", pch=0, xlab="epoch", ylab="loss", lty=1, lwd=2, xlim=c(0,maxEpoch))
  }
  else{
    px <- td[,2+paraX.ind]
    py <- td[,2+paraY.ind]

    xrange[2] <- xrange[2] + (xrange[2]-xrange[1])*0.4 #preserve space for legend
    plot(x=px, y=py, col=color_arr[1], type="l", main="Convergence Performance", pch=0, xlab="para 1", ylab="para2", lty=1, lwd=2,xlim=xrange,ylim=yrange)

    points(x=px[1], y=py[1], col="black", type='p', lwd=2, lty=1, pch=16, cex=2)  #start Point
    text(px[1],py[1], labels="start", adj=c(-0.3, 0.2))
  }

  for(i in 2:nrow(trace.log)){
    xx <- trace.log[i,5]
    td <- as.data.frame(xx$trace)

    if(type == "epoch"){
      px <- td$epoch
      py <- td$loss
    }
    else{
      px <- td[,2+paraX.ind]
      py <- td[,2+paraY.ind]
    }
    points(x=px, y=py, col=color_arr[i], type='l', lwd=2, lty=1, pch=0)

    fp <- nrow(td)
    points(x=px[fp], y=py[fp], col="black", type='p', lwd=2, lty=1, pch=13,cex=1.5)  #final point
  }

  legend("topright", legend = labels, col = color_arr,
         lty = 1, bg = "transparent", lwd=2)

}


#'@title Compute a simple moving average for a given time series
#'
#'@description Compute a moving average using prior or later elements
#'
#'@usage  tsData.ma <- getMA(tsData,N)
#'
#'@details If N is null and direction is "prior", then the current point and all prior points are used in the compuation.
#'         If N is null and direction is "later", then the current point and all later points are used in the computation.
#'         If N is not null, then an N point moving average is computed in the direction specified (default is "prior").
#'         In any case, a one-sided (non-centered) moving average is computed.
#'         If direction is "prior", then the current point and the prior N-1 points are included in the computation.
#'         If direction is "later", then the current point and the later N-1 points are included in the computation.
#'         If there are not enough points to compute an N-point MA, then the original values are retained.
#'
#'@param tsData  A time series object.
#'@param N       An integer indicating how many prior or later elements to include.
#'@param direction A string indicating which elements to use to compute the moving average relative to each point. Valid values are "prior" and "later".
#'
#'@return A time series of moving averages
#'
#'@export

getMA <- function(tsData, N = NULL, direction = "prior")
{
	ma <- numeric(length(tsData))

	if (is.null(N)) {
		if (direction == "prior")
			# Include more points in the moving average as your proceed through time
			for (k in 1:length(tsData))
				ma[k] <- sum(tsData[1:k])/k
		else if (direction == "later")
			# Include fewer points in the moving average as your proceed through time
			# (exclude points before the current point)
			for (k in 1:length(tsData))
				ma[k] <- sum(tsData[k:length(tsData)])/(length(tsData)-k+1)

	} else {
		if (direction == "prior")
			# Compute an N point moving average, where the first N-1 elements retain their original values
			for (k in 1:length(tsData))
				if (k < N)
					ma[k] <- tsData[k]
				else
					ma[k] <- sum(tsData[(k-N+1):k])/N
		else if (direction == "later")
			for (k in 1:length(tsData))
				if (k > length(tsData)-N)
					ma[k] <- tsData[k]
				else
					ma[k] <- sum(tsData[k:(k+N-1)])/N
	}

	maTs <- ts(data = ma, start=start(tsData), end=end(tsData), frequency=frequency(tsData))
	return (maTs)
}


# ************************************************
### simon munzert
### ols and multiple regression
# ************************************************

source("packages.r")
source("functions.r")

# ************************************************
# Implementing interactive relationships ---------

data("wage1")
?wage1

# without interaction
summary(wage_model <- lm(wage ~ exper + tenure, data = wage1))

# with interaction
summary(wage_model <- lm(wage ~ exper + tenure + exper*tenure, data = wage1))

# with interaction, multiplicative variable created manually
wage1$experXtenure <- wage1$exper * wage1$tenure
View(select(wage1, wage, exper, tenure, experXtenure))
summary(wage_model <- lm(wage ~ exper + tenure + experXtenure, data = wage1))

# with interaction, constitutive variables automatically added
summary(wage_model <- lm(wage ~ exper*tenure, data = wage1))

# ************************************************
# Discrete constitutive terms --------------------

data("wage1")
?wage1

# recode continuous variable to discrete variable
table(wage1$edu)
wage1$educ_cat <- car::recode(wage1$educ, "0:9='low' ;
                                           10:14='medium' ;
                                           15:18='high'",
                                           as.factor.result = TRUE,
                                           levels = c("low", "medium", "high"))

# run model
summary(wage_model <- lm(wage ~ educ_cat*female, data = wage1))
summary(wage_model <- lm(wage ~ educ_cat, data = wage1))

# ************************************************
# Replicating Brambor et al. Fig. 2 --------------

# simulation setup
set.seed(123)
N <- 500
x <- runif(N, 0, 1) * 3

z <- runif(N, 0, 1)
z <- ifelse(z >= .5, 1, 0)
z[z >= .5] <- 1
z[z  < .5] <- 0

z <- rbinom(N, 1, .5)
b0 <- 2
b1 <- 0
b2 <- 2
b3 <- 2
e <- rnorm(N, 0, sqrt(.5))
y <- b0 + b1*x + b2*z + b3*x*z + e
dat <- as.data.frame(y = y, x = x, z = z)
# plot points
plot(x[z==0], y[z==0], pch = 1, ylim = c(0, 10), xlab = "X", ylab = "Y")
points(x[z==1], y[z==1], pch = "+")
# compute models
model_full <- lm(y ~ x*z, data = dat)
model_red  <- lm(y ~ x*z - z, data = dat)
# add lines, full model
abline(coef = c(coef(model_full)[1], coef(model_full)[2]), lwd = 3)
abline(coef = c(coef(model_full)[1] + coef(model_full)[3], coef(model_full)[2] + coef(model_full)[4]), lwd = 3)
# add lines, reduced model
abline(coef = c(coef(model_red)[1], coef(model_red)[2]), lwd = 3, col = "red")
abline(coef = c(coef(model_red)[1], coef(model_red)[2] + coef(model_red)[3]), lwd = 3, col = "red")

# ************************************************
# Plotting marginal effects ----------------------

## the interplot packacge

# continuous * continuous setup
summary(wage_model <- lm(wage ~ exper*tenure, data = wage1))

# tenure as mediator
interplot(m = wage_model, var1 = "exper", var2 = "tenure", hist  = TRUE) +
  xlab('Tenure') +
  ylab('Estimated coefficient for experience') +
  ggtitle('Estimated coefficient of experience\non wage by tenure') +
  theme(plot.title = element_text(face='bold'))

# experience as mediator
interplot(m = wage_model, var1 = "tenure", var2 = "exper", hist  = TRUE) +
  xlab('Experience') +
  ylab('Estimated coefficient for tenure') +
  ggtitle('Estimated coefficient of tenure\non wage by experience') +
  theme(plot.title = element_text(face='bold'))

# continuous * discrete setup
wage1$woman <- as.factor(wage1$female)
summary(wage_model <- lm(wage ~ exper*woman, data = wage1))

# tenure as mediator
interplot(m = wage_model, var1 = "exper", var2 = "woman") +
  xlab('Woman') +
  ylab('Estimated coefficient for experience') +
  ggtitle('Estimated coefficient of experience\non wage by gender') +
  theme(plot.title = element_text(face='bold'))

# experience as mediator
interplot(m = wage_model, var1 = "woman", var2 = "exper", hist  = TRUE) +
  xlab('Woman') +
  ylab('Estimated Coefficient for gender') +
  ggtitle('Estimated Coefficient of gender\non wage by experience') +
  theme(plot.title = element_text(face='bold'))

# for more ways to tweak the plots, see
browseURL("https://cran.r-project.org/web/packages/interplot/vignettes/interplot-vignette.html")

# ************************************************
# Diagnosing non-linearity and common support ----

library(interflex)
# Mac users facing installationg problems should check out
# browseURL("http://yiqingxu.org/software/interaction/RGuide.html")
# and perform the listed Terminal calls

# again, the model
summary(wage_model <- lm(wage ~ exper*tenure, data = wage1))

# raw plots
inter.raw(Y = "wage", D = "tenure", X = "exper", data = wage1)
inter.raw(Y = "wage", D = "exper", X = "tenure", data = wage1)
inter.raw(Y = "wage", D = "female", X = "exper", data = wage1)

# plots of Generalized Additive Model (GAM)
inter.gam(Y = "wage", D = "exper", X = "tenure", data = wage1)

# binning
inter.binning(Y = "wage", D = "female", X = "exper", Z = c("tenure"), data = wage1)
inter.binning(Y = "wage", D = "exper", X = "tenure", Z = c("female"), data = wage1, Xdistr = "density")
inter.binning(Y = "wage", D = "exper", X = "tenure", Z = c("female"), data = wage1, cutoffs = (seq(0, 40, 10)))

# kernel estimation
inter.kernel(Y = "wage", D = "exper", X = "tenure", Z="female", data = wage1, nboots = 200, parallel = TRUE, cores = 3)