=begin
[((<index|URL:index.html>))]
= AlgebraicExtensionField
((*(Algebraic Extension Field)*))

A class represents the algebraic extension field.

== File Name:
* ((|algebraic-Extension-feild.rb|))

== SuperClass:

* ((|ResidueClassRing|))

== Included Module

(none)

== Associated Methods:

--- Algebra.AlgebraicExtensionField(field, obj){|x| ... }
    Same as ((<::create>)).

== Class Method

--- ::create(k, obj){|x| ... }
    Returns the extension field ((|k[x]/(p(x))|))
    of the field ((|k|)) by
    the polynomial ((|p(x)|)) of the variable ((|x|)),
    where ((|obj|)) represents the ((|x|)).

    The class methods ((<::var>)), ((<::def_polys>)) and ((<::env_ring>))
    are defined for the return value.

    Example: Create the field ((|F|)) extended by (({x**2 + x + 1 == 0}))
    from ((|Rational|)).
      require "rational"
      require "polynomial"
      require "residue-class-ring"
      F  = Algebra.AlgebraicExtensionField(Rational, "x") {|x| x**2 + x + 1}
      x = F.var
      p( (x-1)** 3 / (x**2 - 1) ) #=> -3x - 3

--- ::to_ary
    Returns (({[self, var]})).

    Example: Define AlgebraicExtensionField and variables simulteniously
      require "rational"
      require "algebraic-extension-field"
      F, a = Algebra.AlgebraicExtensionField(Rational, "a") {|a| a**2 + a + 1}

--- ::var
    Returns the residue class of ((|x|)).
    This method is defined for the residue class ring, ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

--- ::modulus
    Returns the element ((|p(x)|)) of ((|k[x]|)) .
    This method is defined for the residue class ring, ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

--- ::def_polys
    Returns the array of ((<::modulus>))'s of size ((|n|)).
    Where ((|self|)) is defined recursively as the
    ((|AlgebraicExtensionField|))
    of height ((|n|)) and base field ((|k0|)).
    This method is defined for the residue class ring ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

    Example: Make the extension field of cubic roots of 2, 3, 5 over Rational.
      require "algebra"
      # K0 == Rational
      K1 = AlgebraicExtensionField(Rational, "x1") { |x|
        x ** 3 - 2
      }
      K2 = AlgebraicExtensionField(K1, "x2") { |y|
        y ** 3 - 3
      }
      K3 = AlgebraicExtensionField(K2, "x3") { |z|
        z ** 3 - 5
      }

      p K3.def_polys #=> [x1^3 - 2, x2^3 - 3, x3^3 - 5]

      x1, x2, x3 = K1.var, K2.var, K3.var
      f = x1**2 + 2*x2**2 + 3*x3**2
      f0 = f.abs_lift

      p f0.type     #=> (Polynomial/(Polynomial/(Polynomial/Rational)))
      p f0.type == K3.env_ring #=> true

      p f #=> 3x3^2 + 2x2^2 + x1^2
      p f0.evaluate(x3.abs_lift, x2.abs_lift, x1.abs_lift)
          #=> x3^2 + 2x2^2 + 3x3^2

--- ::env_ring
    Returns the multi-variate polynomial ring ((|k0[x1, x2,.., xn]|)).
    Where ((|self|)) is defined recursively as the
    ((|AlgebraicExtensionField|))
    of height ((|n|)) and base field ((|k0|)).
    This method is defined for the residue class ring ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

--- ::ground
    Return the polnomial ring ((|k[x]|)) which is the ground ring of
    the residue class ring.

== Methods
--- abs_lift
    Returns the lift of self in ((<::env_ring>)).
    ( = ((|k0[x1, x2,.., xn] |)) ).

--- [](n)
    Returns the coeffcient of degree ((<n>)). Same as (({lift[n]})).

    Example: Fibonacci Series
      require "algebra"
      t = AlgebraicExtensionField(Integral, "t"){|x| x**2-x-1}.var
      (0..10).each do |n|
        p( (t**n)[1] ) #=> 0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55
      end

=end


source("simulations/generators.r")
source("simulations/fit_all.r")

# Scenario 1: Constant R
beta = c(rep(0.4, 50))
sim1 = simulate_impartial(steps=50, beta, tau1=3, tau2=7, I0=5)
# verify the simulation was close to expected values
plot(sim1$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim1$I, sim1$expected_I))))
lines(sim1$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim1, "simulations/scenario1", ignore_beta_diff=NULL, lambda=c(0, 2^26, 2^27 - 2^26))

# Scenario 2: Linearly increasing R
beta = seq(0.1, 0.9, by = 0.015)
sim2 = simulate_impartial(steps=length(beta), beta, tau1=3, tau2=7, I0=1)
# verify the simulation was close to expected values
plot(sim2$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim2$I, sim2$expected_I))))
lines(sim2$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim2, "simulations/scenario2", lambda=c(0, 2^9, 2^15))

# Scenario 3: Linearly decreasing R
beta = seq(0.9, 0.1, by = -0.015)
sim3 = simulate_impartial(steps=length(beta), beta, tau1=3, tau2=7, I0=1)
# verify the simulation was close to expected values
plot(sim3$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim3$I, sim3$expected_I))))
lines(sim3$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim3, "simulations/scenario3", ignore_beta_diff=NULL, lambda=c(0, 2^8, 2^15))

# Scenario 4: Step-wise increasing beta
beta = c(rep(0.2, 25), rep(0.5, 25))
sim4 = simulate_impartial(steps=50, beta, tau1=3, tau2=7, I0=5)
# verify the simulation was close to expected values
plot(sim4$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim4$I, sim4$expected_I))))
lines(sim4$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim4, "simulations/scenario4", ignore_beta_diff=25, lambda=c(0, 2^18 + 2^17, 2^30))

# Scenario 5: Step-wise decreasing beta
beta = c(rep(0.5, 25), rep(0.2, 25))
sim5 = simulate_impartial(steps=50, beta, tau1=3, tau2=7, I0=5)
# verify the simulation was close to expected values
plot(sim5$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim5$I, sim5$expected_I))))
lines(sim5$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim5, "simulations/scenario5", ignore_beta_diff=25, lambda=c(0, 2^9, 2^20))

# Scenario 6: Large one-day pulses
beta = c(rep(0.3, 19), 1, rep(0.3, 9), 1, rep(0.3, 20))
sim6 = simulate_impartial(steps=50, beta, tau1=3, tau2=7, I0=5)
# verify the simulation was close to expected values
plot(sim6$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim6$I, sim6$expected_I))))
lines(sim6$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim6, "simulations/scenario6", ignore_beta_diff=c(19, 20, 29, 30), lambda=c(0, 2^5, 2^15))

# Scenario 7: End of the epidemic
beta = c(rep(0.4, 30), rep(0.01, length=20))
sim7 = simulate_impartial(steps=50, beta, tau1=3, tau2=7, I0=5)
# verify the simulation was close to expected values
plot(sim7$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim7$I, sim7$expected_I))))
lines(sim7$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim7, "simulations/scenario7", ignore_beta_diff=30, lambda=c(0, 2^10, 2^15))

# Scenario 8: Small number of cases
beta = c(rep(0.3, 50))
sim8 = simulate_impartial(steps=50, beta, tau1=3, tau2=7, I0=10)
# verify the simulation was close to expected values
plot(sim8$I, type="l", ylab="Count", xlab="t", ylim=c(0, max(c(sim8$I, sim8$expected_I))))
lines(sim8$expected_I, col="blue")
legend("topleft", legend=c("I", "E[I]"), col=c("black", "blue"), pch=20)
# fit models and store results
fit_all(sim8, "simulations/scenario8", lambda=c(0, 2^6 + 1, 2^10))


 ZTZRZF Example Program Results

 Tolerance used to estimate the rank of A
      1.00E-02
 Estimated rank of A
      3

 Least squares solution(s)
                    1                 2
 1  ( 1.1669,-3.3224) (-0.5023, 1.8323)
 2  ( 1.3486, 5.5027) (-1.4418,-1.6465)
 3  ( 4.1764, 2.3435) ( 0.2908, 1.4900)
 4  ( 0.6467, 0.0107) (-0.2453, 0.3951)

 Square root(s) of the residual sum(s) of squares
      2.51E-01   8.10E-02


N <- 10000

ts1 <- 1:N
ts2 <- 1:N

experiment <- function () {
	t <- 0
	repeat {
		outcome <- sample(2, 1, prob=c(1/4, 3/4))
		if (outcome == 1) {
			break
		} else {
			t <- t + 1
		}
	}
	t
}

for (i in 1:N) {
	ts1[i] <- experiment()
	ts2[i] <- ts1[i] + experiment()
}

# exercise (i)
print(summary(ts1))
barplot(table(ts1)/N)
# exercise (ii)
barplot(table(ts2)/N)


suppressPackageStartupMessages(library(float))
set.seed(1234)

testd = function(test, truth) all.equal(dbl(test$d), truth$d, tol=tol)
testu = function(test, truth) all.equal(dbl(abs(test$u)), abs(truth$u), tol=tol)
testv = function(test, truth) all.equal(dbl(abs(test$v)), abs(truth$v), tol=tol)
same = function(test, truth)
{
  stopifnot(testd(test, truth))
  stopifnot(ifelse(is.null(test$u), is.null(truth$u), testu(test, truth)))
  stopifnot(ifelse(is.null(test$v), is.null(truth$v), testv(test, truth)))
}

tester = function(s, x, ...)
{
  test = La.svd(s, ...)
  truth = La.svd(x, ...)
  same(test, truth)
}

tol = 1e-5

### m > n
m = 10
n = 3

s = flrnorm(m, n)
x = dbl(s)

tester(s, x, nu=0, nv=0)

tester(s, x, nv=0)
tester(s, x, nu=m, nv=0)
tester(s, x, nu=m-1, nv=0)
tester(s, x, nu=n, nv=0)
tester(s, x, nu=n-1, nv=0)

tester(s, x, nu=0)
tester(s, x, nu=0, nv=n)
tester(s, x, nu=0, nv=n-1)

tester(s, x, nu=m, nv=n)
tester(s, x)

### svd() driver
test = svd(s)
truth = svd(x)
same(test, truth)

### m < n
m = 3
n = 10

s = t(s)
x = t(x)

tester(s, x, nu=0, nv=0)

tester(s, x, nv=0)
tester(s, x, nu=m, nv=0)
tester(s, x, nu=m-1, nv=0)

tester(s, x, nu=0, nv=n)
tester(s, x, nu=0, nv=n-1)
tester(s, x, nu=0, nv=m)
tester(s, x, nu=0, nv=m-1)

tester(s, x, nu=m, nv=n)
tester(s, x)


par(mfrow=c(2,2))
data = read.table("telephone.txt", header=TRUE)
data = data[,1]

x=seq(0,max(data),length=1000)

t_stat = median(data)
B = 1000
tstar = numeric(B)
n = length(data)

seqconst = seq(0.01,0.1,0.001)
constindex = 1
parr = numeric(length(seqconst))

for(j in seqconst){
  for(i in 1:B){
    xstar = rexp(n,j)
    tstar[i] = median(xstar)
  }

  pl = sum(tstar<t_stat)/B
  pr=sum(tstar>t_stat)/B
  p = 2*min(pl,pr)
  parr[constindex] = p
  constindex = constindex+1
}

seqconst[parr>0.05]
plot(parr)

#p is always below 0.05 and therefore it does not stem from the exponential distribution.
#Furthermore, the histogram resembles more of a bell-shaped curve rather than an exponential one

hist(data)


# Calculates the Mandelbrot set (https://en.wikipedia.org/wiki/Mandelbrot_set)
# through the first 20 iterations of the equation z = z^2 + c plotted for
# different complex constants c.

install.packages("caTools")
library(caTools)  # for write.gif
jet.colors <- colorRampPalette(c("green", "blue", "red", "cyan", "#7FFF7F",
                                 "yellow", "#FF7F00", "red", "#7F0000"))
m <- 1000  # define size
C <- complex(real=rep(seq(-1.8,0.6, length.out=m), each=m),
             imag=rep(seq(-1.2,1.2, length.out=m), m))
C <- matrix(C,m,m)  # reshape as square matrix of complex numbers
Z <- 0
X <- array(0, c(m,m,20))  # initialize output 3D array
for (k in 1:20) {
  Z <- Z^2+C  # the central difference equation
  X[,,k] <- exp(-abs(Z))  # capture results
}
write.gif(X, "Mandelbrot.gif", col=jet.colors, delay=900)


## some calculations that LLA has to replicate, done in R
##
## this code is not run for the Lisp tests

## least squares
x <- matrix(c(23,23,22,21,25,20,29,32,24,29),5,2,byrow=TRUE)
y <- x %*% c(1,2) + c(-2,-1,0,1,2)
fit <- lm.fit(x,y)
sum(fit$residuals^2)
fit.full <- lm(y~x-1)

## cholesky
a <- matrix(c(1,2,0,3),2,2,byrow=TRUE)
b <- t(a) %*% a
chol(t(a) %*% a)

## eigenvalues -- hermitian
a <- matrix(1:4,2,2,byrow=TRUE)
aa <- t(a) %*% a
eigen(aa)

## svd
La.svd(matrix(1:6,3,2,byrow=TRUE))


#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: 2013-2017 Crude Mortality from Top 50 Causes
# The R project for Statistical Computing Script by DrewC!

#### Section A: Import Libraries and Datasets and Prepare Data

### Step 1: Import Libraries and Data

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

## Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_fl = read.csv("_data/flcharts_50_stage.csv", fileEncoding = "UTF-8-BOM") # Import dataset from _data folder
df_causes = read.csv("_data/flcharts_aadr_causes_stage.csv", fileEncoding = "UTF-8-BOM") # Import dataset from _data folder
df_cms = read.csv("_data/cedric_cms_pr_value.csv", fileEncoding = "UTF-8-BOM") # Import dataset from _data folder

## Verify Data
head(df_fl) # Mini table with top 5 observations
head(df_causes) # Mini table with top 5 observations
head(df_cms) # Mini table with top 5 observations

### Step 2: Prepare Data for Analysis

## Tidy data types and objects
df_fl = df_fl %>% mutate_if(is.factor, as.character) # Change character to numeric values
df_causes = df_causes %>% mutate_if(is.factor, as.character) # Change character to numeric values
df_cms = df_cms %>% mutate_if(is.factor, as.character) # Change character to numeric values
df_fl = na.omit(df_fl) # Omit rows with NA from Data Frame

## Verify Data
glimpse(df_fl) # Rows, columns, variable types and 10
glimpse(df_causes) # Rows, columns, variable types and 10
glimpse(df_cms) # Rows, columns, variable types and 10

## Write Output to File
text_1 = skim(df_fl)
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Cedric subproject: Developing better ways to measure equity in health",  file) # Insert title
write("Florida Charts Census Tract Mortality Data: 2013-2017 Crude Mortality from Top 50 Causes\n\n",  file) # Insert title
write("Data Summary\n",  file) # Insert title
capture.output(text_1, file = file, append = TRUE) # write summary to file
close(file) # Close file

### Step 3: Identify Top Mortality Measures by Inequality

## Create data frame of Gini by causes
df_features = subset(df_fl, select = -c(Tract, County)) # Remove Other Causes variable
df_gini = as.data.frame(apply(df_features, 2, ineq)) # Apply function to all comuns, 1 for rows and save to data frame
df_gini$rownames <- rownames(df_gini)
colnames(df_gini) <- c("Gini", "Causes") # Rename Columns to function and feature label
rownames(df_gini) <- c()

## Join with To 50 Causes by AADR for 2013-2017
df_join = inner_join(df_gini, df_causes, by = "Causes") ## Join By Columns

## Sort by top 10
df_rank1 = df_join[order(-df_join$AADR),] # Sort df by column
df_rank1 = head(df_rank1, 10)
df_rank2 = df_rank1[order(-df_rank1$Gini),] # Sort df by column

## Verify Data
head(df_rank1) # Mini table with top 5 observations
head(df_rank2) # Mini table with top 5 observations
head(df_join) # Mini table with top 5 observations

## Write Output to File
text_1 = df_rank1
text_2 = df_rank2
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("\n\nTop Causes of Mortality",  file) # Insert title
write("\nBy AADR",  file) # Insert title
capture.output(text_1, file = file, append = TRUE) # write summary to file
write("\nTop 10 Gini\n",  file) # Insert title
capture.output(text_2, file = file, append = TRUE) # write summary to file
close(file) # Close file

#### Section B: Get Outcome Specific Gini coefficient and MSPB at Hospitals by County

### Step 7: Compare Gini and For-Profit Hospitals

## Create health outcome variables
df_fl$Diabetes = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Diabetes, type = "Gini")) # Group By Columns and Average
df_county = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_county) <- c("County", "Gini") # Change Column Names
df_county = df_county[order(-df_county$Gini),] # Sort df by column

## Join with County Value Measure
df_join2 = inner_join(df_county, df_cms, by = "County", how = "left") ## Join By Columns
dim(df_join2)

## Spearman Rank
corr_diabetes = cor.test(x = df_join2$Gini, y = df_join2$MSPB, method = "spearman") # Pearson's Rank for Q->Q

## Write Output to File
text_1 = head(df_county, 10)
text_2 = corr_diabetes
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("\n\nAssociation of Diabetes Inequity and MSPB",  file) # Insert title
write("\nTop 10 Counties by Inequality",  file) # Insert title
capture.output(text_1, file = file, append = TRUE) # write summary to file
write("\nFor Profit Hospitals",  file) # Insert title
capture.output(text_2, file = file, append = TRUE) # write summary to file
write("\n\n\nTHE END",  file) # Insert title
close(file) # Close file

print("THE END")
#### End Script


fitDistToX <- function (x, dist) {
  tx <- dist$x; ty <- dist$y
  y <- numeric(length(x))
  for (i in seq(x)) {
    j <- bsearchtools::lb(tx, x[i])
    if (j <= 1) {
      y[1:i] <- ty[1]
      next
    }
    if (j > length(tx)) {
      y[i:length(x)] <- ty[length(ty)]
      break
    }
    y[i] <- (ty[j] - ty[j-1]) / (tx[j] - tx[j-1]) * (x[i] - tx[j]) + ty[j]
  }
  return(list(x=x,y=y))
}

sampleFromPopDist <- function (n, popDist, seed=1234) {
  set.seed(seed)
  return (sample(popDist$x, n, prob = (popDist$y) / sum(popDist$y), replace = TRUE))
}

KLdistance <- function(sampleDist, popDist) {
  x <- popDist$x
  modifSampleDist <- fitDistToX(x, sampleDist)
  lp <- -log(modifSampleDist$y)
  lq <- -log(popDist$y)
  dx <- diff(modifSampleDist$x)
  dx <- c(dx, dx[length(dx)])
  kl <- (modifSampleDist$y * lp / lq) * dx
  kl[is.na(kl)] <- 0
  return (sum(kl))
}

L2distance <- function (sampleDist, popDist) {
  x <- popDist$x
  modifSampleDist <- fitDistToX(x, sampleDist)
  dx <- diff(modifSampleDist$x)
  dx <- c(dx, dx[length(dx)])
  l2 <- sum((modifSampleDist$y - popDist$y)^2 * dx)
  return (l2)
}

addRandomNoise <- function (vec, noise) {
  newVec <- numeric(length(vec))
  for (i in seq(vec)) {
    newVec[i] <- vec[i] + rnorm (1,0,noise)
  }
  return (newVec)
}


# Goal: Given two vectors of data,
#       superpose their CDFs
#       and show the results of the two-sample Kolmogorov-Smirnoff test

# The function consumes two vectors x1 and x2.
# You have to provide a pair of labels as `legendstrings'.
# If you supply an xlab, it's used
# If you specify log - e.g. log="x" - this is passed on to plot.
# The remaining args that you specify are sent on into ks.test()
two.cdfs.plot <- function(x1, x2, legendstrings, xlab="", log="", ...) {
  stopifnot(length(x1)>0,
            length(x2)>0,
            length(legendstrings)==2)
  hilo <- range(c(x1,x2))

  par(mai=c(.8,.8,.2,.2))
  plot(ecdf(x1), xlim=hilo, verticals=TRUE, cex=0,
       xlab=xlab, log=log, ylab="Cum. distribution", main="")
  grid()
  plot(ecdf(x2), add=TRUE, verticals=TRUE, cex=0, lwd=3)
  legend(x="bottomright", lwd=c(1,3), lty=1, bty="n",
         legend=legendstrings)

  k <- ks.test(x1,x2, ...)
  text(x=hilo[1], y=c(.9,.85), pos=4, cex=.8,
     labels=c(
       paste("KS test statistic: ", sprintf("%.3g", k$statistic)),
       paste("Prob value: ", sprintf("%.3g", k$p.value))
       )
     )
  k
}

x1 <- rnorm(100, mean=7, sd=1)
x2 <- rnorm(100, mean=9, sd=1)

# Check error detection --
two.cdfs.plot(x1,x2)

# Typical use --
two.cdfs.plot(x1, x2, c("X1","X2"), xlab="Height (metres)", log="x")

# Send args into ks.test() --
two.cdfs.plot(x1, x2, c("X1","X2"), alternative="less")

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


install.packages("rJava",type = "source")

install.packages("RWeka")

library(RWeka)

data<-read.csv("C:/Users/Harsh Darji/Desktop/iris.csv")

head(data)

str(data)

model_rweka<-SimpleKMeans(data,control=Weka_control(N=7,I=500,S=100))

model_rweka

# Using R

mydata<-data[,c(1:4)]

model_r<-kmeans(mydata,7)

model_r

#Print centroids

model_r$centers

cluster_Assignment<-data.frame(data,model_r$cluster)

head(cluster_Assignment)
#Outlier
#Setosa is being grouped into cluster no 1 as well as 3 but it should be grouped into 1

#visualization

install.packages("cluster")

library(cluster)

clusplot(mydata,model_r$cluster,color=TRUE,shade=TRUE,labels=2,lines=0)

#RAC

d=dist(as.matrix(mydata))

hc=hclust(d)

plot(hc)


=begin
  # sample-polynomial01.rb

  require "algebra"
  P = Polynomial.create(Integer, "x")
  x = P.var
  p((x + 1)**100) #=> x^100 + 100x^99 + ... + 100x + 1
((<_|CONTENTS>))
=end


milk<-read.csv('monthly-milk-production-pounds-p.csv')
Milk<-milk$Pounds

library(astsa)
sarima(Milk, 0,1,0,0,1,1,12)

library(astsa)
library(forecast)

d=NULL
DD=NULL
d=1
DD=1

per=12
for(p in 1:1){
  for(q in 1:1){
    for(i in 1:3){
      for(j in 1:4){
        if(p+d+q+i+DD+j<=10){
          model<-arima(x=Milk, order = c((p-1),d,(q-1)), seasonal = list(order=c((i-1),DD,(j-1)), period=per))
          pval<-Box.test(model$residuals, lag=log(length(model$residuals)))
          sse<-sum(model$residuals^2)
          cat(p-1,d,q-1,i-1,DD,j-1,per, 'AIC=', model$aic, ' SSE=',sse,' p-VALUE=', pval$p.value,'\n')
        }
      }
    }
  }
}

model<- arima(x=Milk, order = c(0,1,0), seasonal = list(order=c(0,1,1), period=12))

plot(forecast(model))

forecast(model)


# R has QR decomposition built-in (using LAPACK or LINPACK)

a <- matrix(c(12, -51, 4, 6, 167, -68, -4, 24, -41), nrow=3, ncol=3, byrow=T)
d <- qr(a)
qr.Q(d)
qr.R(d)

# now fitting a polynomial
x <- 0:10
y <- 3*x^2 + 2*x + 1

# using QR decomposition directly
a <- cbind(1, x, x^2)
qr.coef(qr(a), y)

# using least squares
a <- cbind(x, x^2)
lsfit(a, y)$coefficients

# using a linear model
xx <- x*x
m <- lm(y ~ x + xx)
coef(m)


#HorseRace returns the horse, A or B or C or D, that wins a race
horserace<-function(){
  chance<-c(30,40,20,10)
  cumchance<-cumsum(chance)
  x<-sample(1:100,1)
  result<-if (x<cumchance[1]) "A" else
    if (x<cumchance[2]) "B" else
      if (x<cumchance[3]) "C" else "D"
  result
}

#HorseRaces runs n races and reports the proportion of times each horse wins
horseraces<-function(n){
  races<-replicate(n,horserace())
  a<-sum(races=="A")/n
  b<-sum(races=="B")/n
  c<-sum(races=="C")/n
  d<-sum(races=="D")/n
  c(a,b,c,d)
}


# Example : 1    Chapter  :  2.3   page no  :  57
#Matrix multiplication as dotproduct of row and column
A<-matrix(c(3,4,5,6),nrow=2,ncol=2,byrow=T)
x<-c(2,1)
B<-A%*%x
B
Ax<-c()
for(i in 1:2){
  Ax<-c(Ax,sum(A[i,]*x))
}
Ax<-matrix(Ax,ncol=1)
Ax


library(neuralnet)
library(caret)
library(grDevices)
library(leaps)
library(relaimpo)
library(corrplot)
library(car)
library(DAAG)
# Alters the way numbers are outputted
options(scipen = 999,digits = 3)
library(nnet)
library(NeuralNetTools)
library(plyr)

# Read the data
fireforest <- read.csv(file.choose())
View(fireforest)
class(fireforest)

# Number of data cases and variables
dim(fireforest)

# Check names of variables - match database infomation.
colnames(fireforest)

# Check to see if any data missing - we're OK here so can proceed.
sum(is.na(fireforest))

# Check to see how many cases have an area of 0
length(which(fireforest$area==0))

# Convert month and day string variables into numeric values
fireforest$month <- as.numeric(as.factor(fireforest$month))
fireforest$day <- as.numeric(as.factor(fireforest$day))

# Density plot - Predictors
# Shows us rain ais right skewed and FFMC is left skewed.
# We can see normal looking distributions for temp, wind, RH, X, DMC and day.
#pdf(file="predictordesnisty.pdf")
par(mfrow=c(2,6),mar=c(3.90, 4.25, 2.5, 0.5))
for (variables in 1:(dim(fireforest)[2]-1)){
  thisvar = fireforest[,variables]
  d <- density(thisvar)
  plot(d, main = names(fireforest[variables]),xlab="")
  polygon(d, col="cyan", border="blue")
  title("Density plots for all 11 Model Variables", line = -19, outer = TRUE)}

# Rain variable has a heavy 0 distribution with only 1.56% of the data
# This will therefore be removed from the model as there is not enough variance
print(paste("Percentage non-zero rain: ",round(length(which(fireforest$rain>0)) /dim(fireforest)[1]*100,2)))

# Since the FFMC is left-skew, we'll cube it to normalize it
par(mfrow=c(1,2),mar=c(5, 4.25, 5.5, 2))
d <- density(fireforest$FFMC)
plot(d,main="FFMC Density (original)",xlab="FFMC index", col='tomato', lwd=3)
fireforest$FFMC<- (fireforest$FFMC^3)
d <- density(fireforest$FFMC)
plot(d,main="FFMC Density (x^3)",xlab="FFMC index", col='tomato', lwd=3)
fireforest <- fireforest[,-which(colnames(fireforest)== "rain")]

# Density plot - Outcome
# Shows us a extensive right skew in the data
par(mfrow=c(1,2),mar=c(5, 4.25, 5.5, 2))
d <- density(fireforest$area)
plot(d,main="Area Burned Density (original)",xlab="Area Burned (Hec)", col='tomato', lwd=3)
d <- density(log(fireforest$area+1))
plot(d,main="Area Burned Density (log(x+1))",xlab="Area Burned (Hec)", col='tomato', lwd=3)

# Heavy skew indicates log transformation
# Since there are also many 0 counts for area, we'll first add 1 before transforming
fireforest$area <- log(fireforest$area+1)

# Examine correlations between all 12 predictors and the area outcome
par(mfrow=c(1,1))
M <- cor(fireforest)
corrplot(M, method="color", outline = TRUE,type="lower",order = "hclust",
         tl.col="black", tl.srt=45, diag=FALSE,tl.cex = 1,mar=c(0,0,3,0),
         title="Correlation Matrix between Predictor and Outcome variables")

assumptionsmodel <- lm(area ~ ., data=fireforest)
lmtest::bptest(assumptionsmodel)
par(mfrow=c(2,2))
plot(assumptionsmodel)

assumptionsmodel_all <- lm(area ~ ., data=fireforest)
assumptionsmodel_0 <- lm(area ~ .,data=fireforest[which(fireforest$area>0),])
# Remove all cases with an area burned of 0
fireforest <- fireforest[which(fireforest$area>0),]
# Plots both with and without 0 residuals
par(mfrow=c(1,2))
hist(assumptionsmodel_all$residuals, main = "Data with 0 area burned", xlab = 'Residuals')
abline(v=mean(assumptionsmodel_all$residuals), col='red', lwd=2)
hist(assumptionsmodel_0$residuals,main = "Data without 0 area burned", xlab = 'Residuals')
abline(v=mean(assumptionsmodel_0$residuals), col='red', lwd=2)

model1 <- lm(area ~ ., data=fireforest)
outcome1 <- summary(model1)
(round(outcome1$coefficients[ , c(2,4)],3))
# Find which variables are significant
sig.pred <- row.names(outcome1$coefficients)[which(outcome1$coefficients[ ,4] <= 0.05)]
rsquare <- round(summary(model1)$r.squared,3)
print(paste("The R2 value is ",rsquare))

# Create interactive terms for Fire index
fireforest$FFMC.DMC <- fireforest$FFMC*fireforest$DMC
fireforest$FFMC.DC <-fireforest$FFMC*fireforest$DC
fireforest$FFMC.ISI <-fireforest$FFMC*fireforest$ISI
fireforest$DMC.DC<-fireforest$DMC*fireforest$DC
fireforest$DMC.ISI<-fireforest$DMC*fireforest$ISI
fireforest$DC.ISI<-fireforest$DC*fireforest$ISI

# Create interactive terms for Weather
fireforest$wind.temp<-(fireforest$wind)*(fireforest$temp)
fireforest$temp.RH<-(fireforest$temp)*(fireforest$RH)
fireforest$wind.RH<-(fireforest$wind)*(fireforest$RH)

# Model with original and interactive terms
model2 <- lm(area~.,data=fireforest)
outcome2 <- summary(model2)
# Find which variables are significant
sig.pred <- row.names(outcome2$coefficients)[which(outcome2$coefficients[ ,4] <= 0.05)]
rsquare <- round(summary(model2)$r.squared,3)
print(paste("The R2 value is ",rsquare))
# Visualise the outliers and influence points in the model
influencePlot(model2,id.n=5)

# Remove the 2 outliers from the data
fireforest2 <- fireforest[-which(row.names(fireforest) %in% c(200,470)),]

# Run full model again with outliers removed
model3 <- lm(area~.,data=fireforest2)
outcome3 <- summary(model3)
# Find which variables are significant
sig.pred <- row.names(outcome3$coefficients)[which(outcome3$coefficients[ ,4] <= 0.05)]
rsquare <- round(summary(model3)$r.squared,3)
print(paste("The R2 value is ",rsquare))


next.perm <- function(p) {
  n <- length(p)
  i <- n - 1
  r = T
  for (i in seq(n - 1, 1)) {
    if (p[i] < p[i + 1]) {
      r = F
      break
    }
  }

  j <- i + 1
  k <- n
  while (j < k) {
    x <- p[j]
    p[j] <- p[k]
    p[k] <- x
    j <- j + 1
    k <- k - 1
  }

  if(r) return(NULL)

  j <- n
  while (p[j] > p[i]) j <- j - 1
  j <- j + 1

  x <- p[i]
  p[i] <- p[j]
  p[j] <- x
  return(p)
}

print.perms <- function(n) {
  p <- 1:n
  while (!is.null(p)) {
    cat(p, "\n")
    p <- next.perm(p)
  }
}

print.perms(3)
# 1 2 3
# 1 3 2
# 2 1 3
# 2 3 1
# 3 1 2
# 3 2 1


# #This will be a different path if in the lab or at home
# dird="E:\\OneDrive\\MATH4753\\DATAxls\\" # 2017
#
# #my function to read data
# myread=function(csv){
#   fl=paste(dird,csv,sep="")
#   read.table(fl,header=TRUE,sep=",")
# }
# #EASY WAY TO READ IN FILES

#spruce.df=myread("SPRUCE.csv")#MS pg478

spruce.df = read.csv("SPRUCE.csv")

#with(spruce.df, dput(list(D=BHDiameter,H=Height),
                     #file="spruce.dat"))
# Or use
#spruce.df=read.table(file.choose(),header=TRUE,sep=",")

#get wd
getwd()

#Top six lines
tail(spruce.df)

#Plot the points
windows()

plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

library(ggplot2)
windows()
g = ggplot(spruce.df,mapping = aes(x = BHDiameter, y = Height)) +
  geom_point()
print(g)

g = g+ geom_smooth(formula = y~ log(x), method = "lm", col = "steelblue")
g = g + geom_smooth(formula = y ~ x, method = "lm", col = "Black")
g = g + geom_smooth(formula = y~ x+ I(x^2), method ="lm", col = "Red")
print(g)

g = g + geom_smooth(formula = y~ poly(x,3), method ="lm", col = "green3")
g

#load s20x library and make lowess smoother
library(s20x)

trendscatter(Height~BHDiameter,f=0.5,data=spruce.df)
# Now make the linear model
spruce.lm=lm(Height~BHDiameter,data=spruce.df)
summary(spruce.lm)
#residuals  created from the linear model object
height.res=residuals(spruce.lm)

#fitted values made from the linear model object
height.fit=fitted(spruce.lm)

windows()
#Make the plot using the plot function
plot(height.fit,height.res)

# Put a lowess smoother through res vs fitted
trendscatter( height.fit,height.res)

# Quick way to make a residual plot
plot(spruce.lm, which =1)

# Two plots testing normality
windows()
normcheck(spruce.lm,shapiro.wilk = TRUE)

## Quadratic object using the linear model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(quad.lm)
add1(spruce.lm,.~.+I(BHDiameter^2))
anova(spruce.lm)
anova(quad.lm)
anova(spruce.lm,quad.lm)
cubic.lm=lm(Height~BHDiameter + I(BHDiameter^2)+I(BHDiameter^3),data=spruce.df)
anova(cubic.lm)
add1(quad.lm,.~.+I(BHDiameter^3))
#add to the scatter plot
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

coef(quad.lm)
names(quad.lm)
quad.lm$coef[2]

myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

 #Or more general method
myplot=function(x){
 quad.lm$coef[1] +quad.lm$coef[2]*x  + quad.lm$coef[3]*x^2
 }

curve(myplot, lwd=2, col="steelblue",add=TRUE)

plot(quad.lm, which=1)

plot(spruce.lm,which=1)
normcheck(quad.lm,shapiro.wilk = TRUE)

summary(quad.lm)

predict(quad.lm, data.frame(BHDiameter=c(3,6,8)))

ciReg(quad.lm)

predict(quad.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm,quad.lm)

data = 15:24
predict20x(quad.lm,data.frame(BHDiameter = data, `I(BhDiameter)^2`=data^2))

anova(quad.lm)
anova(spruce.lm)

height.qfit=fitted(quad.lm)

RSS=with(spruce.df, sum((Height-height.qfit)^2))
RSS
MSS = with(spruce.df, sum((height.qfit-mean(Height))^2))
MSS

TSS = with(spruce.df, sum((Height-mean(Height))^2))
TSS

MSS/TSS

cooks20x(quad.lm)

#Now remove the 24th datum and reanalyze data

quad2.lm=lm(Height~BHDiameter + I(BHDiameter^2) , data=spruce.df[-24,])
summary(quad2.lm)
summary(quad.lm)

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

#some other code you might need
#The following code plots residuals
windows()
#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#Make a quadratic model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)

# Find the coefficients
coef(quad.lm)

#Make a function that produces heights for inputs "x"
myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

# add the quadratic to the points
curve(myplot, lwd=2, col="steelblue",add=TRUE)

#Place segments (residuals) on the plot (except for the 3 largest cooks distances. 18, 21, 24)
with(spruce.df[-c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[-c(18,21,24)]) )
with(spruce.df[c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[c(18,21,24)], col="Red", lwd=3) )
with( spruce.df, arrows(5,Height[24], BHDiameter[24], Height[24],lwd=2,col="Blue"))
with(spruce.df,text(2,Height[24], paste("Highest Cook's","\n", "distance",sep=" ")))
with(spruce.df, text(BHDiameter,Height, 1:36,cex=0.5,pos=4))
 #########################################################################

layout(matrix(1:4,nr=2,nc=2,byrow=TRUE))

#Lets look at where the plots will go
layout.show(4)

#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)
# add the line
abline(spruce.lm)

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

abline(spruce.lm)

#make yhat the estimates of E[Height | BHDiameter]
yhat=with(spruce.df,predict(spruce.lm,data.frame(BHDiameter)))
yhat=fitted(spruce.lm)
# Draw in segments making the residuals (regression errors)
with(spruce.df,{
segments(BHDiameter,Height,BHDiameter,yhat)
})

RSS=with(spruce.df,sum((Height-yhat)^2))

RSS

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#make nieve model
with(spruce.df, abline(h=mean(Height)))
abline(spruce.lm)

#make the explained errors (explained by the model)
with(spruce.df, segments(BHDiameter,mean(Height),BHDiameter,yhat,col="Red"))
MSS=with(spruce.df,sum((yhat-mean(Height))^2))
MSS

# Total  error
#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

with(spruce.df,abline(h=mean(Height)))
with(spruce.df, segments(BHDiameter,Height,BHDiameter,mean(Height),col="Green"))
TSS=with(spruce.df,sum((Height-mean(Height))^2))
TSS
RSS + MSS
MSS/TSS

summary(spruce.lm)

#obtain coefft values
coef(spruce.lm)

#Calculate new y values given x
predict(spruce.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm)

spruce2.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(spruce2.lm)

### More on the problem
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
     ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
     main="Spruce height prediction",data=spruce.df)

yhatt=with(spruce.df,fitted(spruce2.lm))
with(spruce.df,plot(BHDiameter,yhatt,col="Red")
)

sum(residuals(spruce2.lm)^2)
plot(yhatt~BHDiameter,data=spruce.df,type="p")
summary(spruce2.lm)
anova(spruce2.lm)
anova(spruce.lm,spruce2.lm)
MSS
RSS

## piecewise linear model in R
## Model y = b0 + b1x + b2(x-xk)*(x>xk)
## You will need to change the code appropriately
sp2.df=within(spruce.df, X<-(BHDiameter-20)*(BHDiameter>20)) # this makes a new variable and places it within the same df
sp2.df

lmp=lm(Height~BHDiameter + X,data=sp2.df)
tmp=summary(lmp)
names(tmp)
myf = function(x,coef){
  coef[1]+coef[2]*(x) + coef[3]*(x-18)*(x-18>0)
}
plot(spruce.df,main="Piecewise regression")
myf(0, coef=tmp$coefficients[,"Estimate"])
curve(myf(x,coef=tmp$coefficients[,"Estimate"] ),add=TRUE, lwd=2,col="Blue")
abline(v=18)
text(18,16,paste("R sq.=",round(tmp$r.squared,4) ))


#get data from csv to dataframe
data=read.csv("IRIS.csv")
#get column names
print(colnames(data))
#count number of features
ncol(data)
#count number of rows
nrow(data)
#Types of features
for(i in 1:ncol(data)){
  print(colnames(data[i]))
}
#mean,max,avg,min,range,sd,variance,percentile
for(i in 1:(ncol(data)-1))
  {
    print(colnames(data[i]))
    min(data[,i])
    max(data[,i])
    sum(data[,i])/ncol(data)
    mean(data[,i])
    sd(data[,i])
    var(data[,i])
    median(data[,i])
    range(data[,i])

}

#plotting histograms
hist(data$petal_length)
boxplot(data)


General_Euler <- function(num_of_paths, num_of_steps, mu, sigma, Texp=1, X0=0, convert_y_to_x=function(y) y, convert_x_to_y=function(x) x){
    # Simulate a 1-dimensional process using Monte Carlo with the standard Euler scheme.
    # This can be used to simulate the payoff of an option and calculate the implied volatility smile.
    #
    # Args:
    #     num_of_paths (integer): The number of Monte Carlo paths
    #     num_of_steps (integer): The number of steps in each Monte Carlo path
    #     mu (function): The drift coefficient, a function of t (numeric) and X (array-like) returning a scalar
    #     sigma (function): The diffusion coefficient, a function of t (numeric) and X (array-like) returning a scalar
    #     Texp (Optional[numeric]): Time, in years, to simulate process.  Defaults to 1.
    #     X0 (Optional[numeric]): Initial value for the estimator process, X. Defaults to 0.
    #     convert_y_to_x (Optional[function]): A function to convert Y_t to X_t. Defaults to X_t <- Y_t
    #     convert_x_to_y (Optional[function]): A function to convert X_t to Y_t. Defaults to Y_t <- X_t
    # Raises:
    #     Error: If mu is not a function.
    #     Error: If sigma is not a function.
    # Returns:
    #     (list of function(s)):  Currently returns a list holding a function which runs a simulation
    if (!is.function(mu)) stop('mu must be a function')
    if (!is.function(sigma)) stop('sigma must be a function')

    dt <- Texp / num_of_steps
    Y0 <- convert_x_to_y(X0)

    run_monte_carlo <- function(g_maker, strikes, num_paths_to_plot=FALSE){
        # Runs the Monte Carlo simulation to calculate E[g(X_T)] for different strikes.
        #
        # Args:
        #     g_maker (function): A function that returns a function f(x) <- g(x,K)
        #     strikes (array-like): An array of strikes to pass in to g_maker
        #     num_paths_to_plot (Optional[integer or logical]): How many paths should be plotted. Defaults to FALSE (no plot). If TRUE, defaults to 100.
        # Returns:
        #     (array-like): A array of E[g(X_T)] for the range of strikes

        # Simulates the process X_t across time.
        # X is a 2-dimensional matrix with each row representing a path and each entry within it a single timestep.

        dW <- matrix(rnorm(num_of_paths*num_of_steps,sd=sqrt(dt)), nrow=num_of_paths, ncol=num_of_steps)

        # Generate the process Y using the Lamperti transform version of the process X

        # Initialize Y0. More efficient to just initialize all values as Y0
        Y <- matrix(Y0, nrow=num_of_paths, ncol=num_of_steps+1)

        # Step through time
        for (i in 1:num_of_steps){
            t <- (i-1)*dt
            Y[,i+1] <- Y[,i] + mu(t, Y[,i]) * dt + sigma(t, Y[,i]) * dW[,i]
        }

        # Plotting
        if (num_paths_to_plot != FALSE){ # Plots the first num_paths_to_plot paths.
            if (num_paths_to_plot == TRUE) num_paths_to_plot <- 100 # Default value
            num_paths_to_plot <- min(num_paths_to_plot, num_of_paths)
            #matplot plots columns so we transpose
            matplot(seq(0, Texp, Texp/num_of_steps), t(convert_y_to_x(Y[1:num_paths_to_plot,])), main=sprintf('Generated paths (first %i paths) - Euler scheme',num_paths_to_plot), xlab='t', ylab='X_t', type='l', lty=1)
        }

        # Final prices for each path (Undo the Lamperti transform)
        X_Ts <- convert_y_to_x(Y[,ncol(Y)])

        # Returns the mean of psi across all paths for each strike
        # return(vapply(strikes, function(K) mean(g_maker(K)(X_Ts)), FUN.VALUE=1))

        # Calculates prices for each path by row, each strike by column
        price_matrix <- vapply(strikes, function(K) g_maker(K)(X_Ts), FUN.VALUE=numeric(num_of_paths))
        print(data.frame(K=strikes, Variance=diag(var(price_matrix)))) # Diagonals of cov mtx are column variances
        return(colMeans(price_matrix))
    }

    # Return a list holding the function so we can call it object oriented style
    return(list(run_monte_carlo=run_monte_carlo))
}


#' convert quantile to normal with mean 0.5 and variance such that ci% are found within the range (0,1)

quantile_to_normal = function( x, mean =0.5, ci=0.999 ) {

  xmin = min( x[ which(x>0) ], na.rm=T )
  xmax = max( x[ which(x<1) ], na.rm=T )

  pr = {1 - ci} / 2  # one-tailed prob in normal approximation desired
  zsd = 2 * abs( qnorm( pr, mean=0, sd=1) )  # range in x required to have ci% of the population, two tailed
  rsd = 1 / zsd # sd required for population to fit in (0,1)

  zscore = qnorm( x, mean=mean, sd=rsd )

  xx = which( x>=1 | zscore > 1)
  if (length(xx) > 0 ) zscore[ xx ] = 1

  nn = which( x<=0 | zscore < 0)
  if (length(nn) > 0 ) zscore[ nn ] = 0

  return (zscore)
}


#install.packages("GA")
library(GA)

# Funkcja przykładowa z dokumentacji
# f <- function(x) (x^2+x)*cos(x) # Badana funkcja
# lbound <- -10 # Dolne ograniczenie funkcji
# rbound <- 10 # Górne ogranicznie funkcji

f <- function(x) x*sin(10*pi*x)+1
lbound <- -1
rbound <- 2

fA <- function(x) -f(x) # Funkcja odwrotna do badanej, ponieważ minimalizujemy funkcję

# Genetic algorithm
GA <- ga(
   type = "real-valued",
   fitness = fA,
   lower = c(th = lbound), upper = rbound,
   popSize = 50, maxiter = 1000, run = 100
)
summary(GA)
plot(GA)

curve(f, from = lbound, to = rbound, 1000) # rysowanie wykresy funkcji
#points(GA@solution, GA@fitnessValue, col = 2, pch = 19) # ozaczanie punktu na wykresie / tutaj szukanego ekstremum w zakresie
points(GA@solution, f(GA@solution), col = 2, pch = 19) # Musimy uzyskać wartość z funkcji wyjściowej, gdyż badamy funkcje odwrotną


library(glmnet)
library(AER)
rm(list = ls())
setwd("D:/All courses/Data Analysis for Economics(Microeconometrics)/HW4")
data<-read.csv("hw4.csv")

#split into training and test data sets
n<-nrow(data)
train_pos<-sample(n,round(n/2))
train<-data[train_pos,]
test<-data[-train_pos,]

#logistic regression
logit<-glm(gunlaw~.,train,family='binomial',control=list(maxit=100))
coeftest(logit)

#predict on test data
pre=predict(logit,test,type='response')
logitpred<-round(pre)
table(logitpred,test$gunlaw,dnn=c("predicted","Disagree"))
logiterr<-1-mean(logitpred==test$gunlaw)
logiterr

#Regularized by LASSO
# Fit on training data
x<-model.matrix(gunlaw~.,train)
y<-train$gunlaw
lassofit.all<-glmnet(x,y,alpha=1,family="binomial")
plot(lassofit.all,xvar="lambda")

# Cross Validation
cv.lasso <- cv.glmnet(x,y,alpha=1,family="binomial")
plot(cv.lasso)
lambda.star <- cv.lasso$lambda.min
lassofit.star <- glmnet(x,y,alpha=1,lambda=lambda.star,family="binomial")
coef(lassofit.star)

# Predict on test data
newx <- model.matrix(gunlaw ~.,test)
lassopred <- predict(lassofit.star,newx,type="class")
table(lassopred,test$gunlaw,dnn=c("predicted","Disagree"))
lassoerr <- 1-mean(lassopred==test$gunlaw)
lassoerr

#Regularized by Elastic Net
x<-model.matrix(gunlaw~.,train)
y<-train$gunlaw
elastic<-glmnet(x,y,alpha=0.3,family="binomial")
plot(elastic,xvar="lambda")

#Cross Validation
cv.elastic<-cv.glmnet(x,y,alpha=0.3,family="binomial")
plot(cv.elastic)
lambda.star_elastic<-cv.elastic$lambda.min
elastic.star<-glmnet(x,y,alpha=0.3,lambda=lambda.star_elastic,family="binomial")
coef(elastic.star)

#Predict on the test data
newx<-model.matrix(gunlaw~.,test)
elasticpred<-predict(elastic.star,newx,type='class')
table(elasticpred,test$gunlaw,dnn=c("Predicted","Disagree"))
elasticerr<-1-mean(elasticpred==test$gunlaw)
elasticerr


sums <- function(n, x) {
    m <- 0
    l <- 0
    while (l < x) {
        #print(l)
        m <- m+l
        l <- l+n
    }
    return (m)
}

sumsAll <- function(x, n, m) {
    nm <- x*n
    #print(nm)
    return (sums(x, m) + sums(n, m) - sums(nm, m))
}

num <- sumsAll(3, 5, 1000)
print(paste("num", num, sep=" "))


point_in_polygon <- function(polygon, p) {
  count <- 0
  for(side in polygon) {
    if ( ray_intersect_segment(p, side) ) {
      count <- count + 1
    }
  }
  if ( count %% 2 == 1 )
    "INSIDE"
  else
    "OUTSIDE"
}

ray_intersect_segment <- function(p, side) {
  eps <- 0.0001
  a <- side$A
  b <- side$B
  if ( a$y > b$y ) {
    a <- side$B
    b <- side$A
  }
  if ( (p$y == a$y) || (p$y == b$y) ) {
    p$y <- p$y + eps
  }
  if ( (p$y < a$y) || (p$y > b$y) )
    return(FALSE)
  else if ( p$x > max(a$x, b$x) )
    return(FALSE)
  else {
    if ( p$x < min(a$x, b$x) )
      return(TRUE)
    else {
      if ( a$x != b$x )
        m_red <- (b$y - a$y) / (b$x - a$x)
      else
        m_red <- Inf
      if ( a$x != p$x )
        m_blue <- (p$y - a$y) / (p$x - a$x)
      else
        m_blue <- Inf
      return( m_blue >= m_red )
    }
  }
}


StandardizeFeatures<-function(training.set,test.set=NULL,stddev=FALSE) {
	# Subtracts away mean feature vector in each column, given a dataset
	# (assumes no subject.id column); can also divide by std deviation
	#
	# Args:
	#	training.set: dataset of training variables
	#	test.set: dataset of test variables
	#	- if NULL, training set is standardized with training variables
	#	- if given, test set is standardized with training variables
	#	sd: switch for whether standard deviations are divided
	#
	# Returns:
	#	  a dataset standardized columns

  	# Calculate mean and sd vector
	mean<-apply(training.set,2,mean,na.rm=TRUE)
	sd<-apply(training.set,2,sd,na.rm=TRUE)

 	if (is.null(test.set)) {
  		training.set<-sweep(training.set,2,mean,"-")
  		if (!stddev) {
  			return(training.set)
  		}
  		else {
  			return(sweep(training.set,2,sd,"/"))
  		}
	}
	else {
		test.set<-sweep(test.set,2,mean,"-")
		if (!stddev) {
			return(test.set)
		}
		else {
			 return(sweep(test.set,2,sd,"/"))
		}
	}
}

#mean slope: -5.325687e-01
#sd slope: 1.076365e+00


rm (list=ls())

Fx <- function(x) log(x+2)+sin(x)
#Se tiene f= ln(x+2) + sin x, ya que es la interseccion de las dos funciones solicitados
F1x <- function(x) 1/(x+2) + cos(x)
#Metodo de la Secante
#Halla la raiz de Fx

error <- 1E-7

secante <- function(x0,x1) {
    x<-(Fx(x1)*x0-Fx(x0)*x1)/(Fx(x1)-Fx(x0))
    error <- 1E7
    while (error > 1.e-7) {
        x0<-x1
        x1<-x
        x<-(Fx(x1)*x0-Fx(x0)*x1)/(Fx(x1)-Fx(x0))
        if (Fx(x) == 0) break
        error<-abs(Fx(x)/F1x(x))
        cat("X=",x,"\t","E=",error,"\n")
    }
}
secante(0,3)


###############
## Section 4 ##
###############

#install.packages("ordinal")
library(ordinal)
library(MASS)

setwd("C:\\dc_book\\Replication_Files_Element")

financedata <- read.csv("ANES_2016.csv", header=T)

###############
## Table 4.1 ##
###############

finance.ologit <- clm(as.ordered(prospective_persfin) ~ pred_favored_win+health+mortgage+gender+age, data = financedata, link="logit")
finance.ologit.results <- cbind(finance.ologit$coefficients, sqrt(diag(vcov(finance.ologit))), confint.default(finance.ologit, level=0.95))
N <- length(finance.ologit$fitted.values)
colnames(finance.ologit.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(finance.ologit.results, digits=3)))
print(N)

## Note: Warning about formula can be ignored -- clm mistakenly throws an error for long formulas

###############
## Table 4.2 ##
###############

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- apply(finance.ologit$model[,-1], 2, median)

hypo.case.A <- baseline.x

hypo.case.B <- baseline.x
hypo.case.B["pred_favored_win"] <- 0

# multiply by -1 because the formula is tau - XB
hypo.matrix.A <- matrix(hypo.case.A, 4, 5, byrow=TRUE) * -1
hypo.matrix.tau.A <- cbind(diag(4), hypo.matrix.A)

hypo.matrix.B <- matrix(hypo.case.B, 4, 5, byrow=TRUE) * -1
hypo.matrix.tau.B <- cbind(diag(4), hypo.matrix.B)

simprob.A <- plogis(betadraw%*%t(hypo.matrix.tau.A))
simprob.A.1 <- simprob.A[,1]
simprob.A.2 <- simprob.A[,2] - simprob.A[,1]
simprob.A.3 <- simprob.A[,3] - simprob.A[,2]
simprob.A.4 <- simprob.A[,4] - simprob.A[,3]
simprob.A.5 <- 1 - simprob.A[,4]

simprob.B <- plogis(betadraw%*%t(hypo.matrix.tau.B))
simprob.B.1 <- simprob.B[,1]
simprob.B.2 <- simprob.B[,2] - simprob.B[,1]
simprob.B.3 <- simprob.B[,3] - simprob.B[,2]
simprob.B.4 <- simprob.B[,4] - simprob.B[,3]
simprob.B.5 <- 1 - simprob.B[,4]

simprob.diff.1 <- simprob.B.1 - simprob.A.1
simprob.diff.2 <- simprob.B.2 - simprob.A.2
simprob.diff.3 <- simprob.B.3 - simprob.A.3
simprob.diff.4 <- simprob.B.4 - simprob.A.4
simprob.diff.5 <- simprob.B.5 - simprob.A.5

all.results <- cbind(
simprob.A.1, simprob.B.1, simprob.diff.1,
simprob.A.2, simprob.B.2, simprob.diff.2,
simprob.A.3, simprob.B.3, simprob.diff.3,
simprob.A.4, simprob.B.4, simprob.diff.4,
simprob.A.5, simprob.B.5, simprob.diff.5)

quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
first.differences <- cbind(t(quantiles), sds)
colnames(first.differences) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(first.differences) <- c("Much Worse:Yes", "Much Worse:No", "Much Worse:Diff", "Somewhat Worse:Yes", "Somewhat Worse:No", "Somewhat Worse:Diff", "The Same:Yes", "The Same:No", "The Same:Diff", "Somewhat Better:Yes", "Somewhat Better:No", "Somewhat Better:Diff", "Much Better:Yes", "Much Better:No", "Much Better:Diff")
print(round(first.differences, digits=3))

################
## Figure 4.1 ##
################

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- apply(finance.ologit$model[,-1], 2, median)
baseline.matrix <- matrix(baseline.x, 4, 5, byrow=TRUE) * -1  # multiply by -1 because the formula is t - XB
baseline.matrix.tau <- cbind(diag(4), baseline.matrix)
colnames(baseline.matrix.tau) <- names(finance.ologit$coefficients)

colors <- c("#004D7380", "#1C82A380", "#17A1CC80", "#0ABA9E80", "#00DBA680")

age.range <- c(10:100)

ologit.probs1 <- matrix(NA, ndraws, length(age.range))
ologit.probs2 <- matrix(NA, ndraws, length(age.range))
ologit.probs3 <- matrix(NA, ndraws, length(age.range))
ologit.probs4 <- matrix(NA, ndraws, length(age.range))
ologit.probs5 <- matrix(NA, ndraws, length(age.range))

ologit.mean.probs <- matrix(NA, 5, length(age.range))

for (i in 1:length(age.range)) {

	baseline.matrix.tau[,"age"] <- (age.range[i] * -1)
	oprobs <- plogis(betadraw%*%t(baseline.matrix.tau))
	ologit.probs1[,i] <- oprobs[,1]
	ologit.probs2[,i] <- oprobs[,2] - oprobs[,1]
	ologit.probs3[,i] <- oprobs[,3] - oprobs[,2]
	ologit.probs4[,i] <- oprobs[,4] - oprobs[,3]
	ologit.probs5[,i] <- 1 - oprobs[,4]

	oprobs.mean <- plogis(beta%*%t(baseline.matrix.tau))
	ologit.mean.probs[1,i] <- oprobs.mean[1]
	ologit.mean.probs[2,i] <- oprobs.mean[2] - oprobs.mean[1]
	ologit.mean.probs[3,i] <- oprobs.mean[3] - oprobs.mean[2]
	ologit.mean.probs[4,i] <- oprobs.mean[4] - oprobs.mean[3]
	ologit.mean.probs[5,i] <- 1 - oprobs.mean[4]
}

pdf("fig41.pdf")
par(mar=c(5.1, 4.1, 4.1, 5.6), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(ologit.mean.probs[1,]~age.range, xlim=c(18,90), ylim=c(0,0.6), type="n", xlab="Age", ylab="Probability", xaxt="n", las=1, lwd=2)
axis(1, at=c(18, 30, 40, 50, 60, 70, 80, 90))
for (i in 1:length(age.range)){
	points(ologit.probs1[i,] ~ age.range, type="l", col=colors[1], lwd=1)
	points(ologit.probs2[i,] ~ age.range, type="l", col=colors[2], lwd=1)
	points(ologit.probs3[i,] ~ age.range, type="l", col=colors[3], lwd=1)
	points(ologit.probs4[i,] ~ age.range, type="l", col=colors[4], lwd=1)
	points(ologit.probs5[i,] ~ age.range, type="l", col=colors[5], lwd=1)
}
lines(ologit.mean.probs[1,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[2,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[3,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[4,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[5,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
mtext("Much Worse", side=4, at=ologit.mean.probs[1,82], cex=1.1, las=1, line=0.5)
mtext("Somewhat", side=4, at=ologit.mean.probs[2,82]-0.01, cex=1.1, las=1, line=0.5)
mtext("Worse", side=4, at=ologit.mean.probs[2,82]-0.03, cex=1.1, las=1, line=0.5)
mtext("The Same", side=4, at=ologit.mean.probs[3,82], cex=1.1, las=1, line=0.5)
mtext("Somewhat", side=4, at=ologit.mean.probs[4,82]+0.03, cex=1.1, las=1, line=0.5)
mtext("Better", side=4, at=ologit.mean.probs[4,82]+0.01, cex=1.1, las=1, line=0.5)
mtext("Much Better", side=4, at=ologit.mean.probs[5,82], cex=1.1, las=1, line=0.5)
dev.off()

###############
## Table 4.3 ##
###############

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

# AME

ologit.X <- cbind(0,0,0,0, finance.ologit$model[,-1]) * -1  # multiply by -1 because the formula is t - XB
w <- financedata$sample_weight

for (i in 1:4) {

	ologit.X.temp <- ologit.X
	ologit.X.temp[,i] <- 1
	ologit.p.temp <- plogis(betadraw %*% t(ologit.X.temp))
	assign(paste("ologit.p", i, sep="."), ologit.p.temp)
	assign(paste("ologit.d", i, sep="."), ologit.p.temp * (1 - ologit.p.temp))
}

# multiply each row by draws of health coefficients
ame.1 <- diag(betadraw[,"health"]) %*% (0 - ologit.d.1)
ame.2 <- diag(betadraw[,"health"]) %*% (ologit.d.1 - ologit.d.2)
ame.3 <- diag(betadraw[,"health"]) %*% (ologit.d.2 - ologit.d.3)
ame.4 <- diag(betadraw[,"health"]) %*% (ologit.d.3 - ologit.d.4)
ame.5 <- diag(betadraw[,"health"]) %*% (ologit.d.4)

ologit.ame.1 <- apply(ame.1, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.2 <- apply(ame.2, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.3 <- apply(ame.3, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.4 <- apply(ame.4, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.5 <- apply(ame.5, 1, function(x){sum(x * w)/sum(w)})

ologit.ame <- cbind(ologit.ame.1, ologit.ame.2, ologit.ame.3, ologit.ame.4, ologit.ame.5)

ae.1 <- ame.1 * ((1/ologit.p.1) %*% diag(finance.ologit$model[,"health"]))
ae.2 <- ame.2 * ((1/(ologit.p.2 - ologit.p.1)) %*% diag(finance.ologit$model[,"health"]))
ae.3 <- ame.3 * ((1/(ologit.p.3 - ologit.p.2)) %*% diag(finance.ologit$model[,"health"]))
ae.4 <- ame.4 * ((1/(ologit.p.4 - ologit.p.3)) %*% diag(finance.ologit$model[,"health"]))
ae.5 <- ame.5 * ((1/(1 - ologit.p.4)) %*% diag(finance.ologit$model[,"health"]))

ologit.ae.1 <- apply(ae.1, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.2 <- apply(ae.2, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.3 <- apply(ae.3, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.4 <- apply(ae.4, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.5 <- apply(ae.5, 1, function(x){sum(x * w)/sum(w)})

ologit.ae <- cbind(ologit.ae.1, ologit.ae.2, ologit.ae.3, ologit.ae.4, ologit.ae.5)

quantiles.ame <- apply(ologit.ame, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.ame <- apply(ologit.ame, 2, sd)
summary.marginal.ame <- cbind(t(quantiles.ame), sd.ame)

quantiles.ae <- apply(ologit.ae, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.ae <- apply(ologit.ae, 2, sd)
summary.elasticity.ame <- cbind(t(quantiles.ae), sd.ae)

# MEM

mean.x <- apply(finance.ologit$model[,-1], 2, mean)
mean.x.matrix <- matrix(mean.x, 4, 5, byrow=TRUE) * -1
mean.x.all <- cbind(diag(4), mean.x.matrix)

mem.probs <- plogis(betadraw%*%t(mean.x.all))

mem.1 <- -1 * (mem.probs[,1] * (1 - mem.probs[,1])) * betadraw[,"health"]
mem.2 <- ((mem.probs[,1] * (1 - mem.probs[,1])) - (mem.probs[,2] * (1 - mem.probs[,2]))) * betadraw[,"health"]
mem.3 <- ((mem.probs[,2] * (1 - mem.probs[,2])) - (mem.probs[,3] * (1 - mem.probs[,3]))) * betadraw[,"health"]
mem.4 <- ((mem.probs[,3] * (1 - mem.probs[,3])) - (mem.probs[,4] * (1 - mem.probs[,4]))) * betadraw[,"health"]
mem.5 <- (mem.probs[,4] * (1 - mem.probs[,4]))  * betadraw[,"health"]

ologit.mem <- cbind(mem.1, mem.2, mem.3, mem.4, mem.5)

me.1 <- mem.1 * (mean.x["health"]/(mem.probs[,1]))
me.2 <- mem.2 * (mean.x["health"]/(mem.probs[,2] - mem.probs[,1]))
me.3 <- mem.3 * (mean.x["health"]/(mem.probs[,3] - mem.probs[,2]))
me.4 <- mem.4 * (mean.x["health"]/(mem.probs[,4] - mem.probs[,3]))
me.5 <- mem.5 * (mean.x["health"]/(1 - mem.probs[,4]))

ologit.me <- cbind(me.1, me.2, me.3, me.4, me.5)

quantiles.mem <- apply(ologit.mem, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.mem <- apply(ologit.mem, 2, sd)
summary.marginal.mem <- cbind(t(quantiles.mem), sd.mem)

quantiles.me <- apply(ologit.me, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.me <- apply(ologit.me, 2, sd)
summary.elasticity.mem <- cbind(t(quantiles.me), sd.me)

marginal.effects.elasticities <- rbind(summary.marginal.ame, summary.marginal.mem, summary.elasticity.ame, summary.elasticity.mem)
colnames(marginal.effects.elasticities) <- c("Median", "2.5%", "97.5%", "(se)")
category.names <- c("MW", "SW", "S", "SB", "MB")
rownames(marginal.effects.elasticities) <- c(paste("Marginal Effect (AME)", category.names, sep="."), paste("Marginal Effect (MEM)", category.names, sep="."), paste("Elasticity (AME)", category.names, sep="."), paste("Elasticity (MEM)", category.names, sep="."))
print(round(marginal.effects.elasticities, digits=3))

## coefficient ratios

mortgage.age.ratio <- betadraw[,"mortgage"]/betadraw[,"age"]
ratio.results <- quantile(mortgage.age.ratio, probs=c(0.5, 0.025, 0.975))
print(ratio.results)

###############
## Table 4.4 ##
###############

N <- length(finance.ologit$fitted.values)

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
ndraws <- 1000

betadraw <- mvrnorm(ndraws, beta, covmat.beta)
exp.betadraw <- exp(betadraw)
quantiles <- apply(exp.betadraw, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(exp.betadraw, 2, sd)
odds.ratios <- cbind(t(quantiles), sds)
colnames(odds.ratios) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(odds.ratios) <- names(beta)
print(round(odds.ratios, digits=3))
print(N)


 DGEEVX Example Program Results

 Eigenvalues

          Eigenvalue           rcond    error
  1   7.9948E-01               0.9936    -
  2 (-9.9412E-02, 4.0079E-01)  0.7027    -
  3 (-9.9412E-02,-4.0079E-01)  0.7027    -
  4  -1.0066E-01               0.5710    -

 Eigenvectors

          Eigenvector          rcond    error

  1   6.5509E-01               0.8181    -
      5.2363E-01
     -5.3622E-01
      9.5607E-02

  2 (-1.9330E-01, 2.5463E-01)  0.3996    -
    ( 2.5186E-01,-5.2240E-01)
    ( 9.7182E-02,-3.0838E-01)
    ( 6.7595E-01, 0.0000E+00)

  3 (-1.9330E-01,-2.5463E-01)  0.3996    -
    ( 2.5186E-01, 5.2240E-01)
    ( 9.7182E-02, 3.0838E-01)
    ( 6.7595E-01,-0.0000E+00)

  4   1.2533E-01               0.3125    -
      3.3202E-01
      5.9384E-01
      7.2209E-01

 Errors below 10*machine precision are not displayed


# libraries used
 > library("GGally")
 > library("ggplot2")
 > library("scales")
 > library("caret")
 > library("rpart")
 > library("rpart.plot")
 > library("car")
 > library("Metrics")

# Let’s load the data into R –
> kc_house_data <- read.csv(file=”kc_house_data.csv”, header = TRUE)

# Checking for NA values in dataset
> table(is.na(kc_house_data))

# Loading the required libraries –
> library(ggplot2)

# Let's take bedrooms,bathrooms and condition as factors
> kc_house_data$bedrooms <- as.factor(kc_house_data$bedrooms)
> kc_house_data$bathrooms <- as.factor(kc_house_data$bathrooms)
> kc_house_data$sqft_living <- as.factor(kc_house_data$condition)

# Let's look at some data and it's distribution
> p1 <- qplot(bedrooms, data = kc_house_data, geom = "bar", main = "The number of houses by bedrooms")
> p2 <- qplot(bathrooms,data = kc_house_data, geom = "bar" , main = "The number of houses by bathrooms")
> plot(kc_house_data$price, ylab = "Density", xlab = "Price")
>p3 <- ggplot(kc_house_data, aes(price)) + geom_density() +
    scale_y_continuous(labels = comma) +
    scale_x_continuous(labels = comma, limits = c(0, 2e+06)) +
    xlab("price") +
    ggtitle("Price distribution"

# We will now try to compare the price with other features like bedrooms, bathrooms and sqft_living
> scatterplot(x =kc_house_data$price, y=kc_house_data$bedrooms)    #not dependent
> scatterplot(x =kc_house_data$price, y=kc_house_data$bathrooms)   # Seems to be depedent
> scatterplot(x =kc_house_data$price, y=kc_house_data$sqft_living) # Very much dependent

# Correlation between the features of the houses
> ggcorr(kc_house_data, hjust = 0.8, layout.exp =1) + ggtitle("Correlation b/w features")

# Splitting the data to avoid over fits
 > kc_house_data <- kc_house_data[-c(1,2)] # remove the ID and date column
 > train_data <- createDataPartition(kc_house_data$price, p = .7, list = FALSE)
 > test <- kc_house_data[train_data,]
 > train <- kc_house_data[-train_data,]

 > tree <- rpart(price ~ ., data=df)
 > tree_predict <- predict(tree_fit, test)
 > rpart.plot(tree_fit, digits = 4, fallen.leaves = TRUE, type = 3, extra = 101)

 #Extract true value from the dataset
 > tree_true <- test[,1]

 # Results
 > summary(tree_predict)
 # Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
 #315438  315438  462801  540099  654887 5081430

 > summary(tree_true)
 # Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
 # 75000  321500  450000  540100  645000 7700000

 > cor(tree_predict,tree_true ) # 0.8262802

 > rmse(tree_predict, tree_true) # 205319.8

 # Plotting the actual and the predicted distribution
 > result <- data.frame(price=c(tree_predict, tree_true),type=c(replicate(length(tree_predict),"Predicted"),replicate(length(tree_true),"Actual")))

 > ggplot(res, aes(x=price, colour=type)) + scale_x_continuous(labels = comma, limits = c(0, 2e+06)) + scale_y_continuous(labels = comma) +
    geom_density()


scores = read.csv("nm_ajc_results.csv", header=T, sep=",")

# For each state, grade, cohort and year, we created a linear regression model, weighted by the
# number of students in a class
scoresToFit = subset(scores, grade==5 & test_year==2011 & subject == 'read')
fit = lm(scoresToFit$ss2 ~ scoresToFit$ss1, weights= (scoresToFit$n1 + scoresToFit$n2))

# studentized residuals with t-test
# rstandard returns regular studentized residuals
resid_z = rstandard(fit)
# tbd: may be more standard to use rstudent here
resid_t = studres(fit)
# calculate P( |t| >= resid_t, df = n1 - 1 ), a two-tail test
p.value = 2 *  pt(abs(resid_t),df=scoresToFit$n1-1)
tprob = 2 * (1 - pt(abs(resid_t),df=scoresToFit$n1-1))
# tprob represents the chance probability of each year-two score
# R library functions:

# rstandard - standardized residuals: uses population standard
# deviation (result not used here)

# studres - In regression analysis, the standard errors of the
# estimators at different data points vary (compare the middle versus
# endpoints of a simple linear regression), and thus one must divide
# the different residuals by different estimates for the error,
# yielding what are called studentized residuals. (does not use
# population standard deviation)


library(splines)

x_in = c(11, 15, 19, 23, 25)
y_in = c(0.1, 0.12, 0.2, 0.22, 0.2)
x_out = 1:30

ispl <- interpSpline( as.numeric(x_in), y_in)
resultado <- predict(ispl, x_out)

#> source('~/.active-rstudio-document')
#> ispl
#polynomial representation of spline for y_in ~ as.numeric(x_in)
#constant  linear quadratic      cubic
#11     0.10  0.0115   0.00000  0.0000625
#15     0.15  0.0145   0.00075 -0.0003125
#19     0.20  0.0055  -0.00300  0.0002500
#23     0.19 -0.0065   0.00000  0.0000000
#> x_out
#[1]  5 10 11 12 14 15 16 17 18 19 20 22 23 25 30
#> resultado
#$x
#[1]  5 10 11 12 14 15 16 17 18 19 20 22 23 25 30

#$y
#[1] 0.0310000 0.0885000 0.1000000 0.1115625 0.1361875 0.1500000 0.1649375 0.1795000 0.1918125 0.2000000 0.2027500 0.1962500
#[13] 0.1900000 0.1770000 0.1445000

#attr(,"class")
#[1] "xyVector"


############################################################
# R code to analyze the frisbee throws dataset
# Kenyon College STAT 206 Data Analysis
# authors: J Katz, S Kim
############################################################

############################################################
## do preliminary work
## load packages
library(mosaic)
library(pwr)
library(agricolae)
library(multcomp)
library(car)
## you can use the citation() command by itself to cite R itself
## or citation("pkgname") to find the citation for a package

############################################################
## load data
## attach a drive with letter T to your computer
## instructions and credentials are in the project log
discthrows <- read.csv("T:/Documents/STATS/datasets/discthrows.csv")
View(discthrows)
############################################################

############################################################
## do some EDA
head(discthrows)
discmod <- lm(TOTALDIST ~ DISC, data = discthrows)
plot(discmod, c(1:2,4))
throwmod <- lm(TOTALDIST ~ TYPE, data = discthrows)
plot(throwmod, c(1:2,4))
boxplot(TOTALDIST ~ DISC,
        main = "Boxplot of Distance by Disc Type",
        xlab = "Disc Type",
        ylab = "Distance",
        data = discthrows)
boxplot(TOTALDIST ~ TYPE,
        main = "Boxplot of Distance by Throw Type",
        xlab = "Throw Type",
        ylab = "Distance",
        data = discthrows)
favstats(TOTALDIST ~ DISC,
        data = discthrows)[c("DISC","mean","sd","n")]
favstats(TOTALDIST ~ TYPE,
        data = discthrows)[c("TYPE","mean","sd","n")]
## see if the throw distance was affected by serial number
plot(TOTALDIST ~ ThrowSN,
     main = "Distance by Throw Number",
     xlab = "Throw Serial Number",
     ylab = "Total Distance (meters)",
     data = discthrows)

############################################################
## Construct an interaction plot for between-term interaction effects
interaction.plot(discthrows$DISC,
                 discthrows$TYPE,
                 discthrows$TOTALDIST,
                 xlab = "Disc Type",
                 ylab = "Mean of Total Distance",
                 main = "Interaction Plot for Distance by Disc Number",
                 col=c(1:2))
interaction.plot(discthrows$TYPE,
                 discthrows$DISC,
                 discthrows$TOTALDIST,
                 xlab = "Throw Type",
                 ylab = "Mean of Total Distance",
                 main = "Interaction Plot for Distance by Throw Type",
                 col=c(1:3))

############################################################
## Construct a Diagnostic Plot for Unequal Variability
# calculate natural log of group means and sds
log.grp.means = log(mean(TOTALDIST ~ TYPE:DISC, data = discthrows))
log.grp.sd = log(sd(TOTALDIST ~ TYPE:DISC, data = discthrows))

# plot these values
xyplot(log.grp.sd~log.grp.means,
       main = "Diagnostic Plot for Unequal Variability",
       sub = "discthrows",
       type=c("p","r"))
(trnsline = lm(log.grp.sd~log.grp.means))

############################################################
## Construct an overall F-test for the model
fullmod <- aov(TOTALDIST~DISC*TYPE, data = discthrows)
nullmod <- aov(TOTALDIST~1, data = discthrows)
anova(fullmod, nullmod)

## Check the assumptions for a two-way ANOVA with interaction
plot(fullmod, 1:2)
leveneTest(discthrows$TOTALDIST, discthrows$DISC:discthrows$TYPE)
        ## a big P-val means we have homoscedasticity :)

mean(resid(fullmod)) # checking zero mean residuals, it's effectively zero

############################################################
## Construct an F-test for two-way interactions
distancemod <- aov(TOTALDIST ~ DISC*TYPE, data = discthrows)
summary(distancemod)
## the interaction is NOT significant at 0.05 = alpha

############################################################
## Conduct an F-test for each main effect, since interaction is not significant
        ## DISC and TYPE are both significant!
        ## need the agricolae library
mean(TOTALDIST ~ DISC, data = discthrows)
mean(TOTALDIST ~ TYPE, data = discthrows)
plot(LSD.test(distancemod, "DISC", group = TRUE, p.adj = "none"))
plot(LSD.test(distancemod, "TYPE", group = TRUE, p.adj = "none"))

############################################################
############################################################
## MAKING THE MODEL
realmod <- aov(TOTALDIST ~ DISC + TYPE, data = discthrows)
summary(realmod)
reallm <- lm(TOTALDIST ~ DISC + TYPE, data = discthrows)
summary(reallm)

## backwards elimination model building
full=lm(TOTALDIST ~ DISC + TYPE ,data = discthrows)
MSE=(summary(full)$sigma)^2
step(full, scale=MSE, direction="backward")
## forwards elimination
none=lm(TOTALDIST~1,data=discthrows)
step(none,scope=list(upper=full),scale=MSE,direction="forward")
## stepwise
none=lm(TOTALDIST~1,data=discthrows)
step(none,scope=list(upper=full),scale=MSE)


#rows in the theatre and the scores given to the each movie corresponding to the rows
first_row <- c(6,8,7,9, 9, 10)
second_row <- c(6,8,7,5,9, 6)
third_row <- c(5,4,6,6,7, 8)
fourth_row <- c(4,5,3,4,6,8)

#Create a theatre matrix
scores <- rbind(first_row, second_row, third_row, fourth_row)
print(scores)

#Calculate the row wise scores
total_sum <- rowSums(scores)
print(total_sum)

#Merging the total sum to the existing theatre matrix
scores <- cbind(scores, total_sum)
print(scores)

#Adding Column and Row names
rownames(scores) <- c("row1","row2","row3","row4")
colnames(scores) <- c("c1","c2","c3","c4","c5","c6","total")

#Final Theatre Matrix
print(scores)


#' @title gini
#' @description gini index of patchniness from a stratified survey (Myers and Cadigan 1995)
#' @param \code{x} : within strata mean per tow
#' @param \code{y} : strata areas in trawlable units
#' @param \code{plot} : makes the Lorenz plot if set to \code{true}
#' @return estimate of gini index as well as plot if plot=T
#' @examples
#' y=c(2454,	656,	2374,	230,	1221,	619,	172,	2980,	360,	3245,	1016,	2569,	424,	390,	454)
#' x=c(0,	0,	0,	0,	0,	0.25,	1.81,	2.52,	2.6,	3.68,	7.58,	10.07,	13.33,	13.33,	24.99)
#' gini(x,y,plot=T)
#' #0.453 same as example in http://www.nefsc.noaa.gov/publications/crd/pdfs/crd9605f.pdf
#' @author  Adam Cook, \email{Adam.Cook@@dfo-mpo.gc.ca}
#' @export

gini <- function(x,y,plot=F){
			Xi <- data.frame(yh=x,Ah=y)
		    Xi$P = Xi$yh * Xi$Ah
		    Xi = Xi[order(Xi$P),]
		    Xi$cP = cumsum(Xi$P) / sum(Xi$P)
		    Xi$cA = cumsum(Xi$Ah) / sum(Xi$Ah)
		      if(plot) {
		    	with(Xi,plot(cA,cP,type='l'))
		    	abline(a=0,b=1,col='blue')
		    	}
		  gI=NA

		  if(nrow(Xi)>1)  gI = 1-(2*sum(rowMeans(embed(Xi$cP,2)) * diff(Xi$cA)))
		  if(is.finite(gI)){
		  		if(gI<0){
		  			gI = NA
		  		}
		  	}
		    return(gI)
			}


#'@title Return the change points of the trend for the given time series
#'
#'@description Change points are transition points that optionally exceed a certain magnitude and/or
#'             continue in a certain direction for a specified length of time.
#'
#'
#'@details Transition points are defined as indices at which the time series changes direction.
#'         We can think of the trend of a univariate time series as analogous to a smooth function
#'         \eqn{f(t)} defined over a given interval of real numbers, \eqn{[a,b]}.  We know that
#'         for \eqn{t in [a,b]}, \eqn{f} is increasing on \eqn{[a,b]} if \eqn{f'(t) > 0},
#'         \eqn{f} is decreasing on \eqn{[a,b]} if \eqn{f'(t) < 0} and
#'         \eqn{f} is constant on \eqn{[a,b]} if \eqn{f'(t) = 0}.
#'         Similarly, we can examine the sign of the difference of a time series at two subsequent
#'         points in time, to determine if the time series is increasing, decreasing, or constant from one
#'         point in time to the next.
#'         Additionally, if we think of the time series as moving through space, a geometric interpretation
#'         would allow us to treat the time series as a vector with a direction (increasing, decreasing, or constant)
#'         and magnitude (the percent change of the time series from one period of time to the next).  This perspective
#'         allows one to adapt what is considered a change point.  Thus, a change point can merely be a transition point,
#'         or it can be a transition point whose percent change from the previous value exceeds some threshold,
#'         or it can be a transition point that causes the time series to continue in the new direction for a
#'         specified period of time.
#'
#'
#'@usage  tsData.cp <- getTrendChangePoints(tsData, minPctChange, nPeriods)
#'
#'@param tsData A time series object.
#'@param minPctChange The optional lower bound a magnitude must exceed
#'@param nPeriods An optional number of periods the transition must continue into the future
#'
#'@return A vector of integers corresponding to indices of change points in the given time series trend
#'
#'@export

getTrendChangePoints <- function(tsData, minPctChange = NULL, nPeriods = NULL)
{
	# Search neighborhood for points that:
	# i) Transition
	# ii) Optionally greater than some threshold minPctChange
	# iii) Optionally continue in the new direction for nPeriods

	nHood <- getNeighborhoodDf(getTrend(tsData))

	# If neither magnitude of change nor the length of the new direction
    # are specified, the change points are merely the transition points

	nHood.cp <- which(nHood$IS_TP)

	# If a magnitude is specified, transition points must exceed a minimum percent change
	# to be considered a change point

	if (!is.null(minPctChange))
		nHood.cp <- which(nHood$IS_TP & nHood$PCT_CHANGE > minPctChange)

	# If nPeriods is given, each transition point must continue in the new
	# direction for nPeriods

	if (!is.null(nPeriods)) {
		cp <- integer()
		for (k in nHood.cp)
			if (length(unique(nHood$DIFF_SIGN[k:(k+nPeriods)])) == 1)
				cp[length(cp)+1] <- k
		nHood.cp <- cp
	}

	return (nHood.cp)
}


# randtest.r  -  very simple code used to generate the 500 randomization
#  samples from the lab 1 exercise.

n <- dim(lab1)[1]
na <- table(lab1$group)[1]

lab1bigd <- lab1bigr <- rep(0,500)

for (i in 1:500) {
  s <- sample(1:n,na);
  ma <- mean(lab1$Y[s]);
  mb <- mean(lab1$Y[-s]);
  lab1bigd[i] <- mb - ma;
  lab1bigr[i] <- mb/ma;
  }

lab1bigd <- sort(lab1bigd)
lab1bigr <- sort(lab1bigr)

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


# Large-Sample Approximation
n=25
B=13
# test statstic
Bst=(B-(n/2))/(sqrt(n/4))
print(Bst)
# critical value
alpha=0.05
z.alpha=qnorm(1-alpha/2)
print(z.alpha)
print("e BST is not greater than z.alpha, we fail to reject H0")
pvalue=1-pnorm(Bst)
print(pvalue)


=begin
  # sample-elementary-divisor01.rb

  require "algebra"

  M = SquareMatrix(Rational, 4)
  a = M[
    [2, 0, 0, 0],
    [0, 2, 0, 0],
    [0, 0, 2, 0],
    [5, 0, 0, 2]
  ]
  P = Polynomial(Rational, "x")
  MP = SquareMatrix(P, 4)

  ac = a._char_matrix(MP)
  ac.display; puts #=>
  #x - 2,   0,   0,   0
  #  0, x - 2,   0,   0
  #  0,   0, x - 2,   0
  # -5,   0,   0, x - 2

  p ac.elementary_divisor #=> [1, x - 2, x - 2, x^2 - 4x + 4]

  require "algebra/matrix-algebra-triplet"
  at = ac.to_triplet.e_diagonalize

  at.body.display; puts #=>
  #  1,   0,   0,   0
  #  0, x - 2,   0,   0
  #  0,   0, x - 2,   0
  #  0,   0,   0, x^2 - 4x + 4

  at.left.display; puts #=>
  #  0,   0,   0, -1/5
  #  0,   1,   0,   0
  #  0,   0,   1,   0
  #  5,   0,   0, x - 2

  at.right.display; puts #=>
  #  1,   0,   0, 1/5x - 2/5
  #  0,   1,   0,   0
  #  0,   0,   1,   0
  #  0,   0,   0,   1

  p at.left * ac * at.right == at.body #=> true
((<_|CONTENTS>))
=end


trajanja <- faithful$eruptions
cekanja <- faithful$waiting

sredina.trajanja <- sum(trajanja)/length(trajanja)
sredina.trajanja
sredina.trajanja <- mean(trajanja)
sredina.trajanja

sredina.cekanja <- mean(cekanja)
sredina.cekanja

mediana.trajanja <- median(trajanja)
mediana.trajanja

mediana.cekanja <- median(cekanja)
mediana.cekanja

kvartili.trajanja <- quantile(trajanja)
kvartili.trajanja

kvartili.trajanja <- quantile(trajanja, c(0,0.25,0.5,0.75,1) )
kvartili.trajanja

percentili.trajanja <- quantile(trajanja,
    c(0,0.1,0.2,0.3,0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1) )
percentili.trajanja

opseg.trajanja <- range(trajanja)[2] - range(trajanja)[1]
opseg.trajanja
opseg.trajanja <- max(trajanja) - min(trajanja)
opseg.trajanja

opseg.medju.kvartilima.trajanja <- IQR(trajanja)
opseg.medju.kvartilima.trajanja

boxplot(trajanja)

disperzija.trajanja <- var(trajanja)
disperzija.trajanja

standardna.devijacija.trajanja <- sqrt(var(trajanja))
standardna.devijacija.trajanja
standardna.devijacija.trajanja <- sd(trajanja)
standardna.devijacija.trajanja

kovarijansa.cekanja.i.trajanja = cov(cekanja, trajanja)
kovarijansa.cekanja.i.trajanja

koeficiejnat.korelacije.cekanja.i.trajanja <-  cor(cekanja, trajanja)
koeficiejnat.korelacije.cekanja.i.trajanja

filter.kratko <- faithful$eruptions < 3
filter.kratko
podaci.kratko <- faithful[filter.kratko,]
podaci.kratko
cor(podaci.kratko$waiting, podaci.kratko$eruptions)


# SIMPLE IMPLEMENTATION OF HAMILTONIAN MONTE CARLO.
#
# Radford M. Neal, 2010.
#
# This program appears in Figure 2 of "MCMC using Hamiltonian dynamics",
# to appear in the Handbook of Markov Chain Monte Carlo.
#
# The arguments to the HMC function are as follows:
#
#   U          A function to evaluate minus the log of the density of the
#              distribution to be sampled, plus any constant - ie, the
#              "potential energy".
#
#   grad_U     A function to evaluate the gradient of U.
#
#   epsilon    The stepsize to use for the leapfrog steps.
#
#   L          The number of leapfrog steps to do to propose a new state.
#
#   current_q  The current state (position variables only).
#
# Momentum variables are sampled from independent standard normal
# distributions within this function.  The value return is the vector
# of new position variables (equal to current_q if the endpoint of the
# trajectory was rejected).
#
# This function was written for illustrative purposes.  More elaborate
# implementations of this basic HMC method and various variants of HMC
# are available from my web page, http://www.cs.utoronto.ca/~radford/

HMC = function (U, grad_U, epsilon, L, current_q)
{
  q = current_q
  p = rnorm(length(q),0,1)  # independent standard normal variates
  current_p = p

  # Make a half step for momentum at the beginning

  p = p - epsilon * grad_U(q) / 2

  # Alternate full steps for position and momentum

  for (i in 1:L)
  {
    # Make a full step for the position

    q = q + epsilon * p

    # Make a full step for the momentum, except at end of trajectory

    if (i!=L) p = p - epsilon * grad_U(q)
  }

  # Make a half step for momentum at the end.

  p = p - epsilon * grad_U(q) / 2

  # Negate momentum at end of trajectory to make the proposal symmetric

  p = -p

  # Evaluate potential and kinetic energies at start and end of trajectory

  current_U = U(current_q)
  current_K = sum(current_p^2) / 2
  proposed_U = U(q)
  proposed_K = sum(p^2) / 2

  # Accept or reject the state at end of trajectory, returning either
  # the position at the end of the trajectory or the initial position

  if (runif(1) < exp(current_U-proposed_U+current_K-proposed_K))
  {
    return (q)  # accept
  }
  else
  {
    return (current_q)  # reject
  }
}


#Series temporais e analises preditivas - Fernando Amaral

library(forecast)
library(ggplot2)
library(seasonal)
library(seasonalview)
library(urca)

#importar dados do hotel
dados = read.csv(file.choose(),header = F)
print(dados)

#treino/teste
ocupacaotreino = ts(dados, start = c(2003,1), end = c(2015,12), frequency=12)
ocupacaoteste  = ts(dados, start = c(2016,1), end = c(2017,12), frequency=12)

#ARIMA
modeloarima = auto.arima(ocupacaotreino,  trace = F,stepwise = F, approximation = F )
preverarima = forecast(modeloarima, h=24)

#ets
modeloets = ets(ocupacaotreino)
preverets = forecast(modeloets, h=24)

plot(preverarima)
lines(preverets$mean, col="red")

accuracy(preverarima,ocupacaoteste)
accuracy(preverets,ocupacaoteste)

plot(ocupacao)
lines(preverarima$mean, col="blue")
lines(preverets$mean, col="green")

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/11.2.Comparando Modelos.r


MSR=11128.14
MSC=544.44
t=5
MSE=2887.29
# relative efficiency of this Latin square design relative to a completely randomized design is
re=(MSR+MSC+(t-1)*MSE)/((t+1)*MSE)
re


print ("first task")

a <- c( -1, 0, 2, 3, -5, 6, 0, 5, -1, 0, 5, -6, 0, 6, -8, 9)
b <- c( 6, 1, -6, -3, -8, 7, 0, 10, -4, -6, 4, 1, -3, 0, -2, 4)
p <- c ( -4, 6, -7, 3, 0, -7, 5, 4, 3, -6, 7, 1, 0, 4, -2, 3)
fir <- ((7)*a)+(2*b)
print ("first answer")
fir
sec <- ((-2)*as.numeric(a%*%b))*p+5*(norm(p, type="2"))*a
print ("second answer")
sec
thr <- (-2)*(norm(p, type="2"))*p-7*as.numeric(a%*%b)*p+9*as.numeric(b%*%p)*a
print ("third answer")
thr

Задача 2

print ("second task")
mat <- rbind(c(0,0,0,-1,8,0,6,-1),c(0,0,0,8,4,0,-5,4),c(0,0,0,11,3,0,0,6),c(7,0,0,0,0,8,0,-2),c(4,0,0,0,0,-4,-2,-6),c(-3,0,-4,0,-2,0,0,0),c(13,-7,0,8,1,0,0,0),c(-4,0,0,9,-5,0,0,0))
rua <- c(5,-5,-14,10,-6,2,2,8)
X <- solve(mat)%*%rua
print ("Answer for the sec task")
X
mat%*%X
rua

задача 4

print ("fourth task")
A <- rbind(c(19, 0 ,0 ,0 ,0 ,0 ,0 ,20),c(0 ,7 ,0 ,0, 0, 0, 0, 0),c(0, 0, 13, 0, 0, 0, 0, 0),c(0, 0, 0, 11, 0, 0, 0, 0),c(0, 9, 0, 0, 17, 0, 0, 0),c(0, 0, 0, 0, 0, 5, 0, 0),c(0, 0, 0, 0, 0, 0, 3, 0),c(0, 0, 0, 0, 0, 0, 0, 1))
A
options(digits=3) # Задать количество значащих цифр для вывода
print ("собственные числа ")
d <- eigen(A)$values; d # Собственные значения матрицы A
print ("собственные вектора")
P <- eigen(A)$vectors; P # Собственные векторы A, стоящие в столбцах матрицы
P
print (" Проверим ортогональность полученного собственного базиса ")
sum(P[,1]^2) # Например, длина первого собственного вектора
P[,1] %*% P[,2] # Например, скалярное произведение (f1, f2)
sum(P[,2]^2); P[,2] %*% P[,3] # длина 2 собственного вектора и (f2, f3)
sum(P[,3]^2); P[,3] %*% P[,4] # длина 3 собственного вектора и (f3, f4)
sum(P[,4]^2); P[,4] %*% P[,5] # длина 4 собственного вектора и (f4, f5)
sum(P[,5]^2); P[,5] %*% P[,6] # длина 5 собственного вектора и (f5, f6)
sum(P[,6]^2); P[,6] %*% P[,7] # длина 6 собственного вектора и (f6, f7)
sum(P[,7]^2); P[,7] %*% P[,8] # длина 7 собственного вектора и (f7, f8)
sum(P[,8]^2); P[,8] %*% P[,1] # длина 8 собственного вектора и (f8, f1)
print ("Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.
Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.")

задача 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 = "max")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(10, 15)) # Задаем целевую функцию: f = 5*X1 +3*X2 для модели М
add.constraint(M, c(1,4), ">=", 4) # Задаем ограничение:
add.constraint(M, c(-3, 1), ">=", -10) # Аналогично
add.constraint(M, c(-8, 5), "<=", 29) # Аналогично
add.constraint(M, c(5, 2), "<=", 54) # Аналогично
rownames(M) <- c("A", "B", "C", "D") # Называем ограничения в модели М
M
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M)
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


fig.no = 1
pdf(sprintf("plot-%03d.pdf", fig.no),
            width=7, height=5, pointsize=10)
fig.no = fig.no + 1

# This figure shows the mapping between q and k and how variable size clusters result.
par(cex.lab=1.5)
par(cex.axis=1.5)
scale = 30
q.marks = (sin(seq(-pi/2+0.01,pi/2-0.01,length.out=16))+1)/2
plot(q.marks, scale*asin(2*q.marks-1)/pi+scale/2, xlim=c(0,1.05), ylim=c(-3,scale),
    lwd=2, cex=0.7,
    type='b', ylab='k', xlab='q')
for (i in 1:(length(q.marks))) {
    q = q.marks[i]
    lines(c(q,q), c(-3, scale*asin(2*q-1)/pi + scale/2 -1), lwd=2, col='gray')
}
dev.off()

pdf(sprintf("plot-%03d.pdf", fig.no),
            width=7, height=5, pointsize=10)
fig.no = fig.no + 1

# this shows the old and sqrt limits
par(cex.lab=1.5)
par(cex.axis=1.5)
q = seq(0, 1, by=0.001)
plot(q, 6*q*(1-q), type='l', lwd=2, ylab="Cluster Size")
lines(q, 8/pi*sqrt(q*(1-q)), lwd=2, lty=2)

dev.off()

pdf(sprintf("plot-%03d.pdf", fig.no),
            width=7, height=5, pointsize=10)
fig.no = fig.no + 1

par(cex.lab=1.5)
par(cex.axis=1.5)
plot(q, 100*(asin(2*q-1)/pi+0.5), type='l', lwd=2,
    ylab="k")

dev.off()


deg <- function(radians) 180*radians/pi
rad <- function(degrees) degrees*pi/180
sind <- function(ang) sin(rad(ang))
cosd <- function(ang) cos(rad(ang))
tand <- function(ang) tan(rad(ang))
asind <- function(v) deg(asin(v))
acosd <- function(v) deg(acos(v))
atand <- function(v) deg(atan(v))

r <- pi/3
rd <- deg(r)

print( c( sin(r), sind(rd)) )
print( c( cos(r), cosd(rd)) )
print( c( tan(r), tand(rd)) )

S <- sin(pi/4)
C <- cos(pi/3)
T <- tan(pi/4)

print( c( asin(S), asind(S) ) )
print( c( acos(C), acosd(C) ) )
print( c( atan(T), atand(T) ) )


# confidence.band (Derek Young and David Hunter)
# based on Ellipses, by J. Fox and G. Monette, from
# car package

confidence.band = function(model, levels=0.95, segments=50, col.points=palette()[1],
                           col.line=palette()[1], col.bands=palette()[2],
                           lty.line=1, lty.bands=2, ...) {
  if (attr(model$terms,"intercept")!=1 || length(model$coef) !=2) {
    stop(paste("condifence.bands only works for simple linear regression\n",
               "with one predictor and an intercept"))
  }
  plot(model$model[,2:1], col=col.points, ...)
  abline(model, col=col.line, lty=lty.line, lwd=2)
  angles=(0:segments)*pi/segments
  halfcircle = cbind(cos(angles), sin(angles))
  chol.shape = chol(vcov(model))
  slopes = (halfcircle %*% chol.shape)[,2]
  angles = angles+angles[which.max(slopes)]
  halfcircle = cbind(cos(angles), sin(angles))
  center = model$coef
  radius = sqrt(2*qf(levels, 2, df.residual(model)))
  for (r in radius) {
    for (i in 1:2) {
      halfcircle = -halfcircle
      ellipse = sweep(r*(halfcircle %*% chol.shape), 2, center, "+")
      int = ellipse[,1]
      slope = ellipse[,2]
      x = -diff(int)/diff(slope)
      y = int[-1]+slope[-1]*x
      lines(x, y, lwd=2, lty=lty.bands, col=col.bands)
    }
  }
}


library(dplyr)
library(ggplot2)
library(ggthemes)

setwd("~/Desktop/chapter 2")

mydata <- read.csv("WA_Fn-UseC_-HR-Employee-Attrition.csv")

head(mydata)

str(mydata)

dim(mydata)

numeric_mydata <- mydata[,c(1,4,6,7,10,11,13,14,15,17,19,20,21,24,25,26,28:35)]
numeric_Attrition = as.numeric(mydata$Attrition)- 1
numeric_mydata = cbind(numeric_mydata, numeric_Attrition)
library(corrplot)
M <- cor(numeric_mydata)
corrplot(M, method="circle")

#Finding how many correlations are bigger than 0.70
k = 0
for(i in 1:25){
for(r in 1:25){
  if(M[i,r]> 0.70 & i != r){
    print(rownames(M)[i])
    print(colnames(M)[r])
    print(M[i,r])
    k= k + 1
  }
}  }
print(k/2)

options( warn = -1 )
### Overtime vs Attiriton
l <- ggplot(mydata, aes(OverTime,fill = Attrition))
l <- l + geom_histogram(stat="count")
print(l)
tapply(as.numeric(mydata$Attrition) - 1 ,mydata$OverTime,mean)

### MaritalStatus vs Attiriton
l <- ggplot(mydata, aes(MaritalStatus,fill = Attrition))
l <- l + geom_histogram(stat="count")
print(l)
tapply(as.numeric(mydata$Attrition) - 1 ,mydata$MaritalStatus,mean)

###JobRole vs Attrition
l <- ggplot(mydata, aes(JobRole,fill = Attrition))
l <- l + geom_histogram(stat="count")
print(l)
tapply(as.numeric(mydata$Attrition) - 1 ,mydata$JobRole,mean)
mean(as.numeric(mydata$Attrition) - 1)

###Gender vs Attrition
l <- ggplot(mydata, aes(Gender,fill = Attrition))
l <- l + geom_histogram(stat="count")
print(l)
tapply(as.numeric(mydata$Attrition) - 1 ,mydata$Gender,mean)

###EducationField vs Attrition
l <- ggplot(mydata, aes(EducationField,fill = Attrition))
l <- l + geom_histogram(stat="count")
print(l)
tapply(as.numeric(mydata$Attrition) - 1 ,mydata$EducationField,mean)

###Department vs Attrition
l <- ggplot(mydata, aes(Department,fill = Attrition))
l <- l + geom_histogram(stat="count")
print(l)
tapply(as.numeric(mydata$Attrition) - 1 ,mydata$Department,mean)

###BusinessTravel vs Attrition
l <- ggplot(mydata, aes(BusinessTravel,fill = Attrition))
l <- l + geom_histogram(stat="count")
print(l)
tapply(as.numeric(mydata$Attrition) - 1 ,mydata$BusinessTravel,mean)

### x=Overtime, y= Age, z = MaritalStatus , t = Attrition
ggplot(mydata, aes(OverTime, Age)) +
  facet_grid(.~MaritalStatus) +
  geom_jitter(aes(color = Attrition),alpha = 0.4) +
  ggtitle("x=Overtime, y= Age, z = MaritalStatus , t = Attrition") +
  theme_light()

### MonthlyIncome vs. Age, by  color = Attrition
ggplot(mydata, aes(MonthlyIncome, Age, color = Attrition)) +
  geom_jitter() +
  ggtitle("MonthlyIncome vs. Age, by  color = Attrition ") +
  theme_light()

if (!require("corrplot"))          install.packages("corrplot")
if (!require("ggplot2"))           install.packages("ggplot2")
if (!require("caret"))             install.packages("caret")
if (!require("rpart"))             install.packages("rpart")
if (!require("rpart.plot"))        install.packages("rpart.plot")
if (!require("e1071"))             install.packages("e1071")
if (!require("caTools"))           install.packages("caTools")
if (!require("rattle"))            install.packages("rattle")
if (!require("gridExtra"))         install.packages("gridExtra")
if (!require("ROCR"))              install.packages("ROCR")
if (!require("randomForest"))      install.packages("randomForest")
if (!require("randomForestSRC"))   install.packages("randomForestSRC")
if (!require("reshape2"))          install.packages("reshape2")
if (!require("RColorBrewer"))      install.packages("RColorBrewer")

sum(is.na(mydata))

library(caret)
#Setting the random seed for replication
set.seed(1234)

#setting up cross-validation
cvcontrol <- trainControl(method="repeatedcv", repeats=10, number = 10, allowParallel=TRUE)

mydata$EmployeeNumber=mydata$Over18=mydata$EmployeeCount=mydata$StandardHours = NULL

train.bagg <- train(Attrition ~ .,
                   data=mydata,
                   method="treebag",B=10,
                   trControl=cvcontrol,
                   importance=TRUE)

train.bagg

library(party)

bagctrl <- bagControl(fit = ctreeBag$fit,
                      predict = ctreeBag$pred ,
                      aggregate = ctreeBag$aggregate)
ctrainbagg <- train(Attrition ~ .,
                   data=mydata,
                   method="bag",
                   trControl=cvcontrol,bagControl = bagctrl,
                   allowParallel=TRUE)

ctrainbagg

ctrainbagg$finalModel

svm.predict <- function (object, x)
{
 if (is.character(lev(object))) {
    out <- predict(object, as.matrix(x), type = "probabilities")
    colnames(out) <- lev(object)
    rownames(out) <- NULL
  }
  else out <- predict(object, as.matrix(x))[, 1]
  out
}

bagctrl <- bagControl(fit = svmBag$fit,
                      predict = svm.predict ,
                      aggregate = svmBag$aggregate)

# fit the bagged svm model
set.seed(300)
svmbag <- train(Attrition ~ ., data = mydata, method="bag",
                trControl = cvcontrol, bagControl = bagctrl,allowParallel = TRUE)

svmbag

svm.predict <- function (object, x)
{
 if (is.character(lev(object))) {
    out <- predict(object, as.matrix(x), type = "probabilities")
    colnames(out) <- lev(object)
    rownames(out) <- NULL
  }
  else out <- predict(object, as.matrix(x))[, 1]
  out
}

ctrl <- trainControl(method = "cv", number = 10,
                     selectionFunction = "oneSE")

bagctrl <- bagControl(fit = svmBag$fit,
                      predict = svm.predict ,
                      aggregate = svmBag$aggregate)

# fit the bagged svm model
set.seed(300)
svmbag <- train(Attrition ~ ., data = mydata, method="bag",
                trControl = cvcontrol, bagControl = bagctrl)

svmbag

library(kernlab)

str(nbBag)

nb.predict <- function (object, x)
{
 if (is.character(lev(object))) {
    out <- predict(object, as.matrix(x), type = "probabilities")
    colnames(out) <- lev(object)
    rownames(out) <- NULL
  }
  else out <- predict(object, as.matrix(x))[, 1]
  out
}

bagctrl <- bagControl(fit = nbBag$fit,
                      predict = nbBag$pred ,
                      aggregate = nbBag$aggregate)

# fit the bagged nb model
set.seed(300)
nbbag <- train(Attrition ~ ., data = mydata, method="bag",
                trControl = cvcontrol, bagControl = bagctrl)

nbbag

library(klaR)

library(doMC)
registerDoMC(cores = 4)

str(nnetBag)

bagctrl <- bagControl(fit = nbBag$fit,
                      predict = nbBag$pred ,
                      aggregate = nbBag$aggregate)

# fit the bagged nb model
set.seed(300)
nbbag1 <- train(Attrition ~ ., data = mydata, method="bag",B=100,
                trControl = cvcontrol, bagControl = bagctrl)

nbbag1