#' Principal Components Analysis
#'
#' @param data.mat Input data matrix
#'
#' @return Object of class tomPCA with rotation and x data
#' @export
#'
#' @examples
#' test.matrix = matrix(
#'    c(2, 4, 3, 1, 5, 7),
#'    nrow=3,
#'    ncol=2)
#'
#' pca.obj = PCA(test.matrix)
PCA = function(data.mat)
{
  # Scale data
  scaled.mat = scale(data.mat, scale = FALSE)

  # Run SVD on scaled data
  sm.svd = base::svd(scaled.mat)

  # Get x mat
  x.mat = sm.svd$u %*% diag(sm.svd$d)
  rot.mat = sm.svd$v

  # Return rotation and x
  return(structure(list(rotation = rot.mat, x = x.mat), class = "tomPCA"))
}


#### #### #### #### #### #### #### #### #### #### ####
####
#### MDS
#### http://www.sthda.com/english/articles/31-principal-component-methods-in-r-practical-guide/122-multidimensional-scaling-essentials-algorithms-and-r-code/
#### #### #### #### #### #### #### #### #### #### ####

rm(list=ls())
#librerie
library(magrittr)
library(dplyr)
library(ggpubr)
library(magrittr)
library(dplyr)
library(ggpubr)
library(MASS)
## dataset
data("swiss")
head(swiss)
?swiss

# # # # # # # # # # #
# MDS
# # # # # # # # # # #
mds <- swiss %>%
  dist() %>%
  cmdscale() %>%
  as.data.frame()
colnames(mds) <- c("Dim.1", "Dim.2")
# Plot MDS
ggscatter(mds, x = "Dim.1", y = "Dim.2",
          label = rownames(swiss),
          size = 1,
          repel = TRUE)

### ### ### ### ### ### ### ### ### ### ###
### Vediamo altri pacchetti che fanno
### MDS
### ### ### ### ### ### ### ### ### ### ###
# il dataset
?eurodist

# standard sintassi
mds1 = cmdscale(eurodist, k = 2)
# plot
plot(mds1[,1], mds1[,2], type = "n", xlab = "", ylab = "", axes = FALSE,
     main = "cmdscale (stats)")
text(mds1[,1], mds1[,2], labels(eurodist), cex = 0.9, xpd = TRUE)

library(vegan)
# 2) MDS 'wcmdscale'
mds2 = wcmdscale(eurodist, k=2, w=rep(1,21))
# plot
plot(mds2[,1], mds2[,2], type = "n", xlab = "", ylab = "",
     axes = FALSE, main = "wcmdscale (vegan)")
text(mds2[,1], mds2[,2], labels(eurodist), cex = 0.9, xpd = TRUE)

library(ecodist)
# 3) MDS 'pco'
mds3 = pco(eurodist)
# plot
plot(mds3$vectors[,1], mds3$vectors[,2], type = "n", xlab = "", ylab = "",axes = FALSE, main = "pco (ecodist)")
text(mds3$vectors[,1], mds3$vectors[,2], labels(eurodist),
     cex = 0.9, xpd = TRUE)

library(labdsv)
mds4 = pco(eurodist, k = 2)
# plot
plot(mds4$points[,1], mds4$points[,2], type = "n", xlab = "", ylab = "", axes = FALSE, main = "pco (labdsv)")
text(mds4$points[,1], mds4$points[,2], labels(eurodist),
     cex = 0.9, xpd = TRUE)

library(ape)
mds5 = pcoa(eurodist)

# plot
plot(mds5$vectors[,1], mds5$vectors[,2], type = "n", xlab = "", ylab = "",axes = FALSE, main = "pcoa (ape)")
text(mds5$vectors[,1], mds5$vectors[,2], labels(eurodist),
     cex = 0.9, xpd = TRUE)

library(ade4)
mds6 = dudi.pco(eurodist, scannf = FALSE, nf = 2)
# plot
plot(mds6$li[,1], mds6$li[,2], type = "n", xlab = "", ylab = "",
     axes = FALSE, main = "dudi.pco (ade4)")
text(mds6$li[,1], mds6$li[,2], labels(eurodist), cex = 0.9)

library(smacof)
mds7 = smacofSym(eurodist, ndim = 2)

# plot
plot(mds7$conf[,1], mds7$conf[,2], type = "n", xlab = "", ylab = "",
     axes = FALSE, main = "smacofSym (smacof)")
text(mds7$conf[,1], mds7$conf[,2], labels(eurodist),
     cex = 0.9, xpd = TRUE)


library(tidyr)

find.logit.coef.ifr = function(path_to_ifr_by_age){

  ifr.by.age <- as_tibble(read.csv(path_to_ifr_by_age))
  stopifnot( c('age','ifr_mean')%in%colnames(ifr.by.age) )
  ifr.by.age <- ifr.by.age %>%
    select(age, ifr_mean, ifr_cl, ifr_cu)

  x = seq(mean(c(0,9)),mean(c(80,89)),10)
  y.mean = unique(ifr.by.age$ifr_mean)

  # fit non linear regression
  mylogit <- glm(y.mean ~ log(x), family = quasibinomial)

  mean_sd_coef <- summary(mylogit)$coefficients[,1:2]

  # plot
  # logit = function(p) log(p/(1-p))
  # invlogit = function(x) 1/(1+exp(-x))
  #
  # par(mfrow = c(1, 2))
  # plot(log(x), logit(y.mean))      # on the original scale
  #
  # x.pred = 1:100
  #
  # plot(x.pred, invlogit(glm_coef[1] + glm_coef[2]*log(x.pred)), col = "dodgerblue", lwd = 2, type = "l")
  # points(x, y.mean)
  #

  return(mean_sd_coef)
}

find.polynomial.coef.ifr = function(path_to_ifr_by_age){

  ifr.by.age <- as_tibble(read.csv(path_to_ifr_by_age))
  stopifnot( c('age','ifr_mean')%in%colnames(ifr.by.age) )
  ifr.by.age <- ifr.by.age %>%
    select(age, ifr_mean, ifr_cl, ifr_cu)

  x = seq(mean(c(0,9)),mean(c(80,89)),10)
  y.mean = unique(ifr.by.age$ifr_mean)

  ## check data
  # par(mfrow = c(1, 2))
  # plot(x, y.mean)      # on the original scale
  # plot(log_x + log_x2, log(y.mean))

  # fit non linear regression
  log_x = log(x)
  log_x2 = (log(x))^2

  mult_lm <- lm(log(y.mean) ~ log_x + log_x2)
  mean_coef <- mult_lm$coefficients
  mean_sd_coef <- summary(mult_lm)$coefficients[,1:2]

  # plot fit
  # x.pred = 0:100
  # plot(x.pred, exp(lm_coef[1] + lm_coef[2]*log(x.pred) + lm_coef[3]*log(x.pred)^2), col = "dodgerblue", lwd = 2, type = "l")
  # points(x, y.mean)
  return(mean_sd_coef)
}


n<-100
w<-1; a1<-runif(n, min = w*0.5, max = w*1.5)
w<-2; a2<-runif(n, min = w*0.5, max = w*1.5)
w<-3; a3<-runif(n, min = w*0.5, max = w*1.5)

if (T) {
  sd2<-0.2
  w<-1; a1<-rnorm(n, mean = w, sd =sd2)
  w<-2; a2<-rnorm(n, mean = w, sd = sd2)
  w<-3; a3<-rnorm(n, mean = w, sd = sd2)
}

ww<-c(a1,a2,a3)
a<-1.2
b<-0.66
h<-data.frame(w=rep(1:3,each=n),wobs=ww,cons=a*ww^b)
cleanup()
plot(x=h$w,y=h$cons)
lines(x=h$wobs,y=h$cons,type='p',col='red')

plot(x=log(h$wobs),y=log(h$cons))

aa<-lm(log(cons)~log(wobs),data=h)

h$predict<-predict(aa)
plot(x=log(h$wobs),y=log(h$cons))
lines(x=log(h$w),y=log(h$cons),col='red',type='p')
abline(aa)

plot(x=h$wobs,y=(h$cons))

co<-coef(aa)
h$pred2<-exp(co[1])*h$wobs^co[2]
lines(x=h$wobs,y=h$pred2,col='red',type='p')
summary(aa)
cat("a:",a," b:",b,"\n")
cat("estimated a:",exp(co[1])," b:",co[2],"\n")


# this is the modelfile for separate meta-analysis
# for humerus and femur data
# the two meta-analyses are run in the same file to allow easy
# construction of results
#

model {

#### Humerus data
    for(k1 in 1:K.hum) {

        # observational part of the model
        x.down.1dot[k1] ~ dbin(p.down.1dot[k1], N.down.hum[k1])
        x.nodown.1dot[k1] ~ dbin(p.nodown.1dot[k1], N.nodown.hum[k1])

        p.down.1dot[k1] <- ilogit(eta.xi.hum[k1, 1])
        p.nodown.1dot[k1] <- ilogit(eta.xi.hum[k1, 2])

        # structural part of the model
        eta.xi.hum[k1, 1:2] ~dmnorm(Eta.Xi.hum[1:2], Omega.hum)

    }

    # prior for mean -- independent vague priors suffice
    #                -- otherwise, mvnormal with vague Wishart
    Eta.Xi.hum[1] ~ dnorm(mu0.hum[1], prec.mu0.hum[1])
    Eta.Xi.hum[2] ~ dnorm(mu0.hum[2], prec.mu0.hum[2])

    # S.hum is a diagonal matrix of sd's
    S.hum[1,1] ~ dunif(s.lower.hum[1], s.upper.hum[1])  # or use inverse gamma
    S.hum[2,2] ~ dunif(s.lower.hum[2], s.upper.hum[2])
    S.hum[1,2] <- 0
    S.hum[2,1] <- S.hum[1,2]

    # R.hum is a correlation matrix
    R.hum[1,1] <- 1
    R.hum[2,2] <- 1
    R.hum[1,2] ~ dunif(r.lower.hum[1], r.upper.hum[1])  # or use atanh
    R.hum[2,1] <- R.hum[1,2]

    # Factorize
    Tau.hum <- S.hum %*% R.hum %*% S.hum
    Omega.hum <- inverse(Tau.hum)

#### Femur data
    for(k2 in 1:K.fem) {

        # observational part of the model
        x.down.dot1[k2] ~ dbin(p.down.dot1[k2], N.down.fem[k2])
        x.nodown.dot1[k2] ~ dbin(p.nodown.dot1[k2], N.nodown.fem[k2])

        p.down.dot1[k2] <- ilogit(eta.xi.fem[k2, 1])
        p.nodown.dot1[k2] <- ilogit(eta.xi.fem[k2, 2])

        # structural part of the model
        eta.xi.fem[k2, 1:2] ~dmnorm(Eta.Xi.fem[1:2], Omega.fem)

    }

    # prior for mean -- independent vague priors suffice
    #                -- otherwise, mvnormal with vague Wishart
    Eta.Xi.fem[1] ~ dnorm(mu0.fem[1], prec.mu0.fem[1])
    Eta.Xi.fem[2] ~ dnorm(mu0.fem[2], prec.mu0.fem[2])

    # S.fem is a diagonal matrix of sd's
    S.fem[1,1] ~ dunif(s.lower.fem[1], s.upper.fem[1])  # or use inverse gamma
    S.fem[2,2] ~ dunif(s.lower.fem[2], s.upper.fem[2])
    S.fem[1,2] <- 0
    S.fem[2,1] <- S.fem[1,2]

    # R.fem is a correlation matrix
    R.fem[1,1] <- 1
    R.fem[2,2] <- 1
    R.fem[1,2] ~ dunif(r.lower.fem[1], r.upper.fem[1])  # or use atanh
    R.fem[2,1] <- R.fem[1,2]

    # Factorize
    Tau.fem <- S.fem %*% R.fem %*% S.fem
    Omega.fem <- inverse(Tau.fem)

    # Data to report
    tpr.hum <- ilogit(Eta.Xi.hum[1])
    fpr.hum <- ilogit(Eta.Xi.hum[2])

    tpr.fem <- ilogit(Eta.Xi.fem[1])
    fpr.fem <- ilogit(Eta.Xi.fem[2])

    diff.tpr <- tpr.hum - tpr.fem
    diff.fpr <- fpr.hum - fpr.fem

    or.tpr <- exp(Eta.Xi.hum[1]-Eta.Xi.fem[1])
    or.fpr <- exp(Eta.Xi.hum[2]-Eta.Xi.fem[2])

    diff.eta <- Eta.Xi.hum[1]-Eta.Xi.fem[1]
    diff.xi <- Eta.Xi.hum[2]-Eta.Xi.fem[2]

}


#'@title calcAbt
#'
#'@description Estimate transverse bulb area (\code{Abt}) (m^2) using method in
#'Rakke (2016).
#'
#'@param Cm Midship area coefficient (dimensionless) (see \code{\link{calcCm}})
#'@param breadth Moulded breadth (m)
#'@param actualDraft Actual draft (m)
#'
#'@details
#'Transverse sectional area of the bulb at the position where the still-water
#'surface intersects the stem (m^2) using actual draft. Actual draft is
#'typically obtained from sources such as AIS messages or ship records.
#'
#'@return \code{Abt} (vector of numericals, m^2)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29. p. 166-170
#'
#'\href{http://hdl.handle.net/11250/2410741}{Rakke, S. G. 2016. "Ship
#'Emissions Calculation from AIS." NTNU}
#'
#'@seealso \code{\link{calcCm}}
#'
#'@examples
#'calcAbt(0.98, 32, 10)
#'calcAbt(c(0.98,0.99), c(32,45.5), c(10,15.5))
#'
#'@export

calcAbt <-function(Cm, breadth, actualDraft){

  Abt<-0.08*Cm*breadth*actualDraft

  return(Abt)
}


library(MASS)
#Q1
dt=Boston
#Q2
reg=lm(formula=medv~crim+zn+indus+chas+nox+rm+age+dis+rad+tax+ptratio+black+lstat, data=dt)
print(summary(reg))
#Q3
dt1 = sort.int(sample(nrow(dt), nrow(dt)*.8))
train<-dt[dt1,]
test<-dt[-dt1,]
#Q4
reg1=lm(formula=medv~crim+zn+indus+chas+nox+rm+age+dis+rad+tax+ptratio+black+lstat, data=train)
res=predict(reg1,test)
print(res)
#Q5
err=mean(abs(res-test$medv))
print(err)
hist(res-test$medv)


x1=runif(40,0,10)
x2=runif(40,10,20)

e1 = rnorm(20,0,2)
e2 = rnorm(20,0,3)

y1 = 1+2.5*x1 + e1
y2 = 35+-1.5*x2 + e2

xx=c(x1,x2)
yy=c(y1,y2)

x0 = seq(0,20,.1)
m0 = lm(yy~xx)
m1 = lm(y1~x1)
m2 = lm(y2~x2)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(MASS)

## simulation for PE exercise
## Values are from Harte (2017)
n.years <- 12
periods.per.year <- 4
dtime <- 1/periods.per.year
times <- seq(dtime, n.years, by=dtime)
mgmt.fee <- 0.02
invest.time.end <- max(times)
capital0 <- 100
fees <- capital0*mgmt.fee*dtime
investment0 <- capital0 - fees

rf <- 0.05

## drift/OU reversion parameters
#pe.alpha <- 0.04
mu.mkt <- 0.11
mu.delta <- 0.41
mu.nu <- 0.08
theta.pi <- 0.16; kappa.pi <- 0.42
pi0 <- theta.pi

## covariance parameters; some correlations differ from Harte (2017)
pe.beta <- 1.3
vol.delta <- 0.21*sqrt(dtime); vol.nu <- 0.11*sqrt(dtime); vol.pi <- 0.16*sqrt(dtime)
vol.mkt.sys <- 0.15*sqrt(dtime); vol.mkt.idio <- 0.35*sqrt(dtime)
corr.delta <- -0.3; corr.nu <- 0.8; corr.pi <- -0.3

cov.delta <- corr.delta*vol.delta*vol.mkt.sys
cov.nu    <- corr.nu*vol.nu*vol.mkt.sys
cov.pi    <- corr.pi*vol.pi*vol.mkt.sys
cov.mtx <- matrix(c(vol.delta^2,        0,        0,     cov.delta,       0,
                    0,           vol.nu^2,        0,        cov.nu,       0,
                    0,                  0, vol.pi^2,        cov.pi,       0,
                    cov.delta,     cov.nu,   cov.pi, vol.mkt.sys^2,       0,
                    0,                  0,        0,             0, vol.mkt.idio^2),
                  nrow=5)

## generate random variates
B.rvs <- mvrnorm(mu=rep(0, 5), Sigma=cov.mtx, n=n.years*periods.per.year)
colnames(B.rvs) <- c("B.delta", "B.nu", "B.pi", "B.mkt", "B.epsilon")

delta <- pmin(pmax(mu.delta*dtime + B.rvs[,"B.delta"], 0), 1)
nu <- pmin(pmax(mu.nu*times + B.rvs[,"B.nu"], 0), 1)
pi.ou <- c(pi0)
for (i in 2:length(times)) {
    pi.ou[i] <- pi.ou[i-1] + kappa.pi*(theta.pi - pi.ou[i-1])*dtime + B.rvs[i-1,"B.pi"]
}
dmkt <- mu.mkt*dtime + pe.beta*B.rvs[,"B.mkt"] + B.rvs[,"B.epsilon"]

## simulate the cashflows and value
drawdowns <- c(delta[1]*investment0)
rcvd.distn <- c(0)
value <- c(0)
for (i in 2:length(times)) {
    d.drawdowns <- delta[i]*(investment0 - drawdowns[i-1])*(times[i] < invest.time.end)
    drawdowns[i] <- drawdowns[i-1] + d.drawdowns
    d.rcvd.distn <- nu[i]*value[i-1]
    if (i < length(times)) {
        rcvd.distn[i] <- rcvd.distn[i-1] + d.rcvd.distn
        dvalue <- value[i-1]*dmkt[i-1] + d.drawdowns - d.rcvd.distn
    } else {
        rcvd.distn[i] <- rcvd.distn[i-1] + value[i-1]
        dvalue <- -value[i-1]
    }
    value[i] <- value[i-1] + dvalue
}


# Harmonic Series

# How We Got From There To Here:
# A Story of Real Analysis
# rate of convergence: page 130 - 132,
# Harmonic Series also appears on pages 56 and 150.
n <- 10^9
a <- 0
for (i in 1:n) {
a <- (a + (1/i))
}

a

n2 <- 10^4
a2 <- 0
for( i in 1:n2)
{
	a2 <- (a2 + (1/i))
}

a2

n3 <- 10 ^ 7
a3 <- 0
for(i in 1:n3)
{
	a3 <- (a3 + (1/i))
}

a3

n4 <- 100
a4 <- 0
for(i in 1:n4)
{
	a4 <- (a4 + (1/i))
}

print(a4)


library("car")  # load the 'car' package
data("Anscombe")  # load the data set
#?Anscombe  # read a description of the data
head(Anscombe)  # look at the first few lines of the data
pairs(Anscombe)

# response = educational expenditure
# predictors: income, young age, urban

data = list(edu=Anscombe$education, income=Anscombe$income, young=Anscombe$young, urban=Anscombe$urban)

lmod = lm(Anscombe$education ~ Anscombe$income + Anscombe$young + Anscombe$urban, data=Anscombe)
summary(lmod)

plot(predict(lmod), resid(lmod))

library("rjags")

# edu likelyhood = normal dist, predict y given the mean calculated using the yuong, urban and income coefficents
# normal prior for income, young and urban coeficents with large 1m variance to reduce correlations
# prior on variance in an inverse gamma
mod1_string = " model {
    for (i in 1:length(education)) {
        education[i] ~ dnorm(mu[i], prec)
        mu[i] = b0 + b[1]*income[i] + b[2]*young[i] + b[3]*urban[i]
    }

    b0 ~ dnorm(0.0, 1.0/1.0e6)
    for (i in 1:3) {
        b[i] ~ dnorm(0.0, 1.0/1.0e6)
    }

    prec ~ dgamma(1.0/2.0, 1.0*1500.0/2.0)
    	## Initial guess of variance based on overall
    	## variance of education variable. Uses low prior
    	## effective sample size. Technically, this is not
    	## a true 'prior', but it is not very informative.
    sig2 = 1.0 / prec
    sig = sqrt(sig2)
} "

data1_jags = as.list(Anscombe)

set.seed(72)
#data1_jags = list(y=dat$loginfant, n=nrow(dat), log_income=dat$logincome)

# choose to monitor standard dev
params1 = c("b", "sig")

inits1 = function() {
    inits = list("b"=rnorm(3, 0.0, 100.0), "prec"=rgamma(1,1.0,1.0))
}

# run the model with 3 chains each starting with inits1 params
mod1 = jags.model(textConnection(mod1_string), data=data1_jags, inits=inits1, n.chains=3)

dic.samples(mod1, n.iter=100e3)

# burn in period
update(mod1, 1000)

mod1_sim = coda.samples(model=mod1, variable.names=params1, n.iter=100e3)

# stack matrices vertically
mod1_csim = do.call(rbind, mod1_sim)

### Convergence
plot(mod1_sim)
gelman.diag(mod1_sim)
autocorr.diag(mod1_sim)
effectiveSize(mod1_sim)
summary(mod1_sim)


 DSYGV Example Program Results

 Eigenvalues
       -2.2254    -0.4548     0.1001     1.1270

 Eigenvectors
             1          2          3          4
 1      0.0690    -0.3080    -0.4469     0.5528
 2      0.5740    -0.5329    -0.0371     0.6766
 3      1.5428     0.3496     0.0505     0.9276
 4     -1.4004     0.6211     0.4743    -0.2510

 Estimate of reciprocal condition number for B
        5.8E-03

 Error estimates for the eigenvalues
        9.3E-14    2.5E-14    1.1E-14    5.1E-14

 Error estimates for the eigenvectors
        1.0E-13    2.1E-13    1.8E-13    1.4E-13


#Regresion lineal

#se cargan los datos colocando como parametros que los decimales seran separados por un ","
data <- read.table("muestra_estudiantes.txt",header=TRUE)
data
#Nombre de columnas a ignorar para este experimento, calclulo de ignora pues es la salida deseada
drops <- c("cant_mat","escuela","gestion_plantel","tipo_plantel","nivel_socioeco","nivel_estudios_padres","genero","opsu")
#se descarta Cant_cats por tener correlacion poco significativa
data <- data[ , !(names(data) %in% drops)]
data
pairs(data)
cor(data)

y <- data[,6]
y
x <- data[,1:5]
x

x11()
par(mfrow=c(1,2))
plot(y,x[,1])
plot(y,x[,2])
x11()
par(mfrow=c(1,2))
plot(y,x[,3])
plot(y,x[,4])
x11()
par(mfrow=c(1,1))
plot(y,x[,5])
#
mod1 <- lm(y ~ x[,1] + x[,2] + x[,3] + x[,4] + x[,5])
#Analsis de Modelo
summary(mod1)

# Other useful functions
coefficients(mod1) # model coefficients
confint(mod1, level=0.95) # CIs for model parameters
fitted(mod1) # predicted values
residuals(mod1) # residuals
anova(mod1) # anova table
vcov(mod1) # covariance matrix for model parameters
influence(mod1) # regression diagnostics

resi = residuals(mod1)

#para la prueba de No normalidad
shapiro.test(residuals(mod1))

#para la prueba de Homogenidad de los datos
#crear un factor
library(Rcmdr)
fac=NULL
for(i in 1:6){
fac=c(fac,rep(i,21))}
fac
levene.test(resi, fac)

#Prueba de Aletoridad de los datos
secu=c(seq(1,126))

x11()
plot(secu,resi,col="red",type="l")
abline(h = 0, v = 0, lty = 2, col = 4)
# diagnostic plots
layout(matrix(c(1,2,3,4),2,2)) # optional 4 graphs/page
plot(mod1)

ECM <- mean(resi^2)
ECM


cal.rate <- function(N.lim, r.lim) {
    rate <- function(N, r) {
        p <- (1 + r) ^ N
        0.5*(1+N)*r /(p*N*r / (p-1) - 1)
    }
    N <- seq(N.lim[1], N.lim[2])
    r <- seq(r.lim[1], r.lim[2], length.out=diff(N.lim)+1)
    z <- outer(N, r, rate)
    list(N=N, r=r, z=z)
}

plot.rate <- function(d, col="lightblue",
    theta=30, phi=20,
    r=50,
    expand=0.5,
    ltheta=90, lphi=180,
    shade=0.75,
    nticks=5) {

    # sub=expression(italic(f)~(bold(x))==frac(1,2~pi~sqrt(sigma[11]~
    # sigma[22]~(1-rho^2)))~phantom(0)^bold(.)~exp~bgroup("{",
    # list(-frac(1,2(1-rho^2)),
    # bgroup("[", frac((x[1]~-~mu[1])^2, sigma[11])~-~2~rho~frac(x[1]~-~mu[1],
    # sqrt(sigma[11]))~ frac(x[2]~-~mu[2],sqrt(sigma[22]))~+~
    # frac((x[2]~-~mu[2])^2, sigma[22]),"]")),"}"))

    persp(d$N, d$r, d$z,
    xlab="N", ylab="r", zlab="z",
    main="Plot the rate ",
    # sub=sub,
    col="lightblue",
    theta=theta, phi=phi,
    r=r,
    expand=expand,
    ltheta=ltheta, lphi=lphi,
    shade=shade,
    ticktype="detailed",
    nticks=nticks) # produces the 3-D plot

    # mtext(expression(list(mu[1]==0,mu[2]==0,sigma[11]==10,sigma[22]==10,sigma[12]==15,rho==0.5)), side=3) # adding a text line to the graph
}

if (FALSE) {
    source("./src/cal.rate.r")
    d <- cal.rate(N.lim=c(1,120), r.lim=c(0, 0.01))
    plot.rate(d=d)

}


## Plotting Sierpinski triangle. aev 4/1/17
## ord - order, fn - file name, ttl - plot title, clr - color
pSierpinskiT <- function(ord, fn="", ttl="", clr="navy") {
  m=640; abbr="STR"; dftt="Sierpinski triangle";
  n=2^ord; M <- matrix(c(0), ncol=n, nrow=n, byrow=TRUE);
  cat(" *** START", abbr, date(), "\n");
  if(fn=="") {pf=paste0(abbr,"o", ord)} else {pf=paste0(fn, ".png")};
  if(ttl!="") {dftt=ttl}; ttl=paste0(dftt,", order ", ord);
  cat(" *** Plot file:", pf,".png", "title:", ttl, "\n");
  for(y in 1:n) {
    for(x in 1:n) {
      if(bitwAnd(x, y)==0) {M[x,y]=1}
    ##if(bitwAnd(x, y)>0) {M[x,y]=1}   ## Try this for "reversed" ST
  }}
  plotmat(M, pf, clr, ttl);
  cat(" *** END", abbr, date(), "\n");
}
## Executing:
pSierpinskiT(6,,,"red");
pSierpinskiT(8);


# Dati
totale <- 12
monetevincenti <- 4
moneteperdenti <- 8

estratte <- 4

# Y = AX + B(C + DX)
A <- 2
B <- 1
C <- 4
D <- -1

# Domande

domanda1 <- 0
domanda2 <- 5
domanda3_a <- 8
domanda3_b <- 0

# Svolgimento
d_f <- dhyper(m = monetevincenti, n = moneteperdenti, k = estratte, x = c(0:estratte))
p_f <- phyper(m = monetevincenti, n = moneteperdenti, k = estratte, q = c(0:estratte))

prX <- function(k){
  n <- totale
  h <- monetevincenti
  r <- moneteperdenti

  if(k >= 0) {
    choose(h,k) * choose(n-h, r-k)/choose(n,r)
  }
  else {
    0
  }
}

primadomanda <- 1
if (domanda1 != 0) {
  for(i in 0:(domanda1 - 1)){
    primadomanda <- primadomanda - prX(i)
  }
}

y <- function(x) {
  (B*D+A)*x + B*C
}

y_invert <- function(y) {
  (y - B*C)/(A + B*D)
}

y_list <- sort(c(y(0:estratte)))
secondadomanda <- d_f[y_invert(y_list[domanda2])+1]

TRENTA <- 30

if(domanda3_a <= y_list[estratte+1]) {
  d3_primointervallo <- seq(y_invert(domanda3_a), TRENTA)
} else {
  d3_primointervallo <- seq(-TRENTA, y_invert(domanda3_a))
}

if(domanda3_b <= y_list[estratte+1]) {
  d3_secondointervallo <- seq(domanda3_b, TRENTA)
} else {
  d3_secondointervallo <- seq(-TRENTA, domanda3_b)
}

tmp <- intersect(d3_primointervallo, d3_secondointervallo)+1
tmp <- tmp[!is.na(tmp)]
if (length(tmp) > 1) {
  numeratore <- d_f[tmp]
  numeratore <- numeratore[!is.na(numeratore)]
  denominatore <- d_f[d3_secondointervallo+1]
  denominatore <- denominatore[!is.na(denominatore)]
  terzadomanda <- sum(numeratore)/sum(denominatore)
} else {
  terzadomanda <- p_f[tmp]/sum(d_f[d3_secondointervallo+1])
}

if(length(terzadomanda) == 0) {
  terzadomanda <- 0
}

# Output
print(primadomanda)
print(secondadomanda)
print(terzadomanda)


# Guía del fichero: https://rpubs.com/probestaunal/taller01

###################################################################################################
#                                  INTRODUCCIÓN A LA ESTADÍSTICA                                  #
###################################################################################################
#  1. Clasificar según su naturaleza (cualitativa, cuantitativa discreta, cuantitativa continua)  #
#     y establecer la escala de medición de las siguientes variables.                             #
###################################################################################################
# Estrato socio-económico.                                    # Cualitativa, ordinal.             #
# Sexo.                                                       # Cualitativa, nominal.             #
# Número de unidades defectuosas.                             # Cuantitativa discreta, razón.     #
# Calificación de un examen (valores: aprobado, no aprobado). # Cualitativa, nominal.             #
# Nivel educativo (valores: básica, pregrado, posgrado).      # Cualitativa, ordinal.             #
# Estatura (en metros).                                       # Cuantitativa continua, razón.     #
# Temperatura (en grados centigrados).                        # Cuantitativa continua, intervalo. #
# Edad (en años cumplidos).                                   # Cuantitativa discreta, razón.     #
# Opinión (valores: a favor, en contra, no sabe/no responde). # Cualitativa, nominal.             #
# Raza.                                                       # Cualitativa, nominal.             #
# Número de hermanos.                                         # Cuantitativa discreta, razón      #
# Utilidades anuales (en millones pesos).                     # Cuantitativa continua, razón.     #
# Tiempo requerido para ejecutar una tarea (en minutos).      # Cuantitativa continua, razón.     #
# Índice de masa corporal (en kg/m2).                         # Cuantitativa continua, razón.     #
# Concentración de dióxido de carbono (CO2, en ppm).          # Cuantitativa continua, razón.     #
# pH (valores: básico, neutro, ácido).                        # Cualitativa, ordinal.             #
# Resistencia eléctrica (en ohm).                             # Cuantitativa continua, razón.     #
# Presión (en pa).                                            # Cuantitativa continua, razón.     #
# Densidad (en kg/m3).                                        # Cuantitativa continua, razón.     #
# Latitud/longitud (en grados, minutos y segundos).           # Cuantitativa continua, intervalo. #
###################################################################################################


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

# https://cran.r-project.org/web/packages/GA/vignettes/GA.html#constrained-optimisation
func3d <- function(x)
{
  100*(x[1]^2-x[2]^2)+(1-x[1])^2
}

c1 <- function(x)
{
  x[1]*x[2] + x[1] - x[2] + 1.5
}

c2 <- function(x)
{
  10 - x[1]*x[2]
}

x1LBound <- 0
x1RBound <- 1
x2LBound <- 0
x2RBound <- 13

ngrid <- 250
x1 <- seq(x1LBound, x1RBound, length = ngrid)
x2 <- seq(x2LBound, x2RBound, length = ngrid)
x12 <- expand.grid(x1, x2)
col <- adjustcolor(bl2gr.colors(4)[2:3], alpha = 0.2)
plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
image(x1, x2, matrix(ifelse(apply(x12, 1, c2) <= 0, 0, NA), ngrid, ngrid), col = col[2], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = 21, add = TRUE)

fitness <- function(x)
{ r
  f <- -func3d(x)                    # we need to maximise -func3d(x)
  pen <- sqrt(.Machine$double.xmax)  # penalty term
  penalty1 <- max(c1(x),0)*pen       # penalisation for 1st inequality constraint
  penalty2 <- max(c2(x),0)*pen       # penalisation for 2nd inequality constraint
  f - penalty1 - penalty2            # fitness function value
}

GA <- ga("real-valued", fitness = fitness,
         lower = c(x1LBound, x2LBound), upper = c(x1RBound, x2RBound),
         # selection = GA:::gareal_lsSelection_R,
         maxiter = 1000, run = 200, seed = 123)
summary(GA)

fitness(GA@solution)
func3d(GA@solution)
c1(GA@solution)
c2(GA@solution)

plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
image(x1, x2, matrix(ifelse(apply(x12, 1, c2) <= 0, 0, NA), ngrid, ngrid), col = col[2], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = 21, add = TRUE)
points(GA@solution[1], GA@solution[2], col = "dodgerblue3", pch = 3)  # GA solution


efficient_frontier = function(MRet,rangeMu)
{
  uM = dim(MRet)[1]
  pM = dim(MRet)[2]
  #compute the portfolio's expected returns
  expRet = colMeans(MRet)

  #use sample variance matrix (does not change anything compared to pop. so this one
  #is unbiased!)

  Omega = var(MRet)
  # expVar = t(weights)%*%Omega%*%weights

  #create a matrix of expected returns and constraints: t(E) and t(1) right and only one
  #cause its the returns of each and the weight of each that we scale to one
  unityVec = rep(1,pM)

  A = rbind(expRet,unityVec)
  print(A)

  # compute var in function of expected returns independently of the weights:
  n = length(rangeMu)
  myVar = rep(NA,n)
  myWeights = matrix(data=NA,nrow=n,ncol=pM)

  for(i in 1:n)
  {
    b = matrix(data=c(rangeMu[i],1),nrow=2)
    myVar[i] = t(b)%*%solve(A%*%solve(Omega)%*%t(A))%*%b
    myWeights[i,] = solve(Omega)%*%t(A)%*%solve(A%*%solve(Omega)%*%t(A))%*%b
  }

  # dev.new()
  mySd = myVar^0.5
  return(mySd)

  # plot(mySd,rangeMu,t='l')
  # Ones = matrix(data=c(1,1),nrow=2)
  # weightsMinVar = solve(Omega)%*%Ones%*%solve(t(Ones)%*%solve(Omega)%*%Ones)
  # muMinVar = t(weightsMinVar)%*%expRet
  #case where we want the sum of the weights to sum to one (less efficient and more risky
  #(we want to achieve a kind of zero investment portfolio.)
  # bMax = matrix(data=c(targetMu,1),nrow=2)
  # print(bMax)

  # bMax = rbind(targetMu,)
  # case where target weights sum to zero - better for us.
  # bMaxZero = matrix(data=c(targetMu,0),nrow=2)
  # bMaxZero = rbind(targetMu,0)
  # weightsMinVarTarget = solve(Omega)%*%t(A)%*%solve(A%*%solve(Omega)%*%t(A))%*%bMaxZero
}

efficient_frontier_single = function(MRet)
{
  rangeMu = seq(0.001,0.025,0.01)
  mySd = efficient_frontier(MRet,rangeMu)

  dev.new()
  plot(mySd*100,rangeMu*100,xlab="volatility (%)",ylab="expected return (%)")
}

efficient_frontier_simul = function(MRet)
{
  pM = dim(MRet)[2]
  rangeMu = seq(-0.01,0.05,0.001)
  mySd = efficient_frontier(MRet[,1:9],rangeMu)

  dev.new()
  plot(mySd*100,rangeMu*100,xlab="volatility (%)",ylab="expected return (%)",t='l',xlim=c(0,max(mySd*100)),ylim=c(-1,5))

  for(j in 10:pM)
  {
    mySd = efficient_frontier(MRet[,1:j],rangeMu)
    lines(mySd*100,rangeMu*100,col='red')
    # Sys.sleep(0.5)
  }
}


PATH <- '00_data/AUTOPREISE.CSV'

AP <- read.csv(PATH)

with(AP, plot(KW, VERBR))

AP_FORMULA <- VERBR ~ KW

AP_MODEL <- lm(AP_FORMULA, AP)
AP_MODEL
summary(AP_MODEL)

abline(AP_MODEL, lwd = 2, col = 'red')
plot(AP_MODEL)

VERBR_PREDICTION <- predict(AP_MODEL, AP)
head(data.frame(AP$VERBR, VERBR_PREDICTION))

plot(AP$VERBR, VERBR_PREDICTION,
		 xlim = c(0, 30),
		 ylim = c(0, 30))
abline(y ~ x, coef = c(0, 1))


require(poweRlaw)
source("power_fun.r")
#Create distribution object
#
m <- displ$new()
m$setXmin(1);m$setPars(2.51)
#
#Generate random numbers            #
#
testP <- dist_rand(m, 100)

m$setXmin(30);m$setPars(1.51)

testP <- c(testP,dist_rand(m, 100))

m <- displ$new(testP)

(e1 <- estimate_pars(m))
plot(m,pch=19, col="violet")
m$setPars(e1$pars)
lines(m,col=2)

(e2 = estimate_xmin(m))
m$setPars(e2$pars);m$setXmin(e2$xmin)
lines(m,col=4)

(est<-discpowerexp.fit(testP,1))

x <- sort(unique(testP))
x <- x[x>=est$threshold]
y<-pdiscpowerexp(x,est$exponent,est$rate,est$threshold)

lines(x,y,col=3)

cdfplot_displ_exp(testP,e1$pars,est$exponent,est$rate,1)

# Use contiuous power laws

m <- conpl$new(testP)

(e2 <- estimate_pars(m))
plot(m,pch=19, col="violet")
m$setPars(e1$pars)
lines(m,col=2)

ex <- conexp$new(testP)
(e3 <-estimate_pars(ex))
ex$setPars(e3$pars)
lines(ex,col=3)

(es1<-powerexp.fit(testP,1))
x <- sort(unique(testP))
x <- x[x>=es1$xmin]
y<-ppowerexp(x,es1$xmin,es1$exponent,es1$rate,lower.tail=F)

lines(x,y,col=1)


library(simecol)
library(reshape2)
library(ggplot2)

acutehiv <- new("odeModel",
  main = function(time, init, parms, ...){
    with(as.list(c(init,parms)),{
    # ODEs
    N <- S+I1+I2
    dS <- lambd-beta1*c*S*I1/N-beta2*c*S*I2/N-mu*S
    dI1 <- beta1*c*S*I1/N+beta2*c*S*I2/N-alpha*I1-mu*I1
    dI2 <- alpha*I1-mu*I2-gamma*I2
    list(c(dS,dI1,dI2))
   })},
  parms = c(beta1=1./50,beta2=1./200,c=1,alpha=1./8,gamma=1./520,mu=1./(70*52),lambd=10000./(70*52)),
  times = c(from=0,to=60*52,by=1),
  init = c(S=9999,I1=1,I2=0),
  solver = "lsoda"
)

acutehiv <- sim(acutehiv)

acutehiv.out <- out(acutehiv)
acutehiv.out.long <- melt(as.data.frame(acutehiv.out),"time")

# Plot
ggplot(acutehiv.out.long,aes(x=time,y=value,colour=variable,group=variable)) +
  geom_line(lwd=2) + xlab("Time") + ylab("Number") + scale_y_log10()


## calculate net and zernike fit wavefronts from any of psifit, fftfit, vortexfit

wf_net <- function(wf.raw, cp, options) {

  nr <- nrow(wf.raw)
  nc <- ncol(wf.raw)
  prt <- pupil.rhotheta(nr, nc, cp)
  rho <- prt$rho
  theta <- prt$theta
  if (options$sgs > 1) {
    subs <- matrix(FALSE, nr, nc)
    subs[seq(1, nr, by=options$sgs), seq(1, nc, by=options$sgs)] <- TRUE
    subs[is.na(rho)] <- FALSE
  } else {
    subs <- !is.na(rho)
  }
  wf.v <- wf.raw[subs]
  rho.v <- rho[subs]
  th.v <- theta[subs]
  rho.v <- rho.v[!is.na(wf.v)]
  th.v <- th.v[!is.na(wf.v)]
  wf.v <- wf.v[!is.na(wf.v)]
  fit <- fitzernikes(wf.v, rho.v, th.v,
                     eps=cp$obstruct,
                     maxorder=options$maxorder,
                     nthreads=options$nthreads,
                     uselm=options$uselm,
                     isoseq=options$isoseq)
  if (options$uselm) {
    cfit <- coef(fit)
  } else {
    cfit <- fit
  }
  if (options$isoseq) {
    ind.ptf <- c(1:3, 5)
    ind.sa4 <- 13
    ind.sa6 <- 25
    ind.astig <- c(6, 4)
    ind.coma <- 8:9
    zc.low <- numeric(28)
  } else {
    ind.ptf <- 1:4
    ind.sa4 <- 9
    ind.sa6 <- 16
    ind.astig <- 5:6
    ind.coma <- 7:8
    zc.low <- numeric(16)
  }
  if (sign(cfit[ind.sa4])*sign(options$satarget[1]) < 0) {
    cfit <- -cfit
    wf.raw <- -wf.raw
    if (!options$uselm) fit <- -fit
  }

  zc.low[ind.ptf] <- cfit[ind.ptf]
  zc.low[c(ind.sa4, ind.sa6)] <- zc.low[c(ind.sa4, ind.sa6)] + options$satarget
  zc.low[ind.astig] <- zc.low[ind.astig] + options$astig.bath
  if (is.element(6, options$zc0)) {
    zc.low[ind.coma] <- cfit[ind.coma]
  }
  wf.net <- wf.raw - pupil(zcoef=zc.low, maxorder=6, isoseq=options$isoseq,
                           nrow=nr, ncol=nc, cp=cp)
  if (options$plots) {
    if (tolower(.Platform$OS.type) == "windows") {
      windows(width=18, height=6)
    } else {
        x11(width=18, height=6)
    }
    split.screen(figs=c(1,3))
    screen(1)
    plot(wf.net, cp=cp, col=options$colors, addContours=FALSE)
    mtext(paste("RMS = ", format(pupilrms(wf.net),digits=3)))
  }
  zcoef.net <- cfit
  zcoef.net[1:length(zc.low)] <- zcoef.net[1:length(zc.low)] - zc.low
  wf.smooth <- pupil(zcoef=zcoef.net, maxorder=options$maxorder, isoseq=options$isoseq,
                     cp=cp, nrow=nr, ncol=nc)
  if (options$plots) {
    screen(2)
    plot(wf.smooth, cp=cp, col=options$colors)
    mtext(paste("RMS = ", format(pupilrms(wf.smooth),digits=3)))
  }
  wf.residual <- wf.net - wf.smooth
  if (options$plots) {
    screen(3)
    plot(wf.residual, cp=cp, col=grey256, addContours=FALSE)
    mtext(paste("RMS = ", format(pupilrms(wf.residual),digits=3)))
    close.screen(all.screens=TRUE)
  }
  list(wf.net=wf.net, wf.smooth=wf.smooth, wf.residual=wf.residual,
       fit=fit, zcoef.net=zcoef.net[-1])
}

#' Methods for class "wf_fitted"
#'
#' Summary, print, and plot methods for the returned list of values
#'  from [psifit()], [fftfit()], or [vortexfit()]
#'
#' @param wffit the return values from one of the fringe analysis routines
#' @param digits number of digits to display in print and summary methods
#' @param ... values passed to [plot.pupil()]
#' @return print method returns data frame with Zernike coefficients
summary.wf_fitted <- function(wffit, digits=3) {
  cat("Image size(s)     : ", nrow(wffit$wf.smooth), " x ", ncol(wffit$wf.smooth), "\n")
  cat("Unsmoothed RMS    : ", format(pupilrms(wffit$wf.net), digits=digits), "\n")
  cat("Zernike fit RMS   : ", format(sqrt(crossprod(wffit$zcoef.net)), digits=digits), "\n")
  cat("Zernike fit Strehl: ", format(strehlratio(sqrt(crossprod(wffit$zcoef.net))), digits=digits), "\n")
  cat("Zernike fit P-V   : ", format(pupilpv(wffit$wf.smooth), digits=digits), "\n")
  cat("PVr               : ", format(PVr(wffit$wf.smooth, wffit$wf.residual), digits=digits), "\n")
}

print.wf_fitted <- function(wffit, digits=3) {
  if (is.element("lm", class(wffit$fit))) {
    fit <- coef(wffit$fit)
  } else {
    fit <- wffit$fit
  }
  nz <- length(wffit$zcoef.net)
  znames <- paste("Z", 0:nz, sep="")
  df.zernikes <- data.frame(Z = znames, Zcoef.Raw = fit, Zcoef.net = c(0, wffit$zcoef.net))
  summary.wf_fitted(wffit, digits=digits)
  cat("\n")
  print(df.zernikes, digits=digits, row.names=FALSE)
  invisible(df.zernikes)
}

plot.wf_fitted <- function(wffit, wftype="smooth", ...) {
  wf <- get(paste("wf", wftype, sep="."), wffit)
  plot.pupil(wf, cp=wffit$cp, ...)
}


#
# Don't complain; just work harder! Dan Stanford
#
# Our responsibility is to do what we can, learn what we can, improve the solutions, and pass them on. RF
#
# @author: me@andreagirardi.it
# @since: Wed Jan 22 17:29:30 CET 2020
# @project: RExercises
# @module: ggplot2 samples
# @desc:
#
# @prerequisite
#   install.packages('ggplot2')
#   library(ggplot2)
#   library(ggthemes)
#   mtcars

# Histogram of hwy mpg values - histogram is frequency count so, on aes, one single value is passed
> ggplot(mpg, aes(x = hwy)) + geom_histogram(fill ="red", alpha = 0.5, bins = 30)

# Barplot of car counts per manufacturer with color fill defined by cyl count
# NOTE: X axis is not a continous variable, it is a discrete one meanings we have different groups of manufacturer
> ggplot(mpg, aes(x = mpg$manufacturer)) + geom_bar(aes(fill=factor(mpg$cyl)))

# Create a scatterplot of volume versus sales. Afterwards play around with alpha and color arguments to clarify information.
> head(txhousing)
> ggplot(txhousing, aes(x = txhousing$sales, y=txhousing$volume)) + geom_point(color = "blue", alpha = 0.5)

# Add a smooth fit line to the scatterplot from above. Hint: You may need to look up geom_smooth()
> ggplot(txhousing, aes(x = txhousing$sales, y=txhousing$volume)) + geom_point(color = "blue", alpha = 0.5) + geom_smooth(color = "red")


require(Rgraphviz)
require(gRbase)
require(gRim)

# Undirected graphs
undirected.graph = ug(~a:b:e + a:c:e + b:d:e + c:d:e + c:g + d:f)
plot(undirected.graph)

# Subset of a graph
subset.graph = subGraph(c("a", "b", "e"), undirected.graph)

# Directed graphs
directed.graph = dag(~a + b:a + c:a:b + d:c:e + e:a)
plot(directed.graph)

# Moralize a DAG
plot(moralize(directed.graph))

# Parents and children
parents("c", directed.graph)
children("c", directed.graph)

# Is the graph complete?
is.complete(undirected.graph, set=c("a", "b"))

# Ancestral graph of a node
ag = ancestralGraph(c("d"), directed.graph)
plot(ag)

# For A->B->C
# Conditional probablity tables
arr.a = parray("A", levels=2, values=c(.01,.99)))
arr.ba = parray(c("B","A"), levels=c(2,2), values=c(.95,.05, .001,.999))
arr.cb = parray(c("C","B"), levels=c(2,2), values=c(.80,.20, .010,.990))

# Joint distributions
arr.a.ba = tableMult(arr.a, arr.ba)
arr.a.ba.cb = tableMult(arr.a.ba, arr.cb)

# Marginal distributions
mar.ab = tableMargin(arr.a.ba.cb, margin=c('A','B'))
mar.b = tableMargin(mar.ab, margin=c('B'))

# Conditional probability tables using gRain
require(gRain)
yn = c("yes","no")
a    = cptable(~asia, values=c(1,99),levels=yn)
t.a  = cptable(~tub+asia, values=c(5,95,1,99),levels=yn)
s    = cptable(~smoke, values=c(5,5), levels=yn)
l.s  = cptable(~lung+smoke, values=c(1,9,1,99), levels=yn)
b.s  = cptable(~bronc+smoke, values=c(6,4,3,7), levels=yn)
e.lt = cptable(~either+lung+tub,values=c(1,0,1,0,1,0,0,1),levels=yn)
x.e  = cptable(~xray+either, values=c(98,2,5,95), levels=yn)
d.be = cptable(~dysp+bronc+either, values=c(9,1,7,3,8,2,1,9), levels=yn)

# Compile conditional prob table
plist = compileCPT(list(a, t.a, s, l.s, b.s, e.lt, x.e, d.be))
bnet = grain(plist)

plist
par(mfrow=c(2,1))
plot(bnet)
plot(triangulate(moralize(bnet$dag)))

# Querying and updating beliefs
querygrain(bnet, nodes=c('lung','tub','bronc'))
bnet.f <- setFinding(bnet, nodes=c('asia','dysp'), state=c('yes','yes'))
pFinding(bnet.f)
querygrain(bnet.f, nodes=c('lung','tub','bronc'))


## 3. Importing Data into R ##

library(readr)
recent_grads<-read_csv('recent_grads.csv')

## 5. Indexing Data Frames ##

college_majors<-recent_grads$Major
unemployment_subset<-recent_grads[c(1,3,5),'Unemployment_rate']

## 6. Selecting Data Columns ##

library(dplyr)
recent_grads_select<-recent_grads %>%
    select(Major,Major_category,Total,Men,Women,Median,Unemployment_rate)

## 7. Adding a New Column ##

recent_grads_select <- recent_grads %>%
    select(Major, Major_category, Total, Men, Women, Median, Unemployment_rate)
recent_grads_select<-recent_grads_select %>%
   mutate(Women_percent=Women/Total*100)

## 8. Filtering by a Single Condition ##

dim(recent_grads_select)
recent_grads_health<-recent_grads_select %>%
    filter(Major_category=='Health')
recent_grads_money<-recent_grads_select %>%
    filter(Median>70000)

## 9. Filtering by Multiple Conditions: Meeting At Least One Criterion ##

recent_grads_science<-recent_grads_select %>%
   filter(Major_category=='Biology & Life Science' | Major_category=='Physical Sciences')

## 10. Filtering by Multiple Conditions ##

potential_majors<-recent_grads_science %>%
    filter(Median>=40000 & Women_percent>40)

## 11. Arranging Data Frames by Variables ##

my_majors<-potential_majors %>%
  arrange(Unemployment_rate,desc(Median))


### 제0장 패키지의 인스톨 ####

install = function(packages){
  new.packages <- packages[!(packages %in% installed.packages()[, "Package"])]
  if (length(new.packages))
    install.packages(new.packages, dependencies = TRUE)
  sapply(packages, require, character.only = TRUE)
}

required.packages = c("mosaic", "mosaicCalc", "distrEx", "distrTeach", "TeachingDemos", "stats4", "tkrplot")
install(required.packages)

## 1. 동전 던지기의 분포 ####

 n_num =10000
 r_rflip = do(n_num) * rflip(2)

# 앞면의 수의 분포 근삿값
 taa = tally(~heads, data=r_rflip)
  taa/n_num
 histogram(~ heads, data=r_rflip, width=1)

### 2. 기댓값 구하기 ####

f  = makeFun(2*exp(-2*x) ~ x)
F  = antiD(x*f(x) ~ x)
Ex = F(Inf) - F(0)

r_exp = rexp(10000,2)
mean(r_exp)

### 3. 이항분포의 포아송분포 근사 ####

 Poisson_2 = Pois(2)
 Binom_21  = Binom(10, 0.2)
 Binom_22  = Binom(100, 0.02)

 par(mfrow=c(3,1))
 plot(Poisson_2, mfColRow = FALSE, to.draw.arg="d", ylab="")
 plot(Binom_21, mfColRow = FALSE, to.draw.arg="d", ylab="", xlim=c(0, 12))
 plot(Binom_22, mfColRow = FALSE, to.draw.arg="d", ylab="", xlim=c(0, 12))

 par(mfrow=c(1,1))

### 4. 이항분포의 정규분포 근사 ####

 plotDist("binom", size=100, prob=.30, col=2, lwd=2) +
  plotDist("norm", mean=30, sd=sqrt(100 * .3 * .7), add=TRUE)

### 5. 합의 분포 #####
 n=100000
 X1 = rnorm(n,1,1)
 X2 = rnorm(n,2,1)
 SX = X1+X2
 plot(density(SX, bw=0.8), xlim=c(-4,9),ylim=c(0,0.35), main="", xlab="")
  lines(density(X1, bw=0.8),lty=2, col=4)
  lines(density(X2, bw=0.8),lty=2, col=2)
  legend("topright", c(expression(X[1]+X[2]),
    expression(X[1]), expression(X[2])), lty=c(1,2,2), col=c(1,4,2))

### 6. 대수의 법칙 ####

 illustrateLLN(Distr = Pois(2), main="Posssion(2)")

### 7. 중심극한정리 ####

  clt.examp(1)
  clt.examp(5)
  clt.examp(10)
  clt.examp(30)
  par(mfrow=c(1,1))

### 8. 검정력의 비교 ####
run.power.examp()

### 9. 신뢰구간의 비교 ####
run.ci.examp()


#Class script to introduce atomic vectors
#02/08/2022
#RCS

#Using the assignment operator
x <- 5
x <- 3+3
y = 4 #legal but not best
y = y + 1.1
print(y)

#Naming variables
x <- 3
plantHeight <- 10 #camelCaseformatting
plant.height <- 9 #collides with other r format
plant_format <- 3 #snake_case_formatting. supposedly most readable
. <- 5.5 #reserve for a generic, temp holding variable
z <- . #for passing

#data types in R are organized by dimensions
#1 dimension
#2 dimensions
#n dimensions

#data are either homogenous or hetergenous
#see class notes for more discussion

#one dimensional atomic vectors

#the combine (or concatenate) function
z <- c(3.2,5,5,6)
print(z)

typeof(z) #tells you type of variable
is.numeric(z) #tells you whether a variable is numeric
is.character(z) #tells you whether a variable is character

#C always *flattens* elements*
z <- c(c(3,4),c(5,6))
z

#character string braceted w/ " or '
z <- c('perch','bass','trout')
z

#quotes can be imbedded
z <- c("This is only 'one' character string", "another character 'string'")
z

#building logicals / boolean variables
z <- c(TRUE, TRUE, FALSE)
typeof(z)
is.logical(z)
is.integer(z)

#length tells how many elements
length(x)
length(z)
#length(Z) #not found because Z (capitol) doesn't exist

#Names of vector elements
#Optional attribute - a form of metadata
z <- runif(5)
z
names(z)
names(z) <- c('chow','beagle','pug','akita','mutt')
print(names(z))
print(z)

#add names as variable is built
z2 <- c(gold=3.3, silver=10, lead=2)
z2

#reset names
names(z2) <- NULL
z2
names(z2) <- c('copper','zinc')
z2

#use length and check individual elements with []
length(z)
z
z[3]
typeof(z[3])

#problems with NA for functions
z <- c(3.2,3.3, NA)
z
length(z)
typeof(z)
typeof(z[3])

is.na(z) #tells you which values are NA
mean(z) #NA b/c z has an NA value
!is.na(z) #NOT NA
mean(z[!is.na(z)]) #mean of subset of z that doesn't have NA

#NaN, -Inf, Inf
#NaN = Not a number
0/0
1/0
-1/0

#feature 1 of vecotrs: coercion
z <- c(0,'o')
typeof(z)

a <- runif(10)
a

#comparison operator yields a logical

a > 0.5

#doing math operations on a logcail coerces to a integer

#Ex: how many elements are greater than 0.5
sum(a > 0.5)

#proportion of elements meeting a condition
mean(a < 0.2)
mean(a > 0.2)
mean(a > 2)

#feature 2: vectorization
z <- c(10,20,30)
z + 1

#what happens when 2 vectors are added
y <- c(1,2,3)
z + y

#feature 3: recycling
z <- seq(1:6)
x <- c(10,20,30)
z+x

x <- c(10,20,30,40)
z+x


install.packages('multcomp')

library(multcomp) #have a look at the manual on cran
#https://cran.r-project.org/web/packages/multcomp/multcomp.pdf

#making a fake categorical for demo
mtcars$cyl = as.factor(mtcars$cyl)

#predict hp using cyl and mpg
#mpg is a numeric
#cyl is categorical
ex_ancova = aov(hp ~ cyl + mpg, data = mtcars)

summary(ex_ancova) #sig cyl

#base r
#this gives us a warning
TukeyHSD(ex_ancova, which = 'cyl')

# with this, we can compare the categoricals, even though there
# is a numeric covariate.
# could extend to multiple categricals as well, just change the mcp() accordingly
cars_mc <- glht(ex_ancova, linfct = mcp(cyl = 'Tukey'))
summary(cars_mc)

#^subtle thing I found, glht won't work as shown if you do mtcars$cyl in the initial
#call of the aov function... which is odd


##' Estimate minimum specificity from population testing
##'
##' Produces an estimate of minimum specificty under the assumption that of the tests identified only negatives as positives
##' @param positive vector of numbers; the number of positive tests in each sample
##' @param total vector of numbres; the total number of tests (positive and negative) in each sample
##' @param cutoff the cutoff for the estimate, i.e. the confidence level desired
##' @param samples number of values of specificity to sample
##' @param min_specificity minimum specificity to test
##' @param max_specificity maximum specificity to test
##' @param prevalence background prevalence; if >0 then it is assumed that
##' sensitivity is 0, i.e. all positives are still false positives and some of
##' the negatives are false negatives
##' @return estimate of the lower bound of specificity at
##' the desired confidence level
##' @author Sebastian Funk
##' @export
estimate_min_specificity <- function(positive, total, cutoff = 0.95,
                                     samples = 1000,
                                     min_specificity = 0.997,
                                     max_specificity = 1,
                                     prevalence = 0) {

  true_negative <- round(pmax(positive, total * (1 - prevalence)))

  ## create data frame with false test positive and true test negative
  dta <- tibble(positive = positive, negative = true_negative - positive)
  spec <- dta %>%
    expand_grid(specificity =
                  seq(min_specificity, max_specificity,
                      length.out = samples)) %>%
    ## probability of seeing positives given specificty is at most x
    ## (where at the maximum all positives are false positives)
    mutate(p = pbeta(1 - specificity, positive + 1,
                     negative + 1, lower.tail = FALSE)) %>%
    group_by(specificity) %>%
    ## overall probability that specificity is at most x
    summarise(probability = 1 - prod(p), .groups = "drop") %>%
    ungroup()

  min_spec <- spec %>%
    ## get probability that specificity is at least x
    filter(probability > cutoff) %>%
    summarise(min_spec = max(specificity)) %>%
    .$min_spec

  return(min_spec)
}


rm(list=ls())
library(dict)
library(ggplot2)
library(reshape)
############################################
# Defining all functions I need later
############################################

# Function for shifting the variables back - i.e. get e_{t-1} from e_t
shift <- function(x, lag) {
  n <- length(x)
  xnew <- rep(NA, n)
  if (lag < 0) {
    xnew[1:(n-abs(lag))] <- x[(abs(lag)+1):n]
  } else if (lag > 0) {
    xnew[(lag+1):n] <- x[1:(n-lag)]
  } else {
    xnew <- x
  }
  return(xnew)
}

# Function for getting x (one sample)
get_x <- function(length, a, beta){
  # Need more epsilons since I have two lags
  epsilon <- rnorm(length+2)
  # Calculating e
  e_tmp <- epsilon - (5/6)*shift(epsilon,1) + (1/6)*shift(epsilon,2)
  e <- e_tmp[3:length(e_tmp)]

  #Calculating u
  u_initial <- e[1]
  u <- u_initial
  for (i in seq(2,ts_length)){
    u_t <- a*u[i-1] + e[i]
    u <- c(u, u_t)
  }

  # Calculating x
  x <- beta_0 + u
  return(x)
}

get_coef_se <- function(x){
  x_t1 <- shift(x,1)
  x_t1 <- x_t1[2:length(x_t1)]

  y <-  x[2:length(x)]
  ols_frame <- data.frame(y, x_t1)
  modl <- lm(y ~ x_t1, data=ols_frame)
  sum <- summary(modl)

  d <- dict()
  #Adding the coefficient as well as SE
  d[['coef_and_se']] <- sum$coefficients[2,1:2]
  #Now including varaince of errors; needed for strategy 2 and 3
  d[['gamma_e']] <- sum$sigma
  d[['e']] <- sum$residuals
  return(d)
}

k <- function(z){
  c <- (6*pi*z)/5
  value <- 3/(c**2) * (sin(c)/(c)-cos(c))
  return(value)
}

covs <- function(x, h){
  x_th <- shift(x,h)[(h+1):length(shift(x,h))]
  x_t <- x[(h+1):length(x)]

  return(cov(x_t, x_th))
}

get_omega <- function(e, strategy){

  gamma_0 <- var(e)
  T <- length(e)
  sum_T <- length(e) - 2

  if (strategy == "strategy2"){
    q <- floor(T**(4/5))
  } else {
    q <- floor(T**(1/3))
  }

  sum_overh <- 0
  for (h in seq(sum_T)){
    z <- (h/(q+1))
    value <-  k(z)*covs(e,h)*2
    sum_overh <- sum_overh + value
  }

  omega_hat <- (T/(T-2))*(gamma_0 + sum_overh)
  return(omega_hat)
}

strategy1 <- function(a, a1_hat, a1_hat_se){
  t_ratio <- (a1_hat-a)/a1_hat_se
  return(t_ratio)
}

strategies_lrvar <- function(a, a1_hat, a1_hat_se, gamma_e, e, strategy){
  omega_hat <- get_omega(e, strategy)

  correction <- sqrt(gamma_e/omega_hat)
  secondterm <- ((omega_hat-gamma_e)/(2*sqrt(omega_hat))) * ((1000*a1_hat_se)/(gamma_e))

  t_ratio <- correction * (a1_hat-a)/a1_hat_se - secondterm
  return(t_ratio)
}

get_tratios <- function(x_mat, a, sample_size){
  t_ratios1 <- vector()
  t_ratios2 <- vector()
  t_ratios3 <- vector()

  for (sample in seq(sample_size)){

    # Frist getting the coefficients, gamma_e and the errors themselves
    d <- get_coef_se(x=x_mat[sample,])

    t1 <- strategy1(a=1,
                    a1_hat=d[['coef_and_se']][1],
                    a1_hat_se=d[['coef_and_se']][2])
    t_ratios1 <- cbind(t_ratios1, t1)

    t2 <- strategies_lrvar(a=1,
                           a1_hat = d[['coef_and_se']][1],
                           a1_hat_se = d[['coef_and_se']][2],
                           gamma_e = d[['gamma_e']],
                           e = d[['e']],
                           strategy="strategy2")
    t_ratios2 <- cbind(t_ratios2, t2)

    t3 <- strategies_lrvar(a=1,
                           a1_hat = d[['coef_and_se']][1],
                           a1_hat_se = d[['coef_and_se']][2],
                           gamma_e = d[['gamma_e']],
                           e = d[['e']],
                           strategy="strategy3")
    t_ratios3 <- cbind(t_ratios3, t3)
  }

  out_mat <- matrix(c(t_ratios1,
                      t_ratios2,
                      t_ratios3), nrow=3,
                    ncol=1000, byrow = TRUE)
  return(out_mat)
}

calculate_P <- function(ratio_mat, critical_val){
  samples <- dim(ratio_mat)[1]
  p_list <- vector()

  for (sample in seq(samples)){
    values <- ratio_mat[sample,]
    p <- sum((values<(critical_val))/length(values))
    p_list <- cbind(p_list, p)
  }
  return(p_list)
}

############################################
# Setting the parameters and calulating
############################################

ts_length <- 1000
sample_size <- 1000
a <- 1
beta_0 <- 1

x_mat <- matrix(NA, sample_size, ts_length)

# Filling up the matrix; each row is sample
for (sample in seq(sample_size)){
  x_mat[sample,] <- get_x(ts_length, a, beta_0)
}

ratios <- get_tratios(x_mat, 1, sample_size)
calculate_P(ratios, (-2.86))

 plotting <- function(e){

   T <- length(e) + 1
   sum_T <- length(e) - 1

   horizon <- seq(1, sum_T)
   df = data.frame('horizon' = horizon)

   for (i in cbind('strategy2', 'strategy3')){
     if (i == "strategy2"){
       q <- floor(T**(4/5))
     } else {
       q <- floor(T**(1/3))
     }

     cov_list <- vector()
     kernel_list <- vector()
     sum_overh <- 0
     for (h in seq(sum_T)){
       z <- (h/(q+1))
       value <-  k(z)
       kernel_list <- rbind(kernel_list, value)

       cov <- covs(e, h-1)
       cov_list <- rbind(cov_list, cov)
     }
     df[i] <- kernel_list
   }
   df['cov'] <- cov_list
   return(df)
 }

 results <- get_coef_se(x_mat[109,])
 res <- results[['e']]
 values <- seq(1, 998)

 df1 <- plotting(res)

p1 = ggplot(data=df1, aes(x=horizon)) +
   geom_line(aes(y=strategy2), color="#0072B2") +
   geom_line(aes(y=strategy3), color="#D55E00") +
   geom_point(aes(y=cov), alpha=0.2, colour="black", size=0.2) +
   xlab('Horizon') +
   ylab('Values') +
   ggtitle('Kernel values and covariances')

print(p1)

random

df1$cov
covs(res,1)

results[['gamma_e']]**2


runsum <- function(v) {
  rs <- c()
  for(i in 1:length(v)) {
    rs <- c(rs, sum(v[1:i]))
  }
  rs
}

grade <- function(v) {
  g <- vector("numeric", length(v))
  for(i in 1:length(v)) {
    g[v[i]] <- i-1
  }
  g
}

makespiral <- function(spirald) {
  series <- vector("numeric", spirald^2)
  series[] <- 1
  l <- spirald-1; p <- spirald+1
  s <- 1
  while(l > 0) {
    series[p:(p+l-1)] <- series[p:(p+l-1)] * spirald*s
    series[(p+l):(p+l*2-1)] <- -s*series[(p+l):(p+l*2-1)]
    p <- p + l*2
    l <- l - 1; s <- -s
  }
  matrix(grade(runsum(series)), spirald, spirald, byrow=TRUE)

}

print(makespiral(5))


xbar=31.80
ybar=2.785
Sxx=485.60
Syy=7.36
Sxy=55.810
Beta1=Sxy/Sxx
Beta0=ybar-Beta1*xbar
print(Beta1)
print(Beta0)


make_prior_data <- function(family, params, func) {
  list(
    family = get_family(family),
    # parameters = as.data.frame(params),
    parameters = params,
    prior_function = func
  )
}

describe_prior <- function(family, parameters) {
  range <- parameters[["range"]]
  parameters <- parameters[!grepl("range", names(parameters))]
  if (!is.null(range)) {
    range_text <- paste0("\n    range: ", range_as_text(range), "\n")
  }

  if (all(range == c(-Inf, Inf))) {
    range_text <- "\n"
  }

  if (class(family) == "beta") {
    range_text <- "\n"
  }

  parameter_names <- names(parameters)
  parameter_values <- unname(parameters)
  return(paste0(
    "Prior\n",
    "  Family\n    ", class(family), "\n",
    "  Parameters\n",
    paste0("    ", parameter_names, ": ", parameter_values, collapse = "\n"),
    range_text
  ))
}

range_as_text <- function(range) {
  paste0(range[1], " to ", range[2])
}

prior_data_names <- c("family", "parameters", "prior_function")

#################################################################
##                 DEFINITIONS OF THE PRIORS                   ##
#################################################################

# class definition

#' Specify a prior
#' @description Define priors using different different distribution families
#' @param family the prior distribution (see details)
#' @param ... see details
#'
#' @details
#' ## Available distribution families
#' The following distributions families can be used for the prior
#' * \code{normal} a normal distribution
#' * \code{student_t} a scaled and shifted t-distribution
#' * \code{cauchy} a Cauchy distribution
#' * \code{uniform} a uniform distribution
#' * \code{point} a point
#' * \code{beta} a beta distribution
#' The parameters that need to be specified will be dependent on the
#' family
#'
#' ## Normal distribution
#' When \code{family} is set to \code{normal} then the following
#' parameters may be be set
#' * \code{mean} mean of the normal prior
#' * \code{sd} standard deviation of the normal prior
#' * \code{range} (optional) a vector specifying the parameter range
#'
#' ## Student t distribution
#' When \code{family} is set to \code{student_t} then the following
#' parameters may be set
#' * \code{mean} mean of the scaled and shifted t prior
#' * \code{sd} standard deviation of the scaled and shifted t prior
#' * \code{df} degrees of freedom of the scaled and shifted t prior
#' * \code{range} (optional) a vector specifying the parameter range
#'
#'  ## Cauchy distribution
#' When \code{family} is set to \code{cauchy} then the following
#' parameters may be set
#' * \code{location} the centre of the Cauchy distribution (default: 0)
#' * \code{scale} the scale of the Cauchy distribution
#' * \code{range} (optional) a vector specifying the parameter range
#'
#' ## Uniform distribution
#' When \code{family} is set to \code{uniform} then the following
#' parameters must be set
#' * \code{min} the lower bound
#' * \code{max} the upper bound
#'
#' ## Point
#' When \code{family} is set to \code{point} then the following
#' parameters may be set
#' * \code{point} the location of the point prior (default: 0)
#'
#' ## Beta
#' When \code{family} is set to \code{beta} then the following
#' parameters may be set
#' * \code{alpha} the first shape parameter
#' * \code{beta} the second shape parameter
#'
#' @md
#' @return an object of class \code{prior}
#' @export
#'
#' @examples
#'
#' # specify a normal prior
#' prior(family = "normal", mean = 0, sd = 13.3)
#'
#' # specify a half-normal (range 0 to Infinity) prior
#' prior(family = "normal", mean = 0, sd = 13.3, range = c(0, Inf))
#'
#' # specify a student t prior
#' prior(family = "student_t", mean = 0, sd = 13.3, df = 79)
#'
#' # specify a truncated t prior
#' prior(family = "student_t", mean = 0, sd = 13.3, df = 79, range = c(-40, 40))
#'
#' # specify a cauchy prior
#' prior(family = "cauchy", location = 0, scale = .707)
#'
#' # specify a half cauchy prior
#' prior(family = "cauchy", location = 0, scale = 1, range = c(-Inf, 0))
#'
#' # specify a uniform prior
#' prior(family = "uniform", min = 0, max = 20)
#'
#' # specify a point prior
#' prior(family = "point", point = 0)
#'
#' # specify a beta prior
#' prior(family = "beta", alpha = 2.5, beta = 3.8)
prior <- function(family, ...) {
  if (!methods::existsMethod(signature = family, f = "make_prior")) {
    stop(family, " is not a valid distribution family")
  }
  make_prior(family = new(family), ...)
}

setGeneric("make_prior",
  function(family, ...) standardGeneric("make_prior"),
  signature = "family",
)

setMethod(
  "make_prior",
  signature(family = "normal"),
  function(family, mean, sd, ...) {
    make_prior.normal(family, mean, sd, ...)
  }
)

setMethod(
  "make_prior",
  signature(family = "point"),
  function(family, point = 0) {
    if (missing(point)) {
      warning("Point value is missing. Assuming 0", call. = FALSE)
    }
    make_prior.point(family, point)
  }
)

setMethod(
  "make_prior",
  signature(family = "uniform"),
  function(family, min, max) {
    make_prior.uniform(family, min, max)
  }
)

setMethod(
  "make_prior",
  signature(family = "student_t"),
  function(family, mean, sd, df, ...) {
    make_prior.student_t(family, mean, sd, df, ...)
  }
)

setMethod(
  "make_prior",
  signature(family = "cauchy"),
  function(family, location = 0, scale, ...) {
    make_prior.cauchy(family, location, scale, ...)
  }
)

setMethod(
  "make_prior",
  signature(family = "beta"),
  function(family, alpha, beta, ...) {
    make_prior.beta(family, alpha, beta, ...)
  }
)

truncate_normalise <- function(family, range, ...) {
  unnormalised <- function(x) get_function(family)(x = x, ...) # nolint

  truncated_function <- function(x) {
    ifelse(in_range(x, range),
      unnormalised(x),
      0
    )
  }

  constant <- 1 / integrate(
    Vectorize(truncated_function),
    range[1],
    range[2]
  )$value

  normalised <- function(x) truncated_function(x) * constant
  return(normalised)
}

#' @method prior normal
#' @usage prior(family = "normal", mean, sd, range)
#' @noRd
make_prior.normal <- function(family, mean, sd, range = NULL) { # nolint
  if (missing(mean) | missing(sd)) {
    stop("You must specify `mean` and `sd` for a normal prior", call. = FALSE)
  }

  if (sd <= 0) {
    stop("`sd` must be greater than 0")
  }

  if (missing(range)) {
    range <- get_default_range(family)
  }

  params <- list(mean = mean, sd = sd, range = range)

  func <- truncate_normalise(
    family = family,
    range = range,
    mean = mean,
    sd = sd
  )

  desc <- describe_prior(family, params)
  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = params$range,
    type = "normal",
    func = func,
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(mean = mean, sd = sd),
    function_text = paste0(
      "prior(\"normal\", mean = ",
      mean, ", sd = ",
      sd, ")"
    )
  )
}

#' @method prior point
#' @usage prior(family = "point", point)
#' @noRd
make_prior.point <- function(family, point = 0) {
  func <- function(x) get_function(family)(x = x, point = point)
  width <- 4
  range <- c(point - width, point + width)
  params <- list(point = point)
  # func <- make_distribution("point", list(point = point)) # nolint
  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)
  new(
    Class = "prior",
    data = data,
    theta_range = c(point, point),
    func = func,
    type = "point",
    dist_type = "point",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(point = point),
    function_text = paste0("prior(\"point\", point = ", point, ")"),
    desc = desc
  )
}

#' @method prior uniform
#' @usage prior(family = "uniform", min, max)
#' @noRd
make_prior.uniform <- function(family, min, max) {
  if (missing(min) | missing(max)) {
    stop("You must specify `min` and `max` for a uniform  prior", call. = FALSE)
  }

  func <- function(x) get_function(family)(x = x, min = min, max = max)
  params <- list(min = min, max = max)

  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = c(min, max),
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(mean = mean, sd = sd),
    function_text = paste0(
      "prior(\"uniform\", min = ",
      min, ", max = ", max, ")"
    )
  )
}

#' @method prior student_t
#' @usage prior(family = "student_t", mean, sd, df, range)
#' @noRd
make_prior.student_t <- function(family, mean, sd, df, range = NULL) {
  if (missing(mean) | missing(sd) | missing(df)) {
    stop("You must specify `mean`, `sd`, and `df` for a student_t prior",
      call. = FALSE
    )
  }

  if (missing(range)) {
    range <- get_default_range(family)
  }

  func <- truncate_normalise(
    family = family,
    range = range,
    mean = mean,
    sd = sd,
    df = df
  )

  params <- list(mean = mean, sd = sd, df = df, range = range)

  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = range,
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(mean = mean, sd = sd, df = df),
    function_text = paste0(
      "prior(\"student_t\", mean = ", mean,
      ", sd = ", sd,
      ", df = ", df, ")"
    )
  )
}

#' @method prior cauchy
#' @usage prior(family = "cauchy", location, scale, range)
#' @noRd
make_prior.cauchy <- function(family, location = 0, scale, range = NULL) {
  if (missing(range)) {
    range <- get_default_range(family)
  }

  func <- truncate_normalise(family = family, range = range, location = location, scale = scale)

  params <- list(location = location, scale = scale, range = range)
  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = params$range,
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(location = location, scale = scale),
    function_text = paste0(
      "prior(\"cauchy\", location = ",
      location, ", scale = ",
      scale, ")"
    )
  )
}

#' @method prior beta
#' @usage prior(family = "beta", alpha, beta)
#' @noRd
make_prior.beta <- function(family, alpha, beta, range = NULL) {
  if (missing(alpha) | missing(beta)) {
    stop("You must specify `alpha` and `beta` for a beta  prior", call. = FALSE)
  }

  if (missing(range)) {
    range <- get_default_range(family)
  }

  func <- truncate_normalise(family = family, range = range, beta = beta, alpha = alpha)
  params <- list(alpha = alpha, beta = beta, range = range)

  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = params$range,
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(alpha = alpha, beta = beta),
    function_text = paste0(
      "prior(\"beta\", alpha = ",
      alpha, ", beta = ", beta, ")"
    )
  )
}


library(generativeart)
library(ggplot2)
library(tidyr)

# set the paths
IMG_DIR <- "images/"
IMG_SUBDIR <- "./"
IMG_SUBDIR2 <- "./"
IMG_PATH <- paste0(IMG_DIR, IMG_SUBDIR)

LOGFILE_DIR <- "logfile/"
LOGFILE <- "logfile.csv"
LOGFILE_PATH <- paste0(LOGFILE_DIR, LOGFILE)

# create the directory structure
generativeart::setup_directories(IMG_DIR, IMG_SUBDIR, IMG_SUBDIR2, LOGFILE_DIR)

# set seed
seed <- generate_seeds(1)
#set.seed(seed)
set.seed(seed)
# include a specific formula, for example:
my_formula <- list(
  x = quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)),
  y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^3))
)

# making a data frame with the visualization
df <- generate_data(my_formula)

# make a file name
file_name <- generate_filename(seed, "png")

# make a plot
polar = TRUE
if (polar == TRUE) {
  plot <- df %>%
    ggplot2::ggplot(ggplot2::aes(x = x, y = y)) +
    ggplot2::geom_point(alpha = 0.1, size = 0, shape = 20) +
    ggplot2::theme_void() +
    ggplot2::coord_fixed() +
    ggplot2::coord_polar()
} else {
  plot <- df %>%
    ggplot2::ggplot(ggplot2::aes(x = x, y = y)) +
    ggplot2::geom_point(alpha = 0.1, size = 0, shape = 20) +
    ggplot2::theme_void() +
    ggplot2::coord_fixed()
}

# add background
output_plot <- plot + theme(plot.background = element_rect(fill = "#f8d0b0"))
print(output_plot)

# save an image
save_file = TRUE
if (save_file){
  # add new image to log file
  logfile <- check_logfile_existence()
  logfile <- generate_logfile_entry(logfile, my_formula, seed, file_name)

  ggsave(output_plot, filename = paste(IMG_PATH, file_name, sep = ""), width = 6, height = 6)
}


 # probability
# given
probability_A<-0.5
probability_A_Compliment<-1 - probability_A
print(probability_A_Compliment)
probability_B<-0.2
probability_B_Compliment<-1 - probability_B
print(probability_B_Compliment)
probability_A_intersection_B<-0.05
print(probability_A_intersection_B)
probability_A_union_B<-probability_A+probability_B-probability_A_intersection_B
print(probability_A_union_B)


#' Computes the infloss on the off-diagonals of two matrices
#'
#' @param A Matrix
#' @param B Matrix with the same size as A
#' @return Maximal off-diagonal difference between A and B
#' @export
infloss <- function(A, B)
{
  dif <- abs(A - B)
  diag(dif) <- rep(0, dim(A)[1])
  return(max(dif))
}

#' Computes precision of a precision matrix estimator
#'
#' @param theta True precision matrix
#' @param theta.estimate Estimator of theta
#' @return Precision of theta.estimate with theta being the target
#' @export
precision <- function(theta, theta.estimate)
{
  adj.theta <- apply(theta, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.theta) <- rep(0, dim(theta)[1])
  adj.estimate <- apply(theta.estimate, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.estimate) <- rep(0, dim(theta)[1])
  num.edges.estimate <- sum(adj.estimate)/2
  num.edges.same <- sum (apply(adj.theta - adj.estimate, c(1,2), function(x) if(x!=0) {return(1)} else{return(0)}))/2
  return(num.edges.same/ num.edges.estimate)
}

#' Compute recall of a precision matrix estimator
#'
#' @param theta True precision matrix
#' @param theta.estimate Estimator of theta
#' @return Recall of theta.estimate with theta being the target
#' @export
recall <- function(theta, theta.estimate)
{
  adj.theta <- apply(theta, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.theta) <- rep(0, dim(theta)[1])
  adj.estimate <- apply(theta.estimate, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.estimate) <- rep(0, dim(theta)[1])
  num.edges.theta <- sum(adj.theta)/2
  num.edges.same <- sum (apply(adj.theta - adj.estimate, c(1,2), function(x) if(x!=0) {return(1)} else{return(0)}))/2
  return(num.edges.same/ num.edges.theta)
}

#' Compute performance of a precision matrix estimator
#'
#' @param theta True precision matrix
#' @param theta.estimate Estimator of theta
#' @param decimal Number of decimals such that entries of absolute size 1e-decimal are set to zero
#' @return f1 F_1-score of theta.estimate with theta being the target
#' @return recall Recall of theta.estimate with theta being the target
#' @return precision Precision of theta.estimate with theta being the target
#' @export
f1score <- function(theta, theta.estimate, decimal=4)
{
  #we don't want to include edges with values like e-17 which occure due to the
  #precision matrix generation algorithm. Thats why we round...
  theta <- round(theta, decimal)
  theta.estimate <- round(theta.estimate, decimal)

  #generate the adjacency matrices. diagonal entries are set to 0
  adj.theta <- apply(theta, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.theta) <- rep(0, dim(theta)[1])
  #we use a little trick here: set values of the adjacency matrix to 2.
  #we do this so that we can count the number of same edges in an easy way:
  #if both edges are nonexistent -> adj.Theta - adj.estimate = 0
  #if one of them is existent -> adj.Theta - adj.estimate \in \{ 1, -2\}
  #if both are existent -> adj.Theta - adj.estimate = -1
  adj.estimate <- apply(theta.estimate, c(1,2), function(x) if (x!=0){return(2)} else {return(0)})
  diag(adj.estimate) <- rep(0, dim(theta)[1])

  # every edge occurs exactly 2 times
  num.edges.theta <- sum(adj.theta)/2
  num.edges.estimate <- sum(adj.estimate/2)/2

  num.edges.same <- sum(apply(adj.theta - adj.estimate, c(1,2), function(x) if(x==-1) {return(1)} else{return(0)})) / 2

  recall <- num.edges.same / num.edges.theta
  if( num.edges.estimate > 0)
  {
    precision <- num.edges.same / num.edges.estimate
    f1 <- 2 * (precision * recall)/ (precision + recall)
  }
  else
  {
    precision <- 0
    f1 <- 0
  }

  return(list("f1"=f1, "recall"=recall, "precision"=precision))
}


#########################
#scalar & mode of numbers
#########################
x <- 1 # default behaviour
print(x)
mode(x)
class(x)
typeof(x)

y <- 1L # forced to be an integer
print(y)
mode(y)
class(y)
typeof(y)

## attributes
x <- 1
attributes(x)

##Vectors: scalar & character strings
text <- "message"
print(text)
length(text)
mode(text)

##Matrices
m <- rbind(c(1,2), c(3,4))
m
attributes(m)

m <- matrix(nrow = 2, ncol = 2)
m
dim(m)
attributes(m)

##Lists
x <- list(1, "a", TRUE, 1+4i)
x
attributes(x)

x <- list(x = 1, y = "abc", d = c(1,2,3))
x

##Complex example
z <- hist(Nile)
class(z)
attributes(z)
str(z)
summary(z)

##Data Frames
d <- data.frame(list(sensor = c("temperature", "pressure")), value=c(10, 15))
d

x <- data.frame(foo = 1:4, bar = c(T, T, F, F))
x

##Factors
x <- factor(c("yes", "yes", "no", "yes", "no"))
x
class(x)
y <- unclass(x)
y

#Order levels in factors
x <- factor(c("yes", "yes", "no", "yes", "no"), levels = c("yes", "no"))
x
unclass(x)

##Implicit Coercion in Vector
y <- c(1.7, "a")
class(y)
y

y <- c(T, 2)
class(y)
y

y <- c("a", T)
class(y)
y

##Explicit Coercion
x <- 0:6
class(x)
x1 <- as.numeric(x)
class(x1)
x2 <- as.logical(x)
class(x2)
x3 <- as.character(x)
class(x3)

##Explicit Coercion - Non-Sense
x <- c("a", "b", "c")
class(x)
x1 <- as.numeric(x)
x1
class(x1)
x2 <- as.logical(x)
x2
class(x2)
x3 <- as.complex(x)
x3
class(x3)


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

# system.time(fib(40))


library(ggplot2)
library(gridExtra)
library(reshape2)
library(RColorBrewer)

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

greypal <- rev( brewer.pal(9, "Greys")[-1] )

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

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

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

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

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

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

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

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

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

## full
q <- qplot(data = plotdata, x = time, y = value, geom = "line", color = variable, xlab = "Time", ylab = "Infection Count") +
		scale_colour_manual(values = greypal,
		                    labels = paste(1:8),
		                    name = "Location") +
		theme_bw()

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

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

df2 <- data.frame(time = 0:T, loc = infec_counts)
plotdata2 <- melt(df2, id = "time")

qd <- qplot(data = plotdata2, x = time, y = value, geom = "line", color = variable, xlab = "Time", ylab = "Infection Count") +
		scale_colour_manual(values = greypal,
		                    labels = paste(1:8),
		                    name = "Location") +
		theme_bw()

ggsave(qd, filename="dataplot2.pdf", height=4, width=6.5)

## 1 v. 6, no bridge
q2 <- qplot(0:T, ssdeout[1,'I',], geom = "line") +
		geom_line(aes(y = ssdeout[6,'I',])) +
		theme_bw()

print(q2)

## 1 v. 6 bridge

## add some extra connections
neinum[1] <- neinum[1] + 1
neibmat[1,3] <- 6

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

q3 <- qplot(0:T, ssdeout[1,'I',], geom = "line") +
		geom_line(aes(y = ssdeout[6,'I',])) +
		theme_bw()

print(q3)


# Example : 1   Chapter : 8.2     Page No: 427
# Find the currents
A<-matrix(c(-1,-1,0,-1,0,0,1,0,-1,0,-1,0,0,1,1,0,0,-1,0,0,0,1,1,1),ncol=4)
AT<-t(A)
Laplacian_matrix<-AT%*%A
Laplacian_matrix<-Laplacian_matrix[-4,-4]
b<-c(1,0,0)
x<-solve(Laplacian_matrix,b)
x<-c(x,0)
print("Voltages are given by S * ")
print(x)
print("S is source")
y<--1*A%*%x
print("Currents are given by S * ")
print(y)


#' The bivariate GLMGA distribution
#'
#' @param y1 vector of quantiles.
#' @param y2 vector of quantiles.
#' @param sigma vector of parameters with length = 2.
#' @param a  common parameter with length = 1.
#' @param b vector of parameters with length = 2.
#'
#' @return Density function of the bivariate GLMGA distribution with parameters sigma, a and b.
#' @export
#'
#' @examples
#' n.grid <- 20
#' sigma <- c(0.5, 0.5)
#' a <- 20
#' b <- c(5, 5)
#' xgrid <- ygrid <- seq(0.01, 20, length.out = n.grid)
#' grid <- expand.grid("u1" = xgrid, "u2" = ygrid)
#' mtrx3d <- matrix(0, nrow = nrow(grid), ncol = 3)
#' mtrx3d[, 1] <- grid[, 1]
#' mtrx3d[, 2] <- grid[, 2]
#' for (i in 1:nrow(mtrx3d)) {
#'   mtrx3d[i, 3] <- dMGLMGA(
#'     y1 = grid[i, 1], y2 = grid[i, 2],
#'     sigma = sigma,
#'     a = a, b = b
#'   )
#' }
#' head(mtrx3d)
dMGLMGA <- function(y1, y2, sigma, a, b) {
  sigma1 <- sigma[1]
  sigma2 <- sigma[2]
  b1 <- b[1]
  b2 <- b[2]
  d <- 2
  out1 <- gamma(a + d / 2) / (gamma(a) * gamma(0.5)^d * (sigma1 * y1 * sigma2 * y2)) * ((2 * b1)^sigma1 * y1)^(-1 / (2 * sigma1)) * ((2 * b2)^sigma2 * y2)^(-1 / (2 * sigma2))
  out2 <- (((2 * b1)^(sigma1) * y1)^(-1 / sigma1) + ((2 * b2)^(sigma2) * y2)^(-1 / sigma2) + 1)^(a + d / 2)

  z <- out1 / out2
  return(z)
}


library(dplyr)
library(sjmisc)
library(sjPlot)
library(ggplot2)

data("mtcars")

names (mtcars)
head(mtcars)

newcars<-select(mtcars,c("mpg","hp","wt"))

##plot  a correlation matrix for all variables
sjp.corr (newcars)

sjt.corr (newcars,show.p = TRUE,p.numeric = TRUE)


source('base.r')

# calculate manhattan distance between vectors p, q
manhattan.distance <- function(p, q){
  return (sum(abs(p - q)))
}

# calculate median of input vector
kmedians.medians.of.columns <- function(X){

  medians = list()
  nr_of_columns <- ncol(X)

  for (i in 1:nr_of_columns){
    medians[[i]] = median(X[,i], na.rm = F)
  }

  return(unlist(medians))
}

# initialize centroids by randomly selecting vectors from the dataset
kmedians.init.centroids.with.random.selection <- function(X, nr_of_centroids){

  centroids <- list()
  nr_of_dimensions = ncol(X)

  random_indexes <- sample.int(nrow(X), nr_of_centroids)

  for (i in 1:nr_of_centroids){
    index = random_indexes[i]
    centroids[[i]] <- as.vector(X[index, ])
  }

  return (centroids)
}

# initialize centroids by calculating k-means clusters
kmedians.init.centroids.with.kmeans <- function(X, nr_of_centroids){

  centroids <- list()
  nr_of_dimensions = ncol(X)
  kmeans_result <- kmeans(X, nr_of_centroids, nstart = 25)
  kmeans_centroids <- as.matrix(kmeans_result["centers"][[1]])

  for (i in 1:nrow(kmeans_centroids)){
    centroids[[i]] <- as.vector(kmeans_centroids[i, ])
  }

  return (centroids)
}

# initialize centroids
kmedians.init.centroids <- function(X, nr_of_centroids, type){

  if (type == 'k-means')
    return(kmedians.init.centroids.with.kmeans(X, nr_of_centroids))

  return(kmedians.init.centroids.with.random.selection(X, nr_of_centroids))
}

# calculate centroid that is nearest to data_vector
kmedians.nearest.centroid <- function(centroids, data_vector){

  nr_of_centroids = length(centroids)
  distance_from_centroids = list()

  for (k in 1:nr_of_centroids){
    centroid = centroids[[k]]
    distance_from_centroids[[k]] = manhattan.distance(data_vector, centroid)
  }

  min_distance = min(unlist(distance_from_centroids))
  centroid_index = which.min(unlist(distance_from_centroids))

  return (list(centroid_index, min_distance))
}

# allocate data vectors to centroids
kmedians.allocate.to.centroids <- function(X, centroids){

  nr_of_items = nrow(X)
  centroid_allocations = matrix(nrow = nr_of_items, ncol = 1)

  for (i in 1:nr_of_items){
    data_vector <- X[i,]
    nearest_centroid <- kmedians.nearest.centroid(centroids, data_vector)
    centroid_allocations[i,1] = nearest_centroid[[1]]
  }

  return(centroid_allocations)
}

# update centroids based on median of latest allocations
kmedians.update.centroids <- function(X, centroids, centroid_allocations){

  new_centroids <- list()
  nr_of_centroids <- length(centroids)

  for (k in 1:nr_of_centroids){
    item_indexes_allocated_to_centroid <- which(centroid_allocations[, 1] == k)
    items_allocated_to_centroid <- as.matrix(X[item_indexes_allocated_to_centroid, ])

    if (nrow(items_allocated_to_centroid) == 0){
      new_centroids[[k]] <- integer(ncol(X))
    }
    else{
      items_medians <- kmedians.medians.of.columns(items_allocated_to_centroid)
      new_centroids[[k]] <- items_medians
    }
  }

  return(new_centroids)
}

# perform kmedians clustering on input data
kmedians <- function(X, centers, max_iterations = 100){

  centroids <- kmedians.init.centroids(X, centers, 'k-means')

  for (i in 1:max_iterations){

    centroid_allocations = kmedians.allocate.to.centroids(X, centroids)
    new_centroids <- kmedians.update.centroids(X, centroids, centroid_allocations)
    print(paste('Update centroids - iteration :', i, sep = " "))

    no_change_in_centroids = vectors.are.equal(unlist(centroids), unlist(new_centroids))
    if (no_change_in_centroids) { break }

    centroids = new_centroids
  }

  rownames(centroid_allocations) <- row.names(X)
  return(centroid_allocations)
}


rm(list=ls())
library(testthat)
library(ShipPowerModel)

context("Test unit conversion functions")

test_that("calcSpeedUnitConversion works",
          {
            expect_equal( calcSpeedUnitConversion(10),
                          5.144
                         )
          }
         )

test_that("calcDispUnitConversion works",
          {
           expect_equal(calcDispUnitConversion(1),
                        1/1.025)

            expect_equal(calcDispUnitConversion(tonnageDisp = c(1,2,3,4),
                                                seawaterDensity = c(1, 2,0.5,2)
                                                ),
                         c(1,1,6,2)
                         )
          }
         )


knitr::opts_chunk$set(echo = TRUE)
set.seed(2021)

library(tidyverse)
library(rBeta2009)
library(kableExtra)
library(latex2exp)
library(magrittr)
library(pwr)

gx <- function(x) {
  return(0.5 * exp(-abs(x)))
}

fx <- function(x) {
  return(exp(-(abs(x) ^ 3) / 3))
}

fgx <- function(x) {
  return(fx(x) / gx(x))
}

m <- fgx(-1)

m_gx <- function(x, m) {
  return(m * gx(x))
}

par(mfrow = c(2, 2))

curve(fx, -5, 5, xlab = "x", ylab = "f(x)",
      col = "darkgrey", lwd = 2, main = "Gráfico de f(x)")

curve(gx, -5, 5, xlab = "y", ylab = "g(y)",
      col = "darkgrey", lwd = 2, main = "Gráfico de g(y)")

curve(fgx, -4, 4, ylab = "f(x)/g(x)", main = "Gráfico de f(x)/g(x)")
points(c(-1, 1), c(m, m), pch = 20, col = "blue")
abline(h = m, lty = 2, col = "blue")
segments(c(-1, 1), c(0, 0), c(-1, 1), c(m, m), lty = 2, col = "blue")

curve(m_gx(x, m), -5, 5, col = "red", ylab = "f(x) e m*g(x)",
      main = "Gráfico de f(x) e mg(x)")
curve(fx(x), add = TRUE)
legend("topright", c("f(x)", "m*g(x)"), col = c("black", "red"),
       lty = 1, bty = "n")

gerador <- function(n) {
  nger <- n0 <- 0
  ax <- c()
  while (n0 < n) {
    rej <- TRUE
    while (rej) {
      nger <- nger + 1
      u <- runif(1)
      y <- ifelse(u <= 0.5, log(2 * u), - log(2 * (1 - u)))

      if (m * runif(1) <= fgx(y)) {
        n0 <- n0 + 1
        ax[n0] <- y
        rej <- FALSE
      }
    }
  }

  result <- list(sample = ax, n_gerado = nger)
  return(result)

}

amostra_gerada_50 <- gerador(50)
ax_50 <- amostra_gerada_50$sample

amostra_gerada_100 <- gerador(100)
ax_100 <- amostra_gerada_100$sample

amostra_gerada_400 <- gerador(400)
ax_400 <- amostra_gerada_400$sample

par(mfrow = c(2, 2))
hist(ax_50, freq = FALSE, main = "Histograma da amostra n = 50",
     xlab = "x", ylab = "Densidade",
     col = "orange", border = "brown")
hist(ax_100, freq = FALSE, main = "Histograma da amostra n = 100",
     xlab = "x", ylab = "Densidade",
     col = "orange", border = "brown")
hist(ax_400, freq = FALSE, main = "Histograma da amostra n = 400",
     xlab = "x", ylab = "Densidade",
     col = "orange", border = "brown")

amostra <- c(ax_50, ax_100, ax_400)
tamanho <- c(rep(50, length(ax_50)),
             rep(100, length(ax_100)),
             rep(400, length(ax_400)))

df <- data.frame(amostra, tamanho)

boxplot(amostra ~ tamanho,
        data = df,
        main = "Diferentes Boxplots para\ncada tamanho de amostra",
        xlab = "Tamanho da amostra",
        ylab = "Observações",
        col = "orange",
        border = "brown"
)

r <- 1000
lambda <- 2
po_sample <- function(r, lambda, n) {

  pvalue <- c()
  aceptance <- c()
  medias_v <- c()
  poder_dif <- seq(2.2, 4, length.out = 5) - 2
  power_1 <- c()

  for (i in 1:r) {

    sample_p <- rpois(n, lambda)
    media <- mean(sample_p)

    p_value <- pnorm(media, mean = lambda, sd = sqrt(1 / n * lambda))
    pvalue[i] <- p_value

    medias_v[i] <- media

    if (pvalue[i] >= 0.05) {
      aceptance[i] <- 1
    }
    else {
      aceptance[i] <- 0
    }
  }

  poder_1 <- power.t.test(n = n, delta = poder_dif[1],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "two.sided",
                          type = "one.sample")
  power_1[1] <- (as.numeric(unlist(poder_1[5])))

  poder_2 <- power.t.test(n = n, delta = poder_dif[2],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[2] <- as.numeric(unlist(poder_2[5]))

  poder_3 <- power.t.test(n = n, delta = poder_dif[3],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[3] <- as.numeric(unlist(poder_3[5]))

  poder_4 <- power.t.test(n = n, delta = poder_dif[4],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[4] <- as.numeric(unlist(poder_4[5]))

  poder_5 <- power.t.test(n = n, delta = poder_dif[5],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[5] <- as.numeric(unlist(poder_5[5]))

  results <- list(pvalor = pvalue, aceita = aceptance,
                  media = medias_v, poder = power_1)

  return(results)
}

a <- po_sample(r, lambda, 10)
b <- po_sample(r, lambda, 30)
c <- po_sample(r, lambda, 75)
d <- po_sample(r, lambda, 100)

freqa <- table(a$aceita) * 100 / sum(table(a$aceita))
freqb <- table(b$aceita) * 100 / sum(table(b$aceita))
freqc <- table(c$aceita) * 100 / sum(table(c$aceita))
freqd <- table(d$aceita) * 100 / sum(table(d$aceita))

tabela <- rbind("Amostra n = 10" = freqa, "Amostra n = 30" = freqb,
                "Amostra n = 75" = freqc, "Amostra n = 100" = freqd)
tabela_1 <- as.data.frame(tabela)

tabela_1 %>% mutate_all(linebreak) %>%
knitr::kable(tabela_1, align = "c",
             caption = "Tabela de Erro Tipo I (em %)",
             col.names = c("Rejeita Hipótese Nula",
                           "Não Rejeita Hipótese Nula"),
             format = "latex") %>%
    kable_styling(position = "center")

tabela_2 <- rbind("Amostra n = 10" = a$poder, "Amostra n = 30" = b$poder,
                  "Amostra n = 75" = c$poder, "Amostra n = 100" = d$poder)
p <- seq(2.2, 4, length.out = 5)
df2 <- data.frame(round(tabela_2, 2))

knitr::kable(df2, align = "c",
             caption = "Tabela do Poder do Teste $\\lambda \\in[2,2;4]$",
             col.names = c(paste("$\\lambda =$", p[1]),
                           paste("$\\lambda =$", p[2]),
                           paste("$\\lambda =$", p[3]),
                           paste("$\\lambda =$", p[4]),
                           paste("$\\lambda =$", p[5])),
             format = "latex", escape = F) %>%
kable_styling(position = "center")

library("rmarkdown")
render("Trabalho1/trab1.Rmd", "pdf_document")

update.packages(ask = FALSE, checkBuilt = TRUE)
tinytex::tlmgr_update()


a <- 5.0
l <- 8.0

n <- 10000
centX <- a/2 * runif(n)
alpha <- runif(n, min=0, max=pi/2)

if (l < a) {
	ifa <- (centX <= l*cos(alpha) / 2)
	p <- mean(ifa)
	print(p)
	newPi <- 2 * l / (p * a)
	print(newPi)
} else {
	minArr <- vector()
	for (i in seq(1, n))
	{
		minArr <- c(minArr, min(c(l*cos(alpha[i])/2, a/2)))
	}
	ifa <- (centX <= minArr)
	p <- mean(ifa)
	print(p)
	newPi <- 2 * l / ((p-1) * a) - 2 * (sqrt(l^2-a^2) + a*asin(a/l)) / ((p-1) * a)
	print(newPi)
}