## utilities for manipulating positions

radec2hms <- function(...) {
  radec <- unlist(list(...))
  dec <- radec[2]
  ra <- radec[1]/15
  ra.h <- trunc(ra)
  ra <- 60*(ra-ra.h)
  ra.m <- trunc(ra)
  ra.s <- 60*(ra-ra.m)
  ds <- sign(dec)
  dec.d <- trunc(dec)
  dec <- 60*abs(dec-dec.d)
  dec.m <- trunc(dec)
  dec.s <- 60*(dec-dec.m)
  cat(paste(ra.h, ra.m, format(ra.s, digits=2),sep=":"))
  if (ds >= 0) cat(" +") else cat(" -")
  cat(paste(dec.d, dec.m, format(dec.s, digits=1), sep=":"), "\n")
}

hms2radec <- function(...) {
  radec <- unlist(list(...))
  nr <- length(radec)/2
  radec <- matrix(radec,nr,2)
  ra <- radec[,1]
  dec <- radec[,2]
  ra.h <- trunc(ra)
  ra <- 100*(ra-ra.h)
  ra.m <- trunc(ra)
  ra.s <- 100*(ra-ra.m)
  ra.d <- 15*(ra.h + ra.m/60 + ra.s/3600)
  dec.sign <- sign(dec)
  dec <- abs(dec)
  dec.d <- trunc(dec)
  dec <- 100*abs(dec-dec.d)
  dec.m <- trunc(dec)
  dec.s <- 100*(dec-dec.m)
  dec.d <- dec.sign*(dec.d+dec.m/60+dec.s/3600)
  list(ra=ra.d, dec=dec.d)
}

lb2radec <- function(...) {
  rotm <- matrix(c(-.054876, -.873437, -.483835,
        .494109, -0.444830, .746982,
        -0.867666, -0.198076, 0.455984), 3, 3)
  lb <- unlist(list(...))
  nr <- length(lb)/2
  lb <- matrix(lb, nr, 2)
  l <- pi*lb[,1]/180
  b <- pi*lb[,2]/180
  x.lb <- rbind(cos(b)*cos(l), cos(b)*sin(l), sin(b))
  x.ad <- rotm %*% x.lb
  a <- atan2(x.ad[2,], x.ad[1,])
  a[a<0] <- 2*pi+a[a<0]
  d <- asin(x.ad[3,])
  ad <- data.frame(ra=a*180/pi, dec=d*180/pi)
  ad
}

radec2lb <- function(...) {
    rotm <- t(matrix(c(-.054876, -.873437, -.483835,
        .494109, -0.444830, .746982,
        -0.867666, -0.198076, 0.455984), 3, 3))
    radec <- unlist(list(...))
    nr <- length(radec)/2
    radec <- matrix(radec,nr,2)
    ra <- pi*radec[,1]/180
    dec <- pi*radec[,2]/180
    x.ad <- rbind(cos(ra)*cos(dec),sin(ra)*cos(dec),sin(dec))
    x.lb <- rotm %*% x.ad
    l <- atan2(x.lb[2,], x.lb[1,])
    l[l<0] <- 2*pi+l[l<0]
    b <- asin(x.lb[3,])
    lb <- data.frame(l=180*l/pi, b=180*b/pi)
    lb
}


result = 0
b = 1
for i in range(0,n):
    temp = result
    result = b
    b = temp + b


#' f_bbgd
#'
#' The descent algorithm with Barzilar-borwein stepsize
#'
#' @param v_y   vector of y
#' @param v_x   vector of x
#' @param v_k0  vector of internal knots for covariates
#' @param v_m   vector of orders for covariates
#'
#' @param init initialization for $\beta$
#' @param v_smooth  vector of smoothing parameters
#' @param maxit maximum number of iterations
#' @param eps   stopping critria threshhold
#' @param eta   stopping criteria for gradient size
#' @param trace indicator whether to plot trace
#'
#'
#' @return the estimated $\beta$
#'
f_bbgd <- function(v_y, v_x, v_k0, v_m, init = NULL,
                        v_smooth = rep(1, 3),
                        maxit = 1e4, eps = 1e-3, eta = NULL, trace = NULL) {

#-------------------------------------------------------
##### set up #####
#-------------------------------------------------------
    function_call <- match.call()
    x_ord <- order(v_x)
    v_x <- v_x[x_ord]
    v_y <- v_y[x_ord]
    s_center <- mean(v_x)
    s_sd <- sd(v_x)
    v_x <- c(scale(v_x))
    iter <- 0L
    converge <- F
    #Define dimensions
    k1 <- v_k0[1]; k2 <- v_k0[2]; m1 <- v_m[1]; m2 <- v_m[2]
    #Require
    m_n1 <- f_n1(v_x, k1, m1)
    m_g1 <- f_g1(k2, m2)
    m_g2 <- f_g2(k2, m2)
    m_sigmatau <- f_sigmatau(k2 + m2)
    m_sigma <- f_sigma(k1 + m1, k2 + m2)
    m_s <- f_mats(k1 + m1, k2 + m2, v_smooth)
    n_m2 <- rep(0, k2 + m2); n_m2[k2 + m2] <- 1

    #Precalculate
    m_h1 <- f_h1(m_n1, m_g1, m_g2, m_sigmatau, n_m2)

    #Initialization
    if (is.null(init)) {
        init <- f_init(v_y, v_x, m_sigma, m_n1, v_k0, v_m, m_s)
    }
    til_beta0 <- init
    v_beta0 <- og_beta(til_beta0, k1 + m1, k2 + m2)
    v_grad0 <- 0

    #Calculate H2 (most time consuming)
    v_taustar <- f_tausearch(v_y, m_n1, til_beta0, m_sigma, k2, m2)
    m_ntau <- f_ntau(v_taustar, k2, m2)
    m_h2 <- f_h2(m_n1, m_ntau, m_g1, m_sigmatau)

    ##Loss
    s_loss <- f_loss(v_beta0, til_beta0, v_taustar, v_y, m_sigma, m_h1, m_h2, m_s)

    ##trace
    if (!is.null(trace)) {
        con_quan <- list(
                    x = v_x,
                    y = v_y,
                    center = s_center,
                    sd = s_sd,
                    v_k0 = v_k0,
                    v_m = v_m,
                    m_sigma = m_sigma,
                    n1 = m_n1,
                    til_beta = til_beta0,
                    iter = iter,
                    loss = s_loss,
                    alpha = 0,
                    bet = 0)
        cq_plot(trace, con_quan)
    }

    #Standard gradient updates
    v_deriv <- f_lossderiv(til_beta0, v_k0 + v_m, m_sigma, m_h1, m_h2)
    v_grad1 <- f_grad(v_beta0, v_deriv, m_s)
    #Calculate new coefficients
    s_step <- 0.25
    v_beta1 <- v_beta0 - s_step * v_grad1
    til_beta1 <- tilde_beta(v_beta1, k1 + m1, k2 + m2)
    new_loss <- f_loss(v_beta1, til_beta1, v_taustar, v_y, m_sigma, m_h1, m_h2, m_s)

    #Repeat
    while (maxit > iter) {
        iter <- iter + 1

        #Calculate difference
        v_delta <- v_beta1 - v_beta0
        v_gdiff <- v_grad1 - v_grad0

        #bb stepsize
        s_delgrad <- crossprod(v_delta, v_gdiff)
        step1 <- crossprod(v_delta) / s_delgrad
        step2 <- s_delgrad / crossprod(v_gdiff)
        s_step <- min(step1, step2, 100)
        if (s_step < 0) s_step <- 0.25

        #update v_beta0, til_beta0, v_grad0, s_loss
        v_beta0 <- v_beta1
        til_beta0 <- til_beta1
        v_grad0 <- v_grad1
        s_loss <- new_loss

        #Update H2 (most time consuming)
#ptm <- proc.time()# Start the clock!
        v_taustar <- f_tausearch(v_y, m_n1, til_beta1, m_sigma, k2, m2)
#print(proc.time() - ptm)# Stop the clock
        m_ntau <- f_ntau(v_taustar, k2, m2)
        m_h2 <- f_h2(m_n1, m_ntau, m_g1, m_sigmatau)

        #Calculate gradient
        v_deriv <- f_lossderiv(til_beta1, v_k0 + v_m, m_sigma, m_h1, m_h2)
        v_grad1 <- f_grad(v_beta1, v_deriv, m_s)

        #Update v_beta1, til_beta1, new_loss
        v_beta1 <- v_beta0 - s_step * v_grad1
        til_beta1 <- tilde_beta(v_beta1, k1 + m1, k2 + m2)
        new_loss <- f_loss(v_beta1, til_beta1, v_taustar, v_y, m_sigma, m_h1, m_h2, m_s)

        #Check stop criterion
        if (is.null(eta)) {
            converge <- (abs(new_loss - s_loss) <= eps * abs(s_loss))
        } else {
            converge <- (norm_2(v_grad1) / norm_2(v_beta0) <= eta)
        }

        ##trace
        if (!is.null(trace)) {
            con_quan$til_beta <- til_beta1
            con_quan$loss <- new_loss
            con_quan$iter <- iter
            cq_plot(trace, con_quan)
        }

        #If gradient size criteria
        if (converge) break

    }

#-------------------------------------------------------
##### Output #####
#-------------------------------------------------------

    out <- list(
        beta = v_beta1,
        til_beta = til_beta1,
        gradient = v_grad1,
        converge = converge,
        stepsize = s_step,
        grad_size = norm_2(v_grad1),
        iter = iter,
        loss = new_loss,
        tau = v_taustar,
        x = v_x,
        y = v_y,
        center = s_center,
        sd = s_sd,
        v_k0 = v_k0,
        v_m = v_m,
        n1 = m_n1,
        m_sigma = m_sigma,
        mat_s = m_s,
        alpha = 0,
        bet = 0,
        call = function_call)

    return(out)
}


##### Chapter 3: Classification using Nearest Neighbors --------------------
pacman::p_load("class", "gmodels", "tidyverse")
## Example: Classifying Cancer Samples ----
## Step 2: Exploring and preparing the data ----

# import the CSV file
wbcd <- read.csv(".//Chapter03//wisc_bc_data.csv", stringsAsFactors = FALSE)

# examine the structure of the wbcd data frame
wbcd
# drop the id feature
wbcd <- wbcd[-1]

# table of diagnosis
table(wbcd$diagnosis)

# recode diagnosis as a factor
wbcd$diagnosis <- factor(wbcd$diagnosis, levels = c("B", "M"),
                         labels = c("Benign", "Malignant"))

# table or proportions with more informative labels
round(prop.table(table(wbcd$diagnosis)) * 100, digits = 1)

# summarize three numeric features
summary(wbcd[c("radius_mean", "area_mean", "smoothness_mean")])

# create normalization function
normalize <- function(x) {
  return ((x - min(x)) / (max(x) - min(x)))
}

# test normalization function - result should be identical
normalize(c(1, 2, 3, 4, 5))
normalize(c(10, 20, 30, 40, 50))

# normalize the wbcd data
wbcd_n <- as.data.frame(lapply(wbcd[2:31], normalize))

# confirm that normalization worked
summary(wbcd_n$area_mean)

# create training and test data
wbcd_train <- wbcd_n[1:469, ]
wbcd_test <- wbcd_n[470:569, ]

# create labels for training and test data

wbcd_train_labels <- wbcd[1:469, 1]
wbcd_test_labels <- wbcd[470:569, 1]

## Step 3: Training a model on the data ----

# load the "class" library
library(class)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test,
                      cl = wbcd_train_labels, k = 21)

## Step 4: Evaluating model performance ----

# load the "gmodels" library
library(gmodels)

# Create the cross tabulation of predicted vs. actual
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred,
           prop.chisq = FALSE)

## Step 5: Improving model performance ----

# use the scale() function to z-score standardize a data frame
wbcd_z <- as.data.frame(scale(wbcd[-1]))

# confirm that the transformation was applied correctly
summary(wbcd_z$area_mean)

# create training and test datasets
wbcd_train <- wbcd_z[1:469, ]
wbcd_test <- wbcd_z[470:569, ]

# re-classify test cases
wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test,
                      cl = wbcd_train_labels, k = 21)

# Create the cross tabulation of predicted vs. actual
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred,
           prop.chisq = FALSE)

# try several different values of k
wbcd_train <- wbcd_n[1:469, ]
wbcd_test <- wbcd_n[470:569, ]

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=1)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=5)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=11)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=15)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=21)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=27)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

# 타이디문법으로 재구성
install.packages("modeldata")
pacman::p_load("dplyr", "class", "gmodels", "tidyverse", "ggplot2", "rsample", "recipes", "caret", "modeldata") # 없는 패키지는 자동으로 다운로드받아줌
library(modeldata)

options(scipen = 999)
ggplot2::theme_set(ggplot2::theme_light())

".//Chapter03//wisc_bc_data.csv" %>%
  read.csv(stringsAsFactors = FALSE) %>%
  as.tibble %>%
  mutate_if(is.ordered, factor, ordered = FALSE) -> wbcd

wbcd %>% # 양성과 음성 수 보기
  select(-id) %>%
  glimpse() %>%
  mutate(diagnosis = str_replace_all(diagnosis, "M", "Malignant")) %>%
  mutate(diagnosis = str_replace_all(diagnosis, "B", "Benign")) %>%
  count(diagnosis)

wbcd %>% # 양성과 음성 비율 보기
  select(-id) %>%
  mutate(diagnosis = str_replace_all(diagnosis, "M", "Malignant")) %>%
  mutate(diagnosis = str_replace_all(diagnosis, "B", "Benign")) %>%
  count(diagnosis) %>%
  mutate(prop=format(prop.table(n)*100, digits=3))

library(tidymodels) # 머신러닝용 타이디패키지
wbcd %>% # 훈련데이터, 테스트데이터 생성 (7:3 비율로 나누었다!)
  select(-id) %>%
  mutate(diagnosis = str_replace_all(diagnosis, "M", "Malignant")) %>%
  mutate(diagnosis = str_replace_all(diagnosis, "B", "Benign")) %>%
  ungroup() %>%
  rsample::initial_split(prop = 0.7, strata = diagnosis) -> wbcd_split

wbcd_split %>% # 데이터 어떻게 생겼나?
  training() %>% # 테스트 데이터 보려면 testing()
  glimpse()

wbcd_split %>% training() -> train_df
wbcd_split %>% testing() -> test_df

# 이제부터 직관적인 분석이 시작됩니다.
df_rec <- recipe(diagnosis ~., data = train_df) %>%
  step_downsample(diagnosis) %>% # 훈련데이터 정제작업
  step_center(-diagnosis) %>% # 숫자 데이터를 평균0으로 정규화
  step_scale(-diagnosis) %>% # 숫자 데이터를 표준편차 1로 정규화
  prep()

df_juiced <- juice(df_rec)

df_juiced %>% pivot_longer(-diagnosis) %>%
  ggplot() +
  geom_histogram(aes(value, fill = diagnosis)) +
  facet_wrap(~name)

baked_test <- bake(df_rec, new_data = test_df)

install.packages("kknn")
#make a knn spec
knn_spec <- nearest_neighbor() %>%
  set_engine("kknn") %>%
  set_mode("classification")

#make a rf spec
rf_spec <- rand_forest() %>%
  set_engine("ranger") %>%
  set_mode("classification")

#use the knn spec to fit the pre-processed training data
knn_fit <- knn_spec %>%
  fit(diagnosis ~., data = df_juiced)

#use the rf spec to fit the pre-processed training data
rf_fit <- rf_spec %>%
  fit(diagnosis ~., data = df_juiced)

rf_fit

knn_fit %>%
  predict(baked_test) %>%
  bind_cols(baked_test) %>%
  metrics(truth = diagnosis, estimate = .pred_class)

knn_fit %>%
  predict(df_juiced) %>%
  bind_cols(df_juiced) %>%
  metrics(truth = diagnosis, estimate = .pred_class)

rf_fit %>%
  predict(df_juiced) %>%
  bind_cols(df_juiced) %>%
  metrics(truth = diagnosis, estimate = .pred_class)

results_train <- knn_fit %>%
  predict(df_juiced) %>%
  mutate(model = "knn",
         truth = df_juiced$diagnosis) %>%
  bind_rows(rf_fit %>%
              predict(df_juiced) %>%
              mutate(model = "rf",
                     truth = df_juiced$diagnosis)

  ) %>%
  mutate(accuracy = if_else(.pred_class == truth, "yes", "no"))

results_test <- knn_fit %>%
  predict(baked_test) %>%
  mutate(model = "knn",
         truth = baked_test$diagnosis) %>%
  bind_rows(rf_fit %>%
              predict(baked_test) %>%
              mutate(model = "rf",
                     truth = baked_test$diagnosis)

  ) %>%
  mutate(accuracy = if_else(.pred_class == truth, "yes", "no"))

results_train %>%
  ggplot() +
  geom_bar(aes(accuracy, fill = accuracy)) +
  facet_wrap(~ model)

results_test %>%
  ggplot() +
  geom_bar(aes(accuracy, fill = accuracy)) +
  facet_wrap(~ model)


#' @title calcHullEff
#'
#' @description Calculate the hull efficiency (\code{hullEff}) (dimensionless)
#' for a specified vessel.
#'
#' @param thrustFactor Thrust deduction coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcHMThrustFactor}} and \code{\link{calcKristThrustFactor}})
#' @param wakeFraction Wake fraction coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcHMWakeFraction}} and \code{\link{calcKristWakeFrac}})
#'
#'@seealso \itemize{
#'\item \code{\link{calcHMThrustFactor}}
#'\item \code{\link{calcKristThrustFactor}}
#'\item \code{\link{calcHMWakeFraction}}
#'\item \code{\link{calcKristWakeFrac}}}
#'
#' @return \code{hullEff} (vector of numericals, dimensionless)
#'
#' @examples
#' calcHullEff(c(0.19,0.17), c(0.32,0.29))
#'
#' @export

calcHullEff <- function(thrustFactor, wakeFraction ){

  hullEff<- (1-thrustFactor)/(1-wakeFraction)

  return(hullEff)
}


# 1A
# X... pocet stad na 1km^2
# X - pouzijeme Poissonovu vetu
lambda = 1/25
t = 100
lt = lambda*t # parametr Poissonova rozdeleni

# P(x <= 6)
# V oblasti 100km^2 bude nejvyse 6 stad
ppois(6, lt) # s pravdepodobnosti 88,93 %

# 1B
# P(1<=X<=7) = P(X <= 7) - P(X <= 0)
# V oblasti 100km^2 bude alespon 1 ale nejvyse 7 stad
ppois(7, lt) - ppois(0, lt) # s pravdepodobnosti 93,06 %

# 1C
# V oblasti 100km^2 bude alespon 5 stad, jestlize 2 stada byla nalezena
(1-ppois(4,lt)) / (1-ppois(1,lt)) # 0.4085801

# 1D
lambda = 1/25
t = 50
# P(X >= 1) = P(X > 0) = 1 - P(X <= 0)
# V oblasti 50km^2 bude alespon jedno stado
1 - ppois(0, lambda*t) # s pravdepodobnosti 86,47 %

# 2A
# X... pocet opravenych domacich ukolu za 1h
# X - pouzijeme Poissonovu vetu
lambda = 6 # cetnost vyskytu za hodinu
t = 8 # behem 8mi hodin
lt = lambda*t # parametr Poissonova rozdeleni

# P(x > 50) = 1 - P(X <= 49)
# Opravi vice jak 50 ukolu
1 - ppois(50, lt) # s 35,13% pravdepodobnosti

#Pravd fun
x = 20:80
P_x = dpois(x-1, lt)
plot(x, P_x)
grid()

#Dist fun
x = 20:80
F_x = ppois(x-1, lt)
plot(x, F_x, type='s')
grid()

# 2B
# Opravi 45 az 55 ukolu
ppois(55, lt) - ppois(45-1, lt) # s 54,67% sanci

# 2C
# Opravi 55 ukolu jestlize 40 opravil
(1 - ppois(54, lt)) / (1 - ppois(39, lt)) # s pravdepodobnosti 19,4 %

# 2D
# X ... pocet pokusu nez vybereme spatny ukol
# X ~ NB(k = 3,p = 0.2)
x = 17
k = 3
p = 0.2
# P(X > 15) = 1 - P(X <= 15)
# Narazi na tri spatne ukoly nejdrive za 17 pokusu
1-pnbinom(x - k, k, p) # s pravdepodobnosti 30,96 %

# 3A
# X ... doba do restartu ve dnech
## X ~ Exp(lambda), kde E(X)=1/lambda
lambda = 1/365

x = seq(from = 0, to = 2500, by = 1)
f_x = dexp(x-1, lambda)
plot(x, f_x, cex = 0.1, main="Hustota pravdepodobnosti po dnech")
grid()

F_x = pexp(x-1, lambda)
plot(x, F_x, type='s', main="Distribucni funkce po dnech")
grid()

# 3B
# Restart bude potreba nejdrive za 13 mesicu
1 - pexp(365/12*13, lambda) # s pravdepodobnosti 33,85 %
x = seq(from = 0, to = 2500, by = 1)
f_x = dexp(x-1, lambda)
plot(x, f_x, cex = 0.1, main="Hustota pravdepodobnosti a restart po 13 mesicich")
lines(c(0, 2500),c(dexp(365/12*13, lambda), dexp(365/12*13, lambda)))
lines(c(365/12*13, 365/12*13),c(0, max(f_x)))
grid()

# 3C
# Pravdepodobnost restartu po roce pouzivani v nasledujicich 14 dnech
pexp(365 + 365/52*2, lambda) - pexp(365, lambda) # je 1,38 %.

# 3D
# P(X<t)=0,9 -> F(t)=0,9 -> t… 90% kvantil
# Server bude treba restartovat s 90 % pravdepodobnosti
qexp(0.9, lambda) # po 840,4 dnech.

# 4A
# Systolicky krevni tlak, normalni rozdeleni se stredni hodnotou 112 a smerodatnou odchylkou 10
mu = 112
sigma = 10

# vykreslime si Hustotu pravdepodobnosti
x = seq(from = 70, to = 150, by = 0.1)
f_x = dnorm(x, mean=mu, sd=sigma)
plot(x, f_x, cex = 0.01, main="Hustota pravdepodobnosti")
grid()

# vykreslime si Distribucni funkci
F_x = pnorm(x, mean=mu, sd=sigma)
plot(x, F_x, type = 'l', main="Distribucni funkce")
grid()

# 4B
# Tlak mimo rozmezi 90 az 120g
1- (pnorm(120, mean=mu, sd=sigma) - pnorm(90, mean=mu, sd=sigma)) # s pravdepodobnosti 22,58 %

# Zaznaceni do grafu
# x = c(seq(from = 50, to = 90, by = 0.1),seq(from = 120, to = 180, by = 0.1))
# Vysrafovana oblast je pod krivkou v levo od hodnoty 90 a v pravo od hodnoty x=120 a y<0
x = seq(from = 70, to = 150, by = 0.1)
f_x = dnorm(x, mean=mu, sd=sigma)
plot(x, f_x, cex = 0.01, main="Hustota pravdepodobnosti")
lines(c(90,90),c(0,max(f_x)))
lines(c(120,120),c(0,max(f_x)))
grid()

# 4C
# Tlak nizsi nez 105mmHg
pnorm(105, mean=mu, sd=sigma) # s pravdepodobnosti 24,2 %
F_x = pnorm(x, mean=mu, sd=sigma)
plot(x, F_x, type = 'l', main="Distribucni funkce s tlakem")
lines(c(105,105),c(0,max(F_x)))
lines(c(70,150),c(pnorm(105, mean=mu, sd=sigma),pnorm(105, mean=mu, sd=sigma)))
grid()

# 4D
# 82. percentil
qnorm(0.82, mean=mu, sd=sigma) # je 121.15 mmHg
# Vysvetleni percentilu: 82% lidi ma hodnotu systolickeho krevniho tlaku do hranice 121.15 mmHg


library(tidyr)
library(ggplot2)
library(dplyr)
library(cowplot)
library(readr)

predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

#file_lst <- list.files("sim_results",pattern="n100.txt",full.names=T)
t <- read_csv("../processed_results/all.csv")

t %>% group_by(sel_coef,epistasis_coef,mu_prob) %>%
  mutate(an_mean_fitness=predict_mean_fitness(100,100,sel_coef,epistasis_coef),q=1-epistasis_coef)-> t_sum

for (s in c(0.1, 0.01, 0.001, 0.0001)){
  t_sum %>% filter(sel_coef==s) -> f

  p <- ggplot(f, aes(x=mu_prob*100, y=mean_fitness,color=factor(q)))+
    stat_summary(fun.y = mean,
                 fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
                 fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
                 geom = "pointrange",
                 size=0.4)+
    geom_line(aes(y = an_mean_fitness,group=factor(epistasis_coef),color=factor(q)))+
    xlab('Ne*mu')+
    ylab('Mean fitness')+
    scale_x_log10()+
    #scale_y_continuous(breaks=seq(0.99,1,0.005))+
    guides(col = guide_legend(title="Q",reverse = TRUE))+
    theme(axis.title = element_text(size = 14),
          axis.text = element_text(size = 12),
          legend.text = element_text(size = 11),
          legend.title = element_text(size = 12))

  save_plot(paste0("../plots/mean_fit_v_time_s",s,".pdf"), p)
}


#' Calculates mean and standard error of frequency data
#'
#' Helper function for Francis ESS calculations.
#' @param bins the values in the class marks (ages in this case)
#' @param N the total number (ESS in this case)
#' @param frdist the frequency distribution (should sum to one over the bins)
#' @return vector of mean and standard error
#' @export

CalcFreqMeanSE <- function(bins,N,frdist){
  Y <- bins
  f <- N*frdist
  n <- sum(f)
  sumfY <- sum(f*Y)
  Ybar <- sumfY/n
  sumfY2 <- sum(f*Y*Y)
  CT <- sumfY^2/n
  sumfy2 <- sumfY2-CT
  s2 <- sumfy2/(n-1)
  sigma <- sqrt(s2)
  stderror <- sigma/sqrt(n)  # note this is standard deviation of the mean
  meanstderror <- c(Ybar,stderror)
  return(meanstderror)
}


=begin
  # sample-algebraicfield02.rb

  require "algebra"

  F = AlgebraicExtensionField(Rational, "x") {|x| x**2 + x + 1}
  x = F.var
  p( (x + 1)**100 )
  p( (x-1)** 3 / (x**2 - 1) )

  H = AlgebraicExtensionField(F, "y") {|y| y**5 + x*y + 1}
  y = H.var
  p( 1/(x + y + 1)**7 )
((<_|CONTENTS>))
=end


outliers_fnc <- function(x, conf.level = 0.95)
{
  x <- x[!is.na(x)]
  del.val <- NULL

  while (TRUE) {
    n <- length(x)
    if (n < 3) {
      break
    }

    r <- range(x)
    t <- abs(r - mean(x)) / sd(x)
    q <- sqrt((n - 2) / ((n - 1) ^ 2 / t ^ 2 / n - 1))
    p <- n * pt(q, n - 2, lower.tail = FALSE)

    if (t[1] < t[2]) {
      if (p[2] < 1 - conf.level) {
        del.val <- c(del.val, r[2])
        x <- x[x != r[2]]
        next
      }
    } else {
      if (p[1] < 1 - conf.level) {
        del.val <- c(del.val, r[1])
        x <- x[x != r[1]]
        next
      }
    }
    break
  }
  return(list(x = x, del.val = del.val))
}


#####################################################
#
# Usage: R --vanilla --slave < linear_reqgression.r
# 	http://d.hatena.ne.jp/n_shuyo/20090709/predictive
#
#####################################################

M <- 9		# number of basis function
alpha <- 2	# hyper parameter α
beta <- 25	# hyper parameter β
Lattice <- 30	# number of graph's lattice
s<-0.1
u_i<-0.5

# training data
xlist <- seq(0, 1, length=25)
tlist <- sin(2*pi*xlist) + rnorm(length(xlist), sd=0.2)
D0 <- data.frame(x=xlist, t=tlist)

predictive <- function(D) {
    # design matrix
    gauss_base_func <- function(x)exp(-(x-u_i)^2/(2*s*s))
    phi <- function(x) sapply(x,function(x){exp(-(x-seq(0,1,length=9))^2/(2*s*s))})
    PHI <- t(phi(D$x))

    # convariance matrix & means
    S_N_inv <- alpha * diag(9) + beta * t(PHI) %*% PHI
    S_N <- solve(S_N_inv)
    m_N <- beta * S_N %*% t(PHI) %*% D$t

    # regression function
    y <- function(x)(t(phi(x)) %*% m_N)
    plot(y, xlim=c(0,1), ylim=c(-1.2, 1.2))
    par(new=T)
    plot(D, xlim=c(0,1), ylim=c(-1.2, 1.2), ylab="")

    # predictive distribution
    var_N <- function(x) {1/beta + (t(phi(x)) %*% S_N %*% phi(x))[1]}
    function(x,t) {
        mapply(function(x,t)dnorm(t,m=(t(m_N) %*% phi(x))[1], s=var_N(x), log=T), x, t)
    }
}
draw_dist <- function(p){
    x <- seq(0, 1, length=Lattice)
    t <- seq(-1.5, 1.5, length=Lattice*2)
    z <- outer(x, t, p)
    persp(x, t, z, theta=0, phi=60, shade=0.4)
}

p <- predictive(D0[sample(length(D0$x))[1:1],])
draw_dist(p);
p <- predictive(D0[sample(length(D0$x))[1:2],])
draw_dist(p);
p <- predictive(D0[sample(length(D0$x))[1:4],])
draw_dist(p);
p <- predictive(D0)
draw_dist(p);

# pdf("PRML_graph.pdf")
# dev.off()


# https://fivethirtyeight.com/features/who-will-win-the-lucky-derby/
# The bugle sounds, and 20 horses make their way to the starting gate for the first annual Lucky Derby.
# These horses, all trained at the mysterious Riddler Stables, are special.
# Each second, every Riddler-trained horse takes one step. Each step is exactly one meter long.
# But what these horses exhibit in precision, they lack in sense of direction.
# Most of the time, their steps are forward (toward the finish line) but the rest of the time they are backward
# (away from the finish line). As an avid fan of the Lucky Derby, you’ve done exhaustive research on these 20 competitors.
# You know that Horse One goes forward 52 percent of the time, Horse Two 54 percent of the time, Horse Three 56 percent, and so on,
# up to the favorite filly, Horse Twenty, who steps forward 90 percent of the time.
# The horses’ steps are taken independently of one another, and the finish line is 200 meters from the starting gate.

# Handicap this race and place your bets! In other words, what are the odds (a percentage is fine) that each horse wins?

# Libraries
library(tidyverse)

# Inputs
n_horses <- 20                    # horses in race
stp      <- 1                     # length of each step
dir_fwd  <- seq(52, 90, 2) / 100  # chance each horse takes step forward
dst      <- 200                   # length of race

# Code
# Odds each horse wins
trials  <- 10000
winners <- rep(0, n_horses)
for (i in 1:trials) {
  track <- tibble(horses = 1:n_horses,
                  pos = rep(0, n_horses),
                  fwd = dir_fwd)
  a <- runif(1000, 0, 1)
  while(max(track$pos) < dst) {
    b <- sample(a, n_horses)
    track <- track %>%
      mutate(pos = pmax(0, pos + ifelse(fwd >= b, 1, -1)))
  }
  # Tally wins
  # Count ties as wins
  winners[which(track$pos >= dst)] <- winners[which(track$pos >= dst)] + 1
}

# Output
track <- track %>% mutate(win = winners / sum(winners))
print(track)
ggplot(track) +
  geom_point(mapping = aes(win, horses))


\name{generate_fit_only}
\alias{generate_fit_only}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Simulating networks from the Caldarelli model}
\description{
  This function generates networks from the Caldarelli model. In this model, the preferential attachment function is constant, i.e. \eqn{A_k = 1}, and node fitnesses are sampled from some probability distribution.
}
\usage{
generate_fit_only(N             = 1000   ,
                 num_seed       = 2      ,
                 multiple_node  = 1      ,
                 m              = 1      ,
                 mode_f         = "gamma",
                 s              = 10     )
}

%- maybe also 'usage' for other objects documented here.
\arguments{
  The parameters can be divided into two groups.

  The first group specifies basic properties of the network:
    \item{N}{
      Integer. Total number of nodes in the network (including the nodes in the seed graph). Default value is \code{1000}.
    }
  \item{num_seed}{
    Integer. The number of nodes of the seed graph (the initial state of the network). The seed graph is a cycle. Default value is \code{2}.
  }
  \item{multiple_node}{
    Positive integer. The number of new nodes at each time-step. Default value is \code{1}.
  }
  \item{m}{
    Positive integer. The number of edges of each new node. Default value is \code{1}.
  }

  The final group of parameters specifies the distribution from which node fitnesses are generated:
    \item{mode_f}{
      String. Possible values:\code{"gamma"}, \code{"log_normal"} or \code{"power_law"}. This parameter indicates the true distribution for node fitness. \code{"gamma"} = gamma distribution, \code{"log_normal"} = log-normal distribution. \code{"power_law"} = power-law (pareto) distribution. Default value is "gamma".
    }
\item{s}{
Non-negative numeric. The inverse variance parameter. The mean of the distribution is kept at \eqn{1} and the variance is \eqn{1/s} (since node fitnesses are only meaningful up to scale). This is achieved by setting shape and rate parameters of the Gamma distribution to \eqn{s}; setting mean and standard deviation in log-scale of the log-normal distribution to \eqn{-1/2*log (1/s + 1)} and \eqn{(log (1/s + 1))^{0.5}}; and setting shape and scale parameters of the pareto distribution to \eqn{(s+1)^{0.5} + 1} and \eqn{(s+1)^{0.5}/((s+1)^{0.5} + 1)}. If \code{s} is \code{0}, all node fitnesses \eqn{\eta} are fixed at \code{1} (i.e., \enc{Barabási}{Barabasi}-Albert model). The default value is \code{10}.
}
}

\value{
  The output is a \code{PAFit_net} object, which is a List contains the following four fields:
    \item{graph}{a three-column matrix, where each row contains information of one edge, in the form of \code{(from_id, to_id, time_stamp)}. \code{from_id} is the id of the source, \code{to_id} is the id of the destination.}
    \item{type}{a string indicates whether the network is \code{"directed"} or \code{"undirected"}.}
    \item{PA}{a numeric vector contains the true PA function.}
  \item{fitness}{fitness values of nodes in the network. The name of each value is the ID of the node.}
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. Caldarelli, G., Capocci, A. , De Los Rios, P. & \enc{Muñoz}{Munoz}, M.A. (2002). Scale-Free Networks from Varying Vertex Intrinsic Fitness. Phys. Rev. Lett., 89, 258702 (\url{http://link.aps.org/doi/10.1103/PhysRevLett.89.258702}).
}
\seealso{
  For subsequent estimation procedures, see \code{\link{get_statistics}}.

  For other functions to generate networks, see \code{\link{generate_net}}, \code{\link{generate_BA}}, \code{\link{generate_ER}} and \code{\link{generate_BB}}. }

\examples{
  library("PAFit")
  # generate a network from the Caldarelli model with alpha = 1, N = 100, m = 1
  # the inverse variance of distribution of node fitnesses is s = 10
  net <- generate_fit_only(N = 100,m = 1,mode = 1, s = 10)
  str(net)
  plot(net)
}

% Add one or more standard keywords, see file 'KEYWORDS' in the
% R documentation directory.
\concept{ fitness model }% __ONLY ONE__ keyword per line


=begin
[((<index|URL:index.html>))]
((<Algebra::MPolynomial>))
/
((<Algebra::MPolynomial::Monomial>))
/
((<Algebra::MPolynomialFactorization>))
/
((<Algebra::Groebner>))

= Algebra::MPolynomial
((*(Class of Multi-variate Polynomial Ring)*))

This class expresses the multi-variate polynomial ring over arbitrary ring.
For creating the actual class, use the class method ((<::create>))
or ((<Algebra.MPolynomial>))(), giving the coefficient ring.

== File Name:
* ((|m-polynomial.rb|))

== SuperClass:

* ((|Object|))

== Included Modules:

* ((|Enumerable|))
* ((|Comparable|))
* ((<Algebra::Groebner>))

== Associated Function:

--- Algebra.MPolynomial(ring [, obj0 [, obj1 [, ...]]])
    Same as ((<::create>))(ring [, obj0[, obj1[, ...]]]).

== Class Methods:

--- ::create(ring [, obj0 [, obj1 [, ...]]])
    Creates a multi-variate polynomial ring class over the coefficient
    ring expressed by the class: ((|ring|)).

    The objects (({obj0, obj1, ...})) are reserved and represent variables.
    They are only to utilize for the names of variables (for ((|to_s|)) )
    and the distinction.

    The return value of this method is a sub-class of ((|Algebra::MPolynomial|)).
    This class has class-methods: ((|ground|)) and ((|vars|)),
    which return
    the coefficient ring ((|ring|)) and an array of variables.

    The variables represented by objects (({obj0, obj1, ...})) can be
    able to obtain as :(({var(obj0)})), (({var(obj1)})),... So,
    (({vars == [var(obj0), var(obj1), ...]})).

    The order of each variable is: (({obj0 > obj1 > ...})), and
    the order of monomials is determined by ((<::set_ord>)).

    Example: Polynomial ring over Integer
      require "m-polynomial"
      P = Algebra::MPolynomial.create(Integer, "x", "y", "z")
      x, y, z = P.vars
      p((-x + y + z)*(x + y - z)*(x - y + z))
      #=> -x^3 + x^2y + x^2z + xy^2 - 2xyz + xz^2 - y^3 + y^2z + yz^2 - z^3
      p P.ground #=> integer

--- ::vars([obj0 [, obj1 [, ...]]])
    ((*When no parameter is designated*)), it returns the array of
    all variables, already reserved.

    Example:
      P = Algebra.MPolynomial(Integer, "x", "y", "z")
      p P.vars #=> [x, y, z]

    ((*When only one parameter of ((|String|)) is designated *)),
    splits the string into identifiers and reserves them, which
    represent variables. The string of "AN ALPHABET + SOME DIGITS" can be
    an identifier.

    If the object has been already reserved, no new reservation is done.
    The return value of this method is an array of variables corresponding
    to the objects.

    Example:
      P = Algebra.MPolynomial(Integer)
      x, y, z, w = P.vars("a0b10cd")
      p P.vars #=> [a0, b10, c, d]
      p [x, y, z, w] #=> [a0, b10, c, d]

    ((*Otherwise*)), reserve objects (({obj0, obj1, ...})) which represent
    variables. If the object has been already reserved, no reservation is
    done.
    The return value of this method is an array of variables corresponding
    to the objects.

    Example:
      P = Algebra.MPolynomial(Integer)
      p P.vars("x", "y", "z") #=> [x, y, z]

--- ::mvar([obj0 [, obj1 [, ...]]])
    ((*When no parameter is designated*)), it returns the array of
    all variables, already reserved.

    ((*Otherwise*)), reserve objects (({obj0, obj1, ...})) which represent
    variables. If the object has been already reserved, no reservation is
    done.
    The return value of this method is an array of variables corresponding
    to the objects.

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

    Example: Define MPolynomial ring and variables simulteniously
      P, x, y, z, w = Algebra.MPolynomial(Integer, "a", "b", "c", "d")

--- ::var(obj)
    Returns the variable, which is represented by ((|obj|)).

    Example:
      P = Algebra.MPolynomial(Integer, "X", "Y", "Z")
      x, y, z = P.vars
      P.var("Y") == y #=> true

--- ::variables
    Returns the array of reserved objects, which represent variables.

--- ::indeterminate(obj)
    Same as ((<::var>)).

--- ::zero?
    Returns true if ((|self|)) is zero.

--- ::zero
    Returns zero.

--- ::unity
    Returns unity.

--- ::set_ord(ord [, v_ord])
    Sets the order of monomials as ((|ord|)) which is ((|Symbol|))
    of ordering type.
    The possible designations are ((|:lex|)) (lexicographic order (default)),
    ((|:grlex|)) (graded lexicographic order), ((|:grevlex|)) (graded
    reverse lexicographic order).

    The order of variables is the order of reservation.
    By the array ((|v_ord|)), we can transform the order.

    Example: the order of (({x, y, z = P.var("xyz")}))
      require "m-polynomial"
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2

      P.set_ord(:lex)
      p f #=> -5x^3 + 7x^2z^2 + 4xy^2z + 4z^2

      f.method_cash_clear
      P.set_ord(:grlex)
      p f #=> 7x^2z^2 + 4xy^2z - 5x^3 + 4z^2

      f.method_cash_clear
      P.set_ord(:grevlex)
      p f #=> 4xy^2z + 7x^2z^2 - 5x^3 + 4z^2

      f.method_cash_clear
      P.set_ord(:lex, [2, 1, 0]) # z > y > x
      p f #=> 7x^2z^2 + 4z^2 + 4xy^2z - 5x^3

    See ((<::with_ord>)).

--- ::ord=(x)
    Same as ((<::set_ord(x)>)).

#--- ::order=(obj)
#    Same as ((<::set_ord(obj)>)).

--- ::get_ord
    Returns the monomial order. (:lex, :grlex, :grevlex)

--- ::ord
    Same as ((<::get_ord>)).

#--- ::order
#    Same as ((<::get_ord>)).

--- ::with_ord(ord [, v_ord[ [, array_of_polys]])
    Executes the block with monomial ordering ((|ord|)) and
    order of variables ((|v_ord|)). These ordering are
    available only in the block.(See ((<::set_ord>)).)
    When the array of polyomials ((|array_of_polys|)) is given,
    for each of them, ((<method_cash_clear>)) is invoked before
    the execution. (This is not a thread-safe block.)

    Example:
      require "m-polynomial"
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2

      P.with_ord(:lex, nil, [f]) do
        p f    #=> -5x^3 + 7x^2z^2 + 4xy^2z + 4z^2
        p f.lt #=> -5x^3
      end

      P.with_ord(:grlex, nil, [f]) do
        p f    #=> 7x^2z^2 + 4xy^2z - 5x^3 + 4z^2
        p f.lt #=> 7x^2z^2
      end

      P.with_ord(:grevlex, nil, [f]) do
        p f    #=> 4xy^2z + 7x^2z^2 - 5x^3 + 4z^2
        p f.lt #=> 4xy^2z
      end

      P.with_ord(:lex, [2, 1, 0], [f]) do # z > y > x
        p f    #=> 7x^2z^2 + 4z^2 + 4xy^2z - 5x^3
        p f.lt #=> 7x^2z^2
      end

--- ::monomial(ind[, c])
    Returns the monomial of multi-degree ((|ind|)) and
    coefficient ((|c|)).
    (((<Algebra::MPolynomial::Monomial>)) is not extend.)
    If ((|c|)) is omitted, it is assumed to be the unity.

#--- ::const(x)
#--- ::regulate(x)
#--- ::method_cash_clear(*m)

== Methods:

--- monomial(ind[, c])
    Same as ((<::monomial>))

#--- each
#--- keys
#--- values
#--- [](ind)
#--- []=(ind, c)
#--- constant_coeff
#--- include?
#--- compact!
#--- rt!

--- constant?
    Retruns true if ((|self|)) is a constant.

--- monomial?
    Returns true if ((|self|)) is a monomial.

--- zero?
    Returns true if ((|self|)) is zero.

--- zero
    Returns zero.

--- unity
    Retruns unity.

--- method_cash_clear
    Clears the cashes of methods.

    In this library, some results of methods are stored so as not to
    do same calculations. When the order of monomials is changed,
    we must clear the cashes.

    The methods which have cashes are following:
    ((<lc>)), ((<lm>)), ((<lt>)), ((<rt>)), ((<multideg>)).

    Example:
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2
      P.set_ord(:lex)
      p f.lt #=> -5x^3
      P.set_ord(:grlex)
      p f.lt #=> -5x^3
      f.method_cash_clear
      p f.lt #=> 7x^2z^2

--- ==(other)
    Returns true if ((|self|)) is equal to ((|other|)).

--- <=>(other)
    Returns positive if ((|self|)) is greater than ((|other|)).

--- +(other)
    Returns the sum of ((|self|)) and ((|other|)).

--- -(other)
    Returns the difference of ((|self|)) from ((|other|)).

--- *(other)
    Returns the product of ((|self|)) and ((|other|)).

--- **(n)
    Returns the ((|n|))-th power of ((|self|)).

--- /(other)
    Returns the quotient of ((|self|)) by ((|other|)).
    ((|other|)) must be constant.

--- divmod(f0 [, f1 [,...]])
    Returns the array [the array of quotients, the remainder]
    by (({f0, f1,...})).

      P = Algebra.MPolynomial(Integer)
      x, y = P.vars("xy")
      f = x**2*y + x*y**2 + y**2
      f0 = x*y - 1
      f1 = y**2 - 1
      p f.divmod(f0, f1) #=> [[x + y, 1], x + y + 1]
      p f % [f0, f1]     #=> x + y + 1

--- %(others)
    Returns the remainder of ((|self|)) by polynomials ((|others|)).
    It is equal to (({divmod(*others)[1]})).

--- multideg
    Returns the multiple degree as an array.

    Example: in lex order,
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.multideg #=> [3, 1]

--- totdeg
    Returns the total degree.

    Example:
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.totdeg   #=> 4

--- deg
    Same as multideg.

--- lc
    Returns the leading coefficient.

    Example: in lex order,
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.lc       #=> -5

--- lm
    Returns the leading monomial.
    The return value is extended by ((<MPolynomial::Monomial>)).

    Example: in lex order,
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.lm       #=> x^3y

--- lt
    Returns leading term. This is equal to (({lc * lm})).

    Example: in lex order
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.lt       #=> -5x^3y

--- rt
    Returns the rest term. This is equal to (({self - lt})).

    Example: in lex order,
      f = 4*x*y**2*z + 4*z**2 - 5*x**3*y + 7*x**2*z**2
      p f.rt       #=> 4*z**2 - 5*x**3*y + 7*x**2*z**2

--- to_s
    Return the representation of ((|String|)). To change the format of
    expression, use ((|display_type|)).
    The values which are able to designate to ((|display_type|)) is:
    ((|:norm|)) (default) and  ((|:code|)).

    Example:
      P = Algebra.MPolynomial(Integer)
      x, y, z = P.vars("xyz")
      f = -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2
      p f #=> -5x^3 + 7x^2z^2 + 4xy^2z + 4z^2
      P.display_type = :code
      p f #=> -5*x**3 + 7*x**2*z**2 + 4*x*y**2*z + 4*z**2

--- map_to(ring[, vs]){|c, ind| ... }
    Returns the sum over ((|ring|)) of the evaluations of ...
    for the multi-degree ((|ind|)) and coefficient ((|c|)).
    If ((|vs|)) is omitted, it is assumed to be ((<::vars>)).

    If (({f})) is the polynomial over (({P})),
    (({f.map_to(P) {|c, ind| c * P.monomial(ind)}})) equals to (({f})).

--- project(ring[, vs]){|c, ind| ... }
    Returns the sum over ((|ring|)) of the evaluations of ...
    on the monomial
    for the multi-degree ((|ind|)) and coefficient ((|c|)).

    If (({f})) is the polynomial over (({P})),
    (({f.progect(P) {|c, ind| c}})) equals to (({f})).

    (({project(ring){|c, ind| f(c, ind)}})) equals to (({map_to(ring){|c, ind| f(c, ind) * self.class.monomial(ind)}})).

    If ((|vs|)) is omitted, it is assumed to be ((<::vars>)).

    Example:
      require "m-polynomial"
      require "rational"
      P = Algebra::MPolynomial(Integer, "x", "y", "z")
      x, y, z = P.vars
      f = x**2 + 2*x*y - z**3
      PQ = Algebra::MPolynomial(Rational, "x", "y", "z")
      p f.project(PQ) {|c, ind| Rational(c) / (ind[0] + 1)}
                        #=> 1/3x^2 + xy - z^3
      p f.convert_to(PQ)      #=> x^2 + 2xy - z^3

--- evaluate(obj0[, [obj1, [obj2,..]]])
    Reterns the value entering ((|obj0, obj1, obj2,...|)) for each value.
    This equivalent to
    ((<project>))(({(ground, [obj0, obj1, obj2,..]){|c, ind| c}})).

    Example:
      require "m-polynomial"
      P = Algebra::MPolynomial(Integer, "x", "y", "z")
      x, y, z = P.vars
      f = x**2 + 2*x*y - z**3
      p f.evaluate(1, -1, -1) #=> 0 (in Integer)
      p f.evaluate(y, z, x)   #=> -x^3 + y^2 + 2yz (in P)

--- call(obj0[, [obj1, [obj2,..]]])
    Same as ((<evaluate>)).

--- sub(var, value)
    Returns the value of substitution of ((|var|)) by ((|value|)).

    Example:
      require "m-polynomial"
      P = Algebra::MPolynomial(Integer)
      x, y, z = P.vars("x", "y", "z")
      f = (x - y)*(y - z - 1)
      p f.sub(y, z+1)    #=> 0

--- convert_to(ring)
    Returns the polynomial the one converted on ((|ring|)).
    This is equivalent to ((<project>))(({(ring){|c, ind| c}})).

--- derivate(var)
    Returns the partial differential by the variable ((<var>)).

= Algebra::MPolynomial::Monomial
(Module of Monomial)

The return value of ((<lt>)) and ((<lm>)) is extended by this module.

== Methods:

#--- ind
#--- coeff
#--- <=>(other)
--- divide?(other)
    Returns true if ((|self|)) is divided by ((|other|)), which is
    assumed to be a monomial.

--- /(other)
    Returns the quotient of ((|self|)) by ((|other|)), which is
    assumed to be a monomial.

--- prime_to?(other)
    Returns true if ((|self|)) is prime to ((|other|)), which is
    assumed to be a monomial.

--- lcm(other)
    Returns the least common multiple of ((|self|)) and ((<other>)), which is
    assumed to be a monomial.

--- divide_or?(other0, other1)
    Returns the same value as ((|divide?(other0.lcm(other1))|)).

= Algebra::MPolynomialFactorization
((*(Module of Factorization)*))

The module of factorization of polynomials.

== File Name:
((|m-polynomial-factor.rb|))

== Methods:
--- factorize
    Returns the factorization.

    The following type can be factorized:
    * Integer
    * Rational
    * prime field

= Algebra::Groebner
(Module of Groebner Basis)

== File Name:
* ((|groebner-basis.rb|))
* ((|groebner-basis-coeff.rb|))

== Class Methods:

--- Groebner.basis(f)
    Returns the array of reduced Groebner basis from the array of basis
    ((|f|)).
    Equivalent to ((<Groebner.basis(Groebner.minimal_basis(Groebner.basis_159A(f)))>)).

    Example:
      require "m-polynomial"
      require "rational"
      P = Algebra.MPolynomial(Rational)
      P.set_ord :grevlex
      x, y, z = P.vars("xyz")
      f1 = x**2 + y**2 + z**2 -1
      f2 = x**2 + z**2 - y
      f3 = x - z
      b = Groebner.basis([f1, f2, f3])
      p b #=> [y^2 + y - 1, z^2 - 1/2y, x - z]

--- Groebner.basis_159A(f)
    Returns the array of Groebner basis from the array of basis
    ((|f|)).

--- Groebner.minimal_basis(f)
    Returns the array of minimal Groebner basis from the array of
    Groebner basis ((|f|)).

--- Groebner.reduced_basis(f)
    Returns the array of reduced Groebner basis from the array of
    minimal Groebner basis ((|f|)).

--- Groebner.basis_coeff(f)
    Returns the array of Groebner basis from the array of basis
    ((|f|)) and the array of coefficients to express them.

    Example:
      require "m-polynomial"
      require "rational"
      P = Algebra.MPolynomial(Rational)
      P.set_ord :grevlex
      x, y, z = P.vars("xyz")
      f1 = x**2 + y**2 + z**2 -1
      f2 = x**2 + z**2 - y
      f3 = x - z
      fs = [f1, f2, f3]
      c, b = Groebner.basis_coeff(fs)
      p b #=> [y^2 + y - 1, z^2 - 1/2y, x - z]
      p c #=> [[1, -1, 0], [0, 1/2, -1/2x - 1/2z], [0, 0, 1]]
      for i in 0..2
        p c[i].inner_product(fs) == b[i] #=> true
      end

--- Groebner.basis?(f)
    Return true if ((|f|)) is an array of Groebner basis.

--- Groebner.minimal_basis?(f)
    Return true if ((|f|)) is an array of minimal Groebner basis.

--- Groebner.reduced_basis?(f)
    Return true if ((|f|)) is an array of reduced Groebner basis.

== Methods:
--- S_pair(other)
    Returns the S-pair of ((|self|)) and ((|other|)).

    Example:
      (x**2*y + y**2 + z**2 -1).S_pair(x**2*z + z**2 - y)
        #=> y^2z + y^2 - yz^2 + z^3 - z

--- divmod_s(f1[, f2[, f3...]])
    Returns a array (({[[q1, q2, q3, ...], r]}))
    of the array of quotients (coefficients of division)
    and the remainder of division of ((|self|)) by
    basis (({f1, f2, f3, ...})).

    We convert (({f1, f2, f3, ...})) into Groebner basis and make the division.
    So (({divmod(f1, f2, ...).last == 0})) is equivalent to that ((|self|))
    is in the ideal (({(f1, f2, ...)})).

    Example:
      require "m-polynomial"
      require "rational"
      P = Algebra.MPolynomial(Rational)
      P.set_ord :grevlex
      x, y, z = P.vars("xyz")
      f1 = x**2 + y**2 + z**2 -1
      f2 = x**2 + z**2 - y
      f3 = x - z
      fs = [f1, f2, f3]
      f = x**3 + y**3 + z**3
      c, r = f.divmod_s(*fs)
      p r #=> yz + 2y - 1
      p c #=> [y - 1, -y + z + 1, x^2]
      p f == c.inner_product(fs) + r #=> true

--- div_cg(f, cg)
    Returns (({[q, r]})) where q (quotients) and
    r (remain) of division, which are obtained from the basis
    ((|f|)) and (({cg}))=((<Groebner.basis_coeff>))(f).
    ((<divmod_s>))(f) returns
    (({div_cg(f, Groebner.basis_coeff(f))})).

=end


=begin
  # sample-quotientfield02.rb

  require "algebra"

  F13 = ResidueClassRing(Integer, 13)

  P = Polynomial(F13, "x")
  Q = LocalizedRing(P)
  x = Q[P.var]
  p ( 1 / (x**2 - 1) - 1 / (x**3 - 1) )

  #This is equivalent to the following
  F = RationalFunctionField(F13, "x")
  x = F.var
  p ( 1 / (x**2 - 1) - 1 / (x**3 - 1) )
((<_|CONTENTS>))
=end


###############################################################################
# Pessismistic Open Field RL algorithm
#
# From Figure 1, Zorowitz et al. (2020)
# Translated from Python to R
# See https://github.com/ndawlab/seqanx for the original code
#
# Value iteration
#
###############################################################################

library(pheatmap)
library(proxy)
library(dplyr)
library(RColorBrewer)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# Define parameters.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#

# Variables
reward = 10
punishment = -10
epsilon = 0
start = 116

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# Environment setup and visualization.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#

# Initialize environment:
size <- 11
grid <- matrix(0, nrow = size, ncol = size)
grid[2,3] <- reward # number 14
grid[2,9] <- punishment # number 20

# Visualize environment:
pheatmap::pheatmap(grid, legend = FALSE, cluster_col = FALSE, cluster_row = FALSE,
                   display_numbers = TRUE, color = colorRampPalette(brewer.pal(n = 7, name = "RdYlBu"))(100))

# Identify coordinates of viable states:
viable_coordinates = data.frame(x = rep(1:size, each = size), y = rep(1:size))

# Make transition matrix with NA's and 1's:
transition_matrix <- proxy::dist(viable_coordinates, viable_coordinates, method = "Euclidean")
transition_matrix <- ifelse(transition_matrix == 1, 1, NA)

transition_matrix[14,] <- NA
transition_matrix[20,] <- NA
transition_matrix[14,14] <- 1
transition_matrix[20,20] <- 1

# Define rewards:
R <- matrix(0, nrow = size*size, ncol = size*size)
R[,14] <- reward; R[14,14] <- 0
R[,20] <- punishment; R[20,20] <- 0
R <- ifelse(transition_matrix == 1, R, NA)

# Define state information:
states <- 1:(size*size)
n_states <- length(states)
viable_states <- states[-c(14,20)] # viable states are states minus terminal states
n_viable_states <- length(viable_states)

# Iteratively define MDP information:
info <- data.frame(S = 0, S_prime = 0, R = 0)
index = 1
for (s in 1:n_states) {

  # What are the possible next states?
  s_prime = which(transition_matrix[s,] %in% 1)  # check on which position are the ones

  # What are the rewards for these next states?
  r = R[s, s_prime]

  # What is the probability of transitioning to next state?
  # t = 1 # determinisitic

  for (i in 1:length(s_prime)) {
    info[index,1] = s; info[index,2] <- s_prime[i]; info[index,3] <- r[i]
    index = index + 1
  }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# Value iteration and visualization.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#

# Function: Pessimism
pessimism <- function(arr, w) {
  return(w * max(arr) + (1 - w) * min(arr))
}

# Simulation parameters:
weights <- c(1, 0.5, 0)
gamma = 0.95
tol = 0.0001
max_iter = 100

# Initialize value iteration:
for (weight in weights) {

  # Initialize Q-values:
  Q <- matrix(rep(0, nrow(info)), ncol = 1) # Q is the expected reward for every possible transition
  copy <- info

  # Solve for Q-values:
  for (i in 1:max_iter) {

    # Make copy:
    q <- Q
    copy$Q <- q

    # Precompute successor value:
    V_prime <- c()
    for (s in 1:(size*size)) {
      arr <- copy %>% filter(S == s)
      V_prime[s] <- pessimism(arr$Q, weight) # V_prime is the value function for every possible state given the policy
    }

    # Compute Q-values:
    for (i in 1:nrow(info)) {
      Q[i] <- info$R[i] + gamma * V_prime[info$S_prime[i]]
    }

    # Compute delta:
    delta <- abs(Q - q)

    # Check for termination (i.e., all values of delta below threshold):
    if (all((delta < tol) == TRUE)) { break }
  }

  # Solve for values:
  copy = info
  copy$Q = Q

  # Identify max by state:
  V <- c()
  for (s in 1:(size*size)) {
    arr <- copy %>% filter(S == s)
    V[s] <- max(arr$Q) # V is the max value function for every possible state given the policy
  }

  # Fill in terminal states:
  grid_pessism <- matrix(V, nrow = size, ncol = size, byrow = TRUE)
  grid_pessism[2,3] = reward
  grid_pessism[2,9] = punishment

  # Visualize environment:
  pheatmap::pheatmap(grid_pessism, legend = FALSE, cluster_col = FALSE, cluster_row = FALSE,
                     display_numbers = TRUE, color = colorRampPalette(brewer.pal(n = 7, name = "RdYlBu"))(100),
                     main = paste0("Weight: ", weight))

  # Compute policy:
  policy <- c()
  policy[1] <- s <- start
  i = 1
  while ( s != 14 && s != 20) {

    # Compute optimal q(s, a):
    temp <- copy %>% filter(S == s)
    s <- temp$S_prime[which.max(temp$Q)]

    # Append it to policy
    policy <- c(policy, s)

    # Make sure it doesn't get stuck:
    i = i + 1
    if (i > 100) { break }
  }
}


# Getting Started in Fixed/Random Effects Models Using R.
# Oscar Torres-Reyna, Princeton University.

# Load Required Packages:
  require(foreign); library(foreign)
  require(car); library(car)
  require(gplots); library(gplots)

# Read Data Examples from Web or Local System:
  Panel <- read.dta("http://dss.princeton.edu/training/Panel101.dta")
  Panel <- read.dta(file = "C:\\Users\\Pooya\\OneDrive\\MyThesis\\MyTutorials\\Panel_Data_using_R\\Data_Examples\\Data.dta")
  Panel <- read.csv(file = "C:\\Users\\Pooya\\OneDrive\\MyThesis\\MyTutorials\\Panel_Data_using_R\\Data_Examples\\Data.csv", header = TRUE, sep = ',')

# Exploring Panel Data:
  coplot(formula = y ~ year | country, data = Panel, type = "l")
  scatterplot(y ~ year | country, data = Panel, boxplot = FALSE, smooth = TRUE, reg.line = FALSE)

# Fixed Effects: Plot Heterogeneity across Countries:
  plotmeans(formula = y ~ country, data = Panel, main = "Heterogeineity across Countries")

# Fixed Effects: Plot Heterogeneity across Years
  plotmeans(formula = y ~ year, data = Panel, main = "Heterogeineity across Years")

# OLS Regression:
  View(Panel)
  # y ~ x1:
  plot(x = Panel$x1, y = Panel$y, type = "p", xlab = "x", ylab = "y", pch = 19, col = "green")
  OLS <- lm(formula = y ~ x1, data = Panel)
  abline(OLS, lwd = 3, col = "green", lty = 2)
  summary(OLS)
  # y ~ x2:
  par(new = TRUE)
  plot(x = Panel$x2, y = Panel$y, type = "p", xlab = "x", ylab = "y", pch = 19, col = "red")
  OLS <- lm(formula = y ~ x2, data = Panel)
  abline(OLS, lwd = 3, col = "red", lty = 2)
  summary(OLS)
  # y ~ x3:
  par(new = TRUE)
  plot(x = Panel$x3, y = Panel$y, type = "p", xlab = "x", ylab = "y", pch = 19, col = "blue")
  OLS <- lm(formula = y ~ x3, data = Panel)
  abline(OLS, lwd = 3, col = "blue", lty = 2)
  summary(OLS)
  # y ~ x1 + x2 + x3:
  par(new = TRUE)
  OLS <- lm(formula = y ~ x1 + x2 + x3, data = Panel)
  abline(OLS, lwd = 3, col = "black", lty = 2)
  summary(OLS)

# Fixed Effects Using Least Squares Dummy Variable Model:
  fixed.dum <- lm(y ~ x1 + x2 + x3 + factor(country) - 1, data = Panel)
  summary(fixed.dum)

# Why Intercept Ignore: fixed.dum <- lm(y ~ x1 + factor(country), data = Panel)

yhat <- fixed.dum$fitted.values

scatterplot(yhat ~ Panel$x1 | Panel$country, boxplot = FALSE, xlab = "x1", ylab = "yhat", smooth = FALSE)
abline(lm(Panel$y ~ Panel$x1), lwd = 3, col = "red")

# Comparing OLS vs LSDV model: ----------------------------------------------------------------

apsrtable(ols, fixed.dum, model.names = c("OLS", "OLS_DUM"))

# Fixed effects: n entity-specific intercepts (using plm): ------------------------------------

fixed.individual <- plm(formula = y ~ x1 + x2 + x3, data = Panel, index = c("country", "year"), model = "within", effect = "individual")
summary(fixed.individual)

fixed.time <- plm(formula = y ~ x1 + x2 + x3, data = Panel, index = c("country", "year"), model = "within", effect = "time")
summary(fixed.time)

fixed.twoways <- plm(formula = y ~ x1 + x2 + x3, data = Panel, index = c("country", "year"), model = "within", effect = "twoways")
summary(fixed.twoways)

# Extracts the fixed effects from a plm object: Fixed Effects (constants for each coun --------

fixef(fixed.individual)
fixef(fixed.time)
fixef(fixed.twoways, effect = "time")

# F Test for Individual and/or Time Effects: Testing for fixed effects, null - OLS better -----
# than fixed (If the p-value is < 0.05 then the fixed effects model is a better choice)

pFtest(fixed.individual,ols)
pFtest(fixed.time, ols)
pFtest(fixed.twoways, ols)

# RANDOM-EFFECTS MODEL: -----------------------------------------------------------------------

random <- plm(formula = y ~ x1 + x2 + x3, data = Panel, effect = "individual", model ="random", index = c("country", "year"))
summary(random)

# Fixed or Random: Hausman Test ---------------------------------------------------------------

phtest(fixed.individual, random)

# Testing for Time-Fixed Effects --------------------------------------------------------------
fixed.time.dummy <- plm(formula = y ~ x1 + x2 + x3 + factor(year), data = Panel, model ="within", index = c("country", "year"))
summary(fixed.time.dummy)

# Testing time-fixed effects:  The null is that no time-fixed effects needed ------------------

pFtest(fixed.time.dummy, fixed.individual)

# Lagrange Multiplier Test - time effects (Breusch-Pagan): ------------------------------------

plmtest(fixed.individual, c("time"), type = ("bp"))

# Testing for random effects: Breusch-Pagan Lagrange multiplier (LM) --------------------------

pool <- plm(formula = y ~ x1 + x2 + x3, data = Panel, index = c("country", "year"), effect = "individual", model = "pooling")
summary(pool)

# Breusch-Pagan Lagrange Multiplier for random effects. Null is no panel effect (i.e.  --------

plmtest(pool, type = c("bp"))

# Testing for cross-sectional dependence/contemporaneous correlation: -------------------------
# using Breusch-Pagan LM test of independence and Pasaran CD test.
# The null hypothesis in the B-P/LM and Pasaran CD tests of independence is that residuals across entities are not correlated.

pcdtest(fixed.individual, test = c("lm"))

pcdtest(fixed.individual, test = c("cd"))

# Testing for serial correlation --------------------------------------------------------------
# The null is that there is not serial correlation:

pbgtest(fixed.individual)

# Testing for unit roots/stationarity ---------------------------------------------------------
# The Dickey-Fuller test to check for stochastic trends
# The null hypothesis is that the series has a unit root (i.e. non-stationary).

Panel.set <- plm.data(Panel, index = c("country", "year"))
adf.test(Panel.set$y, k = 2)

# Testing for heteroskedasticity: -------------------------------------------------------------


muX <- 3.68
sigma1 <- 0.64

muY <- 4.8
sigma2 <- 0.49

domanda1 <- 9.51

muSomma <- muX + muY
sigmaQuadratoSomma <- sigma1^2 + sigma2^2
sigmaSomma <- sqrt(sigmaQuadratoSomma)

risposta1 <- pnorm(domanda1, muSomma, sigmaSomma, FALSE);

risposta2 <- sigmaQuadratoSomma / ((domanda1-muSomma)^2)

print(risposta1)
print(risposta2)


x1 <- 18.91
x2 <- 22.81

prMinore <- 6/100
prMaggiore <- 7/100

pr2C <- 1-prMaggiore

pr3 <- 10/100

x4 <- 4.64

q1 <- qnorm(prMinore)
q2 <- qnorm(pr2C)

mu <- ((-q2*x1)/q1 + x2)/(1-q2/q1);

sigma <- (x1-mu)/q1;

risposta4 <- pnorm(x4^2, mu, sigma);

print(mu)

print(sigma);

q1 <- qnorm(1-pr3);

risposta3 <- (x2 - mu)/q1

print(risposta3)

print(risposta4)


johnson_tol <- function(xall, alpha=0.01, P=0.99, side=1) {

    ## xall = data set
    ## alpha  = 1 - confidence
    ## P = pvalue = coverage (tolerance interval only)
    pvalue <- P

    ## install.packages('tolerance')
    library(tolerance)
    ## install.packages('SuppDists')
    library(SuppDists)

    ## Johnson distribution calculations from SuppDists package
    jparms  <- JohnsonFit(xall)
    ## transform xall dataset to normally distributed z using Johnson distribution
    zall <- john_z(xall, jparms)
    df <- as_tibble( data.frame(x=xall, z=zall) )

    na_rows <- df[is.na(df$z),]
    if (nrow(na_rows) != 0) {

        ## z values could not be calculated for all x values
        cat('\n')
        cat('##############################\n')
        cat('  ERROR IN JOHNSON_TOL  \n')
        cat('  z(x) = NA for some x values \n')
        cat('##############################\n')
        print(jparms)
        print(na_rows)
        ztol_out <- normtol.int(zall, alpha = alpha, P=pvalue, side=side)
        ztol_upper <- NA
        xtol_upper <- NA

    } else {

        ## johnson fit returned z values for all x values so possibly a decent fit

        ## xz_plot <- plot(xall, zall)

        ## define function to find x for a given z
        ## zero <- function(x, parms=jparms, ztarget) john_z(x, parms) - ztarget
        zero <- function(x, parms, z) john_z(x, parms) - z

        ## check use of uniroot
        ## xcheck <- 13
        ## ztarget <- john_z(xcheck)
        ## ztox <- uniroot(zero, lower=min(xall), tol=1E-10, upper=2*max(xall), ztarget=ztarget)$root
        ## x_from_z <- uniroot(zero, ztarget=ztarget,
        ##                     lower=min(xall), upper=2*max(xall), tol=1E-10)$root

        ## find tolerance limits using normal distribution calculations on z
        ztol_out <- normtol.int(zall, alpha = alpha, P=pvalue, side=side)
        xmin <- min(xall)
        xmax <- max(xall)
        if (side == 1) {
            ztol_upper <- ztol_out$'1-sided.upper'
            ztol_lower <- ztol_out$'1-sided.lower'
        } else if (side == 2) {
            ztol_upper <- ztol_out$'2-sided.upper'
            ztol_lower <- ztol_out$'2-sided.lower'
        }

        ## transform z back to u
        ##  uniroot is not very robust so try newton raphson
        ##  xrange <- max(xall) - min(xall)
        ##  xtol_upper <- uniroot(zero, ztarget=ztol_upper,
        ##                        lower=xmax, upper=xmax + xrange, tol=1E-10)$root

        if (jparms$type == 'SB') {
            ## Not sure tolerance limits have meaning for a bounded fit
            xtol_lower <- NA
            xtol_upper <- NA
        } else {
            ## Tolerance limits should have meaning for SU and SN
            ## Upper tolerance limit should have meaning for SL
            xtol_upper <- newton.raphson(zero, parms=jparms, z=ztol_upper, xguess=mean(xall), tol=1E-10)
            if (jparms$type == 'SL') {
                xtol_lower <- NA
            } else {
                xtol_lower <- newton.raphson(zero, parms=jparms, z=ztol_lower, xguess=mean(xall), tol=1E-10)
            }
        }
    }
    return(list(xz=df, jparms=jparms, ztol_out=ztol_out,
                ztol_upper=ztol_upper, xtol_upper=xtol_upper,
                ztol_lower=ztol_lower, xtol_lower=xtol_lower))
}

## ## test
##
## set.seed(1)
## x                          <- rnorm(n=1E5, mean=10, sd=1)
## tol_out_john               <- johnson_tol(x, alpha=0.1, P=0.99, side=1)
## jparms                     <- tol_out_john$jparms
## ztol_upper                <- tol_out_john$ztol_upper
## ztol_upper
## upper_tolerance_limit_john <- tol_out_john$xtol_upper$`root approximation`
## upper_tolerance_limit_john
##
## xz <- tol_out_john$xz
## plotspace(1,3)
## hist(xz$x)
## hist(xz$z)
## plot(xz$x, xz$z)


designBased = function(gamma, outcome_vec, pcf_cat_vec, instid_vec){
	#' Compute Design Based Draper-Gittoes Z-Scores
	#'
	#'	\code{designBased} implements design based approach and
	#' computes O, E, and z vectors following Draper-Gittoes (2004)
	#'
	#' @param gamma Parameter in [0,1] controling pooling.
	#' Gamma = 1 is complete global pooling, gamma = 0 is complete local pooling.
	#' @param outcome_vec Vector with elements in {0,1} denoting the binary outcome.
	#' @param pcf_cat_vec Vector with unique values for each PCF category.
	#' @param instid_vec Vector with unique values for each institution.
	stopifnot( all( outcome_vec %in% c(0,1)) )
	#Some of the inputs need to be factors
	pcf_cat_vec = as.factor(pcf_cat_vec)
	instid_vec = as.factor(instid_vec)

	#Summarize
	instid_unique = levels(instid_vec)
	n_students = length(outcome_vec)
	n_u = length(levels(instid_vec))
	n_cat = length(levels(pcf_cat_vec))
	p_global = mean(outcome_vec)
	#Compute Table 2 in Draper-Gittoes
	y_mat = n_mat = matrix(0, nrow =n_u, ncol = n_cat)

	for (i in 1:n_students){
    inst = as.integer(instid_vec[i])
    categ = as.integer(pcf_cat_vec[i])
    n_mat[inst,categ] = n_mat[inst,categ] + 1
    y_mat[inst, categ] = y_mat[inst, categ] + outcome_vec[i]
	}
	p_mat = y_mat / n_mat
	p_mat[n_mat == 0] = 0

	#Marginal summaries
	pcf_p_vec = apply(y_mat, 2, sum) / apply(n_mat, 2, sum)
	n_u_vec = apply(n_mat, 1, sum)
	n_cat_vec = apply(n_mat, 2, sum)

	#Equation (2) in Draper-Gittoes (2004)
	O = apply(y_mat, 1, sum) / apply(n_mat, 1, sum)
	#Equation (3) in D-G
	E = apply(t(t(n_mat) * pcf_p_vec), 1, sum) / n_u_vec
	#Equation (4) in D-G
	D = O - E

	#Variance
	lambdaFun = function(i,k,j){
		#Equation (7) in D-G
		if (i == k){
			return(n_mat[i,j]/n_u_vec[i] * (1 - (n_mat[i,j]/n_cat_vec[j])))
		} else{
			return( -1 * (n_mat[i,j] * n_mat[k,j]) / (n_u_vec[i] * n_cat_vec[j]) )
		}
	}
	vFun = function(k,j, gamma = 0.5){
		#Equation (11) in D-G
		n = n_mat[k,j]
		pcomb = function(p_local){gamma * p_global + (1-gamma) * p_local}
		if (n > 0){
			p_local = p_mat[k, j]
			p_star = pcomb(p_local)
			return(p_star * (1-p_star)/n)
		} else {
			return(0)
		}
	}
	computeVi = function(i, gamma){
		#Equation (8) in D-G
		v = 0
		for (k in 1:n_u){
			for (j in 1:n_cat){
				v = v + lambdaFun(i,k,j)^2 * vFun(k, j, gamma)
			}
		}
		return(v)
	}
	#Now compute w/ lapply
	V = sapply(1:n_u, computeVi, gamma)
	SE = sqrt(V)

	Z = (O - E) / SE

	out_df = data.frame(
			inst = as.numeric(as.character(instid_unique)),
			effect = O-E,
			O = O,
			E = E,
			D = D,
			SE = SE,
			Z = Z,
			n = n_u_vec
	)
	return( out_df[order(out_df$inst), ])
}


# A matrix is a collection of elements of the same data type (numeric, character, or logical)
# arranged into a fixed number of rows and columns. Since you are only working with rows and columns,
# a matrix is called two-dimensional.

# Construct a matrix with 3 rows that contain the numbers 1 up to 9
matrix(1:9, byrow=TRUE, nrow=3)

# byrow: indicates that the matrix is filled by row. For columns use param of FALSE
# nrow: indicates the number of rows to fill

# Box office Star Wars (in millions!)
new_hope <- c(460.998, 314.4)
empire_strikes <- c(290.475, 247.900)
return_jedi <- c(309.306, 165.8)

# Create box_office
box_office <- c(new_hope, empire_strikes, return_jedi)

# Construct star_wars_matrix
star_wars_matrix <- matrix(box_office, byrow=TRUE, nrow=3)


# calculate probability in normal distribution with R
# variable y  with normal distribution N(??, ??), where ??=20 and ?? = 2
# pnorm function gives the probability of a normally distributed random number to be less that the value of a given number.
#  the probability that a measurement will be less than 23 is given by
pnorm(23,mean =20,sd=2)


#---------------------------------------------------------------------
# nn_norm -- Utility function for normalizing matrices for neural
#            network analyses.
#
# Usage:  normed_mat <- nn_norm(input, [type=c("mm","z")], [alt=normed_mat])
#
# Args:
#  input  -- An input vector or matrix to be normalized by columns.
#  type   -- One of "mm" for min-max normalization or "z" for z-scores
#  alt    -- An already normalized matrix with the same number of columns
#            as the input from which the scaling and offset are used.
#
# Description:
#  By default, nn_norm applies min-max scaling to the input matrix and
#  returns a normalized copy of the input. The offset and scaling factor
#  used for normalization are returned as attributes of the output
#  matrix, specifically "nn_norm:offset" and "nn_norm:scale". These
#  attributes can then be used to restore the original matrix, or used
#  to apply equivalent normalization to another matrix when passed as
#  the alt argument.
#
#  See nn_unnorm for the inverse of this.
#
# Author: Bunnell -- 1/4/20
#----------------------------------------------------------------------
nn_norm <- function(inp, type="mm", alt=NULL) {
#
# Calculate or assign scale and offset
#
  if (is.null(alt)) {
    if (type == "mm") {
      #cat("scale MM\n")
      if (is.null(dim(inp))) {
        coff <- min(inp)
        cscl <- max(inp) - coff
        if (cscl == 0) {
          cscl = 1
        }
      } else {
        cmax <- apply(inp, 2, max)
        coff <- apply(inp, 2, min)
        cscl <- cmax - coff
        j <- which(cscl == 0 | is.nan(cscl) | is.na(cscl))
        cscl[j] <- 1
      }
    } else {
      #cat("scale Z\n")
      if (is.null(dim(inp))) {
        coff <- mean(inp)
        cscl <- sd(inp)
        if (cscl == 0 || is.na(cscl) || is.nan(cscl))
          cscl = 1
      } else {
        cscl <- apply(inp, 2, sd)
        coff <- apply(inp, 2, mean)
        j <- which(cscl == 0 | is.nan(cscl) | is.na(cscl))
        cscl[j] <- 1
      }
    }
  } else {
    #cat("alt scaling\n")
    coff <- attr(alt, "nn_norm:offset")
    cscl <- attr(alt, "nn_norm:scale")
  }
#
# Apply the scaling
#
  if (is.null(dim(inp))) {  # Must be a vector
    oup <- (inp - coff) / cscl
  } else {
    oup <- t((t(inp) - coff) / cscl)
  }
#
# Save scaling parameters as attributes
#
  attr(oup, 'nn_norm:offset') = coff
  attr(oup, 'nn_norm:scale') = cscl

  oup
}

#---------------------------------------------------------------------
# nn_unnorm -- Utility function to undo normalization that was applied
#              to a matrix or vector.
#
# Usage:  matrix <- nn_unnorm(input, [alt=normed_mat])
#
# Args:
#  input  -- An previously normalized input vector or matrix or similar
#            object that is presumed to be in the normalized space of
#            another object passed as the alt argument.
#  alt    -- An already normalized matrix with the same number of columns
#            as the input from which the scaling and offset are used.
#
# Description:
#  By default, nn_unnorm uses the attributes of the input matrix to
#  recover the offset and scaling parameters and applies the inverse
#  operation to restore the original unnormalized matrix.
#
#  If the alt argument is provided, nn_unnorm instead uses the
#  scaling attributes from the alt matrix to apply to the input matrix.
#
#  See nn_norm for the inverse of this.
#
# Author: Bunnell -- 1/4/20
#----------------------------------------------------------------------
#
nn_unnorm <- function(inp, alt=NULL) {
  if (is.null(alt)) {
    coff <- attr(inp, "nn_norm:offset")
    cscl <- attr(inp, "nn_norm:scale")
  } else {
    coff <- attr(alt, "nn_norm:offset")
    cscl <- attr(alt, "nn_norm:scale")
  }

  if (is.null(dim(inp))) {
    oup <- cscl * inp + coff
  } else {
    oup <- t((t(inp) * cscl) + coff)
  }

  oup
}


#' @title quantile_to_normal
#' @description convert quantile to normal with mean 0.5 and variance such that ci% are found within the range (0,1)
#' @family abysmally documented
#' @author  Jae Choi, \email{jae.choi@@dfo-mpo.gc.ca}
#' @export
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)
}


library(MASS);

intervallo1 <- c(0,9)
intervallo2 <- c(9,16)

k_coeffs <- c(1, -1/7);

domanda3 <- 9

k <- 1
density1 <- function(x){

  k*k_coeffs[1]

}

density2 <- function(x){

  k*k_coeffs[2]*(x-intervallo2[2]);

}

ass1 <- function(x){

  x*k*k_coeffs[1];

}

ass2 <- function(x){

  x*k*k_coeffs[2]*(x-16)

}

integral1 <- integrate(Vectorize(density1), lower = intervallo1[1], upper = intervallo1[2])
integral2 <- integrate(Vectorize(density2), lower = intervallo2[1], upper = intervallo2[2])
integral <- integral1$value + integral2$value;
risposta1 <- 1/integral
print(fractions(risposta1));

k <- risposta1

integral1 <- integrate(Vectorize(ass1), lower = intervallo1[1], upper = intervallo1[2])
integral2 <- integrate(Vectorize(ass2), lower = intervallo2[1], upper = intervallo2[2])
integral <- integral1$value + integral2$value;

print(integral);

risposta3 <- 0
if( domanda3 >= intervallo1[1] && domanda3 <= intervallo2[2] ){
  if( intervallo1[1] <= domanda3 && domanda3 < intervallo1[2] ){
    integral <- integrate(Vectorize(density1), lower = intervallo1[1], upper= domanda3)
    integral <- integral$value
  } else{
    integral1 <- integrate(Vectorize(density1), lower = intervallo1[1], upper = intervallo1[2])
    integral2 <- integrate(Vectorize(density2), lower = intervallo2[1], upper = domanda3)
    integral <- integral1$value + integral2$value
  }
  risposta3 <- 1 - (integral);
}

print(risposta3)


#  Calculating a Confidence Interval From a Normal Distribution
n<-50
 a<-2.8
 s<-0.6
 #  we will use a 95% confidence level and wish to find the confidence interval
 margin <- qnorm(0.975)*s/sqrt(n)
 left_i <- a-margin
   right_i <- a+margin
   print("Confidence interval is")
   print(left_i)
   print(right_i)


=begin
  # sample-geometry04.rb

  require 'algebra'

  R = MPolynomial(Rational)
  x,y,a1,a2,b1,b2,c1,c2 = R.vars('xya1a2b1b2c1c2')
  V = Vector(R, 2)
  X, A, B, C = V[x,y], V[a1,a2], V[b1,b2], V[c1,c2]

  def perpendicular(p0, p1, p2, p3)
    (p0-p1).inner_product(p2-p3)
  end

  def line(p1, p2, p3)
    SquareMatrix.det([[1, *p1], [1, *p2], [1, *p3]])
  end

  l1 = perpendicular(X, A, B, C)
  l2 = perpendicular(X, B, C, A)
  l3 = perpendicular(X, C, A, B)

  s = line(A, B, C)
  g = Groebner.basis [l1, l2, l3, s-1] #s-1 means non degeneracy

  g.each do |f|
    p f
  end
  #x + a1a2b1 - a1a2c1 - a1b1c2 + a1c1c2 + a2^2b2 - a2^2c2 - a2b1^2 + a2b1c1 - a2b2^2 + a2c2^2 + b1^2c2 - b1c1c2 - b1 + b2^2c2 - b2c2^2
  #y - a1^2b1 + a1^2c1 + a1b1^2 - a1c1^2 - a2^2b1 + a2^2c1 + a2b1b2 + a2b1c2 - a2b2c1 - a2c1c2 - a2 - b1^2c1 - b1b2c2 + b1c1^2 + b2c1c2
  #a1b2 - a1c2 - a2b1 + a2c1 + b1c2 - b2c1 - 1
((<_|CONTENTS>))
=end


comb.sort<-function(a){
  gap<-length(a)
  swaps<-1
  while(gap>1 & swaps==1){
    gap=floor(gap/1.3)
    if(gap<1){
      gap=1
      }
    swaps=0
    i=1
    while(i+gap<=length(a)){
        if(a[i]>a[i+gap]){
        a[c(i,i+gap)] <- a[c(i+gap,i)]
        swaps=1
        }
        i<-i+1
      }
  }
  return(a)
}


### fimd1.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 21mar2012
### Version 2, 4nov2015
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.12

### Chapter 1 	Introduction
### Section 1.1 The problem of missing data

### calculate the mean of three numbers
y <- c(1, 2, 4)
mean(y)

### calculate the mean of three numbers, where one is missing
y <- c(1, 2, NA)
mean(y)

### repeat, but with any missing data removed
mean(y, na.rm=TRUE)

### store your current options (safety measure)
youroptions <- options()

### demo regression that generates an error message using default na.fail
options(na.action = na.fail)

### uncomment to see the error
### lm(Ozone ~ Wind, data=airquality)

### remove incomplete observations by 'na.action = na.omit'
fit <- lm(Ozone ~ Wind, data = airquality, na.action = na.omit)
coef(fit)

### set automatic na.action = na.omit
options(na.action = na.omit)

### find out how many rows were deleted
deleted <- na.action(fit)
naprint(deleted)

### more incomplete rows if we add Solar.R as predictor
fit2 <- lm(Ozone ~ Wind+Solar.R, data=airquality)
naprint(na.action(fit2))

### restore your original options, but set na.omit
options(youroptions)
options(na.action=na.omit)

### Section 1.3.2 Pairwise deletion

### note: mean(<data.frame>) is deprecated
colMeans(airquality, na.rm=TRUE)
cor(airquality, use="pair")
cov(airquality, use="pair")

### Section 1.3.3 Mean imputation

### install the mice package from CRAN if you have not yet done so
### by uncommenting and running the next line
# install.packages("mice")

library("mice")
library("lattice")

### impute the mean
imp <- mice(airquality, method="mean", m=1, maxit=1)

### Figure 1.1
lwd <- 1.5
par(mfrow=c(1,2))
breaks <- seq(-20, 200, 10)
nudge <- 1
x <- matrix(c(breaks-nudge, breaks+nudge), ncol=2)
obs <- airquality[,"Ozone"]
mis  <- imp$imp$Ozone[,1]
fobs <- c(hist(obs, breaks, plot=FALSE)$counts, 0)
fmis <- c(hist(mis, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R, na.groups=ici(imp),
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### Section 1.3.4 Regression imputation

fit <- lm(Ozone ~ Solar.R, data=airquality)
pred <- predict(fit, newdata=ic(airquality))

### alternative using mice
imp <- mice(airquality[,1:2], method="norm.predict", m=1, maxit=3,seed=1)

### Figure 1.2
par(mfrow = c(1,2))
fmis <- c(hist(pred, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R,
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### Section 1.3.5 Stochastic regression imputation

imp <- mice(airquality[,1:2],method="norm.nob",m=1,maxit=1,seed=1)

### Figure 1.3
par(mfrow = c(1,2))
mis  <- imp$imp$Ozone[,1]
fmis <- c(hist(mis, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R, na.groups=ici(imp),
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### Section 1.3.6 LOCF and BOCF

par(mfrow=c(1,1))
Oz <- airquality$Ozone
locf <- function(x) {
  a <- x[1]
  for (i in 2:length(x)) {
    if (is.na(x[i])) x[i] <- a
    else a <- x[i]
  }
  return(x)
}
Ozi <- locf(Oz)
colvec <- ifelse(is.na(Oz),mdc(2),mdc(1))

### Figure 1.4

plot(Ozi[1:80],col=colvec,type="l",xlab="Day number",ylab="Ozone (ppb)")
points(Ozi[1:80],col=colvec,pch=20,cex=1)

### Section 1.4.3 Example of multiple imputation

imp <- mice(airquality, seed=1, print=FALSE)
fit <- with(imp, lm(Ozone ~ Wind + Temp + Solar.R))
tab <- round(summary(pool(fit)),3)
tab[,c(1:3,5)]

fit <- lm(Ozone~Wind+Temp+Solar.R,data=airquality,na.action=na.omit)
round(coef(summary(fit)),3)

### Figure 1.6
par(mfrow = c(1,2))
mis  <- imp$imp$Ozone[,1]
fmis <- c(hist(mis, breaks, plot=FALSE)$counts, 0)
y <- matrix(c(fobs, fmis), ncol=2)
matplot(x, y, type="s",
        col=c(mdc(4),mdc(5)), lwd=2, lty=1,
        xlim = c(0, 170), ylim = c(0,40), yaxs = "i",
        xlab="Ozone (ppb)",
        ylab="Frequency")
box()

tp <- xyplot(imp, Ozone~Solar.R, subset = .imp==1,
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))
print(tp, newpage = FALSE, position = c(0.48,0.08,1,0.92))

### scatterplot of all imputed data sets (not in the book)
xyplot(imp, Ozone~Solar.R | .imp,
       ylab="Ozone (ppb)", xlab="Solar Radiation (lang)",
       cex = 0.75, lex=lwd,
       ylim = c(-20, 180), xlim = c(0,350))

### Figure 1.7

Oz <- airquality$Ozone
colvec <- ifelse(is.na(Oz),mdc(2),mdc(1))
par(mfrow=c(1,1))
plot(Oz[1:80],col=mdc(1),type="l",xlab="Day number",ylab="Ozone (ppb)")
points(Oz[1:80],col=mdc(1),pch=20,cex=1)

idx <- ici(airquality$Ozone) & (1:153)<81
x   <- (1:153)[idx]
points(x=x,y=complete(imp,1)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,2)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,3)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,4)$Ozone[idx],col=mdc(2),pch=20,cex=1)
points(x=x,y=complete(imp,5)$Ozone[idx],col=mdc(2),pch=20,cex=1)

### figure of the autocorrelation function
### (not in the book)

par(mfrow=c(2,5))
acf.ozone <- with(imp,acf(Ozone))
model <- expression(acf(resid(lm(Ozone ~ Wind + Temp + Solar.R))))
acf.resid <- with(imp,model)
calcacf <- function(acf.list) {
  k <- length(acf.list)
  acc <- acf.list[[1]]$acf
  for (i in 2:k) acc <- acc + acf.list[[i]]$acf
  return(acc/k)
 }
oz <- round(calcacf(acf.ozone$analyses),2)
re <- round(calcacf(acf.resid$analyses),2)


options(scipen = 999)

set.seed(082421)
# creating 5 different categories, with different amounts of time they show up in the data
categories = rep(letters[1:5], times = c(5, 4, 6, 8, 7))

# 30 observations with the mean and standard deviation
test_scores = rnorm(n = 30, mean = 7.14, sd = 2.16)

# Making the categories act like categories rather than numerical values
categories = as.factor(categories)

# Observations (be careful R is case sensitive)
N = 30

# Getting frequencies by using R as a calculator

# get the frequencies of all the categories
table(categories)

# Frequency & Percentage of A
5/30
(5/30)*100

# Frequency & Percentage of B
4/30
(4/30)*100

# Frequency & Percentage of C
6/30
(6/30)*100

# Frequency & Percentage of D
8/30
(8/30)*100

# Frequency & Percentage of E
7/30
(7/30)*100

# cumulative frequencies of categories A & B
(5/30) + (4/30)
# another option is to do the calculations above and then just add up the frequency of A with the frequency of B
.167 + .133

# To get the cumlative percentage of all 5 categories
(5/30)*100 + (4/30)*100 + (6/30)*100 + (8/30)*100 + (7/30)*100
# you can also use the calculations above to add up all the percentages
16.667 + 13.333 + 20 + 26.667 + 23.333

# Now getting frequencies by using objects

#remember that N is the number of observations
N

freq_a <- 5/N
freq_a

# Percent of category A
percent_a <- freq_a*100
percent_a

freq_b <- 4/N
freq_b

percent_b <- freq_b*100
percent_b

freq_c <- 6/N
freq_c

percent_c <- freq_c*100
percent_c

freq_d <- 8/N
freq_d

percent_d <- freq_d*100
percent_d

freq_e <- 7/N
freq_e

percent_e <- freq_e*100
percent_e

# cumulative frequency of A & B
freq_ab = freq_a + freq_b
freq_ab

# To get the cumlative percentage of all 5 categories
total_percent = percent_a + percent_b + percent_c + percent_d + percent_e
total_percent

# find the mode
# which value occurs most often
table(categories)

# Finding the mean
sort(test_scores)

#look for the middle value or in this case the 15th and 16th observations
# 7.060384 & 7.212301 and then divide by 2
(7.06 + 7.21)/2

# find the median using objects
sort(test_scores)
sort(test_scores)[15:16]

get_median = (7.06 + 7.21)/2
get_median

median(test_scores)

# Finding the mean
# look at test scores first in order for lowest to highest
sort(test_scores)

# Now let's get the sum of the scores
1.98 + 3.54 + 3.57 + 4.28 + 4.40 + 4.51 + 4.98 + 5.67 + 5.90 + 6.09 + 6.44 + 6.44 + 6.59 + 6.82 + 7.06 +
  7.21 + 7.29 + 7.82 + 7.87 + 7.87 + 8.24 + 8.69 + 8.85 + 8.92 + 9.38 + 9.41 + 10.67 + 10.95 + 12.06 + 12.59

# Now let's divide the sum of the scores by the number of observations to get the mean
(1.98 + 3.54 + 3.57 + 4.28 + 4.40 + 4.51 + 4.98 + 5.67 + 5.90 + 6.09 + 6.44 + 6.44 + 6.59 + 6.82 + 7.06 +
    7.21 + 7.29 + 7.82 + 7.87 + 7.87 + 8.24 + 8.69 + 8.85 + 8.92 + 9.38 + 9.41 + 10.67 + 10.95 + 12.06 + 12.59)/30

# 7.20 is the mean of our scores

# Now getting the mean with objects
sort(test_scores)

# look at how many observations we have
N

# Now lets get the sum of the scores
sum_of_scores = sum(test_scores)
sum_of_scores

# get the mean
xbar = sum_of_scores/N
# could also look at it this way
xbar2 = sum_of_scores/30

xbar
xbar2

# we get the same mean

#Finding how far each participant deviates from the mean value/score
sort(test_scores)
# look at how far students deviated from the average score by doing each one individually
1.98 - 7.20
3.54 - 7.20
3.57 - 7.20
4.28 - 7.20
4.40 - 7.20
4.51 - 7.20
4.98 - 7.20
5.67 - 7.20
5.90 - 7.20
6.09 - 7.20
6.44 - 7.20
6.44 - 7.20
6.59 - 7.20
6.82 - 7.20
7.06 - 7.20
7.21 - 7.20
7.29 - 7.20
7.82 - 7.20
7.87 - 7.20
7.87 - 7.20
8.24 - 7.20
8.69 - 7.20
8.85 - 7.20
8.92 - 7.20
9.38 - 7.20
9.41 - 7.20
10.67 - 7.20
10.95 - 7.20
12.06 - 7.20
12.59 - 7.20

# now to get the sum of the deviations
# this is right, you might just have to go past two decimal points
(-5.22) + (-3.66) + (-3.63) + (-2.92) + (-2.8) + (-2.69) + (-2.22) + (-1.53) + (-1.3) + (-1.11) + (-.76) + (-.76) +
  (-.61) + (-.38) + (-.14) + .01 + .09 + .62 +.67 + .67 + 1.04 + 1.49 + 1.65 + 1.72 + 2.18 +2.21 + 3.47 + 3.75 + 4.86 + 5.39

# Now getting the deviations from the mean score/value using objects
# remember to look at the test scores
sort(test_scores)

# lets remember what the mean was
xbar

# look at how far students deviated from the average score using the objects we created earlier
deviation = test_scores - xbar
deviation

# look to see how far the worse test score was from the mean
sort(deviation)

# getting the sum of the deviations
sum(deviation)


# Example : 4   Chapter : 2.7   Pageno : 110
# Product of matrix and its trnspose gives symmetric matrix
R<-matrix(c(-1,0,1,-1,0,1),ncol=3)
RT<-t(R)
print("R * t(R)")
print(R%*%RT)
print("t(R) * R")
print(RT%*%R)


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('gen')

## ----lspline2,echo=FALSE,child='lspline.Rnw'----------------------------------

## ----lspline,echo=FALSE,bty='l',cap='A linear spline function with knots at $a = 1, b = 3, c = 5$.'----
x <- c(0,1,3,5,6)
y <- c(4,3,5.5,5,2)
plot(x, y, type="l", xlab=expression(X), ylab=expression(f(X)), axes=FALSE)
axis(1)
axis(2, labels=FALSE)

## ----rcscomp2,child='rcscomp.Rnw'---------------------------------------------

## ----rcscomp,mfrow=c(1,2),left=-2,h=3.5,w=4.5,cap='Restricted cubic spline component variables for $k = 5$ and knots at $X = .05, .275, .5, .725$, and $.95$.  Nonlinear basis functions are scaled by $\\tau$.  The left panel is a $y$--magnification of the right panel.  Fitted functions such as those in Figure \\ref{fig:gen-rcsex} will be linear combinations of these basis functions as long as knots are at the same locations used here.',scap='Restricted cubic spline component variables for 5 knots'----
require(Hmisc)
x <- rcspline.eval(seq(0,1,.01),
                   knots=seq(.05,.95,length=5), inclx=T)
xm <- x
xm[xm > .0106] <- NA
matplot(x[,1], xm, type="l", ylim=c(0,.01),
        xlab=expression(X), ylab='', lty=1)
matplot(x[,1], x,  type="l",
        xlab=expression(X), ylab='', lty=1)

## ----rcsex2,child='rcsex.Rnw'-------------------------------------------------

## ----rcsex,h=6,w=5.5,left=-2,bot=2,mfrow=c(2,2),ps=13,cap='Some typical restricted cubic spline functions for $k = 3, 4, 5, 6$.  The $y$--axis is $X\\beta$.  Arrows indicate knots. These curves were derived by randomly choosing values of $\\beta$ subject to standard deviations of fitted functions being normalized.',scap='Some typical restricted cubic spline functions'----
x <- seq(0, 1, length=300)
for(nk in 3:6) {
  set.seed(nk)
  knots <- seq(.05, .95, length=nk)
  xx <- rcspline.eval(x, knots=knots, inclx=T)
  for(i in 1 : (nk - 1))
    xx[,i] <- (xx[,i] - min(xx[,i])) /
              (max(xx[,i]) - min(xx[,i]))
  for(i in 1 : 20) {
    beta  <- 2*runif(nk-1) - 1
    xbeta <- xx %*% beta + 2 * runif(1) - 1
    xbeta <- (xbeta - min(xbeta)) /
             (max(xbeta) - min(xbeta))
    if(i == 1) {
      plot(x, xbeta, type="l", lty=1,
           xlab=expression(X), ylab='', bty="l")
      title(sub=paste(nk,"knots"), adj=0, cex=.75)
      for(j in 1 : nk)
        arrows(knots[j], .04, knots[j], -.03,
               angle=20, length=.07, lwd=1.5)
    }
    else lines(x, xbeta, col=i)
  }
}

## ----regass2,child='regass.Rnw'-----------------------------------------------

## ----regass,echo=FALSE,cap='Regression assumptions for one binary and one continuous predictor',axes=FALSE----
plot(0:1, 0:1, xlab=expression(X[2]), ylab=expression(C(Y)),
     axes=FALSE,  type='n')
axis(1, at=0:1, labels=rep('',2))
axis(2, at=0:1, labels=rep('',2))
lines(c(.05, .8), c(.05, .5))
lines(c(.05, .8), c(.30, .75))
text(.9, .5, expression(X[1]==0), adj=.5)
text(.9, .75,expression(X[1]==1), adj=.5)

x <- c(0,1,3,5,6)
y <- c(4,3,5.5,5,2)
plot(x, y, type="l", xlab=expression(X), ylab=expression(f(X)), axes=FALSE)
axis(1)
axis(2, labels=FALSE)

require(Hmisc)
x <- rcspline.eval(seq(0,1,.01),
                   knots=seq(.05,.95,length=5), inclx=T)
xm <- x
xm[xm > .0106] <- NA
matplot(x[,1], xm, type="l", ylim=c(0,.01),
        xlab=expression(X), ylab='', lty=1)
matplot(x[,1], x,  type="l",
        xlab=expression(X), ylab='', lty=1)

x <- seq(0, 1, length=300)
for(nk in 3:6) {
  set.seed(nk)
  knots <- seq(.05, .95, length=nk)
  xx <- rcspline.eval(x, knots=knots, inclx=T)
  for(i in 1:(nk-1))
    xx[,i]<-(xx[,i] - min(xx[,i])) /
      (max(xx[,i]) - min(xx[,i]))
  for(i in 1:20) {
    beta  <- 2*runif(nk-1) - 1
    xbeta <- xx%*%beta+2*runif(1) - 1
    xbeta <- (xbeta - min(xbeta)) /
             (max(xbeta) - min(xbeta))
    if(i==1) {
      plot(x, xbeta, type="l", lty=1,
           xlab=expression(X), ylab='', bty="l")
      title(sub=paste(nk,"knots"), adj=0, cex=.75)
      for(j in 1:nk)
        arrows(knots[j], .04, knots[j], -.03,
               angle=20, length=.07, lwd=1.5)
    }
    else lines(x, xbeta, col=i)
  }
}

plot(0:1, 0:1, xlab=expression(X[2]), ylab=expression(C(Y)),
     axes=FALSE,  type='n')
axis(1, at=0:1, labels=rep('',2))
axis(2, at=0:1, labels=rep('',2))
lines(c(.05, .8), c(.05, .5))
lines(c(.05, .8), c(.30, .75))
text(.9, .5, expression(X[1]==0), adj=.5)
text(.9, .75,expression(X[1]==1), adj=.5)


func1 <- function(x) {

    result <- c()

    for(i in 1:length(x)) {

        result<-append(result, x[i]**i)
    }
    return(result)

}

func2 <- function(x) {

    result <- c()

    for(i in 1:length(x)) {

        result<-append(result, (x[i]**i)/i)
    }
    return(result)

}

func3 <- function(x, n) {

    if(n<=0) {
        return("n must be a positive number")
    }

    result = 1

    for(i in 1:n) {
        result = result + (x**i)/i
    }

    return(result)

}

l = func1(c(2,3,4,5,7,9))

func2(c(4,3,5,2))

func3(3,3)


# install.packages("Exact", repos="https://cloud.r-project.org")
library("Exact")

f_obs <- matrix(c(15, 0, 38, 47), nrow=2, ncol=2, byrow=TRUE)
result <- exact.test(f_obs, alternative="two.sided", method="csm", model="Binomial", cond.row=FALSE)
result

f_obs <- matrix(c(16, 13, 37, 34), nrow=2, ncol=2, byrow=TRUE)
result <- exact.test(f_obs, alternative="two.sided", method="csm", model="Binomial", cond.row=FALSE)
result


# Euler/Milstein

r <- 2; K <- 1; beta <- 0.25; Xzero <- 0.5;   # problem parameters
T <- 1; N <- 2^(11); dt <- T/N;               #
M <- 500;                                     # number of paths sampled
R <- c(1, 16, 32, 64, 128);                   # Milstein stepsizes are R*dt

dW <- sqrt(dt)* matrix(runif(M*N),M);
Xmil <- matrix(M, 5);
for(p in 1:5) {
    Dt = R[p]*dt;
    L = N/R[p];
    Xtemp = Xzero*rep(M,1);
    for(j in 1:L) {
        Winc = sum(dW[, seq(R[p]*(j-1)+1, R[p]*(j))]);
        Xtemp = Xzero + Dt*r*Xtemp*(K-Xtemp) + beta*Xtemp*Winc + .5*beta^2*Xtemp*(Winc*Winc - Dt);
    }
    Xmil[,p] <- Xtemp; #store Milstein solution at t=1
}

Xref = Xmil[,1];                             # Reference solution
Xerr = abs(Xmil[,2:5] - repmat(Xref,1,4));   # Error in each path
mean(Xerr);                                  # Mean pathwise errors
Dtvals = dt*R(2:5);                          # Milstein timesteps used

#subplot(224)
plot(Dtvals,
     mean(Xerr),
     log = "xy",
     type = "l");
lines(Dtvals, Dtvals, log = "xy",
#     axis([1e-3 1e-1 1e-4 1],
      xlab = 'dt',
      ylab = 'Sample average of | X(T) - X_L|',
      main = 'milstein')


#' Calculate Unobserved Selection Bias
#'
#' @description We calculate an effect of selection on unobservables
#'     on estiamted coefficient of treatment. This method is presented by
#'     Oster (2019, Journal of Business & Economic Statistics).
#'     Let b0 and r0 be the coefficient of treatment and R-squared
#'     resulting from the regression of outcome on treatment.
#'     Let b1 and r1 be the coefficient of treatment and R-squared
#'     resulting from the regression of outcome on
#'     treatment and observed covariates.
#'     Let rmax be the R-squared resulting from the hypothetical regression
#'     of outcome on treatment, observed covairates, and unobserved covariates.
#'     The value rmax depends on researchers.
#'     Oster' suggestion is `rmax = r1 * 1.3`
#'     (See a paper for detailed discussion).
#'     Define b^ = b1 - (b0 - b1)*(rmax - r1)/(r1 - r0).
#'     Under the following assumpetions,
#'     the value b^ converges to a true b in probability one.
#'     Assumption 1 is that
#'     covariates are orthogonal to unobservables.
#'     Assumption 2 is that
#'     the unobservable and observables are equally related to the treatment.
#'     Assumption 3 is that
#'     the coefficient of covariates on treatment is same as
#'     the coefficient of covairates on outcome.
#'     These assumptions are not precise. See a paper for detailed discussion.
#'
#'
#' @param x an object whose class is `RCT`.
#' @param r_max a numerical value of rmax. Default is null.
#' @param r_multiply a numerical value of multiple of r1. Default is `1.3`.
#'
#' @return a numeric vector whose class is `RCT` and `OsterBias`.
#'
#' @importFrom stringr str_split
#' @importFrom purrr map
#' @importFrom purrr as_vector
#' @importFrom magrittr %>%
#' @importFrom stats coef
#'
#' @export
#+
osterbias <- function(x, r_max = NULL, r_multiply = 1.3) {

  # class check
  if (sum(class(x) == "RCT") == 0) stop("Unsupported class.")

  # extract treatment variables
  d <- str_split(x$treat, "\\+") %>%
    map(~ gsub(" ", "", .)) %>%
    as_vector()

  # extract coefficients
  b0 <- coef(x$fit[[1]])[d]
  r0 <- summary(x$fit[[1]])$r.squared

  b1 <- coef(x$fit[[2]])[d]
  r1 <- summary(x$fit[[2]])$r.squared

  if (!is.null(r_max)) {
    bias <- d %>%
      map(~ (b0[.] - b1[.]) * ((r_max - r1) / (r1 - r0))) %>%
      as_vector()
  } else {
    bias <- d %>%
      map(~ (b0[.] - b1[.]) * ((r_multiply * r1 - r1) / (r1 - r0))) %>%
      as_vector()
  }

  names(bias) <- d
  class(bias) <- append(c("RCT", "OsterBias"), class(bias))

  return(bias)
}