# ......................................................................................
# ........Exercise 10. Introduction to the hypothesis testing, one-sample tests ........
# ..........................Michal Béreš, Martina Litschmannová.........................
# ......................................................................................

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

#  From interval estimates to hypothesis tests ####
#
# * What is a statistical hypothesis test? ####
#
# Let's have the following:
#
# - random variable X (for example men's height)
# - selection from a random variable (height measurement of 30 men)
#
# Statistical testing of hypotheses decides the validity of statistical statement
# (hypothesis) based on the data obtained:
#
# - $H_0$ - null hypotheses
# - $H_A$ - alternative hypotheses
#
# For example:
#
# $H_0$: $\mu_X = 175$
#
# $H_A$: $\mu_X > 175$
#
# Since this is a statistical decision, it will always be tied to some level of
# significance $\alpha$. We can always reach only 2 different decisions:
#
# - I reject $H_0$ in favor of $H_A$
#     - this means that I claim that $H_0$ does not apply
#     - this decision is with the maximum error $\alpha$(significance level, type I
# error) - this means that we are able to influence the size of this error
# - I don't reject $H_0$
#     - this means that I claim that due to the obtained data(selection) it is not
# possible to reject $H_0$
#     - this decision is with error $\beta$(type II error), this error is not directly
# controllable and depends on the type of test used
#
# How hypothesis tests relate to interval estimates and how the level of significance
# enters them will be shown in the next section.

# * Interval estimation and significance level ####
#

data = readxl::read_excel("data/uvod.xlsx")
head(data)

options(repr.plot.width = 12) # width of graphs in Jupyter
par(mfrow = c(1, 2))          # graph graph matrices 1x2

boxplot(data$data)
hist(data$data)

moments::skewness(data$data)       # oblique
moments::kurtosis(data$data) - 3   # sharpness

shapiro.test(data$data)$p.value    # normality test

length(data$data)
mean(data$data)
sd(data$data)

# We make a 95% interval estimate of the mean using a t-test:
#

t.test(data$data, alternative = "two.sided", conf.level = 0.95)$conf.int

# Now imagine that we want to test the hypothesis:$H_0$: $\mu = 100$$H_A$: $\mu
# \neq 100$What would be the decision with respect to the calculated IO and so the
# significance level $\alpha = 0.05$?
#
# Well, confidence interval covers the value 100 with maximal error of 5% (confidence
# 95%). Therefore, we can say we cannot reject this hypothesis at significance value 5%.

# Let's further imagine that we want to test the hypothesis:$H_0$: $\mu =
# 105$$H_A$: $\mu \neq 105$What would be the decision with respect to the
# calculated IO and so the significance level $\alpha = 0.05$?
#
# Well, now its a different case: confidence interval does not cover the value 105 with
# maximal error of 5% (confidence 95%). Therefore, we can say we can reject this
# hypothesis at significance value 5%.

# **What we just did is called a classic test.**
#
# We will show you more classic tests for one-sided alternatives.$H_0$: $\mu =
# 105$$H_A$: $\mu > 105$
#

t.test(data$data, alternative = "greater", conf.level = 0.95)$conf.int

# $H_0$: $\mu = 105$$H_A$: $\mu < 105$
#

t.test(data$data, alternative = "less", conf.level = 0.95)$conf.int

# Note that the first of these one-sided alternatives led to a "rejection" of $H_0$.
# This is because of the comparison of the unlikely $H_0$ with the even less likely
# $H_A$.
#
# *** P-values and connection with CI ####
#
# An alternative to the classical test(where we create CI) is the so-called pure
# significance test:

# H_0: mu=105
# H_A: mu<>105
t.test(data$data, mu = 105, alternative = "two.sided")

t.test(data$data, mu = 105, alternative = "two.sided")$p.value

# The pure significance test results in a p-value. Based on it, we decide whether or not
# to reject $H_0$.
#
# p-value can be understood as the highest possible level of significance, such that our
# decision is - I do not reject. Thus, the CI/field of acceptance would contain the
# examined value:

# H_0: mu=105
# H_A: mu<>105

p.hod = t.test(data$data, mu = 105, alternative = "two.sided")$p.value
p.hod

t.test(data$data, alternative = "two.sided", conf.level = 1 - p.hod)$conf.int

# H_0: mu=105
# H_A: mu>105

p.hod = t.test(data$data, mu = 105, alternative = "greater")$p.value
p.hod

t.test(data$data, alternative = "greater", conf.level = 1 - p.hod)$conf.int

# H_0: mu=105
# H_A: mu<105

p.hod = t.test(data$data, mu = 105, alternative = "less")$p.value
p.hod

t.test(data$data, alternative = "less", conf.level = 1 - p.hod)$conf.int

# * Overwiev of tests for one sample ####
#
# ** Position measures ####
#
# By position measures we mean the data that determines the position of the data. For
# data from the normal distribution we can estimate the mean value, for others the
# median.
#
# *** a) student's t-test ####
#
# - we test the mean value
# - the data must come from a normal distribution
# - exploratory: skewness and sharpness lie in(-2,2)
# - exploratory: The QQ graph has points approximately on the line
# - exact: using a statistical test, eg Shapiro-Wilk test(shapiro.test(data))

# H_0: mu=100
# H_A: mu<>100
t.test(data$data, mu = 100, alternative = 'two.sided')$p.value

# H_0: mu=100
# H_A: mu>100
t.test(data$data, mu = 100, alternative = 'greater')$p.value

# H_0: mu=100
# H_A: mu<100
t.test(data$data, mu = 100, alternative = 'less')$p.value

# *** b) Wilcoxn test ####
#
# - we test the median
# - the data must come from a symmetric distribution
# - exploratory: skewness lies in(-2,2)
# - exploratory: histogram looks approximately symmetrical

# H_0: X_0.5=100
# H_A: X_0.5<>100
wilcox.test(data$data, mu = 100, alternative = 'two.sided')$p.value

# H_0: X_0.5=100
# H_A: X_0.5>100
wilcox.test(data$data, mu = 100, alternative = 'greater')$p.value

# H_0: X_0.5=100
# H_A: X_0.5<100
wilcox.test(data$data, mu = 100, alternative = 'less')$p.value

# *** c) sign test test ####
#
# - we test the median
# - larger range selection(>10)
# - requires "BSDA" library
# - as the most robust test, it can also be used for discontinuous data

# H_0: X_0.5=100
# H_A: X_0.5<>100
BSDA::SIGN.test(data$data, md = 100, alternative = 'two.sided')$p.value

# H_0: X_0.5=100
# H_A: X_0.5>100
BSDA::SIGN.test(data$data, md = 100, alternative = 'greater')$p.value

# H_0: X_0.5=100
# H_A: X_0.5<100
BSDA::SIGN.test(data$data, md = 100, alternative = 'less')$p.value

# ** Variability measures ####
#
# By measures of variability we mean the data determining the dispersion/variability of
# the data. For data from the normal distribution, we can estimate the standard
# deviation.
#
# *** standard deviation test ####
#
# - we test the standard deviation
# - the data must come from a normal distribution
# - exploratory: skewness and kurtosis lie in(-2,2)
# - Explosive: The QQ graph has points approximately on the line
# - exact: using a statistical test, eg Shapiro-Wilk test(shapiro.test(data))
# - requires "EnvStats" package
# - function in R, compares variance !!!

# H_0: sigma=10
# H_A: sigma<>10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'two.sided')$p.value

# H_0: sigma=10
# H_A: sigma>10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'greater')$p.value

# H_0: sigma=10
# H_A: sigma<10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'less')$p.value

# * Probability ####
#
# *** Test of probability ####
#
# - We test the probability
# - We require sufficient data: $n>\frac{9}{p(1-p)}$
# - Clopper's - Pearson's estimate(binom.test)
# - does not take data as a parameter, but the number of successes and the number of
# observation

pi = 0.3
data_bin = runif(n = 100, min = 0, max = 1) < pi

n = length(data_bin)
x = sum(data_bin)
n
x

# H_0: pi=0.2
# H_A: pi<>0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'two.sided')$p.value

# H_0: pi=0.2
# H_A: pi>0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'greater')$p.value

# H_0: pi=0.2
# H_A: pi<0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'less')$p.value

#  Examples ####

library(dplyr)
library(rstatix)

#
# * Example 1. ####
#
# We have a selection of 216 patients and we measured their protein serum(file
# testy_jednovyberove.xlsx sheet bilk_serum). Verify that the average protein
# serum(Albumin) of all patients of this type(population average µ) differs
# statistically significantly from 35 g/l.

# Reading data from xlsx file(using readxl package)
albumin = readxl::read_excel("data/testy_jednovyberove.xlsx",
                             sheet = "bilk_serum")
head(albumin)

colnames(albumin)="value"

# Exploratory analysis
boxplot(albumin$value)
summary(albumin$value)

length(albumin$value) # sd is rounded to 3 valid digits
sd(albumin$value)     # sd and position measures are rounded to the nearest thousandth

# **Position measurement test**
#

# Verification of normality - exploratory
moments::skewness(albumin$value)    # skew
moments::kurtosis(albumin$value)-3  # sharpness

options(repr.plot.width = 12) # width of graphs in Jupyter
par(mfrow = c(1, 2))          # matrix of 1x2 graphs

qqnorm(albumin$value)
qqline(albumin$value)
hist(albumin$value)

# We will use the normality test for the final decision on data normality.

# The presumption of normality is verified by the Shapir - Wilk test.
# H0: Data is a selection from the normal distribution.
# Ha: Data is not a selection from the normal distribution.
shapiro.test(albumin$value)
# p-value>0.05 ->Na hl. significance of 0.05, the assumption of normality cannot be rejected.

# normal OK ->t.test

# H0: mu=35 g/l
# Ha: mu<>35 g/l

t.test(albumin$value, mu=35, alternative = "two.sided")

# p-value<0.05 ->at significance level of 0.05 we reject the null hypothesis
# in favor of the alternative hypothesis
# The mean albumin value differs statistically significantly from 35 g/l.

# * Example 2. ####
#
# Survival times for 100 lung cancer patients treated with the new drug are listed in
# the tests_jednovyberove.xlsx sheet "preziti". It is known from previous studies that
# the average survival of such patients without the administration of a new drug is 22.2
# months. Can these data suggest that the new drug prolongs survival?
#

# Reading data from xlsx file(using readxl package)
preziti = readxl::read_excel("data/testy_jednovyberove.xlsx",
                             sheet = "preziti")
head(preziti)

colnames(preziti)="value"

# # Exploratory analysis
par(mfrow = c(1, 2))          # graph matrix 1x2

boxplot(preziti$value)
hist(preziti$value)

# **Data contains outliars -> we can delete them. Or note that this is probably an
# exponential distribution and the outliars are not actually there(the distribution
# simply behaves this way.)**
#

# Data contains outliars. We can list them with the help of f-ce boxplot.
preziti$ID = seq(1,length(preziti$value))
outliers = preziti %>% identify_outliers(value)
outliers
# if we decided to remove outliers, then
preziti$value_no_outliars = ifelse(preziti$ID %in% outliers$ID,NA,preziti$value)

# Exploratory analysis for data without remote observations
boxplot(preziti$value_no_outliars)

length(na.omit(preziti$value_no_outliars))   # sd is rounded to 3 valid digits
sd(preziti$value_no_outliars,na.rm=TRUE)     # sd and position measurements round. to tenths

# **Position measure(mean/median) test**
#

# Verification of normality - exploratory
moments::skewness(preziti$value_no_outliars,na.rm=TRUE)
moments::kurtosis(preziti$value_no_outliars,na.rm=TRUE)-3

par(mfrow = c(1, 2))          # graph matrix 1x2

qqnorm(preziti$value_no_outliars)
qqline(preziti$value_no_outliars)
hist(preziti$value_no_outliars)

# QQ - graph and history show that the choice of truth. is not a choice of standards. distribution.
# Slanting and pointing corresponds to standards. distribution.
# we will use the normality test.

# We verify the assumption of normality by the Shapirs. Wilkov's test.
shapiro.test(preziti$value_no_outliars)
# p-value<0.05 ->at significance 0.05, we reject the assumption of normality

# exploratory assessment of symmetry - exponential distribution - no symmetry

# normality rejected ->symmetry rejected ->Sign. test
# H0: median=22.2 months
# Ha: median>22.2 months

BSDA::SIGN.test(preziti$value_no_outliars, md=22.2,
                alternative="greater")

# p-value>0.05 -> at significance of 0.05, the null hypothesis cannot be rejected
# Median survival time is not statistically significantly greater than 22.2 months.

median(preziti$value_no_outliars, na.rm = TRUE)

# * Example 3. ####
#
# The machine produces piston rings of a given diameter. The manufacturer states that
# the standard deviation of the ring diameter is 0.05 mm. To verify this information, 80
# rings were randomly selected and their diameter was measured(file
# testy_jednovyberove.xlsx sheet krouzky). Can the results obtained be considered
# statistically significant in terms of improving the quality of production?

# Reading data from xlsx file(using readxl package)
krouzky = readxl::read_excel("data/testy_jednovyberove.xlsx",
                             sheet = "krouzky")
head(krouzky)

colnames(krouzky)="value"

# # Exploratory analysis
boxplot(krouzky$value)

# Data contains outliars. We can list them with the help of f-ce boxplot.
krouzky$ID = seq(1,length(krouzky$value))
outliers = krouzky %>% identify_outliers(value)
outliers
# if we decided to remove outliers, then
krouzky$value_no_outliars = ifelse(krouzky$ID %in% outliers$ID,NA,krouzky$value)

# Exploratory analysis for data without remote observations
summary(krouzky$value_no_outliars,na.rm=TRUE)
boxplot(krouzky$value_no_outliars)

length(na.omit(krouzky$value_no_outliars))# sd is rounded to 3 valid digits
sd(krouzky$value_no_outliars,na.rm=TRUE)  # sd and position measures round. per thousandths

# Verification of normality - exploratory
moments::skewness(krouzky$value_no_outliars,na.rm=TRUE)
moments::kurtosis(krouzky$value_no_outliars,na.rm=TRUE)-3

par(mfrow = c(1, 2))          # matrix of 1x2 graphs

qqnorm(krouzky$value_no_outliars)
qqline(krouzky$value_no_outliars)
hist(krouzky$value_no_outliars)
# Both skew and sharpness comply with standards. distribution.
# We will use for the final decision on data normality

# normality test.
# We verify the assumption of normality by the Shapirs. Wilkov's test.
shapiro.test(krouzky$value_no_outliars)
# p-value>0.05 ->Na hl. significance of 0.05 cannot be assumed norms. reject

# variability test ->variance test

# H0: sigma=0.05 mm
# Ha: sigma<0.05 mm
EnvStats::varTest(krouzky$value_no_outliars, sigma.squared = 0.05^2,
                  alternative = "less")

# p-value<0.05 ->At the significance level of 0.05 we reject H0 in favor of Ha

# How to find a 95% interval standard deviation estimate?
pom = EnvStats::varTest(krouzky$value_no_outliars,sigma.squared = 0.05^2,
                        alternative = "less", conf.level=0.95)

sqrt(pom$conf.int)

# * Example 4. ####
#
# TT states that 1% of their resistors do not meet the required criteria. 15 unsuitable
# resistors were found in the tested delivery of 1000 pieces. Is this result with
# agreement with TT's assertion or can we reject it?

n = 1000   # selection range
x = 15     # number of "successes"
p = x/n    # relative frequency(probability point estimate)
p

# Verification of assumptions
9/(p*(1-p))

# Clopper - Pearson(exact) test
# H0: pi=0.01
# Ha: pi<>0.01

binom.test(x = x, n= n, p = 0.01, alternative="two.sided")


(1-0.7*0.7)^2
0.1*0.51*0.51*0.1
1-0.9*0.9*(1-0.2601)

f = function(x){return(6*x-x^2)}
dolniMez = 0
horniMez = 6
1/integrate(f, dolniMez, horniMez)$value

x = 6
3*x^2-x^3/3
x = 0
3*x^2-x^3/3
1/36

f.dens = function(x){
    res = 1/36*(6*x-x^2) # 1/4(6*x+8)
    res[x < 0] = 0
    res[x > 6] = 0
    return(res)
}

F.dist = function(x){
    res = 1/36*(3*x^2-x^3/3)
    res[x < 0] = 0
    res[x > 6] = 1
    return(res)
}

x = seq(from = -1, to = 7, by = 0.01)
fx = f.dens(x)
plot(x, fx, cex = 0.2, main="Graf hustoty")

FX = cumsum(fx)
FX = F.dist(x)
plot(x, FX, cex = 0.2, main="Distribuční funkce")

1-F.dist(2)

data_xlsx = readxl::read_excel("./ZK1/data_123.xlsx",
                  sheet = "Vysledky mereni",
                  skip = 0)

data = data_xlsx[,-1]
colnames(data) = c("prez","dist","typ")

boxplot(data$prez~data$typ)
zaokr = data %>% group_by(typ) %>%
    summarise  (pocet = sum(!is.na(prez)),
                prumer = round(mean(prez, na.rm = TRUE),0),
                smer.odch = ceiling(sd(prez, na.rm = TRUE)*100)/100)
colnames(zaokr) = c('Výrobce','Počet záznamů','Průměr','Směrodatná odchylka')
zaokr %>% print.data.frame()

normSymet = data %>% group_by(typ) %>%
    summarise(  sikmost=round(moments::skewness(prez, na.rm=TRUE),1),
                spicatost=round(moments::kurtosis(prez, na.rm=TRUE)-3,1),
                SW=round(shapiro.test(prez)$p.value,3),
                symetrie=round(lawstat::symmetry.test(prez, boot=FALSE)$p.value,3))
colnames(normSymet) = c('Výrobce','Šikmost','Špičatost','Shapirův-Wilkův test (p-hodnota)','Test symetrie (p-hodnota)')
normSymet %>% print.data.frame()

odhady = data %>% group_by(typ) %>%
    summarise(  median = round(median(prez, na.rm=TRUE),2),
                smer.odch = round(mean(prez, na.rm = TRUE)*100)/100,
                interval = paste0('(',
                    floor(wilcox.test(prez, alternative = 'greater',conf.int=T,conf.level=0.93)$conf.int[1]*10)/10, " ; ",
                    ceiling(wilcox.test(prez, alternative = 'greater',conf.int=T,conf.level=0.93)$conf.int[2]*10)/10
                    ,')'),
                denni.ztrata = round(t.test(prez,mu=8,alternative="greater",conf.level=0.90)$p.value,3),

    )
colnames(odhady) = c('Typ','Bodový odhad (median)','Bodový odhad (str. hodnota)','93% intervalový odhad levostrany (wilcox)', 'denni ztrata')
odhady %>% print.data.frame()

wilcox.test(data$prez, alternative = 'less',conf.int=T)$conf.int

wilcox.test(data$prez[data$typ=="ekonomicky"], mu = 35, alternative = 'greater',conf.level=0.93)$p.value

wilcox.test(x = data$prez[data$typ=="technicky"], y = data$prez[data$typ=="ekonomicky"], alternative = "two.sided",
            conf.level=0.93, conf.int = TRUE)

round(kruskal.test(data$dist ~ data$typ)$p.value,3)

dunn.test::dunn.test(data$dist, data$typ, method="bonferroni",altp=TRUE)
# seřadit podle efektů

# počítání efektů
# průměry ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(median_skup = median(dist, na.rm=T))

# efekty
efekty$efekt = efekty$median_skup - median(data$dist, na.rm=T)# celkový průměr

# vypsat setřízené
efekty %>% arrange(desc(efekt)) %>% print.data.frame()

# NEZAPOMENOUT NA TEORETICKOU ČÁST


histplus <- function(x, breaks=NULL, distribution='normal', sided=2, alpha=0.05, pvalue=0.95, nsigma=2) {
    ## plot histogram and normal distribution
    ## distribution = normal or Weibull
    ## sided  = -1 (lower), 1 (upper), or 2 sided interval
    ## alpha  = 1 - confidence (used in confidence, prediction, and tolerance intervals)
    confidence <- 1-alpha
    ## pvalue = % of data to be covered (used in tolerance interval)
    ## nsigma = number of standard deviations for mean +/- nsigma * standard deviation

    #### debug
    ## x <- mtcars$mpg
    ## distribution <- 'normal'
    ## sided  <- 2
    ## alpha  <- 0.05
    ## confidence <- 1-alpha
    ## pvalue <- 0.95
    ## nsigma <- 2
    ## breaks <- NULL

    ## calculate limits
    if (distribution=='Weibull') {
        ## not sure how to figure out other intervals for Weibull since mean and sd do not make sense
        tol_out <-  exttol.int(x, alpha = alpha, P=pvalue, side=abs(sided))
        shape <- tol_out$'shape.1'
        scale <- tol_out$'shape.2'
        if (sided==-1) {
            lower_conf_limit      <- NA   # not sure how to do this
            lower_sigma           <- NA   # N/A
            lower_pred_limit      <- NA   # not sure how to do this
            lower_tolerance_limit <- tol_out$'1-sided.lower'
            upper_conf_limit      <- NA   # N/A
            upper_sigma           <- NA   # N/A
            upper_pred_limit      <- NA   # N/A
            upper_tolerance_limit <- NA   # N/A
        } else if (sided==1) {
            lower_conf_limit      <- NA   # N/A
            lower_sigma           <- NA   # N/A
            lower_pred_limit      <- NA   # N/A
            lower_tolerance_limit <- NA   # N/A
            upper_conf_limit      <- NA   # not sure how to do this
            upper_sigma           <- NA   # N/A
            upper_pred_limit      <- NA   # not sure how to do this
            upper_tolerance_limit <- tol_out$'1-sided.upper'
        } else {
            lower_conf_limit      <- NA   # not sure how to do this
            lower_sigma           <- NA   # N/A
            lower_pred_limit      <- NA   # not sure how to do this
            lower_tolerance_limit <- tol_out$'2-sided.lower'
            upper_conf_limit      <- NA   # not sure how to do this
            upper_sigma           <- NA   # N/A
            upper_pred_limit      <- NA   # not sure how to do this
            upper_tolerance_limit <- tol_out$'2-sided.upper'
        }
    } else {  # normal distribution (default)
        xmean <- mean(x)
        xsd   <- sd(x)
        tol_out <- normtol.int(x, alpha = alpha, P=pvalue, side=abs(sided))
        if (sided==-1) {
            student_t <- abs(qt(alpha, length(x)-1))
            lower_conf_limit      <- xmean - student_t*xsd*(  1/length(x))^0.5
            lower_sigma           <- xmean -    nsigma*xsd
            lower_pred_limit      <- xmean - student_t*xsd*(1+1/length(x))^0.5
            lower_tolerance_limit <- tol_out$'1-sided.lower'
            upper_conf_limit      <- NA
            upper_sigma           <- NA
            upper_pred_limit      <- NA
            upper_tolerance_limit <- NA
        } else if (sided==1) {
            student_t <- abs(qt(alpha, length(x)-1))
            lower_conf_limit      <- NA
            lower_sigma           <- NA
            lower_pred_limit      <- NA
            lower_tolerance_limit <- NA
            upper_conf_limit      <- xmean + student_t*xsd*(  1/length(x))^0.5
            upper_sigma           <- xmean +    nsigma*xsd
            upper_pred_limit      <- xmean + student_t*xsd*(1+1/length(x))^0.5
            upper_tolerance_limit <- tol_out$'1-sided.upper'
        } else {
            student_t <- abs(qt(alpha/2, length(x)-1))
            lower_conf_limit      <- xmean - student_t*xsd*(  1/length(x))^0.5
            lower_sigma           <- xmean -    nsigma*xsd
            lower_pred_limit      <- xmean - student_t*xsd*(1+1/length(x))^0.5
            lower_tolerance_limit <- tol_out$'2-sided.lower'
            upper_conf_limit      <- xmean + student_t*xsd*(  1/length(x))^0.5
            upper_sigma           <- xmean +    nsigma*xsd
            upper_pred_limit      <- xmean + student_t*xsd*(1+1/length(x))^0.5
            upper_tolerance_limit <- tol_out$'2-sided.upper'
        }
    }

    ## generate distribution
    xmin <- min(x,lower_sigma,lower_pred_limit,lower_tolerance_limit, na.rm=TRUE)
    xmax <- max(x,upper_sigma,upper_pred_limit,upper_tolerance_limit, na.rm=TRUE)
    chuncks <- (xmax-xmin)/1000
    xhist   <- seq(xmin,xmax,by=chuncks)
    if (distribution=='Weibull') {
        xdensity <- dweibull(xhist,shape=shape,scale=scale)
    } else {
        xdensity <- dnorm(xhist,xmean,xsd)
    }
    xdensitymax <- max(xdensity)

    ## make histogram
    if (is.null(breaks)) {
        ##  hist(x, xlim=c(xmin,xmax), freq=FALSE)  # specifying xlim messes up axes
        hist(x,                freq=FALSE)
    } else {
        hist(x, breaks=breaks, freq=FALSE)
    }
    ## add distribution
    lines(x=xhist, y=xdensity, col='red', lty=1)
    ## add lines for mean and limits
    if (distribution=='normal') abline(v=xmean,col="red")
    abline(v=lower_conf_limit          ,col="blue")
    abline(v=lower_sigma               ,col="darkviolet", lty=2)
    abline(v=lower_pred_limit          ,col="darkviolet")
    abline(v=lower_tolerance_limit     ,col="black")
    abline(v=upper_conf_limit          ,col="blue")
    abline(v=upper_sigma               ,col="darkviolet", lty=2)
    abline(v=upper_pred_limit          ,col="darkviolet")
    abline(v=upper_tolerance_limit     ,col="black")
    cat(sided,"sided", distribution,"distribution intervals\n")
    cat("nsigma                 =",nsigma,"\n")
    cat("confidence = 1 - alpha =",confidence,"\n")
    cat("coverage   = pvalue    =",pvalue,"\n")
    if (distribution=='Weibull') {
        cat("shape =",shape,"\n")
        cat("scale =",scale,"\n")
        interval <- c("confidence", "prediction", "tolerance")
        df <- data.frame(interval)
        df$lower <- c(lower_conf_limit, lower_pred_limit, lower_tolerance_limit)
        df$upper <- c(upper_conf_limit, upper_pred_limit, upper_tolerance_limit)
    } else {     # assume normal
        cat("mean                   =",xmean,"\n")
        cat("standard deviation     =",xsd,"\n")
        interval <- c("confidence", "mean +/- nsigma * sd", "prediction", "tolerance")
        df <- data.frame(interval)
        df$lower <- c(lower_conf_limit, lower_sigma, lower_pred_limit, lower_tolerance_limit)
        df$upper <- c(upper_conf_limit, upper_sigma, upper_pred_limit, upper_tolerance_limit)
        ##    cat("mean                                      =", xmean, "\n")
        ##    cat(sided,  "sided upper", confidence, "confidence limit       =", upper_conf_limit,"\n")
        ##    cat(nsigma, "sigma upper limit                       =", upper_sigma     , "\n")
        ##    cat(sided,  "sided", confidence,"upper prediction limit       =", upper_pred_limit, "\n")
        ##    cat(sided,  "sided", confidence,"/",pvalue,"upper tolerance limit =", upper_tolerance_limit, "\n")
    }
    print(df)
}
# histplus(mtcars$mpg)

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


# Define the global variables
# p represents π
# a represents the counter in the Nilakantha Series
# s determines whether to add or subtract
p <- 3
a <- 2
s <- 1

# Define the iteration function
iterate <- function() {
  # I had to use the <<- assignment operator since it is a global variable
  p <<- p + s * (4 / (a * (a * (a + 3) + 2)))
  a <<- a + 2
  s <<- -s
}

# Define counter variable
i <- 0
# Begin while loop
while(i < 150000) {
  # Iterate Nilakantha Series
  iterate()
  # Increment counter variable
  i <<- i + 1
}

# I could have done a repeat loop, but while is easier.
# What the repeat loop would be like:
"
repeat {
  iterate()
  if(i >= 150000) {
    break
  }
  i <<- i + 1
}
"

# Print result
print ( paste("pi =", p))


# Goal: Joint distributions, marginal distributions, useful tables.

# First let me invent some fake data
set.seed(102)                           # This yields a good illustration.
x <- sample(1:3, 15, replace=TRUE)
education <- factor(x, labels=c("None", "School", "College"))
x <- sample(1:2, 15, replace=TRUE)
gender <- factor(x, labels=c("Male", "Female"))
age <- runif(15, min=20,max=60)

D <- data.frame(age, gender, education)
rm(x,age,gender,education)
print(D)

# Table about education
table(D$education)

# Table about education and gender --
table(D$gender, D$education)
# Joint distribution of education and gender --
table(D$gender, D$education)/nrow(D)

# Add in the marginal distributions also
addmargins(table(D$gender, D$education))
addmargins(table(D$gender, D$education))/nrow(D)

# Generate a good LaTeX table out of it --
library(xtable)
xtable(addmargins(table(D$gender, D$education))/nrow(D),
       digits=c(0,2,2,2,2))             # You have to do | and \hline manually.

# Study age by education category
by(D$age, D$gender, mean)
by(D$age, D$gender, sd)
by(D$age, D$gender, summary)

# Two-way table showing average age depending on education & gender
a <- matrix(by(D$age, list(D$gender, D$education), mean), nrow=2)
rownames(a) <- levels(D$gender)
colnames(a) <- levels(D$education)
print(a)
# or, of course,
print(xtable(a))

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


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

oz.per.year <- 10000
rf <- 0.03  # 3% interest rates
wacc <- 0.08  # 8% weighted average cost of capital
num.sims <- 100000 # 100,000 simulations
s0 <- 1300  # gold price at t=0
K <- 1000  # cost of extraction
sigma <- 0.3  # volatility of gold log-returns
lambda <- 1  # rate of mean reversion; 1 => half-life = ln(2) = 0.69 years

## Annual extraction decisions at start of each year (t=0,...,9)
T.list <- 1:9  # 1--9 year options; years 2:8 are 1 year fwd
s.bar.list <- c(1300, rep(1200, 8))  # 1300/oz, then 1200/oz

# gold price follows geometric Brownian motion
sum.val <- (s0-K)/(1+wacc)  # time t=0 decision
for (i in 1:9) {
    T <- T.list[i]
    z <- rnorm(num.sims) # simulated Z_T values
    s.sim <- s0*exp((rf-sigma^2/2)*T+sigma*sqrt(T)*z)
    if (T>1) s.sim <- s.sim*s.bar.list[i]/s0
    opt.terminal.val.sim <- pmax(s.sim - K, 0)
    opt.value <- mean(opt.terminal.val.sim)*exp(-rf*T)
    sum.val <- sum.val + opt.value/(1+wacc)
}
print(sum.val*oz.per.year)

## gold price follows Ornstein-Uhlenbeck mean reversion
sum.val <- (s0-K)/(1+wacc)
for (i in 1:9) {
    T <- T.list[i]
    s.bar <- s.bar.list[i]
    s.meanrevert.sim <- s.bar + exp(-lambda*T)*(s0-s.bar) + sigma*s0*
        sqrt((1-exp(-2*lambda*T))/(2*lambda))*z
    opt.terminal.val.meanrevert.sim <- pmax(s.meanrevert.sim - K, 0)
    opt.meanrevert.value <- mean(opt.terminal.val.meanrevert.sim)*
        exp(-rf*T)
    sum.val <- sum.val + opt.meanrevert.value/(1+wacc)
}
print(sum.val*oz.per.year)

## Quarterly extract decisions at start of each quarter
T.list <- (1:39)/4 # 1--39 quarter options
s.bar.list <- c(rep(1300, 4), 1275, 1250, 1225, rep(1200, 32))

# gold price follows geometric Brownian motion
sum.val <- (s0-K)/(1+wacc)^0.25
for (i in 1:39) {
    T <- T.list[i]
    z <- rnorm(num.sims) # simulated Z_T values
    s.sim <- s0*exp(sigma*sqrt(T)*z)
    opt.terminal.val.sim <- pmax(s.sim - K, 0)
    opt.value <- mean(opt.terminal.val.sim)*exp(-rf*T)
    sum.val <- sum.val + opt.value/(1+wacc)^0.25
}
print(sum.val*oz.per.year/4)

# gold price follows Ornstein-Uhlenbeck mean reversion
sum.val <- (s0-K)/(1+wacc)^0.25
for (i in 1:39) {
    T <- T.list[i]
    s.bar <- s.bar.list[i]
    s.meanrevert.sim <- s.bar + exp(-lambda*T)*(s0-s.bar) + sigma*s0*
        sqrt((1-exp(-2*lambda*T))/(2*lambda))*z
    opt.terminal.val.meanrevert.sim <- pmax(s.meanrevert.sim - K, 0)
    opt.meanrevert.value <- mean(opt.terminal.val.meanrevert.sim)*exp(-rf*T)
    sum.val <- sum.val + opt.meanrevert.value/(1+wacc)^0.25
}
print(sum.val*oz.per.year/4)


nm <- 1
temp <- 1
sum <- 0

while (nm < 4000000) {
    tp <- nm
    nm <- nm + temp
    temp <- tp
    if (nm %% 2 == 0) {
        sum <- nm + sum
    }
}

print(sum)


# Synthetic Data Project
# Laplace probability functions

# Author:
# Version:  5/14/2017

# Copyright 2017

# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
# associated documentation files (the "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the
# following conditions:

# The above copyright notice and this permission notice shall be included in all copies or substantial
# portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
# LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

# density
dlaplace <- function(x, m, lambda, log=F)
  # evaluate Laplace density (double-sided exponential)
  # f(x, m, lambda) =
  # x<m:   lambda/2 * exp[-lambda*(m-x)]
  # x>=m:  lambda/2 * exp[-lambda*(x-m)]
  # note that, by custom, 1/lambda is used in the pdf definition
  if(!log) {
    exp(-abs(x-m)/lambda)/2/lambda
  } else {
    -log(2*lambda)-abs(x-m)/lambda
  }

# cumulative density
plaplace <- function(x, m, lambda) {
  # evaluate Laplace cumulative density (double-sided exponential)
  # F(x, m, lambda) =
  # x<m:   [1-Fexp(m-x, lambda)]/2 = (1-1+exp[-lambda*(m-x)])/2 = exp[-lambda*(m-x)]/2
  # x>=m:  1/2+Fexp(m-x, lambda)/2 = 1/2+(1-exp[-lambda*(x-m)])/2
  #        = 1/2*(1+1-exp[-lambda*(x-m)]) = (2-exp[-lambda*(x-m)])/2
  # note that, by custom, 1/lambda is used in the pdf definition
  i <- ifelse(x<m, 1, -1)
  ((1-i) + i*exp(i/lambda*(x-m)))/2
}

# inverse cdf, Finv(p, m, lambda)
qlaplace <- function(p, m, lambda) {
  # evaluate Laplace quantile (double-sided exponential)
  # Finverse(p, m, lambda) =
  # x<m:   ln(2p)/lambda+m
  # x>=m:  -ln(2-2p)/lambda+m
  # note that, by custom, 1/lambda is used in the pdf definition
  i <- ifelse(p<.5, 1, -1)
  i*log(1-i+i*2*p)*lambda+m
}

# random Laplace quantiles
rlaplace <- function(n, m, lambda)
  qlaplace(runif(n), m, lambda)


# Normal Approximation to the Binomial
# number of trails
n<-1000
# probability of success of single event
z<-0.5
Mean<-n*z
s<-sqrt(n*z*(1-z))
 #  the probability of observing 460 or fewer
pnorm(460,mean=Mean,sd=s)


par(mar=c(5.1, 4.1, 4.1, 7),xpd=TRUE)

plot(0,type="n",

     xlim=c(0,100),ylim=c(0,0.15),ann=FALSE)

p=c(0.1,0.3,0.5,0.7,0.9)

for (i in 1:length(p))

{

  x=1:100

  y=dbinom(x,100,p[i])

  points(x,y,type="l",col=rainbow(length(p))[i])

}

title(main="PMF of binom",xlab="x",ylab="p(x)",cex.main=2,cex.lab=1.2)

box("outer",col="gray")

legend("topright",inset=c(-0.23,0), legend=paste("p=",p),col=rainbow(length(p)),lty=1)


#####
# plots exponential decay curves
# for the number of new child speakers of Mongolian
# over the next 5 generations,
# contrasting the observed rate of shift in the data
# against a hypothetical faster rate
# takes no inputs: data is coded into script
####

rm(list=ls())
library(ggplot2)

# exponential decay constant λ
# where p is the proportional decline per unit of time
# p is positive
lambda <- function(p){-log(1-p)}

# exponential decay function
# where t is time (generations)
decay <- function(p,t){exp(-lambda(p)*t)}

# set two possible values for p:
# observed p(B1,C2|B1) = 0.165
    # this comes from the actual data analysis
# counterfactual p(B1,C2|B1) = 0.423
    # this comes from a hypothetical fake dataset
    # see Puthuval (2017) for explanation
lowball <- function(x){decay(0.165, x)} # observed
highball <- function(x){decay(0.423, x)} # counterfactual

# plot the curves
baseplot <-
  ggplot(data.frame(x=c(0,6)), aes(x=x)) +
  	stat_function(fun=lowball, geom="path", size=1.5) +
  ylim(0, 1) + xlim(0,5) +
  labs(x="Generations", y="New child speakers of Mongolian") +
  ggtitle(paste0("Decline in new child speakers over five generations,",
                 "\nassuming a constant rate of shift"))
# stat_function calculates at 101 points along x range by default

one <- baseplot +
  annotate("text", x=3, y=.75, label="Rate of shift = 0.165", size=5)

two <- baseplot +
  stat_function(
    fun=highball, geom="path", size=1.5, linetype="dotdash") +
  annotate("text", x=3, y=.75,
  	label="Observed rate = 0.165", size=5) +
  annotate("text", x=2.5, y=.07,
  	label="Counterfactual rate = 0.423", size=5)

plots <- c("one", "two")
prefix <- "figures/expdecay_"
l <- mget(plots)

invisible(mapply(ggsave,
	file=paste0(prefix, names(l), ".pdf"),
	width=6, height=4, units="in", plot=l))
invisible(mapply(ggsave,
	file=paste0(prefix, names(l), ".jpg"),
	width=6, height=4, units="in", plot=l))


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

## empirical
alpha <- 0.05  # probability mass in the loss tail
# sort the data; grab the lowest alpha fraction of the data
sorted.x.obs <- sort(x.obs)
frac.idx <- length(sorted.x.obs)*alpha
left.idx <- floor(frac.idx)

# VaR is linearly interpolated between points
rfrac <- 1-(frac.idx-left.idx)
VaR.emp <- sorted.x.obs[left.idx:(left.idx+1)] %*% c(1-rfrac, rfrac)

# ES is just the average of the observed data in the tail
es.emp <- mean(sorted.x.obs[1:left.idx])

## parametric
VaR.norm <- mean.obs + sqrt(var.obs)*qnorm(alpha)
es.norm <- mean.obs - sqrt(var.obs)*dnorm(qnorm(alpha))/alpha

## from kernel density estimate
# create the kernel density estimate
kde <- density(x.obs, kernel="gaussian", bw="SJ")

# now create numerical CDF
int.kde <- cumsum(kde$y)/sum(kde$y)

# Find where alpha is in loss tail
left.idx <- findInterval(alpha, int.kde)

# linearly interpolate to find VaR
rfrac <- (alpha-int.kde[left.idx])/(int.kde[left.idx+1]-int.kde[left.idx])
VaR.kde <- kde$x[left.idx:(left.idx+1)] %*% c(1-rfrac, rfrac)

# numerically integrate kernel density estimate to get ES (a bit hacky)
es.kde <- kde$x[1:left.idx] %*% kde$y[1:left.idx]/sum(kde$y)/alpha

## from Edgeworth expansion - exact
# this function returns the "CDF" of the Edgeworth expansion
int.left.edge <- function(q, mu, sigma, skew=0, exkurt=0) {
  z <- (q-mu)/sigma
  pnorm(z) - dnorm(z)*(skew*(z^2+1)/6 + exkurt*(z^3-3*z)/24
                                      + skew^2*(z^5-10*z^3+15*z)/72)
}

# returns the "conditional expectation" of the Edgeworth expansion
exp.left.edge <- function(q, mu, sigma, skew=0, exkurt=0) {
  z <- (q-mu)/sigma
  mu - sigma/alpha*dnorm(z)*(1 + skew*(z^3)/6 + exkurt*(z^4-2*z^2-1)/24
                               + skew^2*(z^6-9*z^4+9*z^2+3)/72)
}

# Find the point where the area under the left tail equals alpha
# Do this by shifting the integral down by alpha to find where it
# crosses zero (i.e. where the integral equals alpha)
int.left.edge.shifted <- function(q) {
  int.left.edge(q, mean.obs, sqrt(var.obs), skew.obs, exkurt.obs) - alpha
}
find.VaR <- uniroot(int.left.edge.shifted, check.conv = TRUE,
                    lower=-1, upper=mean.obs)

# The VaR is that point; the ES is the integral up to that point
VaR.edge.exact <-find.VaR$root
es.edge.exact <- exp.left.edge(VaR.edge.exact, mean.obs, sqrt(var.obs),
                               skew.obs, exkurt.obs)

## from Edgeworth expansion - numeric
# Alternately, just use numeric integration on the Edgeworth
# expansion points we got from the moments

# create numeric "CDF"
int.edge <- cumsum(edge.expand$approx)/sum(edge.expand$approx)

# linearly interpolate to find VaR
left.idx <- which(int.edge>alpha)[1] - 1
rfrac <- (alpha-int.edge[left.idx])/(int.edge[left.idx+1]-int.edge[left.idx])
VaR.edge.num <- edge.expand$y[left.idx:(left.idx+1)] %*% c(1-rfrac, rfrac)

# numerically integrate Edgeworth expansion to get ES
es.edge.num <- edge.expand$y[1:left.idx] %*% edge.expand$approx[1:left.idx]/
    sum(edge.expand$approx)/alpha

## from Cornish-Fisher expansion
VaR.cornfish <- VaR(x.obs, p=0.05, method="modified", mu=mean.obs, sigma=var.obs,
                    m3=skew.obs, m4=exkurt.obs)
es.cornfish <- ES(x.obs, p=0.05, method="modified", mu=mean.obs, sigma=var.obs,
                  m3=skew.obs, m4=exkurt.obs)

## from EVT
library(evir)

#evir package looks at upper tail, so flip returns
x.neg.obs <- -x.obs

# First, work with the generalized extreme value distribution
gev.model <- gev(x.neg.obs, block=23)
q.gev <- function(p) {
  -1*qgev(1-p, xi=gev.model$par.ests[["xi"]],
               mu=gev.model$par.ests[["mu"]],
               sigma=gev.model$par.ests[["sigma"]])
}
VaR.gev <- q.gev(alpha)  # use evir function
# a bit hacky: numerically integrate CDF to get ES
es.gev <- mean(q.gev(seq(0.001, alpha, 0.001)))

# Next, work with the generalized Pareto distribution
gpd.model <- gpd(x.neg.obs, nextremes=5)
riskmeasures(gpd.model, c(0.95))

## comparison
# now create the exact CDF
t.df <- 5
p.t <- function(q) {
  z1 <- (q+0.05)/desired.sd*t5.sd
  z2 <- (q-0.05)/desired.sd*t5.sd
  pt(z1, df=5)*3/5 + pt(z2, df=5)*2/5
}

# shift CDF down to find the point where alpha is in the loss tail
p.t.quantile <- uniroot(function(q) p.t(q)-alpha, check.conv=TRUE,
                        lower=-1, upper=mean.obs)
VaR.true <- p.t.quantile$root

# function finds ES for a t-distribution to left of quantile q
es.t <- function(q) {
  -dt(qt(q, df=t.df), df=t.df)/q*(t.df-2+qt(q, df=t.df)^2)/(t.df-1)
}

# ES calculation is crusty: we found point for alpha in loss tail.
# Now find ES for both t-distributions; then find average of them
q1 <- pt((VaR.true+0.05)/desired.sd*t5.sd, df=t.df)
q2 <- pt((VaR.true-0.05)/desired.sd*t5.sd, df=t.df)
es.true <- (3/5*es.t(q1) + 2/5*es.t(q2))*desired.sd/t5.sd - 0.01


library(gmp)

left_factorial <- function(n) {
	if (n == 0) return(0)
	result <- as.bigz(0)

	adder <- as.bigz(1)
	for (k in 1:n) {
		result <- result + adder
		adder <- adder * k
	}
	result
}

digit_count <- function(n) {
	nchar(as.character(n))
}

for (n in 0:10) {
	cat("!",n," = ",sep = "")
	cat(as.character(left_factorial(n)))
	cat("\n")
}
for (n in seq(20,110,10)) {
	cat("!",n," = ",sep = "")
	cat(as.character(left_factorial(n)))
	cat("\n")
}
for (n in seq(1000,10000,1000)) {
  cat("!",n," has ",digit_count(left_factorial(n))," digits\n", sep = "")
}


library(deSolve)
library(reshape2)
library(ggplot2)
library(scales)

#Anderson and May (1978) Model F eqn (19)-(21)
HPL_ode <- function(times,init,parms){
  with(as.list(c(parms,init)), {
  # ODEs
  dH=(a-b)*H - alpha*P
  dP=(beta*L*H) - (mu+alpha+b)*P - (alpha*((P^2)/H)*((k+1)/k))
  dL=(lambda*P) - (gamma*L) - (beta*L*H)

  list(c(dH,dP,dL))
  })
}

# L= number of free-living (infective) stages (e.g. larvae)
# H = number of hosts
# P = number of parasites
# a = host birth rate
# b = host death rate
# alpha = parasite impact on host mortality
# beta*l = rate at which hosts pick up infecting stages
# mu = parasite death rate
# k = aggregation parameter
# lambda*P = rate of production of new free-living stages (i.e. parasite fertility)
# gamma = death rate of free-living stages

parms <-c(b=1.05,a=1.4,alpha=0.0003,beta=0.01,mu=0.5,k=0.1,lambda=10.0,gamma=10.0)

init <- c(H=100,P=10,L=10)
times <- seq(0,30,length.out=2001)
HPL_out <- lsoda(init,times,HPL_ode,parms)

HPL_out_long <- melt(as.data.frame(HPL_out),"time")

#Visualisation
ggplot(HPL_out_long,aes(x=time,y=value,colour=variable,group=variable)) +
  geom_line(lwd=2) + xlab("Time") + ylab("Number") + scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
              labels = trans_format("log10", math_format(10^.x)))


#----------------------------------------------------------------------------
# frmAmpCorr -- Formant Amplitude Correction
#
# The amplitude of a resonator is proportional to both its frequency and
# bandwidth. This function is designed to calculate a scaling factor that
# will compensate both frequency and bandwidth factors to result in unit
# amplitude at the resonator center frequency (i.e. amplitude = 1.0 at
# the resonator characteristic frequency).
#
# The amplitude at the resonant frequency is inversely proportional to the
# bandwidth plus a constant offset that is a nonlinear function of the
# bandwidth. The latter function is approximated here via a 4th order
# polynomial.
#
# See also: function formant() that calculates the discrete spectrum of the
# resonator impulse response given the resonator frequency and bandwidth as
# well as the bandwidth of the spectrum and the number of discrete spectral
# bins. The formant function now also includes a scale argument that
# defaults to FALSE for compatibility with previous versions of the function.
# If scale=TRUE, the amplitude spectrum is scaled to have unit gain at the
# resonator frequency.
#
# 12/23/19 -- htb
#---------------------------------------------------------------------------
#
frmAmpCorr <- function(freq, band) {
  coe <- c(-1.683882e-03,4.234928e-04,-1.231765e-07,2.421068e-11,-2.066097e-15)
  m <- 1.0 / band
  b <- coe[1] + coe[2]*band + coe[3]*band^2 + coe[4]*band^3 + coe[5]*band^4
#  cat(paste0("m = ",m,"; b = ",b,"\n"))
  amp <- m*freq + b
  return(amp)
}


#' puntomedio() calcula el punto medio entre 2 puntos
#'
#' @param a vector
#' @param b vector
#'
#' @return vector
#' @export
#'
#' @examples
#' puntomedio(c(1,1),c(2,2))
#' # [1] 1,5 1,5
#'
puntomedio <- function(a,b){
  pmedio <- vector("numeric",2)
  pmedio[1] <- (a[1]+b[1])/2
  pmedio[2] <- (a[2]+b[2])/2
  pmedio
}


##### 医学統計勉強会15第一回基本統計量　R code #####

x <- c(0.684, 1.406, -0.663, -0.124, 0.849, -0.888, -0.492, -0.044, -0.188, 0.536, 2.063, -1.379, 0.920, 0.453, 1.239)

## 数量的なデータの要約 ##

sum(x)			# x の要素の和
length(x)		# x の長さ
mean(x)			# x の平均
median(x)		# x の中央値
quantile(x)		# x の四分位点．Five numbers summary
quantile(x, 0.2)	# x の20%パーセント点
summary(x)			# Five numbers summary + 平均

var(x)			# x の分散
sd(x)			# x の標準偏差
sqrt(x)			# x の平方根
sqrt(var(x))	# x の分散の平方根 = x の標準偏差
IQR(x)			# x の四分位点間距離
quantile(x, 0.75) - quantile(x, 0.25)	# 四分位点間距離の定義の確認

## 視覚的なデータの要約 ##

x <- rnorm(100)	# ランダムなサンプルの生成

hist(x)			# ヒストグラム（頻度）
hist(x, freq=F)	# ヒストグラム（相対頻度）

boxplot(x)		# ボックスプロット

# ヒストグラムとボックスプロット #

# 二峰型 #
x1 <- rnorm(100, mean=0)
x2 <- rnorm(100, mean=4)
x <- c(x1, x2)
hist(x)
boxplot(x)

# 裾の重い分布 #
y1 <- rnorm(100, sd=1)
y2 <- rnorm(100, sd=4)
y <- c(y1, y2)
hist(y)
boxplot(y)

## 二標本問題 ##
x1 <- c(8, 17, 9, 5, 14, 13, 13, 3, 9, 0)
x2 <- c(19, 13, 13, 18, 21, 18, 11, 21, 20, 11)

boxplot(x1, x2)

t.test(x1, x2)		# Welch's t test
wilcox.test(x1, x2)	# Mann-Whitney test, Wilcoxon’s rank sum test

## 分散分析 ##

# サンプルデータ #
Data <- data.frame(
  z = c(8, 16, 7, 18, 6, 11, 15, 11, 20, 7, 19, 20, 21, 19, 24),
  group = factor(c(rep(1,5), rep(2,5), rep(3,5)), label=c("placebo", "drugA", "drugB")))
print(Data)
boxplot(z ~ group, data=Data)

# ANOVA #
fit.aov <- aov(z ~ group, data=Data)
summary(fit.aov)

# Kruskal-Wallis rank sum test #
kruskal.test(z ~ group, data=Data)

## 多重比較 ##

# Tukey's method #
library(MASS)
fit.mc <- TukeyHSD(fit.aov)
print(fit.mc)
plot(fit.mc)

# Dunnett's method (Dunnett post hoc test) #
install.packages("multcomp")	# 最初の一回のみ実行
library(multcomp)
fit.dunnett <- glht(fit.aov, linfct = mcp(group = "Dunnett"))
confint(fit.dunnett, level=0.95)
summary(fit.dunnett)

# William's method #
fit.williams <- glht(fit.aov, linfct = mcp(group = "Williams"))
confint(fit.williams, level=0.95)
summary(fit.williams)


setwd("C:\\Users\\Ashish Arora\\Desktop\\Time series Case Study")

#Loading the data file
mydata<-read.csv("data.csv")
View(mydata)

myts   <- ts(mydata[,-c(1,2)], start=c(1996, 1), end=c(2005, 4), frequency=4)
plot(myts)

#After looking at the graph it is observed that Rest.of.World is a patternless data rest all follow a multiplicative form
#so subsetting the data separately.

myts_ireland   <- ts(mydata$Ireland, start=c(1996, 1), end=c(2005, 4), frequency=4)
myts_Other.EU   <- ts(mydata$Other.EU, start=c(1996, 1), end=c(2005, 4), frequency=4)
myts_Rest.of.Europe   <- ts(mydata$Rest.of.Europe, start=c(1996, 1), end=c(2005, 4), frequency=4)
myts_Total  <- ts(mydata$Total, start=c(1996, 1), end=c(2005, 4), frequency=4)

myts_Rest.of..World  <- ts(mydata$Rest.of..World, start=c(1996, 1), end=c(2005, 4), frequency=4)

# plot series
plot(myts_ireland)
plot(myts_Other.EU)
plot(myts_Rest.of.Europe)
plot(myts_Total)
plot(myts_Rest.of..World)#this is an non-seasonal patternless data so we can implement an exponential smoothening techniques

fit<- decompose(myts_ireland, type = c("multiplicative"))
ls(fit)
forecast(fit$x, 4,level=c(90,95))
accuracy(forecast(fit$x, 4))#The MAPE value of 2.428393 for Ireland predicted values
#FORECASTING AND PLOTTING VALUES FOR NEXT QUATER(2006)
final<-forecast(fit$x, 4,level=c(90,95))
plot(final)

fit1<- decompose(myts_Other.EU, type = c("multiplicative"))
forecast(fit1$x, 4,level=c(90,95))
accuracy(forecast(fit1$x, 4))#The MAPE value of 2.279375 for Other EU predicted values
final1<-forecast(fit1$x, 4,level=c(90,95))
plot(final1)

fit2<- decompose(myts_Rest.of.Europe, type = c("multiplicative"))
forecast(fit2$x, 4,level=c(90,95))
accuracy(forecast(fit2$x, 4))#The MAPE value of 2.871732 for Rest of Europe predicted values
final2<-forecast(fit1$x, 4,level=c(90,95))
plot(final2)

fit3<- decompose(myts_Total, type = c("multiplicative"))
forecast(fit3$x, 4,level=c(90,95))
accuracy(forecast(fit3$x, 4))#The MAPE value of 1.948733 for Total predicted values
final3<-forecast(fit1$x, 4,level=c(90,95))
plot(final3)
####NoW for Rest of world data####
fit4.1 <- HoltWinters(myts_Rest.of..World, beta=FALSE, gamma=FALSE)
ls(fit4.1)
require(forecast)
accuracy(fit4.1$fitted, myts_Rest.of..World)

# double exponential - models level and trend
fit4.2 <- HoltWinters(myts_Rest.of..World, gamma=FALSE)
accuracy(fit4.2$fitted, myts_Rest.of..World)
# triple exponential - models level, trend, and seasonal components
fit4.3 <- HoltWinters(myts_Rest.of..World)
accuracy(fit4.3$fitted, myts_Rest.of..World)

#ETS- Exponential method
fit5<-ets(myts_Rest.of..World)
accuracy(fit5$fitted, myts_Rest.of..World)
summary(fit5)
final5<-forecast(fit5, 4 ,level = c(90,95))
plot(final5)
#Thus for rest of world the lowest MAPE is for ETS method thus we use that to predict the next quaters' values.

##All The final graphs
attach(mtcars)
par(mfrow=c(3,2))
plot(final)
plot(final1)
plot(final2)
plot(final3)
plot(final5)

#The predicted results are stored in final,final1, final2,final3, final5


#' @title estimParamsFromCI
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
    estimParamsFromCI = function( CL, probs=c(0.025, 0.975), distribution="gamma", method="L-BFGS-B", plot=FALSE) {
      # CL  is estimated/approximate 95% confidence bounds
      # probs = associated quantiles
      # pm0 = stating guess for parameters
      # theoreticalCI is theoretical probabilty function
      # pm are the parameters of the distributional function

      distrib =  paste('^',distribution, sep="" )

      if ( grepl( distrib, "normal", ignore.case=TRUE ) )  {
        CIoptim = function( pm, CL, probs) {
          theoreticalCI = pnorm( CL, mean=pm[1], sd = pm[2], log.p=TRUE )
          llik = ( theoreticalCI[1] - log( probs[1] ) )^2 + ( theoreticalCI[2] - log( probs[2] ) )^2
          return( llik )
        }
        pm0 = c( mean(CL), (CL[2]-CL[1])/3 )
        lower = c( -Inf, 1e-09 )
        resnames = c("mean", "sd")
        resdefault = c( 0, 1e5 )
        plotfn = function(x) dnorm(x, res[["mean"]], res[["sd"]])
        plot.range = CL + c( - pm0[2], + pm0[2] )
      }

      if ( grepl( distrib, "lognormal", ignore.case=TRUE ) )  {
        CIoptim = function( pm, CL, probs) {
          theoreticalCI =  plnorm( CL, meanlog=pm[1], sdlog=pm[2], log.p=TRUE  )
          llik = ( theoreticalCI[1] - log( probs[1] ) )^2 + ( theoreticalCI[2] - log( probs[2] ) )^2
          return( llik )
        }
        pm0 =  c( mean(log(CL)), log(CL[2])-log(CL[1])/3 )
        lower = c( -Inf, 1e-9 )
        resnames = c("meanlog", "sdlog")
        resdefault = c( 1e-3, 2 )
        plotfn =  function(x) dlnorm(x, res[["meanlog"]], res[["sdlog"]])
        plot.range = CL * c( 0.01, 1.5 )
      }

      if ( grepl( distrib, "gamma", ignore.case=TRUE ) )  {
        CIoptim = function( pm, CL, probs) {
          theoreticalCI = pgamma( CL, shape=pm[1], rate=pm[2], log.p=TRUE  )
          llik = ( theoreticalCI[1] - log( probs[1] ) )^2 + ( theoreticalCI[2] - log( probs[2] ) )^2
          return( llik )
        }
        pm0 = c( 0.5, 1/mean( CL ))
        lower = c( 1e-9, 1e-9 )
        resnames = c("shape", "rate")
        resdefault = c( 0.1, 0.01 )
        plotfn = function(x) dgamma(x, res[["shape"]], res[["rate"]])
        plot.range = CL * c( 0.01, 1.5 )
      }

      res = optim( pm0, CIoptim, CL=CL, probs=probs, lower=lower, method=method)
      if (res$convergence==0) {
        res = res$par
      } else {
        res= resdefault
      }

      names(res) = resnames

      if (plot) {
        curve( plotfn, plot.range[1], plot.range[2] )
        abline( v=CL[1], lty="dotted" )
        abline( v=CL[2], lty="dotted" )
      }

      return(res)

      # ----------
      debug = FALSE
      if (debug) {
        CL = c(0.5, 10) # initial guess of 95% CI
        estimParamsFromCI( CL, pm0=c(0.1, 0.1) , distribution="gamma", plot=T)
        #  E(X) = shape * scale = shape / rate = res[["shape"]] / res[["rate"]] = 3.69
        #  Var(X) = shape*scale^2 = shape / (rate^2) = res[["shape"]] / res[["rate"]] ^2 =  6.32
        qgamma( 0.025, res[["shape"]], res[["rate"]] )  # = 0.5
        qgamma( 0.975, res[["shape"]], res[["rate"]] )  # = 9.99
        curve( dgamma(x, res[["shape"]], res[["rate"]]), 0.0005, 100)

      }
    }


## Author: Sergio García Prado

rm(list = ls())

## a)
####

##
## Asymptotic distibution of p.hat as parameter p of Bin(n, p)
## p.hat ~ N(p, p * (1 - p) / n)
##

## b)
####

n <- 100
y <- 15
alpha <- 0.05

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

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

opt <- optim(runif(1), NegativeLogLikelihood, y = y, n = n, hessian = TRUE,
             method = "Brent", lower=10e-3, upper = 1 - 10e-3)

(p.hat <- opt$par)
# 0.149999999993663

(p.hat.var <- 1 / opt$hessian[1])
# 0.001274903

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

## c)
####
p.zero <- 1 / 3

(W <- (p.hat - p.zero) ^ 2 / p.hat.var)
# 26.3616557734205

(W.pvalue <- 1 - pchisq(W, df=1))
# 2.83105275666884e-07

## d)

(LRT <- 2 * (LogLikelihood(p.hat, y, n) - LogLikelihood(p.zero, y, n)))
# 17.345619477233

(LRT.pvalue <- 1 - pchisq(LRT, df=1))
# 3.11615708954438e-05


#COIN
p = seq(0,1,0.01)
P10T = function(p) {11 * (1-p)^10}
#  11 to normalize to a density
plot(p, P10T(p),"l")
#
integrate(P10T, lower=0, upper=1)
#
# for the mean
pP10T = function(p)  11 * p * (1-p)^10
integrate(pP10T, lower=0, upper=1) #0.08333333 (1/12)
points(c(0, 0),c(0, 11), pch=16, col="red")
points(c(1/12, 1/12),c(0,  P10T(1/12)),pch=16,col="green")
# for the median
integrate(P10T, lower=0, upper=0.061069081)  #0.50000
points(c(0.061069081, 0.061069081),
     c(0,  P10T(0.061069081)), pch=16, col="blue")
legend(0.6,10, #location
      c("Mode","Mean","Median"), #labels
      cex= 1, #size
      pch=c(16,16,16), #filled circle
      col=c("red","green","blue")) #color


p_1calf=0.83
p_2calf=0.02
p_0calf=0.15

# event A=  dams gives birth to no healthy progeny ,1 healthy progeny,2 healthy progeny(n1=1,n2=1,n3=1)

P_eventA=(factorial(3)*(p_0calf^1*p_1calf^1*p_2calf^1))/(factorial(1)*factorial(1)*factorial(1))
print(P_eventA)
 # event B= 3 dams give birth to 1 healthy progeny(n1=0,n2=3,n3=0)
P_eventB=(factorial(3)*(p_0calf^0*p_1calf^3*p_2calf^0))/(factorial(0)*factorial(3)*factorial(0))
print(P_eventB)
#  the probability of obtaining exactly three healthy progeny from three dams
p=P_eventA+P_eventB
print(p)


#Relation is the relationship between two set of numbers
#It can be represented as ordered pairs
#When we do correlation, we find the relationship between two set of numbers(ie variables)
#The correlation coefficient explains about the relation.
#It gives an idea to expand it as functions

#Functions
# A function is a set of ordered pairs in which the first coordinate, usually x, matches with exactly one second coordinate, y.
# the y coordinate represents the dependent variable
# A function can be expressed as an equation -> f(x) = y
# f(x) - f is the name of the function and x is the name of the independent variable.

#Mathematical modeling
# Mathematical modeling involves creating a set of mathematical equations that describes a situation, solving those equations, and using them to understand the real life problem
# Model can also be used to predict what a system will do for different values of the independent variable. Lastly, a model can be used to estimate quantities that are difficult to evaluate exactly
# The goal is not to produce an exact copy of the "real object" but rather to give a representation of some aspect of the real thing.
# Slope - the coefficient of x
# Rate of change - f(b) - f(a) / (b-a)
hotel = linear_tips
cor(hotel$meal_amt, hotel$tips)
plot(hotel$meal_amt, hotel$tips)
model = lm(tips$meal_amt, data=hotel)
model
summary(model)
new = c(20,25)
newx = as.data.frame(meal_amt=new)
newx
newy = predict(model, newx)
newy
sample.read.csv(file.choose(), header=T)
head(sample)
library(SDSFoundations)
linFit(sample$x, sample$y)
linFitPred(sample$x, sample$y, 1)
linFitPred(sample$x, sample$y, 2)
mean(sample$x)
mean(sample$y)

# Exponential model
expFit(sample$x, sample$y)
# R-squared = 1 - (Explained variation) / Total variation
expFitPred(sample$x, sample$y, 1)
#determining the target is known as Extrapolation - given y we need to find x, this is known as extrapolation
# Logistic growth model will be best explainable when the data has reached the upper limit and there after the growth is consistent, logistic growth model can be used
logisticFit(sample$x, sample$y)
logisticFit(sample$x, sample$y, 1)
logisticFit(sample$x, sample$y, 2)
tripleFit(sample$x, sample$y)


library(deSolve)
library(reshape)
library(ggplot2)
library(plotly)

micro_1 <- function(times,init,parms){
  with(as.list(c(parms,init)), {
  # ODEs
  dS <- r*(1-S/K)*S - beta*S*I
  dI <- beta*S*I-(mu + alpha)*I
  list(c(dS,dI))
  })
}

w <- 1
m <- 10
beta <- 0.0247*m*w**0.44
r <- 0.6*w**-0.27
mu <- 0.4*w**-0.26
K <- 16.2*w**-0.7
alpha <- (m-1)*mu

parms <- c(beta=beta,r=r,mu=mu,K=K,alpha=alpha)
init <- c(S=K,I=1.)
times = seq(0,10,length.out=101)

sir_out <- lsoda(init,times,micro_1,parms)

sir_out_long <- melt(as.data.frame(sir_out),"time")

# Plot
p <- plot_ly(data = sir_out_long, x = ~time[variable=="S"], y = ~value[variable=="S"],type = "scatter", mode = "lines",name = "S(t)") %>%
add_trace(y = ~value[variable=="I"],type = "scatter", mode = "lines",name = "I(t)") %>%
layout(xaxis = list(title="Time"), yaxis = list(title="Number"))
p

m <- c(5,10,20,40)
ws <- 10^seq(-3,3,length.out=601)
betas <- data.frame("ws"=ws, "m5"=0.0247*m[1]*ws^0.44,"m10"=0.0247*m[2]*ws^0.44,"m20"=0.0247*m[3]*ws^0.44,"m40"=0.0247*m[4]*ws^0.44)

# Plot
p <- plot_ly(betas,x=~ws,y=~m5,type = "scatter", mode = "lines",name = "m = 5") %>%
add_trace(y = ~m10,type = "scatter", mode = "lines",name = "m = 10") %>%
add_trace(y = ~m20,type = "scatter", mode = "lines",name = "m = 20") %>%
add_trace(y = ~m40,type = "scatter", mode = "lines",name = "m = 40") %>%
layout(xaxis = list(title="Weight",type = "log"), yaxis = list(title="beta_min",type = "log"))
p


## Author: Sergio García Prado
## Title: Exercises with Solutions 5

rm(list = ls())

Q <- matrix(c(-20,  20,   0,   0,
               10, -30,   0,  20,
                5,   0, -25,  20,
                0,   5,  10, -15),
            4, 4, byrow = TRUE)

(A <- cbind(Q[, 1:(nrow(Q) - 1)], rep(1, nrow(Q))))
# -20	 20	  0	1
#  10	-30	  0	1
#   5	  0	-25	1
#   0	  5	 10	1

(stationary <- solve(A)[nrow(A), ])
# 0.135802469135802 0.172839506172839 0.197530864197531 0.493827160493827

stationary[2] + (5 / (10 + 5)) * stationary[4]
# 0.337448559670782

20 * (1 - stationary[4])
# 10.1234567901235


# Function definitions for the inverse-gamma probability distribution.
# The parameters of the distribution (alpha, beta) are as defined here:
# https://en.wikipedia.org/wiki/Inverse-gamma_distribution

pinvgamma <- function(x, alpha, beta) {
    # The cdf of the inverse-gamma distribution.
    return(1 - pgamma(1/x, shape=alpha, rate=beta));
}

qinvgamma <- function(p, alpha, beta) {
    # The quantile function of the inverse-gamma distribution.
    return(1 / qgamma(1 - p, shape=alpha, rate=beta));
}

dinvgamma <- function(x, alpha, beta) {
    # The pdf of the inverse-gamma distribution.
    if (alpha <= 0 | beta <= 0) {
        stop("Shape or scale parameter negative in dinvgamma().\n");
    }
    log_density <- alpha * log(beta) - lgamma(alpha) - (alpha + 1) * log(x) - (beta / x);
    return(exp(log_density));
}

rinvgamma <- function(n, alpha, beta) {
    # Draw n samples from the inverse-gamma distribution.
    return(1 / rgamma(n=n, shape=alpha, rate=beta));
}


# This file contains R code for the Cmax estimator used as an example in section 3.
# Although not designed to be the most efficient R program, it is simply here to
# assist students in writing their own functions by illustrating several useful concepts.

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

  n = length(song)  # determine the number of notes in the song

  c_temp=0  # this is a temporary counter which tallies the strings of misses

  c_max=0   # this holds the current length of the longest streak of misses

  for(i in 1:n){  # set up a for loop to scan through entire song
    if(song[i]==1){  # use this section only if a miss on note i
      c_temp=c_temp+1   # increase miss streak by 1
      if(c_temp>c_max) c_max=c_temp  # check if new streak is longer than current max
    }
    if(song[i]==0){  # use this section only if a hit on note i
      c_temp=0       # reset current streak of misses
    }
  }

  return(c_max)  # returns the maximum consecutive number of misses
}

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

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

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

	# calculate a one sided p-value
#	pval = sum(tstar_b >= test_stat)/B

	return(pval)
}

# Examples using Songs A and B from Table 1

songA = c(1,0,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0)
Cmax(songA)
Cmax_test(songA,5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
Cmax(songB)
Cmax_test(songB,5000)


library(Sleuth3)
with(case0202,hist(Unaffected-Affected))
diffs<-case0202$Unaffected-case0202$Affected
diffs<-with(case0202,Unaffected-Affected)
diffs
hist(diffs)
t.test(diffs)
with(case0202,t.test(Unaffected,Affected,paired=TRUE))
with(case0202,t.test(Unaffected,Affected))
sample.mean<-mean(diffs) #Calculate the sample mean of the differences
sample.sd<-sd(diffs)     #Calculate the sample standard deviation
n<-length(diffs)         #Find the sample size

se.mean<-sample.sd/sqrt(n)    #Calculate the standard error of the sample mean.
sample.mean/se.mean

pt(3.228928,14) # Area under the t_14 curve to the left of 3.228928
1-pt(3.228928,14) # Area to the right.
2*(1-pt(3.228928,14)) # Two-sided p-value.

qt(.975,14) # t quantile for 95% confidence interval and 14 df.
sample.mean-qt(.975,14)*se.mean
sample.mean+qt(.975,14)*se.mean

library(ggplot2)
qplot(factor(Year),Depth,data=case0201,geom="boxplot")

t.test(Depth~Year,data=case0201,var.equal=TRUE)
t.test(Depth~Year,data=case0201,var.equal=TRUE,alternative="less")


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

data <- read.csv('../../results/client_algos/data_all.csv', sep = ';')

# Means
aggregate(data$time, list(data$combination), median)
# None: 1492.0
# Triple: 1588.5
# BGPSimple: 745.0
# BGPCombined: 736.0
# TripleBGP: 658.5

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: None == Triple
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_0' | data$combination=='combination_1'),])
# p: 0.9318
# => Accept H0, equal means => None == Triple

# H0: None == BGPSimple
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_0' | data$combination=='combination_2'),])
# p: 0.006231
# => Accept H0, non-equal means => None > BGPSimple

# H0: None == BGPCombined
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_0' | data$combination=='combination_3'),])
# p: 0.002631
# => Reject H0, non-equal means => None > BGPCombined

# H0: Triple == BGPSimple
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_1' | data$combination=='combination_2'),])
# p: 0.009066
# => Accept H0, non-equal means => Triple > BGPSimple

# H0: Triple == BGPCombined
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_1' | data$combination=='combination_3'),])
# p: 0.004172
# => Reject H0, non-equal means => Triple > BGPCombined

# H0: None == TripleBGP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_0' | data$combination=='combination_4'),])
# p: 0.00234
# => Reject H0, non-equal means => None > TripleBGP

# H0: Triple == TripleBGP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_1' | data$combination=='combination_4'),])
# p: 0.003434
# => Reject H0, non-equal means => Triple > TripleBGP

# H0: BGPSimple == TripleBGP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_2' | data$combination=='combination_4'),])
# p: 0.5758
# => Accept H0, equal means => BGPSimple == TripleBGP

# H0: BGPCombined == TripleBGP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_3' | data$combination=='combination_4'),])
# p: 0.9484
# => Accept H0, equal means => BGPCombined == TripleBGP

# H0: BGPCombined == BGPSimple
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_3' | data$combination=='combination_2'),])
# p: 0.6689
# => Accept H0, equal means => BGPCombined == BGPSimple


# 04. 정규분포

# 정규분포 : 평균과 분산으로 표시
# 난수함수: rnorm(n, mean=0, sd=1)
# 확률밀도함수: d~
# 누적분포함수(점수): p~
# 누적분포함수(확률): q~

# 난수함수: rnorm(n, mean=0, sd=1)
x <-rnorm(100,50,20) # 숫자 100개를 무작위로 뽑아라. 그런데 평균이 50이고 표준편차가 20이다. 랜덤으로 추출

x # 무작위 추출

x <- sort(x) # 순서대로 정리

x <- round(x,2)

plot(x,
     dnorm(x,50,20),
     type='l', # 선을 연결하는 옵션
     main="정규분포, X~N(50,20)")
abline(v=50, # 평균이 50이니까 보기좋게 선 그린 것
       col="blue",
       lty=2) # 라인 스타일

# 정규분포 누적분포함수(점수)
# pnorm(q, mean=0, sd=1, lower.tail=FALSE)
# 이하 : P(X <= a) lower.tail = TRUE
# 초과: P(X > a) lower.tail = FALSE
# 만약 60점이라면
pnorm(60, mean=50, sd=20, lower.tail=TRUE) # 60점 이하 => 60점이면 아래에 전체의 몇 %가 있는가? 아래료 70%
pnorm(60, mean=50, sd=20, lower.tail=FALSE) # 60점 초과 => 60점을 초과하는 학생은 전체의 몇 % 인가? 상위 몇 %에 속하는가? 30%
abline(v=60, col="red", lty=3)

# 누적분포함수(확률) => 몇 % 일때 점수를 알고 싶다.
# qnorm(p, mean=0, sd=1, lower.tail=FALSE)
# 이하 : P(X <= a) lower.tail = TRUE
# 초과: P(X > a) lower.tail = FALSE
# 상위 35% 안에 들어가려면
qnorm(0.35, mean=50, sd=20, lower.tail=FALSE) # 상위 35%의 점수를 알려주어라. 위에서 부터 재는 것
qnorm(0.35, mean=50, sd=20, lower.tail=TRUE) # 하위 35%의 점수를 알려주어라.
abline(v=57.7, col="green", lty=3)

# 정규분포 그래프
plot(x,
     dnorm(x, 50,20),
     type='l',
     main="정규분포, X~N(50,20)")
abline(v=50, col="blue", lty=3)
abline(v=50+1.96*20, col="red", lty=3) # 신뢰수준 95% 구간에 표시하라.
abline(v=50-1.96*20, col="red", lty=3)

# 표준정규분포 그래프 <- 평균을 0로 하여 그린 그래프
x <- seq(-3, 3, length=200)
plot(x,
     dnorm(x, mean=0, sd=1),
     type='l',
     main="Normal distribution, X~N(0,1)")

# 퀴즈
#대학 경영통계 수업 듣는 학생의 시험점수가 평균 70, 표준편차가 20점이라고 한다.
#상위 35%에 들기 위한 점수는?

qnorm(0.35, 70, 20, lower.tail = FALSE)
qnorm(0.35, mean=70, sd=20, lower.tail=FALSE)

#B이상(80%)에 들기 위한 점수는?7
qnorm(0.2, mean=70, sd=20, lower.tail=TRUE)


?rbinom
n <- 1000 #number of observations
p <- 0.2 #probability of success

#create random binomial distribution of [0,1,...,7] scores
scores <- rbinom(n, 8, p)

#plotting histogram
hist(scores)

#Unfair coin with P(heads) = 0.65, 10 tosses
#10 trials, exactly 7 heads
dbinom(7, 10, 0.65) #using density function

#10 trials, at most 7 heads
pninom(7, 10, 0.65) #cumulative probs, using distribution function

#10 trials, at least 6 heads
# density 6 heads + density 7 heads + ... + density 10 heads
dbinom(6, 10, 0.65)+dbinom(7, 10, 0.65)+dbinom(8, 10, 0.65)+dbinom(9, 10, 0.65)+dbinom(10, 10, 0.65)
#or cumulative of 10 heads - cumulative 5 heads
pbinom(10, 10, 0.65) - pbinom(5, 10, 0.65)

#Plotting better the previous hist(scores) using densities
library(tidyverse)
df <- as_tibble(data.frame(scores))
df_with_freqs <- df %>%
                 group_by(scores) %>%
                 summarize(n=n()) %>%
                 mutate(freq= n/sum(n))

ggplot(df_with_freqs, aes(x=scores, y=freq)) + geom_col() + ylab("Estimated Density")

#Plotting analytical densities in binominal distribution
binom <- as_tibble(list(x=0:n, prob= dbinom(0:n, n, p)))
ggplot(binom, aes(x=x, y=prob)) + geom_col() + ylab("Analytical Density")

#Computing the cumulative density function using previous probability density function
df_with_cdf <- binom %>%
               mutate(cdf=cumsum(prob))
ggplot(df_with_cdf, aes(x=x, y=cdf)) + geom_step() + ylab("CDF")

#Plotting histogram and density with ggplot
ggplot(binom, aes(x))+
  geom_histogram(data=binom, aes(x, ..density..), fill="white", color="darkred")+
  geom_density(kernel="gaussian", aes(x))


#' @export
#'
#' @title Baysian estimation to binomial proportion using a conjugate
#' prior.
#'
#' @description This routine assumes a beta(a,b) prior for a binomial
#' proportion and computes posterior point and inteval estimates
#' for the proportion given
#' an observed number of 'successes' and number of 'trials'.
#'
#' @param x The number of 'successes' (an integer vector)
#'
#' @param n The number of 'trials' (an integer vector)
#'
#' @param a A vector of shape parameters to specify the beta prior
#'
#' @param b A vector of scale parameters to specify the beta prior
#'
#' @param conf A scalar specifying the desired confidence level
#' of the interval estimate.  This scalar should be between 0.5 and 1.
#'
#' @param ci A character string specifying the type of posterior
#' confidence interval to compute.  A value of 'eq' computes
#' posterior intervals with equal area in both tails.  A value
#' of 'hdi' computes highest density interval estimates.  See Details.
#'
#' @details
#'
#' Computations are elementary because the beta(a,b) prior is
#' conjugate for the binomial. Nearly every text on Bayesian
#' estimation shows that given values for \code{x}, \code{n},
#' \code{a}, and \code{b}, the posterior distribution of p
#' is,
#' \deqn{beta(x+a, n-x+b).}
#' Hence, the Bayes point estimator is,
#' \deqn{phat = (x+a) / (n+a+b),}
#' which is the mean of the posterior. Standard error of the
#' posterior is,
#' \deqn{se.phat=sqrt(a*b/((a+b)^2*(a+b+1))).}
#' If \code{a>1} and \code{b>1}, mode of the posterior for p is,
#' \deqn{(a-1)/(a+b-2).}
#'
#'
#' Confidence intervals can be computed two ways. The default,
#' \code{ci='eq'}, puts \code{(1-conf)/2} probability in the
#' lower tail and \code{(1-conf)/2} in the upper tail.
#' That is, the lower limit is
#' \code{qbeta((1-conf)/2,x+a,n-x+b)} and the upper limit is
#' \code{qbeta(1-(1-conf)/2,x+a,n-x+b)}.  If \code{ci='hdi'},
#' this routine finds the interval [l,u] such that
#' \code{pbeta(u,x+a,n-x+b) - pbeta(l,x+a,n-x+b)} and
#' \code{dbeta(u,x+a,n-x+b) = dbeta(l,x+a,n-x+b)}.
#'
#' The default values for \code{a} and \code{b}
#' imply use of the Jeffery's prior.  The Jeffery's prior is
#' proportional to the root of Fisher's information and
#' is equal to beta(0.5,0.5). A flat prior is beta(1,1).
#'
#' @return A data frame with number of rows equal to
#' \code{max(length(x), length(n), length(a), length(b)}
#' containing the Baysian point and interval estimates.
#' The data frame has the
#' following columns:
#' \enumerate{
#'   \item \code{phat} : the Bayes point estimates equal to the
#'   mean of the posterior distribution.
#'   \item \code{phat.mode} : if \code{a>1} and \code{b>1}, this
#'   column contains the mode of the posterior. If either
#'   \code{a<=1} or \code{b<=1}, the posterior is either multi-modal
#'   or its mode is infinity.  In this case, \code{phat.mode = NA}.
#'   \item \code{se.phat} : the standard
#'   error of the posterior distribution.
#'   \item \code{ll.phat} : the lower limit of a \code{100*(1-(1-conf)/2)}%
#'   posterior confidence interval for \code{phat}. See Details for
#'   interpretation under the allowed values of \code{ci}.
#'   \item \code{ul.phat} : the upper limit of a \code{100*(1-(1-conf)/2)}%
#'   posterior confidence interval for \code{phat}. See Details for
#'   interpretation under the allowed values of \code{ci}.
#' }
#'
#' @author Trent McDonald
#'
#'
#' @seealso \code{\link{agrestiCoullPhat}}
#'
#' @examples
#' bayesPhat(0:5, 100, 0.5, 0.5)  # Jeffery's prior
#' bayesPhat(0:5, 100, 1, 1) # flat prior
#'
#' # When prior data is available:
#' x.prior <- 5
#' n.prior <- 100
#' bayesPhat(0:5, 100, x.prior+0.5, n.prior-x.prior+0.5)
#'
#' # Simulation: point est bias and ci coverage
#' trueP <- 0.01
#' n <- 1000
#' x <- rbinom( 1000, n, trueP)
#' baPhat <- bayesPhat( x, n )
#' muBA <- mean(baPhat$phat)
#' covBA <- mean(baPhat$ll.phat <= trueP & trueP <= baPhat$ul.phat)
#' baStats <- c(mean=muBA,
#'              relBias = abs(muBA-trueP)/trueP),
#'              coverage = covBA)
#'
#'
#'
#'
bayesPhat <- function(x, n, a=0.5, b=0.5, conf=0.9, ci="eq"){
  aPost <- x + a
  bPost <- n - x + b
  phat <- aPost / (aPost + bPost)

  se <- sqrt(aPost*bPost / ((aPost+bPost)^2*(aPost+bPost+1)))

  if((aPost>1) & (bPost>1)){
    phat.mode <- (aPost-1) / (aPost + bPost - 2)
  } else {
    phat.mode <- NA
  }

  ll <- qbeta((1-conf)/2,aPost,bPost)
  ul <- qbeta(1-(1-conf)/2,aPost,bPost)
  if(ci=="hdi"){
      if((aPost>1) & (bPost>1)){
        fl <- function(q, a, b, p){
          (dbeta(q,a,b) - p)^2
        }
        hdi.obj <- function(p, a, b, conf, phat.mode){
          q1 <- optim(par=phat.mode/2,fn=fl,a=a, b=b, p=p,
                      method="Brent",lower=0, upper = phat.mode)$par
          q2 <- optim(par=(1+phat.mode)/2,fn=fl,a=a, b=b, p=p,
                      method="Brent",lower=phat.mode, upper = 1)$par
          hdi.prob <- pbeta(q2,a,b) - pbeta(q1,a,b)
          (hdi.prob - conf)^2
        }
        fp <- optim(par=dbeta(phat.mode,aPost,bPost)/2, fn=hdi.obj,
                    a=aPost, b=bPost, conf=conf, phat.mode=phat.mode,
                    method="Brent", lower=1e-10,
                    upper=dbeta(phat.mode,aPost,bPost))$par
        ll <- optim(par=ll,fn=fl,a=aPost, b=bPost, p=fp,
                    method="Brent",lower=0, upper = phat.mode)$par
        ul <- optim(par=ul,fn=fl,a=aPost, b=bPost, p=fp,
                    method="Brent",lower=phat.mode, upper = 1)$par
    } else {
      ll <- ul <- NA
    }
  }

  data.frame(phat=phat, se.phat=se, phat.mode=phat.mode, ll.phat=ll, ul.phat=ul)
}


#' @export
#' @title decibar2depth
#' @description This function calculates depth in meters from pressure in decibars using Saunders and Fofonoff's method
#' @param \code{P} = pressure, in decibars
#' @param \code{lat} = degrees latitude
#' @param \code{Del} = geopotential anomaly (defaults to 0)
#' @param \code{method} = valid values include"default", "seabird", and "unesco", although they all appear to be treated the same
#' @return \code{DEPTH} = depth in M
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @examples
#' decibar2depth(10000,30,0)
#' [1] 9712.653
#' @note
#'
# DEEP-SEA RES., 1976, 23, 109-111.
#' / UNITS:
#' //   PRESSURE     P      DECIBARS
#' //   LATITUDE     LAT    DEGREES
#' //   DEPTH        DEPTH  METERS
#' //   DTN. HEIGHT  DEL    DYN. METERS (geopotenial anomaly in J/kg:: assume 0)
#' // CHECKVALUE:
#' //   1.) DEPTH = 9712.653 M for P=10000 DECIBARS, LAT=30 DEG, DEL=0
#' //   ABOVE FOR STANDARD OCEAN: T=0 DEG CELSIUS; S=35 (PSS-78)
#' // ----------------------------------------------------------
#' // Original fortran code is found in:
#' //   UNESCO technical papers in marine science 44 (1983) -
#' //   'Algorithms for computation of fundamental properties of seawater'
#' @references \url{http://www.code10.info/index.php?option=com_content&view=article&id=67:calculating-the-depth-from-pressure&catid=54:cat_coding_algorithms_seawater&Itemid=79}, \url{http://www.code10.info/index.php?option=com_content&view=article&id=67:calculating-the-depth-from-pressure&catid=54:cat_coding_algorithms_seawater&Itemid=79}
#' @family physical and chemical properties
#' @export

      decibar2depth = function( P, lat, Del=0, method="default" ) {

        if (method %in% c("default", "seabird", "unesco" ) ) {

          X = (sin( lat * pi / 180 ))^2 # convert degree decimal to RADs

          # GR=GRAVITY VARIATION WITH LATITUDE: ANON (1970) BULLETIN GEODESIQUE
          GR = 9.780318 * (1.0 + (5.2788E-3 + 2.36E-5 * X) * X) + 1.092E-6 * P
          DepthTerm = (((-1.82E-15 * P + 2.279E-10) * P - 2.2512E-5) * P + 9.72659) * P ## assuming (35 psu, 0 C, and P=pressure in decibars )
          DEPTH = DepthTerm / GR + Del / 9.8
          return (DEPTH)
        }

      }


# V17: moyenne; V18: max; V25: Nom de l'Etat;
head(df)
#S?lection des colonnes pertinentes
data_80_14 <- data_80_14[,c("V25", "V18", "V17")]
#S?lection des donn?es des Etats qui nous int?ressent
data_80_14=subset(df, V25=="California" | V25=="Louisiana" | V25=="Ohio" | V25=="Minnesota" | V25=="Montana")
#Renommage des colonnes
colnames(data_80_14)[1] <- "?tat"
colnames(data_80_14)[2] <- "Temp?rature maximale"
colnames(data_80_14)[3] <- "Temp?rature moyenne"

#Comme la moyenne est une moyenne arithm?tique, on peut d?terminer
#la temp?rature minimale ? partir de la moyenne et de la temp?rature
#maximale
#Moy = (Min+Max)/2
#2*Moy = Min+Max
#2*Moy-Max = Min
temp_minimale=2*data_80_14$`Temp?rature moyenne`-data_80_14$`Temp?rature maximale`
data_80_14$temp_minimale=temp_minimale

#Calcul de la moyenne et de l'?cart type, pour cet ?chantillon

#Moyenne de la temp?rature max
moy_max_1 <- mean(data_80_14$`Temp?rature maximale`)
#Ecart type sur la temp?rature max
sigma_tmp <- 0
for(j in 1:nrow(data_80_14))
{
  sigma_tmp <- sigma_tmp + (moy_max_1-data_80_14$`Temp?rature maximale`[j])^2

}
#?cart-type = racine carr? de la variance
sigma_max_1 <- sqrt(sigma_tmp/(nrow(data_80_14)-1))

#Moyenne de la temp?rature moyenne
moy_moyenne_1 <- mean(data_80_14$`Temp?rature moyenne`)

#Ecart type sur la temp?rature moyenne
sigma_tmp <- 0
for(j in 1:nrow(data_80_14))
{
  sigma_tmp <- sigma_tmp+(moy_moyenne_1-data_80_14$`Temp?rature moyenne`[j])^2

}
sigma_moy_1 <- sqrt(sigma_tmp/(nrow(data_80_14)-1))

#Moyenne de la temp?rature minimale
moy_min_1 <- mean(data_80_14$`temp_minimale`)

#Ecart type sur la temp?rature minimale
sigma_tmp <- 0
for(j in 1:nrow(data_80_14))
{
  sigma_tmp <- sigma_tmp+(moy_min_1-data_80_14$`temp_minimale`[j])^2

}
sigma_min_1 <- sqrt(sigma_tmp/(nrow(data_80_14)-1))

#-------DEUXIEME ECHANTILLON: 2015 - 2019 -------#
#On fait pareil avec le deuxi?me ?chantillon

# V17 moyenne V18 max V25 Nom de l'Etat
head(df)
data_15_19=subset(df, V25=="California" | V25=="Louisiana" | V25=="Ohio" | V25=="Minnesota" | V25=="Montana")
data_15_19 <- data_15_19[,c("V25", "V18", "V17")]
colnames(data_15_19)[1] <- "?tat"
colnames(data_15_19)[2] <- "Temp?rature maximale"
colnames(data_15_19)[3] <- "Temp?rature moyenne"

#Comme la moyenne est une moyenne arithm?tique, on peut d?terminer
#la temp?rature minimale ? partir de la moyenne et de la temp?rature
#maximale
temp_minimale=2*data_15_19$`Temp?rature moyenne`-data_15_19$`Temp?rature maximale`
data_15_19$temp_minimale=temp_minimale

#Moyenne de la temp?rature max
moy_max_2 <- mean(data_15_19$`Temp?rature maximale`)
#Ecart type sur la temp?rature max
sigma_tmp <- 0
for(j in 1:nrow(data_15_19))
{
  sigma_tmp <- sigma_tmp + (data_15_19$`Temp?rature maximale`[j]-moy_max_2)^2

}
sigma_max_2 <- sqrt(sigma_tmp/(nrow(data_15_19)-1))
print(data_15_19$`Temp?rature maximale`)

#Moyenne de la temp?rature moyenne
moy_moyenne_2 <- mean(data_15_19$`Temp?rature moyenne`)

#Ecart type sur la temp?rature moyenne
sigma_tmp <- 0
for(j in 1:nrow(data_15_19))
{
  sigma_tmp <- eval.parent(substitute(sigma_tmp+(moy_moyenne_1-data_15_19$`Temp?rature moyenne`[j])^2))

}
sigma_moy_2 <- sqrt(sigma_tmp/(nrow(data_15_19)-1))

#Moyenne de la temp?rature minimale
moy_min_2 <- mean(data_15_19$`temp_minimale`)

#Ecart type sur la temp?rature minimale
sigma_tmp <- 0
for(j in 1:nrow(data_15_19))
{
  sigma_tmp <- sigma_tmp+(moy_min_1-data_15_19$`temp_minimale`[j])^2

}
sigma_min_2 <- sqrt(sigma_tmp/(nrow(data_15_19)-1))

#----------- COMPARAISON DES MOYENNES ----------------#
print("Moyennes pour l'?chantillon 1: ")
print(paste0("Temp?rature minimale: ", moy_min_1))
print(paste0("Temp?rature moyenne: ", moy_moyenne_1))
print(paste0("Temp?rature maximale: ", moy_max_1))

print("Moyennes pour l'?chantillon 2: ")
print(paste0("Temp?rature minimale: ", moy_min_2))
print(paste0("Temp?rature moyenne: ", moy_moyenne_2))
print(paste0("Temp?rature maximale: ", moy_max_2))

#---------------- COMPARAISON DES ECARTS TYPE ----------#
print("Ecarts type pour l'?chantillon 1: ")
print(paste0("Temp?rature minimale: ", sigma_min_1))
print(paste0("Temp?rature moyenne: ", sigma_moy_1))
print(paste0("Temp?rature maximale: ", sigma_max_1))

print("Ecarts type pour l'?chantillon 2: ")
print(paste0("Temp?rature minimale: ", sigma_min_2))
print(paste0("Temp?rature moyenne: ", sigma_moy_2))
print(paste0("Temp?rature maximale: ", sigma_max_2))

sigma_essai=sd(data_15_19$`Temp?rature maximale`)
print(paste0("ESSAI FONCTION SD ", sigma_essai))
print(sigma_essai)


> #1.	Dla zmiennych losowych przedstawionych w tabelach obliczyć podstawowe statystyki
> #     Wartość = 1, Prawdopodobieństwo = 1/6 (podobnie dla wartośći 2,3,4,5,6)
>
> #2.	Wygeneruj próby dla n=100 dla następujących rozkładów: Bernoulliego, Dwumianowego, Poissona
> library(Rlab)
Błąd w poleceniu 'library(Rlab)':nie ma pakietu o nazwie ‘Rlab’
> Probs <- rep(1/6, 6)
> items <- seq(1, 6, 1)
> it_mean = mean(items)
> it_median = median(items)
> it_std = sd(items)
> it_var = var(items)
> n = 100
> p = 0.2
> k = 5
> ber <- rbern(n,p)
Błąd w poleceniu 'rbern(n, p)':nie udało się znaleźć funkcji 'rbern'
> ber <- rber(n,p)
Błąd w poleceniu 'rber(n, p)':nie udało się znaleźć funkcji 'rber'
> library(Rlab)
Błąd w poleceniu 'library(Rlab)':nie ma pakietu o nazwie ‘Rlab’
> install.packages("Rlab")
WARNING: Rtools is required to build R packages but is not currently installed. Please download and install the appropriate version of Rtools before proceeding:

https://cran.rstudio.com/bin/windows/Rtools/
Installing package into ‘C:/Users/Adam/Documents/R/win-library/3.6’
(as ‘lib’ is unspecified)
próbowanie adresu URL 'https://cran.rstudio.com/bin/windows/contrib/3.6/Rlab_2.15.1.zip'
Content type 'application/zip' length 347255 bytes (339 KB)
downloaded 339 KB

package ‘Rlab’ successfully unpacked and MD5 sums checked

The downloaded binary packages are in
	C:\Users\Adam\AppData\Local\Temp\RtmpKIlQ6d\downloaded_packages
> library(Rlab)
Rlab 2.15.1 attached.

Dołączanie pakietu: ‘Rlab’

Następujące obiekty zostały zakryte z ‘package:stats’:

    dexp, dgamma, dweibull, pexp, pgamma, pweibull, qexp, qgamma, qweibull, rexp, rgamma, rweibull

Następujący obiekt został zakryty z ‘package:datasets’:

    precip

> ber <- rbern(n,p)
> bin <- rbinom(n,k,p)
> poi <- rpois(n,p)
>
> # 3.	Policz dla nich statystyki podstawowe (średnią, wariancję, kurtozę i skośność).
>
> mean(ber)
[1] 0.23
> median(ber)
[1] 0
> var(ber)
[1] 0.1788889
> skew(ber)
[1] 1.283171
> kurt(ber)
[1] 2.646527
>
>
> mean(bin)
[1] 0.92
> median(bin)
[1] 1
> var(bin)
[1] 0.599596
> skew(bin)
[1] 0.6624718
> kurt(bin)
[1] 3.275383
>
>
> mean(poi)
[1] 0.26
> median(poi)
[1] 0
> var(poi)
[1] 0.2145455
> skew(poi)
[1] 1.397018
> kurt(poi)
[1] 3.703055
>
>
> # 4.Dla rozkładów Dwumianowego, Poissona narysuj wykresy rozkładu prawdopodobieństwa (dobierz dowolnie parametry)
>
> hist(bin)
> hist(poi)
>
>
> # 5.	Dla rozkładów Poissona i Dwumianowego wygeneruj rozkład prawdopodobieństwa dla n = 20, k = 0, …, 20 oraz p = 0.4. #Sprawdź, czy suma prawdopodobieństw wygenerowana dla tych rozkładów jest równa 1
>
> poi <- rpois(20,0.4)
> P <- ecdf(poi)
> plot(P)
>
> bin <- rbinom(20,20,0.4)
> P <- ecdf(bin)
> plot(P)
>
>
> # 6.	Wygeneruj 30 danych dla rozkładu normalnego o średniej równej 0 i odchyleniu standardowym równym 2. Wyznacz statystyki podstawowe – czy są one równe z wartościami teoretycznymi? Sprawdź, czy zwiększenie liczby danych zwiększy dokładność wyliczeń statystyk opisowych.
>
> norm <- rnorm(10, 0, 2)
> norm
 [1] -1.0128677 -0.8912117  1.2523880 -0.2495768  1.8834332 -0.3241169  0.9447989  0.5889541 -4.0469052 -0.0990004
> print('mean - 0')
[1] "mean - 0"
> mean(norm)
[1] -0.1954105
> print('median - 0')
[1] "median - 0"
> median(norm)
[1] -0.1742886
> print('variance - 4') var(norm)
BŁĄD: nieoczekiwany symbol in "print('variance - 4') var"
> print('variance - 4')
[1] "variance - 4"
> var(norm)
[1] 2.705355
> print('skewness - 0')
[1] "skewness - 0"
> skew(norm)
[1] -1.159013
> print('kurtosis - 0')
[1] "kurtosis - 0"
> kurt(norm)
[1] 4.147324
>
>
> norm <- rnorm(100, 0, 2)
>
> print('mean - 0')
[1] "mean - 0"
> mean(norm)
[1] 0.07480349
> print('median - 0')
[1] "median - 0"
> median(norm)
[1] 0.09660881
> print('variance - 4')
[1] "variance - 4"
> var(norm)
[1] 4.825696
> print('kurtosis - 0')
[1] "kurtosis - 0"
> kurt(norm)
[1] 3.351857
> print('skewness - 0')
[1] "skewness - 0"
> skew(norm)
[1] -0.3885361
>
>
> norm <- rnorm(1000, 0, 2)
>
> print('mean - 0')
[1] "mean - 0"
> mean(norm)
[1] 0.06857219
> print('median - 0')
[1] "median - 0"
> median(norm)
[1] 0.1334143
> print('variance - 4')
[1] "variance - 4"
> var(norm)
[1] 3.977514
> print('skewness - 0')
[1] "skewness - 0"
> skew(norm)
[1] -0.2148435
> print('kurtosis - 0')
[1] "kurtosis - 0"
> kurt(norm)
[1] 3.049271
>
>
> # 7.	Narysować histogram dla rozkładu normalnego o parametrach: średnia = 1, odchylenie =2, wykres dla rozkładu standardowego, oraz wykres gęstości dla średniej równej -1 oraz odchylenia równego 0.5.
>
> norm1 <- rnorm(1000, 1, 2)
> norm2 <- rnorm(1000, 0, 1)
> norm3 <- rnorm(1000, -1, 0.5)
>
> hist(norm1)
> hist(norm2)
> hist(norm3)
>


library(tidyr)
library(dplyr)
library(stringr)

as_decimal <- function(binary) {
  binary <- rev(binary)
  total <- 0
  for(j in 1:length(binary)) {
    c <- as.numeric(binary[j])
    total <-total + (c*(2^(j-1)))
  }
  return(total)
}

data <- read.csv("input.csv", header=FALSE) %>%
  mutate(row = str_sub(V1,1,7)) %>%
  mutate(column = str_sub(V1,8,11)) %>%
  mutate(row = str_replace_all(row,"F","0")) %>%
  mutate(row = str_replace_all(row,"B", "1")) %>%
  mutate(column = str_replace_all(column, "L", "0")) %>%
  mutate(column = str_replace_all(column, "R", "1")) %>%
  mutate(row = str_split(row, boundary("character"))) %>%
  mutate(column = str_split(column, boundary("character"))) %>%
  rowwise() %>%
  mutate(row_dec = as_decimal(row)) %>%
  mutate(column_dec = as_decimal(column)) %>%
  mutate(seat_id = (row_dec*8)+column_dec)
# Part 1
print(max(data$seat_id))
# Part 2
compare <- tibble(seat_id=1:max(data$seat_id))
compare <- compare[-data$seat_id,]
print(compare)


#'  This function calculates depth in meters from pressure in decibars using Saunders and Fofonoff's method
#'  \code{P} = pressure, in decibars
#'  \code{lat} = degrees latitude
#'  \code{Del} = geopotential anomaly (defaults to 0)
#'  \code{method} = valid values include"default", "seabird", and "unesco", although they all appear to be treated the same
#'  \code{DEPTH} = depth in M
#'
# DEEP-SEA RES., 1976, 23, 109-111.
#' / UNITS:
#' //   PRESSURE     P      DECIBARS
#' //   LATITUDE     LAT    DEGREES
#' //   DEPTH        DEPTH  METERS
#' //   DTN. HEIGHT  DEL    DYN. METERS (geopotenial anomaly in J/kg:: assume 0)
#' // CHECKVALUE:
#' //   1.) DEPTH = 9712.653 M for P=10000 DECIBARS, LAT=30 DEG, DEL=0
#' //   ABOVE FOR STANDARD OCEAN: T=0 DEG CELSIUS; S=35 (PSS-78)
#' // ----------------------------------------------------------
#' // Original fortran code is found in:
#' //   UNESCO technical papers in marine science 44 (1983) -
#' //   'Algorithms for computation of fundamental properties of seawater'
#'  \url{http://www.code10.info/index.php?option=com_content&view=article&id=67:calculating-the-depth-from-pressure&catid=54:cat_coding_algorithms_seawater&Itemid=79}, \url{http://www.code10.info/index.php?option=com_content&view=article&id=67:calculating-the-depth-from-pressure&catid=54:cat_coding_algorithms_seawater&Itemid=79}

      decibar2depth = function( P, lat, Del=0, method="default" ) {

        if (method %in% c("default", "seabird", "unesco" ) ) {

          X = (sin( lat * pi / 180 ))^2 # convert degree decimal to RADs

          # GR=GRAVITY VARIATION WITH LATITUDE: ANON (1970) BULLETIN GEODESIQUE
          GR = 9.780318 * (1.0 + (5.2788E-3 + 2.36E-5 * X) * X) + 1.092E-6 * P
          DepthTerm = (((-1.82E-15 * P + 2.279E-10) * P - 2.2512E-5) * P + 9.72659) * P ## assuming (35 psu, 0 C, and P=pressure in decibars )
          DEPTH = DepthTerm / GR + Del / 9.8
          return (DEPTH)
        }

        if (method %in% c("seabird", "unesco") ){

          ## NOTE this method is the same as the above ...

          # http://www.seabird.com/application_notes/AN69.htm
          #
          # Sea-Bird uses the formula in UNESCO Technical Papers in Marine Science No. 44.
          # This is an empirical formula that takes compressibility (that is, density) into account.
          # An ocean water column at 0 °C (t = 0) and 35 PSU (s = 35) is assumed.
          #
          # The gravity variation with latitude and pressure is computed as:
          #
          # g (m/sec2) = 9.780318 * [ 1.0 + ( 5.2788x10 -3  + 2.36x10 -5  * x) * x ] + 1.092x10 -6  * p
          #
          # where
          # x = [sin (latitude / 57.29578) ] ^2
          # p = pressure (decibars)
          #
          # Then, depth is calculated from pressure:
          #
          # depth (meters) = [(((-1.82x10 -15  * p + 2.279x10 -10 ) * p - 2.2512x10 -5 ) * p + 9.72659) * p] / g
          #
          # where
          # p = pressure (decibars)
          # g = gravity (m/sec2)

          # x = (sin (latitude / 57.29578) )^2
          # g = 9.780318 * [ 1.0 + ( 5.2788E-3  + 2.36E-5  * x) * x ] + 1.092E-6  * p
          # depth = ((((-1.82E-15  * p + 2.279E-10 ) * p - 2.2512E-5 ) * p + 9.72659) * p) / g

        }

      }


library(MASS) # ginv()
lenth <- function(xy, theta, x.hat=NULL, i.max=1000, threshold=10.0^(-6)) {
  norm2 <- function(v) sum(v*v)
  #
  # Pseudo-MLE.
  #
  improve <- function(x, cs, xy){
    #
    # Improves an initial estimate `x` based on bearings as represented
    # by a 2 x * matrix of cosines and sines `cs` relative to locations `xy`
    # (as a 2 by * matrix).
    #
    if (is.null(x)) {
      cs.star <- cs                                          # Starting estimate
    }
    else {
      xy.relative <- apply(xy, 2, function(v) x-v)           # vectors towards x
      d <- apply(xy.relative, 2, function(v) norm2(v)^(3/2)) # cubed distances
      cs.star <- xy.relative / d                             # direction cosines
    }
    z <- cs[2,]*xy[1,] - cs[1,]*xy[2,]
    a <- cs.star %*% t(cs) * matrix(c(-1,-1,1,1), nrow=2)    # Eq 2.6, lhs
    b <- cs.star %*% z                                       # Eq 2.6, rhs
    u <- solve(a,b)                                          # Solution
    c(u[2], u[1])
  }
  #
  # Convert bearings into direction cosines and sines.
  #
  cs <- sapply(theta, function(x) c(cos(x), sin(x)))
  #
  # Iterate until convergence.
  #
  if (is.null(x.hat)) x.hat <- improve(x.hat, cs, xy)
  repeat {
    x.new <- improve(x.hat, cs, xy)
    eps <- norm2(x.hat-x.new) / sqrt(max(apply(xy, 2, norm2)))
    lines(t(cbind(x.hat, x.new)), pch=2, col="Red")
    x.hat <- x.new
    i.max <- i.max - 1
    if (eps <= threshold) break
    if (i.max < 0) stop("Convergence failed.")
  }
  #
  # Estimate kappa.
  #
  mu.hat <- apply(x.hat - xy, 2, function(u) atan2(u[2], u[1]))
  c.bar <- mean(cos(theta - mu.hat))
  kappa.inv <- 2*(1-c.bar) + (1-c.bar)^2 * (0.48794/c.bar - 0.82905 - 1.3915*c.bar)
  kappa <- 1/kappa.inv
  #
  # Estimate the covariance matrix for x.hat.
  #
  xy.relative <- apply(xy, 2, function(v) x.hat - v)
  d <- apply(xy.relative, 2, function(v) norm2(v)^(3/2))
  cs.star <- xy.relative / d
  q.hat <- cs.star %*% t(cs)
  q.hat <- (q.hat + t(q.hat))/2
  q.hat <- q.hat * matrix(c(1,-1,-1,1), nrow=2)
  q.hat <- q.hat[2:1, 2:1]
  q.hat <- ginv(q.hat, tol=10^(-16)) * kappa.inv
  x.se <- sqrt(q.hat[1,1])
  y.se <- sqrt(q.hat[2,2])

  list(x.hat=x.hat, cov=q.hat, se=c(x.se, y.se), kappa=kappa)
}
#--------------------------------------------------------------------------------------#
set.seed(17)
#
# Target point.
#
x.0 <- c(1, 1)
#
# Observation points.
#
n <- 16
xy <- matrix(rnorm(2*n), nrow=2)
cs <- sapply(theta, function(x) c(cos(x), sin(x)))
#
# Simulate the observed bearings (in radians)
#
xy.fuzzy <- matrix(rnorm(2*n, sd=0.2), nrow=2) + x.0
theta <- apply(xy.fuzzy - xy, 2, function(u) atan2(u[2], u[1]))
#
# Obtain the MLE.
#
fit <- lenth(xy, theta)
#
# Plot all points.
#
cs <- sapply(theta, function(x) c(cos(x), sin(x)))
par(mfrow=c(1,1))
plot(t(cbind(xy, fit$x.hat, x.0)), asp=1, type="n", xlab="x", ylab="y")
    temp <- sapply(1:length(theta),
               function(i) lines(t(cbind(xy[,i], xy[,i]+9*cs[,i])), col="Gray"))
    points(t(xy))
    points(x.0[1], x.0[2], pch=19, col="Blue")
    points(t(fit$x.hat), pch=19, col="Red")
#
# Plot the 95% confidence ellipse.
#
lines(ellipse(fit$cov, centre=fit$x.hat, level=0.95), col="#AA4444")


scaledf <- function(df, meanvec = NULL, scaledata = NULL, scalefactor = 2, zeromin = FALSE) {
    ## centers and scales a dataframe
    ## df          = dataframe of parameters to be scaled
    ## meanvec     = vector of mean values for centering
    ##               default uses means of df for centering
    ## scaledata   = dataframe used to provide range of each parameter for scaling
    ##               default uses range of df for scaling
    ## scalefactor = number used to set range of scaled data (multiplies data by scalefactor / range of scaledata)
    ##               (2 results in -1 to +1 if centered and ranges of scaledata are equal distant from mean)
    ##               (1 results in  0 to +1 if zeroed   and ranges of scaledata are equal distant from mean)
    ## zeromin     = FALSE (default) results in center of scaled df at 0 if ranges of scaledata are equal distant from mean)
    ##             = TRUE results in min of scaled df at 0 if ranges of scaledata are equal distant from mean)
    ## suffix "_s" to be added to each variable to identify it is scaled

    ## center data
    if (missing(meanvec))   meanvec <- apply(df, 2, mean)  # use mean of df  to center
    # subtract meanvec from each row in df; output is a dataframe
    dfcenter <- sweep(df,       2, meanvec,    "-")

    ## scale centered data
    if (missing(scaledata)) scaledata <- df                # use range of df to scale
    ## calculate vector (1 value for each parameter in scaledata) = range of parameter / scalefactor
    scalerange <- (sapply(scaledata,max) - sapply(scaledata,min)) / scalefactor
    ## divide every row in dfcenter by scalerange
    dfs        <- sweep(dfcenter, 2, scalerange, "/")

    ## adjust location center if needed
    if (zeromin == TRUE) dfs <- sweep(dfs, 2, (scalefactor/2), "+")

    ## ## convert to dataframe and ad suffix to column names
    ## dfs <- data.frame(dfs)
    ## names(dfs) <- paste(names(dfs), "_s", sep = "")

    ## return parameters
    return( list(dfs=dfs, meanvec=meanvec, scaledata=scaledata, scalefactor=scalefactor, zeromin=zeromin) )
}
# dfs.out <- scaledf(df)$dfs
# dfs     <- dfs.out$dfs
# summary(dfs)


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 05

rm(list = ls())

observed <- c(34, 10, 20)

(k <- length(observed))
# 3

(n <- sum(observed))
# 64

proportion <- c(9, 3, 2)

(expected <- n * proportion / sum(proportion))
# 41.1428571428571 13.7142857142857 9.14285714285714

(Q <- sum((observed - expected) ^ 2 / expected))
# 15.1388888888889

(pvalue <- 1 - pchisq(Q, df = k - 1))
# 0.000515979024014124


buckets <- read.delim("~/gas-simulator/buckets.txt", sep=" ", header=F)

fn <- buckets

for(vv in buckets[1]) {
  r <- 1
  for (v in vv) {
    fn[r,2] <- fn[r,2]/(4*pi*fn[r,1]^2)*2900000 # 10 is for scale
    r <- r+1
  }
}

#
# Maxwell distribution
#

# f(v)dv = √(m/2pikT)^3*4*pi*v^2*exp(-mv^2/(2kT))*dv

# assume homogeneous buckets distribution in velocity
dv <- buckets[3,1] - buckets[2,1]
maxwell <- buckets

# physical constants
Na = 6.022e+23
R = 8.3144598
k = R/Na

# params
N = 1000000
m = 6.646476410e-27
T = 293.321

# compute maxwell distribution
for(vv in buckets[1]) {
  r <- 1
  for (v in vv) {
    maxwell[r,2] <- N*((m/(2*pi*k*T))^(3/2))*(4*pi*v^2)*exp(-m*(v^2)/(2*k*T))*dv
    r <- r+1
  }
}

sum(buckets[2])
sum(maxwell[2])

plot(buckets, type="o",
  xlab="Velocity",
  ylab="Number of particles"
)
lines(fn, type="o", col="red")
lines(maxwell, type="o", col="green")