# ......................................................................................
# ...............Exercise 13. Nonparametric tests, goodness-of-fit tests ...............
# ..................Michal Béreš, Martina Litschmannová, Adéla Vrtková..................
# ......................................................................................

# 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

#  Conformance distribution probability testing of discrete NV(finite number of values) ####
# - good agreement test
#
# - we test whether the measured data(their relative frequencies) agree with any
# specific distribution(ie its probabilities)
#
# - we test using the $\chi^2$ good match test
#
# - assumptions of the test:(ATTENTION relate to the expected frequencies - ie those
# that we would monitor if the measured data were 100% according to the distribution in
# the hypothesis)
#
# - Expected frequencies ≥ 2,
#
# - at least 80% of expected frequencies>5
#
# - test statistic(the one with $\chi^2$ distribution) is $G = \sum_{i = 1}^k (O_i -
# E_i)^2 / E_i$
#
# - distribution has degree of freedom $df = k - 1 - h$
#
# - k is the number of options
#
# - h is the number of estimated parameters(this applies to incompletely specified
# tests)
#

# example see example 1

# * Good match test for a continuous random variable(or discrete with an infinite ####
# number of values)
#
# - we have to convert to a table with a finite number of values
#
# - for discrete(eg poison) we group from a certain number of columns eg 4,5,6,... to "4
# and more"
#
# - for continuous we produce a series of intervals and see how many values fall within
# the given interval
#
# - eg:(- $\infty$, 3),<3, 4),...,<10, $\infty$)
#
# - then we have to calculate for each interval how many% of data belong to each
# interval, thus obtaining a table of expected probabilities
#
# - we continue as before
#
# - there is a pearson.test(data) function from the nortest package to test the
# normality of the distribution
#

# example 2,3,4

#  PivotTables ####
#
# - tables containing data depending on two factors
#
# - one of the factors is, as a rule, an independent variable in which we monitor
# whether it affects the other factor(dependent variable)
#
# - The independent variable is usually in rows
#
# - is usually dependent in columns
#
# - beware the whole test examines the correlation, not the causality! Causality can be
# assessed by "expert" evaluation
#
# - statistical conclusion: there is a statistically significant dependence between the
# independent and dependent variable(correlation)
#
# - expert assessment: an independent variable statistically significantly affects the
# dependent variable(causality)
#

# * PivotTable Visualization ####
#
# - visualization eg using the barplot function
#
# - pay attention to what rows and columns are, we always want individual divided
# columns to be via independent variables(each column for one value of an independent
# variable)
#
# - beside=T determines whether we want to merge adjacent columns into one split column
# or not
#
# - preferred visualization using mosaicplot
#
# - the same as for barlot, the connected columns must be via independent variables
#

# examples in Examples 5,6,7

# * Dependency table dependencies ####
#
# - Correlation coefficient CC
#
# - Corrected correlation coefficient CCcor
#
# - Cramer's coefficient V
#
# - we will use this first
#
# - cramersV(cont.tab) function from lsr package
#

# Examples in Examples 5,6,7

# * PivotTable Dependency Test ####
#
# - $H_0:$ there is no dependency between an independent(eg is a smoker) and a
# dependent(eg suffering from a disease) variable
#
# - $H_A: \neg H_0$
#
# - chisq.test function(cont.tab)
#
# - assumptions: Expected frequencies ≥ 2, at least 80% of expected frequencies>5
#
# - expected frequencies can be found from chisq.test(cont.tab) \ $ expected
#

#  Association tables ####
#
# - this is a special PivotTable case
#
# - always has exactly 2 options for the dependent and exactly 2 options for the
# independent variable
#

# * Mandatory form of the association table ####
#
# - Lines indicate independent variable options
#
# - the first line is the so-called exposed part of the population(the one exposed to
# the phenomenon we study - eg smokers try to study the effects of smoking)
#
# - the second line is the unexposed part of the population
#
# - The columns indicate the options of the dependent variable
#
# - the first column indicates the occurrence of the phenomenon under investigation(eg
# occurrence of the disease, product error,...)
#
# - the second column indicates the remainder - no occurrence of the investigated
# phenomenon
#

# * Relative risk and odds ratio ####
#
# - Relative risk and odds ratio provide the same information, only in a different
# format
#
# - all point IOs are calculated using the function epi.2by2(associ.tab) from the
# package epiR
#
# - the function takes the association table as input, which must be in the correct
# format!
#

# ** Relative risk ####
#
# - denotes $RR$
#
# - this is the risk ratio(probability of occurrence of the investigated phenomenon) in
# exposed and unexposed populations
#
# - if it is equal to 1, it means the same probabilities of occurrence in exposed and
# unexposed
#
# - if it is greater than 1 then the exposed population is more likely to occur
#
# - if less than 1 then the exposed population is less likely to occur
#
# - point estimate $\hat{RR}$ is calculated as the ratio rel. frequency of the studied
# phenomenon in exposed and unexposed populations
#
# - epi.2by2 provides interval estimates
#
# - if the IO does not contain the value 1 then there is a statistically significant
# dependence between the dependent and independent variable
#

# ** Odds ratio ####
#
# - we denote $OR$
#
# - this is the ratio of chances(chance of occurrence of the studied phenomenon) in
# exposed and unexposed populations
#
# - if it is equal to 1, it means the same chances of occurrence in exposed and
# unexposed
#
# - if it is greater than 1 then the exposed population has a greater chance of
# occurrence
#
# - if less than 1 then the exposed population has a lower chance of occurrence
#
# - point estimate $\hat{OR}$ is calculated as the ratio of chances(selective) of the
# studied phenomenon in exposed and unexposed population
#
# - epi.2by2 provides interval estimates
#
# - if the IO does not contain the value 1 then there is a statistically significant
# dependence between the dependent and independent variable
#

# example in example 7

#  Examples(good match tests) ####
#
# * Example 1. ####
#
# The dice were rolled 6,000 times and the number of falling meshes was recorded.
# [image.png](attachment:64f1169e-6bc1-470a-8afb-b282230c2c9f.png)
#

# H0: The cube is fair.(so all probabilities are 1/6)
# Ha: The cube is not fair.(H0 negation)

x = c(1,2,3,4,5,6)
n.obs = c(979,1002,1015,980,1040,984)
p.exp = c(1/6,1/6,1/6,1/6,1/6,1/6)
n.exp = 6000*p.exp
n.exp # test assumptions must be checked
# All expected frequencies are greater than 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1 - pchisq(x.obs,5)
p.hodnota

# At the significance level of 0.05 we do not reject HO(p-value=0.711,
# Chi-square test of independence, df=5).

# * Example 2. ####
#
# The manufacturing company estimates the number of failures of a particular device in
# 100 hours using a Poisson distribution with parameter 1.2. Employees recorded the
# actual number of failures at a total of 150 100-hour intervals for inspection(results
# are shown in the table). Verify with a clean significance test that the number of
# failures of a given device within 100 hours actually has a Poisson distribution with
# the parameter λt=1.2.
#

# Fully specified test

# H0: The number of faults during 100 operating hours can be modeled
# Poisson distribution with parameter 1.2.
# Ha: The number of faults during 100 operating hours cannot be modeled
# Poisson distribution with parameter 1.2.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

p.exp = dpois(x,1.2)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # test assumptions must be checked
# 4 of the 5 expected frequencies, ie 80%, are greater than 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,4)
p.hodnota

# At the significance level of 0.05 we do not reject HO(p-value=0.590,
# Chi-square test of independence, df=4).

# * Example 3. ####
#
# Employees recorded a total of 150 100-hour breakdowns at check(results are shown in
# the table). Use a clean significance test to see if the number of failures in a given
# device has a true Poisson distribution in 100 hours. </br>
#  ![Image.png](attachment:4da89057-87d1-4bcd-a488-3365237654f7.png)
#

# Incompletely specified test

# H0: The number of faults during 100 operating hours can be modeled
# Poisson distribution.
# Ha: The number of faults during 100 operating hours cannot be modeled
# Poisson distribution.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

lambda.t = weighted.mean(x,n.obs)   # Poisson distribution parameter estimate
lambda.t

p.exp = dpois(x,lambda.t)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # test assumptions must be checked
# 4 out of 5 expected frequencies, ie 80%, are greater than 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,3)
p.hodnota

# At the significance level of 0.05 we do not reject HO(p-value=0.491,
# Chi-square test of independence, df=3).

# * Example 4. ####
#
# Time intervals(s) between the passages of individual vehicles were measured on the
# motorway within a few minutes. The detected values of these distances are recorded in
# the file dalnice.xlsx. Verify that this is data from a normal distribution(use a good
# match test).
#

# automatic test of good agreement from continuous data

dalnice = readxl::read_excel("data/neparametricke_hypotezy.xlsx", sheet=2)
colnames(dalnice)="hodnoty"
head(dalnice)

mu = mean(dalnice$hodnoty)
sigma = sd(dalnice$hodnoty)
mu
sigma

# Generate values for the x-axis
xfit=seq(from = -20, to = 30, length = 100)
# Generate values for the y-axis
yfit=dnorm(xfit, mean = mu, sd = sigma)

hist(dalnice$hodnoty, freq = FALSE, xlim = c(-20, 30))
# Add a curve to the last graph based on the values generated above
lines(xfit, yfit, col="black", lwd=2)

# install.packages("nortest")

# H0: Spacing between vehicles can be modeled by normal distribution.
# Ha: Spacing between vehicles cannot be modeled by normal distribution.

nortest::pearson.test(dalnice$hodnoty)

# Specify the number of degrees of freedom
pom = nortest::pearson.test(dalnice$hodnoty, n.classes = 5)
attributes(pom)

pom$method
pom$n.classes
pom$df
pom$p.value

# HO can be rejected at the significance level of 0.05(p-value<<0.001,
# Chi-square test of good agreement, df=12).

# test what you already know
shapiro.test(dalnice$hodnoty)

#  Examples of PivotTable and Association Tables ####
#
# * Example 5. ####
#
# Decide on the basis of the data file experimentovani-s-telem.xls(Dudová, J. -
# Experimentování s tělem(survey results), 2013. Available online at
# http://experimentovani-stelem.vyplnto.cz), whether there is a connection between
# gender of respondents and whether they have tattoos. Use Cramer V to assess the
# contingency rate.
#

tet = readxl::read_excel("data/neparametricke_hypotezy.xlsx", sheet=3)
head(tet)

tet = tet[,c(6,10)]
colnames(tet) = c("pohlavi","tetovani")
head(tet)

# Preprocessing
# Variants of cat. Variables(factors) must be arranged and named so
# how they should be arranged and named in the accounts. table

kont.tab = table(tet$pohlavi, tet$tetovani)
kont.tab

colnames(kont.tab) = c("má tetování","nemá tetování")
kont.tab

# Exploratory analysis
prop.table(kont.tab)    # associated relative frequencies
prop.table(kont.tab,1)  # line relative frequencies
prop.table(kont.tab,2)  # columnar relative frequencies

# Visualization in standard R
# Cluster bar graph
# compare graphs, which of the graphs is more suitable for the presentation of the data

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

barplot(t(kont.tab),
        legend = colnames(kont.tab),
        beside = T)

barplot(kont.tab,
        legend = rownames(kont.tab),
        beside = T)

# Stacked bar graph

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

barplot(t(kont.tab),
        legend = colnames(kont.tab))

barplot(kont.tab,
        legend = rownames(kont.tab))

# Mosaic chart

options(repr.plot.width = 8) # width of graphs in Jupyter

mosaicplot(t(kont.tab),
           las = 1, # Rotate y-axis labels
           color = gray.colors(2))

# compare which of the graphs is more suitable for the presentation of the given data
mosaicplot(kont.tab,
           las = 1,
           color = gray.colors(2))

# install.packages("lsr")

# Cramer V calculation ####
lsr::cramersV(kont.tab)

# PivotTable independence test

# H0: Data is independent ->whether the individual is male or female
# Does not affect his likelihood of having a tattoo
# HA: negation H0(there is a dependency)

pom = chisq.test(kont.tab)
attributes(pom)

pom$expected # Necessary for verification of assumptions
# All expected frequencies are greater than 5.

pom

# HO can be rejected at the significance level of 0.05(p-value=0.003,
# Chi-square goodness-of-fit test, df=1).
# The observed dependence can be assessed as weak(Cramer's V=0.121).

# * Example 6. ####
#
# For a differentiated approach in personnel policy, the company's management needs to
# know whether job satisfaction depends on whether it is a Prague plant or non-Prague
# plants. The results of the survey are in the following table. Display the data using a
# mosaic chart and, based on the independence test in the combination table, decide on
# the dependence of job satisfaction on the company's location. To assess the
# contingency rate, use Cramer V. </br>
#  ![Image.png](attachment:ebc6062c-1020-4fab-8855-6665d65d59a7.png)
#

# We do not have a data matrix, ie cont. we must enter the table "manually"
kont.tab = matrix(c(10,25,50,15,20,10,130,40),
                  nrow=2,byrow=T)
rownames(kont.tab) = c("Praha","Venkov")
colnames(kont.tab) = c("velmi nespokojen","spíše nespokojen",
                       "spíše spokojen","velmi spokojen")
kont.tab = as.table(kont.tab)
kont.tab

# Exploratory Analysis ####
prop.table(kont.tab)  # associated relative frequencies
prop.table(kont.tab,1)  # line relative frequencies
prop.table(kont.tab,2)  # columnar relative frequencies

# Visualization in standard R
# Mosaic chart
mosaicplot(kont.tab,
           las = 1, # Rotate yo axis labels 90
           color = gray.colors(4))

# Cramer V
lsr::cramersV(kont.tab)

# H0: There is no connection between job satisfaction and company location.
# Ha: There is a connection between job satisfaction and the location of the company.

# Chi-square PivotTable Independence Test ####
pom = chisq.test(kont.tab)
pom$expected
# All expected frequencies are greater than 5.

pom

# HO can be rejected at the significance level of 0.05(p-value<<0.001,
# Chi-square test of good agreement, df=3).
# The observed dependence can be assessed as moderate(Cramer's V=0.296)

# * Example 7.(Association table) ####
#
# Between 1965 and 1968, a cohort study of cardiovascular disease under the Honolulu
# Heart Program began monitoring 8,006 men, of whom 7,872 did not have a history of
# stroke at the start of the study. Of this number, there were 3,435 smokers and 4,437
# non-smokers. When followed for 12 years, 171 men in the group of smokers and 117 men
# in the group of non-smokers suffered a stroke.
#
# *** a) ####
#
# Record the results in the association table.
#

kont.tab = matrix(c(171,3264,117,4320),nrow=2,byrow=T)
rownames(kont.tab) = c("kuřák","nekuřák")
colnames(kont.tab) = c("ano","ne")
kont.tab

# completion of the table of absolute frequencies
kont.tab.full = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.full) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.full) = c("ano", "ne", "sum")

kont.tab.full[1:2, 1:2] = kont.tab
kont.tab.full[1:2, 3] = rowSums(kont.tab)
kont.tab.full[3, 1:2] = colSums(kont.tab)
kont.tab.full[3, 3] = sum(kont.tab)
kont.tab.full

# addition of the table of relative frequencies
kont.tab.rel = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.rel) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.rel) = c("ano", "ne", "sum")

kont.tab.rel[1:2, 1:2] = prop.table(kont.tab)
kont.tab.rel[1:2, 3] = rowSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 1:2] = colSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 3] = sum(kont.tab.rel[1:2, 1:2])
kont.tab.rel

# *** b) ####
#
# Based on visual assessment, estimate the effect of smoking on the incidence of
# cardiovascular disease.
#

# Visualization by mosaic graph in basic R
mosaicplot(kont.tab,
           color = gray.colors(2))

# Cramer V calculation ####
lsr::cramersV(kont.tab)

# According to the mosaic graph and Cramer's V(0.061) there is a connection between smoking
# and the occurrence of apoplexy evaluated as very weak.

# *** c) ####
#
# Determine the absolute risk of cardiovascular disease in smokers and non-smokers.
#

# risk=probability
kont.tab.full

# Smokers
# Assumptions check
p = 171/3435
p

9/(p*(1-p))
# OK(3,435>190.3)

# Calculation of point and 95% Clopper-Pearson interval estimation
prop.test(x = 171, n = 3435)

# The smoker has an apoplexy risk of about 5.0%. 95% Clopper-Pearson
# the interval estimate of this risk is 4.2% to 5.8%.

# Non-smokers
# Assumption check
p = 117/4437
p

9/p/(1-p)
# OK(4,437>350.6)

# Calculation of point and 95% Clopper-Pearson interval estimation
prop.test(117,4437)

# In non-smokers, the risk of apoplexy is about 2.6%. 95% Clopper-Pearson
# the interval estimate for this risk is 2.1% to 3.2%.

# *** d) ####
#
# Determine the relative risk(including 95% of the interval estimate) of cardiovascular
# disease in smokers and non-smokers. Explain the practical significance of the results
# obtained.
#

# install.packages("epiR")

kont.tab

epiR::epi.2by2(kont.tab)

# Smokers have about 1.89 times higher risk of apoplexy than non-smokers. 95%
# the interval estimate for this relative risk is 1.50 to 2.38.
# According to the interval estimate of relative risk, it is clear that at the surface
# significance 0.05 is a statistically significantly higher risk for smokers
# apoplexy than in non-smokers.

# *** e) ####
#
# Determine the absolute chances of cardiovascular disease in smokers and non-smokers.
#

# In a smoker, the chance of apoplexy is about 52: 1,000. at 1,052 smokers
# about 52 occurrences of apoplexy can be expected.
# In non-smokers, the chance of developing apoplexy is about 27: 1,000. for 1,027 non-smokers
# approximately 27 occurrences of apoplexy can be expected.

# *** f) Determine the relative chances of cardiovascular disease in smokers. ####
#

# Smokers have about 1.93(=0.0524/0.0271) times higher chance of apoplexy
# than for non-smokers. 95% interval estimate of this ratio
# the odds are 1.52 to 2.46.
# According to the interval estimate of the odds ratio, it is clear that on the surface
# Significance 0.05 is for smokers
# statistically significantly higher chance of developing apoplexy than in non-smokers.

# *** g) ####
#
# Decide at a significance level of 0.05 on the dependence of the incidence of
# cardiovascular disease on smoking.
#

# Attention! The epi.2by2 command does not output the expected frequency for
# Chi-square test of independence.
# It is not possible to verify the test assumptions!

# H0: There is no link between smoking and the occurrence of apoplexy.
# Ha: There is a link between smoking and the occurrence of apoplexy.

pom = chisq.test(kont.tab)
pom$expected
# All expected frequencies are greater than 5.

pom

lsr::cramersV(kont.tab)

# At the significance level of 0.05, HO can be rejected(p-value<<0.001,
# Chi-square goodness-of-fit test,
# df=1). The observed dependence can be assessed as very weak
# Cramer's V=0.061).


horner <- function(a, x) {
  y <- 0
  for(c in rev(a)) {
    y <- y * x + c
  }
  y
}

cat(horner(c(-19, 7, -4, 6), 3), "\n")


 C02AGJ Example Program Results

 Example 1

 Degree of polynomial =    5

 Computed roots of polynomial

 z =  -1.4918E+00
 z =   5.5169E-01 +/-   1.2533E+00*i
 z =  -8.0579E-01 +/-   1.2229E+00*i

 Example 2

 Degree of polynomial =    5

 Computed roots of polynomial     Error estimates
                                (machine-dependent)

 z =  -1.4918E+00 +0.0000E+00*i       7.4E-16
 z =   5.5169E-01 +1.2533E+00*i       1.1E-16
 z =   5.5169E-01 -1.2533E+00*i       1.1E-16
 z =  -8.0579E-01 +1.2229E+00*i       3.0E-16
 z =  -8.0579E-01 -1.2229E+00*i       3.0E-16


# 4. faza: Analiza podatkov

# Po desetletjih ###############################################################

povprecne_starosti_tabela <- izvajalci_ostalo %>%
  mutate(Desetletje=(Leto%/%10*10)) %>%
  group_by(Desetletje) %>%
  summarise_at(vars(-c(Leto,
                       Izvajalec,
                       Ustanovitev,
                       Izvor,
                       Spol,
                       Festival,
                       Lokacija,
                       Grofija)),
                    funs(mean(., na.rm=TRUE)))

model <- lm(Starost ~ Desetletje, data = povprecne_starosti_tabela)
novo_desetletje <- data.frame(Desetletje = 2020)
predict(model, novo_desetletje)
napoved <- novo_desetletje %>% mutate(Starost = predict(model, .))

povprecne_starosti <- ggplot(povprecne_starosti_tabela,
                             aes(x = Desetletje, y = Starost)) +
  geom_point(color = 'darkgreen',
             size = 2) +
  geom_smooth(method = lm, formula=y~x, fullrange=TRUE) +
  geom_point(data=napoved, aes(x = Desetletje, y = Starost),
             color = 'red',
             size = 5) +
  labs(title = "Povprečna starost izvajalcev - po desetletjih")

# Po letih #####################################################################

povprecne_starosti_tabela_leta <- izvajalci_ostalo %>%
  group_by(Leto) %>%
  summarise_at(vars(-c(Izvajalec,
                       Ustanovitev,
                       Izvor,
                       Spol,
                       Festival,
                       Lokacija,
                       Grofija)),
               funs(mean(., na.rm=TRUE)))

model_leta <- lm(Starost ~ Leto, data = povprecne_starosti_tabela_leta)
nova_leta <- data.frame(Leto = c(2018:2029))
predict(model_leta, nova_leta)
napoved_leta <- nova_leta %>% mutate(Starost = predict(model_leta, .))

povprecne_starosti_leta <- ggplot(povprecne_starosti_tabela_leta,
                             aes(x = Leto, y = Starost)) +
  geom_point(color = 'darkgreen',
             size = 2) +
  geom_smooth(method = lm, formula=y~x, fullrange=TRUE) +
  geom_point(data=napoved_leta, aes(x = Leto, y = Starost),
             color = 'red',
             size = 2) +
  labs(title = "Povprečna starost izvajalcev - po letih")


#Q5. The number 512 is interesting because it is equal to the sum of its digits raised to some power: 5 + 1 + 2 = 8, and 83 = 512. Another example of a number with this property is 614656 = 284.
#We shall define an to be the nth term of this sequence and insist that a number must contain at least two digits to have a sum.
#You are given that a2 = 512 and a10 = 614656.
#Find a30.

List<BigInteger> a = new List<BigInteger>();

for (int b = 2; b < 400; b++) {
    BigInteger value = b;
    for (int e = 2; e < 50; e++) {
        value *= b;

        if (DigitSum(value) == b) {
            a.Add(value);
        }
        if (a.Count > 50) break;
    }
    if (a.Count > 50) break;
}


t=9
v=16
r=3
sw2=2.847
qvalue=qtukey(1-0.05,t,v)
W=qvalue*sqrt(sw2/r)
W
 # any pair of treatment means having a difference between corresponding
#sample means exceeding 4.9 would be declared significantly different


arithmeticMean <- function(a, b) { (a + b)/2 }
geometricMean <- function(a, b) { sqrt(a * b) }

arithmeticGeometricMean <- function(a, b) {
  rel_error <- abs(a - b) / pmax(a, b)
  if (all(rel_error < .Machine$double.eps, na.rm=TRUE)) {
    agm <- a
    return(data.frame(agm, rel_error));
  }
  Recall(arithmeticMean(a, b), geometricMean(a, b))
}

agm <- arithmeticGeometricMean(1, 1/sqrt(2))
print(format(agm, digits=16))


divisors <- function (n) {
  Filter( function (m) 0 == n %% m, 1:(n/2) )
}

table = sapply(1:19999, function (n) sum(divisors(n)) )

for (n in 1:19999) {
  m = table[n]
  if ((m > n) && (m < 20000) && (n == table[m]))
    cat(n, " ", m, "\n")
}


# NOTE: This is the first thing I've ever written in R!
# I had to learn R to solve this programming problem during the competition.
# I'm very proud of this code.

f <- file("stdin")
on.exit(close(f))

T <- readLines(f)
T <- strsplit(T, " ")

testcases <- as.numeric(T[[1]])

for(q in 1:testcases) {
    testcase_input = T[[q+1]]
    A = as.numeric(testcase_input[[1]])
    B = as.numeric(testcase_input[[2]])
    V = as.numeric(testcase_input[[3]])

    constants = pi/(4*A**2)
    f_of_y = function(x){
        return((4*A*log(x) + 2*B**2 - 2*B*sqrt(4*A*log(x)+B**2)))
    }

    goal = V
    accuracy = .2
    test_inp = 1
    test_result = integrate(f_of_y, 1, test_inp)[[1]]

    step_sizes = list(.01, .05, .1, .2, 1, 5, 10)
    step_pos = length(step_sizes)
    last_val = -1

    while (!((goal-accuracy) <=  test_result && test_result <= (goal+accuracy))) {
        poss_new_val = integrate(f_of_y, 1, test_inp+step_sizes[[step_pos]])[[1]]*constants
        #print(step_pos)
        #print(poss_new_val)
        if (poss_new_val > goal+accuracy){
            if(step_pos != 1){
                step_pos = step_pos - 1
                next
            }
        } else {
            test_inp = step_sizes[[step_pos]] + test_inp
            test_result = poss_new_val
        }
        #print("last")
        #print(last_val)
        #print("test")
        #print(test_result)
        # Check if the code is getting stuck in a loop
        # If it is, break, since the actual value is nearby
        if(last_val == test_result){
            break
        }
        last_val = test_result
    }

    # Test to see if there's a better fit nearby
    ret = test_inp
    min_err = abs(V - test_result)

    # Make sure the range of the inputs fit the range of the problem/function
    left_bound = max(1, test_inp-.5)
    for(i in seq(left_bound, test_inp+.5, .01)){
        res = integrate(f_of_y, 1, i)[[1]]*constants
        err = abs(V-res)
        if(err < min_err){
            min_err = err
            ret = i
        }
    }

    ret = format(round(ret, 2), nsmall = 2)
    write(ret, stdout())
}


###########################################################################
#       Pricing European Put Options Through Simulated Levy Processes
#       Research proposed by Liming Feng, Zisheng Chen, and Xiong Lin
#               University of Illinois, Urbana-Champaign
#
# Created by Joseph Loss on 12/17/2018
# Co-developers: Yuchen Duan (UIUC MSFE) and Daniel Liberman (UIC Finance)
#
# Algorithm 1: Simulating a Normal Inverse Gaussian process through a Brownian subordination
#
###########################################################################
# set.seed(2017)
library(tictoc)

no_of_simulations.1 <-  256 * 10 ^ 3
no_of_simulations.2 <- (256 * 4) * 10 ^ 3
no_of_simulations.3 <- (256 * 8) * 10 ^ 3
no_of_simulations.4 <- (256 * 16) * 10 ^ 3
no_of_simulations.5 <- (256 * 32) * 10 ^ 3
no_of_simulations.6 <- (256 * 64) * 10 ^ 3

no_of_simulations.list <- c(no_of_simulations.1, no_of_simulations.2,
                            no_of_simulations.3, no_of_simulations.4,
                            no_of_simulations.5, no_of_simulations.6)

for (i in 1:6)
{
  # Input Parameters --------------------------------------------------------
  # taken from Feng et al, pg.22-23
  alpha = 15;
  beta = -5;
  delta = 0.5;
  r = 0.05;
  q = 0.02;
  s0 = 100;
  K = s0;
  T = 0.5;
  N = 1.0;

  # no_of_simulations = no_of_simulations.list[i];       # run through difference total no_of_simulations back-to-back
  no_of_simulations = no_of_simulations.3;       # change number of iterations here

  # calculate mu using the formula given at the top of pg. 19
  mu = r - q + delta*(sqrt(alpha^2 - (beta+1)^2) - sqrt(alpha^2 - beta^2));

  # calculate gamma using the formula given in the Algorithm 1 pseudocode
  gamma = sqrt(alpha^2 - beta^2)

  stock_prc <- rep(0, no_of_simulations)       # create array of possible stock_prices (1 for each iteration)
  put_prc <- rep(0, no_of_simulations)         # create array of possible put_prices (1 for each iteration)
  call_prc <- rep(0, no_of_simulations)        # create array of possible call_prices (1 for each iteration)
  euro_vanilla_put <- rep(0, no_of_simulations)
  nigv <- rep(0, no_of_simulations)            # create NIG random vector

  # Box-Muller Function Template --------------------------------------------
  BoxMuller <- function()
  {
    n = 2 * N
    z = numeric(n)

    u1 = runif(n / 2, 0, 1)
    u2 = runif(n / 2, 0, 1)

    z1 = sqrt(-2 * log(u1)) * cos(2 * pi * u2)      # half of normal variates
    z2 = sqrt(-2 * log(u1)) * sin(2 * pi * u2)      # other half
    z[seq(1, n, by = 2)] = z1                   # interleave
    z[seq(2, n, by = 2)] = z2                   # two halves

    return(z1)                                # return half
  }

  # Algorithm 1: Normal Inverse Gaussian, Monte-Carlo Simulation --------------------------------------------
  for (j in 1:no_of_simulations)
  {
    # Step 1: Generate G1 and compute zeta --------------------------------------------------
    G1 <- BoxMuller()           # generate standard normal random variable G1
    Z <- (G1^2)/gamma              # compute Z

    zeta <- rep(0, N)
    for (i in 1:N)
    {
      zeta[i] = (1/gamma)*((delta*T) + (0.5*Z[i]) - sqrt((delta*T*Z[i]) + (Z[i]^2)/4))
    }

    # Step 2: Generate uniform random variable U on (0,1) -----------------------------------
    Uniform <- function()       # function to generate uniform r.v. using Algorithm 1, Step 2, on pg. 17
    {
      U = runif(N, 0, 1)
      zt <- rep(0, N)
      for (i in 1:N)
      {
        if (U[i] < (delta*T) / ((delta*T) + gamma * zeta[i])) {
          zt[i] = zeta[i]
        } else  {
          zt[i] = (delta ^ 2 * T^2) / (gamma ^ 2 * zeta[i])
        }
      }
      return(zt)
    }

    zt = Uniform()          # generate zt using uniform function above

    # Step 3: Generate StdNorm variable G2 -------------------------------------------------
    G2 <- rnorm(1,0,1)

    St <- rep(0, N)        # create empty vector for St
    Xt <- rep(0, N)        # create empty vector for Xt

    for (i in 1:N)
    {
      Xt[i] = mu * T + beta * zt[i] + sqrt(zt[i]) * G2[i]     # compute Xt = mu*t + beta*zt + sqrt(zt)*G2
      St[i] = s0 * exp(Xt[i])                         # from pg 16. compute St = S0 * e^(Xt)
    }

    stock_prc[j] = St[N]                                  # reassign variable, ie St = ST (stock value at maturity)
    put_prc[j] = exp(-r*T) * max(0, K - stock_prc[j])     # compute put price at maturity
    call_prc[j] = exp(-r*T) * max(0, stock_prc[j] - K)    # compute call price at maturity
    nigv[j] = Xt[N]

    # Section 5.4, pg.19: European Vanilla Options -------------------------------------------
    # We also calculate the option value "V" using the formula given in Section 5.4.

    # note that the resulting output is identical
    # to the result we generated through St = S0 * e^(Xt) above.
    euro_vanilla_put[j] = s0 * exp(-r * T) * max(0, K/s0 - exp(log(stock_prc[j] / s0)))

  }
  # END MonteCarlo Simulation --------------------------------------------------------------
  # ----------------------------------------------------------------------------------------
}

  # Average the computed prices: -----------------------------------------------------------
  "NIG Stock Price (t=T)"
  sum(stock_prc) / no_of_simulations

  NIG_Put_Value <- sum(euro_vanilla_put) / no_of_simulations
  "NIG Put Value: "
  NIG_Put_Value

  # NIG_Put_Prc <- sum(put_prc) / no_of_simulations
  # "NIG Put Value: "
  # NIG_Put_Prc
  # euro_vanilla_put.value <- sum(euro_vanilla_put) / no_of_simulations
  # "European Vanilla Put Value: "
  # euro_vanilla_put.value

  # values.table <- cbind(NIG_Put_Prc, euro_vanilla_put.value)
  # values.table

  toc(log = TRUE)
  tic.clearlog()
  tic.clear()

# Model Benchmarking & Verification ------------------------------------------------------------------
# NIG Verification --------------------------------------------------------
library(GeneralizedHyperbolic)      # testing our NIG model with GeneralizedHyperbolic built-in "rnig"

GenHyp.NIG <- rnig(no_of_simulations, delta=delta, alpha=alpha, beta=beta)+mu
algo1.NIG <- nigv

par(mfrow=c(1,2))       # Plot NIG distributions

# GeneralizedHyperbolic NIG Histogram
GenHyp.NIG.hist <-
  hist(GenHyp.NIG,
       breaks = 40,
       col = "grey",
       main = "GeneralizedHyperbolic NIG")
xfit <- seq(min(GenHyp.NIG), max(GenHyp.NIG), length = 40)
yfit <- dnorm(xfit, mean = mean(GenHyp.NIG), sd = sd(GenHyp.NIG))
yfit <- yfit * diff(GenHyp.NIG.hist$mids[1:2]) * length(GenHyp.NIG)
lines(xfit, yfit, col = "blue", lwd = 3)

# Algorithm 1 NIG Histogram
algo1.NIG.hist <-
  hist(algo1.NIG,
       breaks = 40,
       col = "grey",
       main = "Algorithm 1 NIG")
xfit <- seq(min(algo1.NIG), max(algo1.NIG), length = 40)
yfit <- dnorm(xfit, mean = mean(algo1.NIG), sd = sd(algo1.NIG))
yfit <- yfit * diff(algo1.NIG.hist$mids[1:2]) * length(algo1.NIG)
lines(xfit, yfit, col = "blue", lwd = 3)

# NIG Mean Comparison
GenHyp.NIG.mu <- (mean(rnig(no_of_simulations, delta=delta, alpha=alpha, beta=beta)+mu))
GenHyp.NIG.mu
algo1.NIG.mu = mean(nigv)                            # our NIG
algo1.NIG.mu

nig_comparison_table <- cbind(algo1.NIG.mu, GenHyp.NIG.mu)
nig_comparison_table

(algo1.NIG.mu - GenHyp.NIG.mu)/GenHyp.NIG.mu         # computed difference in model means

nig_comparison_table

# RQuantLib::EuropeanOption('put',s0,K,q,r,T,0.191)


N0 <- 100
y0 <- 10

library(rstan)
rstan_options(auto_write = TRUE)

options(mc.cores = 4)
rstan:::rstudio_stanc("stan/simple_bernoulli_prior.stan")

#### Sampling from the "prior"
compiled.model.prior <- stan_model("stan/simple_bernoulli_prior.stan")

cc <- 1/2
dd <- 1/2
bb.data <- list(
  N0 = N0,
  y0 = y0,
  c = cc,
  d = dd,
  a_0 = .4
)

prior.bern <- sampling(compiled.model.prior, data = bb.data)
prior.bern

pairs(prior.bern)

log.c_a0 <- bridgesampling::bridge_sampler(prior.bern)

get_c_a0_bernoulli <- function(y0, n0, cc, dd, a_0){
  ans <- lbeta(a_0 * y0 + cc, a_0 *(n0 -y0) + dd)
  return(ans)
}

get_c_a0_bernoulli(
  y0 = bb.data$y0,
  n0 = bb.data$N0,
  cc = bb.data$c,
  dd = bb.data$d,
  a_0 = bb.data$a_0
)
log.c_a0

anaughts <- seq(0, 2, length.out = 100)
c_a0 <- function(x) {
  get_c_a0_bernoulli(
      y0 = bb.data$y0,
      n0 = bb.data$N0,
      cc = bb.data$c,
      dd = bb.data$d,
      a_0 = x
    )
}
MaLs <- sapply(anaughts, c_a0)

plot(anaughts, MaLs, xlab = expression(a[0]), main = "Bernoulli",
     ylab = expression(log(c(a[0]))), type = "l")

plot(anaughts, exp(MaLs), xlab = expression(a[0]),
     ylab = "Marginal likelihood", type = "l")

#####################
####### Posterior using unnormalised power prior
#####################

## New data
### will draw from the same process for simplicity
N <- 1000
y <- 200

compiled.model.unnorm.posterior <- stan_model("stan/simple_bernoulli_posterior_unnormalised.stan")

delta <- 1
nu <- 1
bb.data.forposterior <- list(
  N0 = N0,
  y0 = y0,
  c = cc,
  d = dd,
  delta = delta,
  nu = nu,
  N = N,
  y = y
)

unnorm.posterior.bern <- sampling(compiled.model.unnorm.posterior, data = bb.data.forposterior)
unnorm.posterior.bern
pairs(unnorm.posterior.bern, pars = c("a_0", "theta"))

### Now the normalised prior

compiled.model.norm.posterior <- stan_model("stan/simple_bernoulli_posterior_normalised.stan")

norm.posterior.bern <- sampling(compiled.model.norm.posterior, data = bb.data.forposterior)
norm.posterior.bern
pairs(norm.posterior.bern, pars = c("a_0", "theta", "lp__"))

##### Analysis of p(a_0 | data)
a0.unnorm <- extract(unnorm.posterior.bern, 'a_0')$a_0
a0.norm <- extract(norm.posterior.bern, 'a_0')$a_0

a0.dt <- data.frame(a0 = c(a0.unnorm, a0.norm),
                    normalisation = c( rep("unnormalised", length(a0.unnorm)),
                                       rep("normalised", length(a0.norm)) )
)

library(ggplot2)
ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density() +
  stat_function(fun = function(x) dbeta(x, delta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  ggtitle("Bernoulli") +
  facet_grid(normalisation~., scales = "free") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw()


closest_pair_brute <-function(x,y,plotxy=F) {
    xy = cbind(x,y)
    cp = bruteforce(xy)
    cat("\n\nShortest path found = \n From:\t\t(",cp[1],',',cp[2],")\n To:\t\t(",cp[3],',',cp[4],")\n Distance:\t",cp[5],"\n\n",sep="")
    if(plotxy) {
        plot(x,y,pch=19,col='black',main="Closest Pair", asp=1)
        points(cp[1],cp[2],pch=19,col='red')
        points(cp[3],cp[4],pch=19,col='red')
    }
    distance <- function(p1,p2) {
        x1 = (p1[1])
        y1 = (p1[2])
        x2 = (p2[1])
        y2 = (p2[2])
        sqrt((x2-x1)^2 + (y2-y1)^2)
    }
    bf_iter <- function(m,p,idx=NA,d=NA,n=1) {
        dd = distance(p,m[n,])
        if((is.na(d) || dd<=d) && p!=m[n,]){d = dd; idx=n;}
        if(n == length(m[,1])) { c(m[idx,],d) }
        else bf_iter(m,p,idx,d,n+1)
    }
    bruteforce <- function(pmatrix,n=1,pd=c(NA,NA,NA,NA,NA)) {
        p = pmatrix[n,]
        ppd = c(p,bf_iter(pmatrix,p))
        if(ppd[5]<pd[5] || is.na(pd[5])) pd = ppd
        if(n==length(pmatrix[,1]))  pd
        else bruteforce(pmatrix,n+1,pd)
    }
}


#May 25, 2018
#Fitting a dirichlet to 3 species abundances, predicted by an intercept and two covariates.
#This solution presented by Martyn Plummer
#clear environment, load packages.
rm(list = ls())
library(runjags)

#simulate data.
n <- 100
y1 <- round(rnorm(n, 100, 5))
mat <- rnorm(length(y1), 10, 3)
map <- rnorm(length(y1),100,10)
y1 <- y1 + round(mat*-3) + round(map*1)
y2 <- round(rnorm(n, 100, 5))
y3 <- round(rnorm(n, 100, 5))
spp.y <- as.matrix((data.frame(y1,y2,y3)))
y <- spp.y / rowSums(spp.y)
x <- as.matrix(cbind(rep(1,nrow(y)),mat,map)) #x predictors, including intercept

#Specify JAGS model.
dirichlet.model = "
model {
  #setup priors for each species
  alpha ~ dnorm(0, 1.0E-3)
  for(i in 1:N.x){
  beta[i,1] <- 0
  for (j in 2:N.spp) {
    beta[i,j] ~ dnorm(0, 1.0E-3)
      }
    }

  #implement dirlichet
  for (i in 1:N){
    for (j in 1:N.spp){
      log(a0[i,j]) <- alpha + inprod(beta[,j], x[i,])
    }
    y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
  }

  #map to original parameterization
  for (j in 1:N.spp) {
    m[1,j] <- alpha + beta[1,j]
    for (i in 2:N.x){
      m[i,j] <- beta[i,j]
    }
  }

} #close model loop.
"

#Setup JAGS data object, fit JAGS model.
jags.data <- list(y = y, x = x,
                  N = nrow(y), N.spp = ncol(y), N.x = ncol(x))
jags.out <- runjags::run.jags(dirichlet.model,
                     data=jags.data,
                     adapt = 200,
                     burnin = 2000,
                     sample = 2000,
                     n.chains=3,
                     monitor=c('m'))
#summarize output.
out <- summary(jags.out)

###visualize.
#extract mean parameter matrix.
parms <- (matrix(out[grep('m', rownames(out)),4],nrow = (ncol(x)),ncol = (ncol(y))))
#multiply parameters by predictors to get predicted values.
pred.list <- list()
for(i in 1:ncol(y)){
  pred.list[[i]] <- exp(x %*% parms[,i])
}
pred.list <- (as.matrix(do.call('cbind', pred.list)))
pred.list <- pred.list / rowSums(pred.list)

#Plot predicted vs. observed and the 1:1 line.
par(mfrow = c(1,3))
for(i in 1:ncol(y)){
  plot(y[,i] ~ pred.list[,i])
  r.sq <- summary(lm(y[,i] ~ pred.list[,i]))$r.squared
  abline(0,1, lwd = 2)
  txt <- paste0('R2 = ',round(r.sq,2))
  mtext(txt, side = 3, line = -2, adj = 0.05)
}


mutate <- function(solution, probability, variance, range) {
    mutated_solution <- solution

    for (index in 1:length(mutated_solution)) {
        val <- mutated_solution[index]
        random <- runif(1, 0, 1)

        if (probability > random) {
            addition <- rnorm(1, mean=0, sd=sqrt(variance))
            mutation <- val + addition
            while (mutation < -range || mutation > range) {
                addition <- rnorm(1, mean=0, sd=sqrt(variance))
                mutation <- val + addition
            }
            mutated_solution[index] = mutation
        }
    }

    mutated_solution
}

range <- 5
values <- seq(from=-range, to=range, by=.01)
solution <- sample(values, size=10, replace=TRUE)
probability <- 0.5
variance <- 0.05

mutated_solution = mutate(solution, probability, variance, range)

print("Solution")
sprintf("%.5f", solution)
plot(solution)

print("Mutated Solution")
sprintf("%.5f", mutated_solution)
plot(mutated_solution)

# Plot normal distribution
x <- seq(-range, range, by = .1)
y <- dnorm(x, mean = 0, sd = sqrt(variance))
plot(y, main = "Normal Distribution")


library(MASS)
getPriorProbabilities <- function (dset, column) {
  dsetLength <- dim(dset)[1]
  return (table(dset[, column]) / dsetLength)
}

# getCovMatrix <- function(dset, expectation) {
#   featureTypesCount <- dim(dset)[2]
#   dsetLength <- dim(dset)[1]
#   cov <- matrix(0, nrow = featureTypesCount - 1, ncol = featureTypesCount - 1)
#
#   for (i in 1:dsetLength) {
#     currentFeature <- as.matrix(dset[i, 1:featureTypesCount - 1], nrow = 1)
#
#     tmp <- t(currentFeature - expectation) %*% (currentFeature - expectation)
#     cov <- cov + tmp
#   }
#   cov <- cov / (dsetLength - 1)
#
#   return(cov)
# }

getCovMatrix <- function(dset, expectation) {
  dsetMatrix <- as.matrix(dset[, 1:2])
  featuresCount <- dim(dsetMatrix)[2]
  dsetLength <- dim(dsetMatrix)[1]
  cov <- matrix(0, featuresCount, featuresCount)
  for (i in 1:dsetLength) {
    cov <- cov + t(t(c(dsetMatrix[i,] - expectation))) %*% t(c(dsetMatrix[i, ] - expectation))
  }
  cov <- cov / (dsetLength - featuresCount)
  return(cov)
}

# getLikelihood <- function(point, expectation, covMatrix) {
#   covMatrixInverse <- solve(covMatrix)
#   a <- -(t(expectation) %*% covMatrixInverse %*% expectation) / 2
#   b <- t(point) %*% covMatrixInverse %*% expectation
#
#   return(a + b)
# }

# standard normal distribution formula
getLikelihood <- function(x, expectation, sigma) {
  a <- sqrt((2 * pi) ^ dim(sigma)[1] * det(sigma)) ^ -1
  b <- exp(t(x - expectation) %*% solve(sigma) %*% (x - expectation) / -2)
  return(a * b)
}

getLdfProbability <- function(dset, classesColumn, className, point, lambda, covMatrix, expectations) {
  featuresCount <- length(point)
  croppedDset <- dset[which(dset[, classesColumn] == className), ]
  dsetLength <- dim(dset)[1]

  prior <- getPriorProbabilities(dset, classesColumn)[className]
  # print(prior)

  expectations <- array(dim = featuresCount)
  for (i in 1:featuresCount) {
    expectations[i] <- mean(croppedDset[, i])
  }

  covMatrix <- getCovMatrix(dset, expectations)

  # lambda = rep(1, featuresCount)
  likelihood <- getLikelihood(point, expectations, covMatrix)

  probability <- lambda * prior * likelihood;
  return (probability)
}

ldfClassifier <- function(point, dset) {
  featuresCount <- length(point)
  classes <- unique(dset[, 3])
  classesCount <- length(classes)
  scores <- array(dim = classesCount)

  for (i in 1:classesCount) {
    scores[i] <- getLdfProbability(dset, 'class', classes[i], point, lambdas[i], covMatrix, expectations)
  }
  # print(scores)
  return(classes[which.max(scores)])
}

# mu1 <- c(0, 0)
# mu2 <- c(4, 4)
# sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
# sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
# dset1 <- mvrnorm(250, mu1, sig1)
# dset2 <- mvrnorm(250, mu2, sig2)
# dset <- rbind(cbind(dset1, 1),cbind(dset2, 2))

dset = data.frame(x = double(), y = double(), class = character())

dset <- rbind(dset, data.frame(x = 0, y = 2, class = 1))
dset <- rbind(dset, data.frame(x = 2, y = 0, class = 1))
dset <- rbind(dset, data.frame(x = 2.5, y = 2.5, class = 1))
dset <- rbind(dset, data.frame(x = 3, y = 2, class = 1))

dset <- rbind(dset, data.frame(x = 2, y = 4.5, class = 2))
dset <- rbind(dset, data.frame(x = 4.5, y = 2, class = 2))
dset <- rbind(dset, data.frame(x = 3.1, y = 5.5, class = 2))
dset <- rbind(dset, data.frame(x = 5, y = 3, class = 2))

#
# dset <- rbind(dset, data.frame(x = 2, y = 0, class = 1))
# dset <- rbind(dset, data.frame(x = 0, y = 2, class = 1))
# dset <- rbind(dset, data.frame(x = 1.3, y = 0.7, class = 1))
# dset <- rbind(dset, data.frame(x = 0.8, y = 1.5, class = 1))
# dset <- rbind(dset, data.frame(x = 0.9, y = 1.8, class = 1))
# dset <- rbind(dset, data.frame(x = 1.7, y = 0.8, class = 1))
#
# dset <- rbind(dset, data.frame(x = 2, y = 2, class = 2))
# dset <- rbind(dset, data.frame(x = 0, y = 0, class = 2))
# dset <- rbind(dset, data.frame(x = 1.7, y = 1.9, class = 2))
# dset <- rbind(dset, data.frame(x = 0.3, y = 0.1, class = 2))

# plot(dset[ ,1], dset[ ,2], pch=21, bg=c("green","blue")[dset[ ,3]])

# print(plugInClassifier(c(0, 0), dset))
# # print(getPlugInProbability(dset, 3, 1, c(0, 0), 1))

## generating map
colors <- c("1" = "green", "2" = "blue")
xs <- seq(from = -5, to = 7, by = 0.1)
ys <- seq(from = -5, to = 8, by = 0.1)
## lambdas <- runif(2, min=1, max=100)
lambdas = c(1, 1)
print(lambdas)

all <- length(xs) * length(ys)
progress = 1
for (i in xs) {
  for (j in ys) {
    cat("\rProcessing point", progress, "of", all)
    progress <- progress + 1
    result <- ldfClassifier(c(i, j), dset)
    points(i, j, col = colors[result], pch = 21)
  }
}
cat("\rDone.                      \n")

# library(plotly)
#
# xs <- seq(from = -5, to = 7, by = 0.1)
# ys <- seq(from = -5, to = 8, by = 0.1)
# z <- c()
#
#
# for (y in ys) {
#   curr <- c()
#   for (x in xs) {
#     arg <- c(x, y)
#     value <- ldfClassifier(c(x, y), dset)
#
#     curr <- c(curr, value)
#   }
#   z <- rbind(z, curr)
# }
#
#
# fig <- plot_ly(
#   type = 'contour',
#   x = ~xs,
#   y = ~ys,
#   z = ~z)
# fig


# compute fluxes for radiation model.
# relax radiation model by adding noise to distance with sd 10km, and bootstrapping

compute_radiation_fluxes = function(numrep, radiation_length_scale, population, geodist) {
  flux <- array(0, dim=c(N, N))
  flux_var <-  array(0, dim=c(N, N))
  for (r in 1:numrep) {
    ff <- matrix(0, N, N)
    for (i in 1:N) {
      mi = population[i]
      if (i==1) {
        jj <- 2:N
      } else if (i==N) {
        jj <- 1:(N-1)
      } else {
        jj = c(1:(i-1),(i+1):N)
      }
      js = jj[order(geodist[i,jj]+rnorm(N-1,sd=radiation_length_scale))]
      nj = population[js]
      sij = cumsum(c(0.0,nj))[1:(N-1)]
      ff[i,js] = mi*nj/((mi+sij)*(mi+nj+sij))
      ff[i,i] = 1.0 - sum(ff[i,js]) # this statement weird, as fluxes don't sum to 1, unlike as claimed in Simini paper
    }
    flux = flux + ff
    flux_var = flux_var + ff^2
  }
  flux = flux / numrep
  flux_sd = (flux_var - numrep*(flux^2))/(numrep-1)
  flux_sd[flux_sd<0]=0
  flux_sd = sqrt(flux_sd)/sqrt(numrep)

  list("flux"=flux, "flux_sd"=flux_sd)
}


#
# Testing:
#
# H_0:             b_1 = b_2 = 0   <= null hyphotesis
# H_Alternative:   b_1 != 0 or b_2 != 0
#
# So:
# Unrestricted: y = b_0 + b_1*x_1 + b_2*x_2 + b_3*x_3 + b_4*x_4
# Restricted:   y = b_0 + b_3*x_3 + b_4*x_4

# We are given this data
SSR_R <- 198.3 #sum squares residual for restricted
SSR_U <- 183.2 #sum squares residual for unrestricted
alpha <- 0.05
r = 2 #restrictions (dropped coeficients)
n = 500 #observations
k = 4 #number of coeficients of regressors (b_0 or intercept is not counted here)

# This test is one-sided hypotheses, so only one tail
F_critical_value = qf(alpha, r, n-(k+1), lower.tail = FALSE)
F_statistic = ((SSR_R - SSR_U)/r)/(SSR_U/(n-(k+1)))

print(F_critical_value)
print(F_statistic)

if (F_stat > F_critical_value){
  print("Reject de null hyphotesis")
}else{
  print("No reject de null hyphotesis")
}


# compute the expected vaccine efficacy against breakthrough infections that is
# due to a reduction in the case attributable fraction

# do this so that we can compare it against the estimated overall vaccine
# efficacy against breakthrough infections

# then compute correction factors to the infectiousness for vaccinated cases in
# each of the 4 combinations of vaccine type and  number of doses

# p_s = proportion symptomatic among unvaccinated infections

# p_s_star = proportion symptomatic among vaccinated infections

# VE_s = vaccine efficacy (% reduction) against symptomatic disease

# VE_o = vaccine efficacy (% reduction) against onward infectiousness of
# breakthrough infections

# VE_o(s) = vaccine efficacy (% reduction) against onward infectiousness of
# breakthrough infections, that is mediated by reductions in the fraction
# symptomatic

# absolute infectiousness (z is a transmission probability) of all unvaccinated
# people (symptomatic or asymptomatic)
# z * (p_s + (1 - p_s) / 2)

# absolute infectiousness (z is a transmission probability) of all vaccinated
# people (symptomatic or asymptomatic)
# z * (p_s_star + (1 - p_s_star) / 2)

# relative infectiousness of vaccinated versus unvaccinated (breakthrough)
# infections
#  (z * (p_s_star + (1 - p_s_star) / 2)) / (z * (p_s + (1 - p_s) / 2))
#   = (p_s_star + (1 - p_s_star) / 2) / (p_s + (1 - p_s) / 2)
#   = (1 + p_s_star) / (1 + p_s)

# proportion symptomatic among vaccinated infections
# p_s_star = p_s * (1 - VE_s)

# correction is the multiplier for reduction in onward transmission we want,
# divided by the one expected via reduction in symptomatics
# correction = ((1 - VE_o) / (1 - VE_o_s))

# this ^ can be multiplied by the probability of infection (by age bin, vaccine
# type, vaccine doses) to adjust it ot the correct value

library(tidyverse)

efficacies <- tibble::tribble(
  ~vaccine, ~dose, ~ve_infection, ~ve_symptom, ~ve_onward,
  "pfizer",     1,            30,          33,         46,
  "pfizer",     2,            79,          83,         65,
      "AZ",     1,            18,          33,         48,
      "AZ",     2,            60,          61,         65
) %>%
  mutate(
    across(
      starts_with("ve"),
      ~./100
    )
  )

clinical_fractions <- structure(
  list(
    age_group_5y = c("0-4", "5-9", "10-14", "15-19",
                     "20-24", "25-29", "30-34", "35-39", "40-44", "45-49", "50-54",
                     "55-59", "60-64", "65-69", "70-74", "75-79", "80+"),
    clinical_fraction_mean = c(
      0.29,
      0.29, 0.21, 0.21, 0.27, 0.27, 0.33, 0.33, 0.4, 0.4, 0.49, 0.49,
      0.63, 0.63, 0.69, 0.69, 0.69
    )
  ),
  row.names = c(NA, -17L),
  class = c("tbl_df", "tbl", "data.frame")
)

clinical_fractions %>%
  left_join(
    efficacies,
    by = character()
  ) %>%
  rename(
    clinical_fraction_unvacc = clinical_fraction_mean
  ) %>%
  mutate(
    clinical_fraction_vacc = clinical_fraction_unvacc * (1 - ve_symptom),
    ve_onward_via_symptom = 1 - ((1 + clinical_fraction_vacc) / (1 + clinical_fraction_unvacc)),
    onward_correction = ((1 - ve_onward) / (1 - ve_onward_via_symptom))
  ) %>%
  relocate(
    clinical_fraction_unvacc, .after = clinical_fraction_vacc
  ) %>%
  relocate(
    ve_onward_via_symptom, .after = ve_onward
  )

# p_s <- seq(0.1, 0.9, by = 0.1)
# VE_s <- efficacies$ve_symptom[2]
# VE_o <- efficacies$ve_onward[2]
# p_s_star = p_s * (1 - VE_s)
# VE_o_s <- 1 - ((1 + p_s_star) / (1 + p_s))
# correction <- ((1 - VE_o) / (1 - VE_o_s))


#ganancias
#lazo abierto, sistema planta 1
To<-1.080
Kp<-25.51
Tp<-15.0423
#Ganancia proporcional
GanP<-function(Tp,Kp,To){
  return(Tp/(Kp*To))
}
GanPr<-GanP(Tp,Kp,To)
GanPr
#Kp en ganancia integral
GanI<-function(Tp,Kp,To){
  return((0.9*Tp)/(Kp*To))
}
#PI
GanIn<-GanI(Tp,Kp,To)
GanIn
#tiempo de la integral
Tin<-3.33*To
Tin
#Kp en ganancia derivativa
GanD<-function(Tp,Kp,To){
  return((0.9*Tp)/(Kp*To))
}
#PID
GanPID<-GanD(Tp,Kp,To)
GanPID
#Tiempo integral en derivaticva
Tip<-2*To
Tip
#Tiempo derivativo
Td<-0.5*To
Td

KI<-GanIn/Tin
KI

K<-GanPID/Tip
K
KD<-GanPID*Td
KD

#para un sistema planta 2 en lazo cerrado
Ku<-1.749
Tu<-1.2
GaP<-0.5*Ku
GaP

Gi<-0.45*Ku
Gi

Gd<-0.6*Ku
Gd

#Tiempo integral
#Para un PI
tpi<-Tu/1.2
tpi

#Para la acción derivadiva
tid<-Tu/2
tid
#Tiempo derivativo
tpid<-Tu/8
tpid

Kp<-GaP
Kp

Ki<-Gi/tpi
Ki

kid<-Gd/tid
kid

Kd<-Gd*tpid
Kd

Practica 1 y 2/Parte 2 practica/2.2.2/LazoCerradoYAbierto.r


#!/usr/bin/env Rscript

# NOTE: fOptions uses non-standard definition of cost of carry: b = interestrate - carryrate, i.e. the adjusted drift κ in the geometric Brownian motion:
#   dS_t = (κ - σ^2/2) S_t dt + σ S_t dW_t

library(fOptions)

df = Reduce(function(x,y) merge(x,y,all=TRUE),
             list(data.frame(startprice=c(80,100,120)),
                  data.frame(strikeprice=c(80,100,120)),
                  data.frame(days=c(50,120)),
                  data.frame(interestrate=c(0.05,0.07)),
                  data.frame(carryrate=c(0.0,0.025)),
                  data.frame(sigma=c(0.05,0.1,0.5))
                  ))

bs = df

for (type in c("c","p")) {
    bs[type] = with(bs,
                    GBSOption(TypeFlag = type, S = startprice, X = strikeprice, Time = days/365,
                              r = interestrate, b = interestrate - carryrate, sigma = sigma)@price)
}

write.csv(bs,"bs.csv",row.names=FALSE)

crr = merge(df,data.frame(nsteps=c(20,100)),all=TRUE)
for (otype in c("ce","pe","ca","pa")) {
    crr[otype] = with(crr,
                     sapply(mapply(CRRBinomialTreeOption,TypeFlag = otype, S = startprice, X = strikeprice, Time = days/365,
                                   r = interestrate, b = interestrate - carryrate, sigma = sigma, n=nsteps),
                            function(x) x@price))
}

write.csv(crr,"crr.csv",row.names=FALSE)

tian = merge(df,data.frame(nsteps=c(20,100)),all=TRUE)
for (otype in c("ce","pe","ca","pa")) {
    tian[otype] = with(tian,
                     sapply(mapply(TIANBinomialTreeOption,TypeFlag = otype, S = startprice, X = strikeprice, Time = days/365,
                                   r = interestrate, b = interestrate - carryrate, sigma = sigma, n=nsteps),
                            function(x) x@price))
}
write.csv(tian,"tian.csv",row.names=FALSE)

jr = merge(df,data.frame(nsteps=c(20,100)),all=TRUE)
for (otype in c("ce","pe","ca","pa")) {
    tian[otype] = with(jr,
                     sapply(mapply(JRBinomialTreeOption,TypeFlag = otype, S = startprice, X = strikeprice, Time = days/365,
                                   r = interestrate, b = interestrate - carryrate, sigma = sigma, n=nsteps),
                            function(x) x@price))
}
write.csv(tian,"jr.csv",row.names=FALSE)


=begin
[((<README|URL:README.html>))] [((<Japanese|URL:../doc-ja/index-ja.html>))]
= Algebra
  Version: 0.72 (2006.09.14)
  Author: Shin-ichiro HARA (sinara@blade.nagaokaut.ac.jp)

This is a library of one-variate and multi-variate polynomials.

== 0. First Step

Begin with 'require "algebra"'.

  require "algebra"
  x = Polynomial(Integer, "x").var
  puts( (x+1)**7 )
    #=> x^7 + 7x^6 + 21x^5 + 35x^4 + 35x^3 + 21x^2 + 7x + 1
  puts( (x**7 + 7*x**6 + 21*x**5 + 35*x**4 + 35*x**3 + 21*x**2 + 7*x + 1).factorize )
    #=> (x + 1)^7

== 1. Samples

* ((<Samples|URL:samples.html>))

== 2. Class and Module

 * ((<Algebra|URL:algebra.html>)) (Module of Algebra)
   * ((<Algebra::Polynomial|URL:polynomial.html>)) (Class of Polynomial Ring)
   * ((<Algebra::EuclidianRing|URL:euclidian-ring.html>)) (Eulcidian Ring Module)
   * ((<Algebra::MPolynomial|URL:m-polynomial.html>)) (Multi-variate Polynomial Ring Class)
   * ((<Algebra::ResidueClassRing|URL:residue-class-ring.html>)) (Residue Class Ring Class)
   * ((<Algebra::AlgebraicExtensionField|URL:algebraic-extension-field.html>)) (Algebraic Extension Class)
   * ((<Algebra::LocalizedRing|URL:localized-ring.html>)) (Localized Ring Class)
   * ((<Algebra::MatrixAlgebra|URL:matrix-algebra.html>)) (Matrix Algebra Class)
   * ((<Algebra::AlgebraicParser|URL:algebraic-parser.html>)) (evaluation of algebraic strings)
   * ((<Algebra::Set|URL:finite-set.html>)) (Sets)
   * ((<Algebra::Map|URL:finite-map.html>)) (Maps)
   * ((<Algebra::Group|URL:finite-group.html>)) (Groups)
   * ((<Algebra::PermutationGroup|URL:permutation-group.html>)) (PermutationGroups)

== 3. Other

 * ((<Algebra::ElementaryDivisor|URL:elementary-divisor.html>)) (Elementary Divisor Module)
 * ((<Algebra::JordanForm|URL:jordan-form.html>)) (Jordan Matrix Class)
 * ((<Algebra::MatrixAlgebraTriplet|URL:matrix-algebra-triplet.html>)) (Triplete of Matrices Class)
 * ((<Algebraic Equations|URL:algebraic-equation.html>))
 * ((<Conversions of Polynomial Classes|URL:polynomial-converter.html>))

== 4. Contents of package

=== General
  algebra.rb               File for using Algebra libraries

=== One variate polynomial
  polynomial.rb            Class of one variate polynomial
  euclidian-ring.rb        Module of Euclidian domain
  polynomial-factor.rb     Factorization:
    polynomial-factor-int.rb   Integer version
    polynomial-factor-zp.rb    Zp version
    polynomial-factor-alg.rb   Algebraic number version

=== Multi variate polynomial
  m-polynomial.rb         Class of multi-variate polynomial
    m-index.rb            Class of indices of degrees
  m-polynomial-factor.rb     Factorization:
    m-polynomial-factor-int.rb   Integer version
    m-polynomial-factor-zp.rb    Zp version
  groebner-basis.rb       Module of Groebner basis
  groebner-basis-coeff.rb Module of division by Groebner basis

=== Foundation
  finite-set.rb           Sets
    finite-map.rb         Maps
    finite-group.rb       Groups
      permutation-group.rb  Permutation Groups

=== Common part
  numeric-supplement.rb   Supplement of Numeric
  prime-gen.rb            Class of prime numbers
  polynomial-converter.rb Conversions between polynomial classes
  algebraic-parser.rb     Evaluation of strings
  algebra-system.rb       Common specification of algebras

=== General algebra
  localized-ring.rb       Quotient fields
  matrix-algebra.rb       Matrix
    elementary-divisor.rb Elementary Divisor Class
    matrix-algebra-triplet.rb  Triplet of Matrices Class
    jordan-form.rb        Jordan Block Class
  residue-class-ring.rb   Residue class ring
  algebraic-extention-field.rb Algebraic Extention Field of Polynomial
  splitting-field.rb      Minimal Splitting Field of Polynomial
  galois-group.rb         Galois Group of Polynomial
  linear-algebra.rb       library for linear algebra
  algebraic-equation.rb   library for algebraic equation

=== Others
  array-supplement.rb    Supplement of Array
  doc/                   English Manuals(RD, HTML, TXT)
  doc-ja/                Japanese Manuals(RD, HTML, TXT)
  sample/                Sample Codes
  work/                  (working directory for the developer)

== 5. ToDo
#<<< todo.rd
* ((<todo.html|URL:todo.html>))

== 6. Changes
#<<< changes.rd
* ((<changes.html|URL:changes.html>))

=end


#' sunposition
#'
#' @description Function to assess sun azimuth and elevation given the time in GMT format.
#'
#' @param timenow time indicat in time format equivalent to "POSIXct" or "POSIXt" object.
#' @param  lat numeric latitude in decimal degrees
#' @param lon numeric  longitude in decimal degrees
#' @references
#' Istituto di Biometeorologia Firenze Italy
#' Centro Interdipartimentale di Bioloclimatologia University of Florence
#' \url{http://stackoverflow.com/questions/8708048/position-of-the-sun-given-time-of-day-latitude-and-longitude}
#' @author  Alfonso crisci \email{a.crisci@@ibimet.cnr.it} Marco Morabito \email{m.morabito@@unifi.it}
#'
#'
#' @export

sunposition <- function(timenow,lat, long) {

    time=as.POSIXlt(timenow, "GMT")
    year=as.numeric(format(time,"%Y"))
    hour=as.numeric(format(time,"%H"))
    day=as.numeric(format(time,"%d"))
    month=as.numeric(format(time,"%m"))
    min=as.numeric(format(time,"%M"))
    sec=as.numeric(format(time,"%S"))

    twopi <- 2 * pi
    deg2rad <- pi / 180

    # Get day of the year, e.g. Feb 1 = 32, Mar 1 = 61 on leap years

    month.days <- c(0,31,28,31,30,31,30,31,31,30,31,30)
    day <- day + cumsum(month.days)[month]
    leapdays <- year %% 4 == 0 & (year %% 400 == 0 | year %% 100 != 0) &
                day >= 60 & !(month==2 & day==60)
    day[leapdays] <- day[leapdays] + 1

    # Get Julian date - 2400000
    hour <- hour + min / 60 + sec / 3600 # hour plus fraction
    delta <- year - 1949
    leap <- trunc(delta / 4) # former leapyears
    jd <- 32916.5 + delta * 365 + leap + day + hour / 24

    # The input to the Atronomer's almanach is the difference between
    # the Julian date and JD 2451545.0 (noon, 1 January 2000)
    time <- jd - 51545.

    # Ecliptic coordinates

    # Mean longitude
    mnlong <- 280.460 + .9856474 * time
    mnlong <- mnlong %% 360
    mnlong[mnlong < 0] <- mnlong[mnlong < 0] + 360

    # Mean anomaly
    mnanom <- 357.528 + .9856003 * time
    mnanom <- mnanom %% 360
    mnanom[mnanom < 0] <- mnanom[mnanom < 0] + 360
    mnanom <- mnanom * deg2rad

    # Ecliptic longitude and obliquity of ecliptic
    eclong <- mnlong + 1.915 * sin(mnanom) + 0.020 * sin(2 * mnanom)
    eclong <- eclong %% 360
    eclong[eclong < 0] <- eclong[eclong < 0] + 360
    oblqec <- 23.439 - 0.0000004 * time
    eclong <- eclong * deg2rad
    oblqec <- oblqec * deg2rad

    # Celestial coordinates
    # Right ascension and declination
    num <- cos(oblqec) * sin(eclong)
    den <- cos(eclong)
    ra <- atan(num / den)
    ra[den < 0] <- ra[den < 0] + pi
    ra[den >= 0 & num < 0] <- ra[den >= 0 & num < 0] + twopi
    dec <- asin(sin(oblqec) * sin(eclong))

    # Local coordinates
    # Greenwich mean sidereal time
    gmst <- 6.697375 + .0657098242 * time + hour
    gmst <- gmst %% 24
    gmst[gmst < 0] <- gmst[gmst < 0] + 24.

    # Local mean sidereal time
    lmst <- gmst + long / 15.
    lmst <- lmst %% 24.
    lmst[lmst < 0] <- lmst[lmst < 0] + 24.
    lmst <- lmst * 15. * deg2rad

    # Hour angle
    ha <- lmst - ra
    ha[ha < -pi] <- ha[ha < -pi] + twopi
    ha[ha > pi] <- ha[ha > pi] - twopi

    # Latitude to radians
    lat <- lat * deg2rad

    # Azimuth and elevation
    el <- asin(sin(dec) * sin(lat) + cos(dec) * cos(lat) * cos(ha))
    az <- asin(-cos(dec) * sin(ha) / cos(el))

    # For logic and names, see Spencer, J.W. 1989. Solar Energy. 42(4):353

    cosAzPos <- (0 <= sin(dec) - sin(el) * sin(lat))
    sinAzNeg <- (sin(az) < 0)
    az[cosAzPos & sinAzNeg] <- az[cosAzPos & sinAzNeg] + twopi
    az[!cosAzPos] <- pi - az[!cosAzPos]

    el <- el / deg2rad
    az <- az / deg2rad
    lat <- lat / deg2rad

    return(list(elevation=el, azimuth=az))
}


 E04TCJ Example Program Results

 First solve the problem with the outliers

 --------------------------------------------------------
 E04GG, Nonlinear least squares method for bound-constrained problems
 Status: converged, an optimal solution was found
 Value of the objective             1.05037E+00
 Norm of gradient                   8.78014E-06
 Norm of scaled gradient            6.05781E-06
 Norm of step                       1.47886E-01

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1       -inf        3.61301E-01        inf
     2       -inf        9.10227E-01        inf
     3       -inf        3.42138E-03        inf
     4       -inf       -6.08965E+00        inf
     5       -inf        6.24881E-04        inf
 --------------------------------------------------------

 Now remove the outlier residuals from the problem handle

 --------------------------------------------------------
 E04GG, Nonlinear least squares method for bound-constrained problems
 Status: converged, an optimal solution was found
 Value of the objective             5.96811E-02
 Norm of gradient                   1.19914E-06
 Norm of scaled gradient            3.47087E-06
 Norm of step                       3.49256E-06

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1       -inf        3.53888E-01        inf
     2       -inf        1.06575E+00        inf
     3       -inf        1.91383E-03        inf
     4       -inf        2.17299E-01        inf
     5       -inf        5.17660E+00        inf
 --------------------------------------------------------

 Assuming the outliers points are measured again
 we can enable the residuals and adjust the values

 --------------------------------------------------------
 E04GG, Nonlinear least squares method for bound-constrained problems
 Status: converged, an optimal solution was found
 Value of the objective             6.51802E-02
 Norm of gradient                   2.57338E-07
 Norm of scaled gradient            7.12740E-07
 Norm of step                       1.56251E-05

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   3.00000E-01    3.00000E-01    3.00000E-01
     2       -inf       1.06039E+00         inf
     3       -inf       2.11765E-02         inf
     4       -inf       2.11749E-01         inf
     5       -inf       5.16415E+00         inf


#' Linear Model Coefficients
#'
#' Coefficients of the linear model.
#'
#' @details
#' The model is fit using a QR factorization of the input \code{x}. At this
#' time, that means
#'
#' Both of \code{x} and \code{y} must be distributed in an identical fashion.
#' This means that the number of rows owned by each MPI rank should match, and
#' the data rows \code{x} and labels \code{y} should be aligned.  Additionally,
#' each MPI rank should own at least one row.  Ideally they should be load
#' balanced, so that each MPI rank owns roughly the same amount of data.
#'
#' @section Communication:
#' The operation has the same communication as
#'
#' @param x,y
#' The input data \code{x} and response \code{y}.  Each must be a shaq, and
#' each must be distributed in an identical fashion.  See the details section
#' for more information.
#' @param tol
#' Numerical tolerance for deciding rank.
#'
#' @return
#' A regular vector.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' comm.set.seed(1234, diff=TRUE)
#'
#' x = ranshaq(rnorm, 10, 3)
#' y = ranshaq(runif, 10)
#'
#' fit = lm_coefs(x, y)
#' comm.print(fit)
#'
#' finalize()
#' }
#'
#' @seealso \code{\link{glms}}
#' @name lm_coefs
#' @export
lm_coefs = function(x, y, tol=1e-7)
{
  check.is.shaq(x)
  check.is.shaq(y)

  R = qr_R(x)
  Q = qr_Q(x, R)

  ### NOTE here we assume that x (and hence Q) and y are distributed in identical fashion!
  qty = allreduce(crossprod(Data(Q), Data(y)))
  rank = max(which(abs(diag(R)) > tol))

  if (rank < ncol(x))
  {
    ind = 1:rank
    coefs = solve(R[ind, ind], qty[ind])
    coefs = c(coefs, rep(NA_real_, ncol(x)-rank))
  }
  else
    coefs = solve(R, qty)

  if (ncol(y) == 1)
  {
    dim(coefs) = NULL
    names(coefs) = paste0("x", 1:ncol(x))
  }
  else
    rownames(coefs) = paste0("x", 1:ncol(x))

  coefs
}


# Eric Anderson
#
# Spline interpolate rain gauge data to 0.1
# degree grids and save to .csv
#
# Version 1.0
# 8 April 2015
#
# The purpose of this program is to ingest .csv
# rainfall data for one day, interpolate them to
# 0.1 degree grid spacing, and save them to
# another .csv.

# load libraries
library(maptools) # autoloads sp
library(raster)
library(rgeos)
library(rgdal)
library(akima)
library(fields)

# set workspace
setwd("C:/Users/Eric/Dropbox/ESS508_Python/r_assign")

# Create area of interest for masking final interpolation (and
# extrapolation if necessary)
# This file should stay the same
aoi <- readShapePoly("aoi_sv_buff10_gcs.shp")

# Create vectors for x and y grid spacing. This will only need to # be created once per area to interpolate.
ygrids <- seq(13,14.5,0.1) # ~10km
xgrids <- seq(-90.2,-87, 0.1) # ~10km

# Load station data points (this file will be different every day)
# Note that this may include missing gauge data, but it must be stored as "NaN"
pluv_raw <- read.csv(file="daily_rain.csv")

# Remove rows with missing rain data
pluv <- pluv_raw[complete.cases(pluv_raw),]

print("Rain gauge data read and missing data removed.",quote=0)

# Load coordinates to be interpolated
# This file will only need to be created once per area to interpolate
pt <- read.csv(file="coords.csv")
coordinates(pt)= ~ longitude+ latitude

# Interpolate the pluviometer data to surface rasters
    ## Pick ONE of the following interpolation techniques by setting extLogical to TRUE or FALSE
   extLogical <- TRUE  # if extLogical is true, spline is used (linLogical is false)
   #extLogical <- FALSE  # if extLogical is false, linear is used (see akima documentation).
    # set linLogical to true or false based on extrapolation choice
    if (extLogical == TRUE) linLogical <- FALSE
    if (extLogical == FALSE) linLogical <- TRUE

# Define x, y (same for every day) and interpolated z values (different for every day)
x<- pluv[,4]; y<- pluv[,3]; z<- pluv[,5]
interpex <- mask(raster(interp(x,y,z, linear=linLogical, extrap=extLogical, xo=xgrids, yo=ygrids)),aoi)

# Tell me I'm finished and how to plot an image
print("Interpolation complete. Use plot(interpex) command to see results in R console.",quote=0)

# Stack interpolated rasters... (only needed if many days are to be prepared at the same time)
rStack = stack(interpex)

# Perform the value extraction on the raster stack
# (extracts interpolated rain values from raster to the 0.1 degree-spaced points)
rVal = extract(rStack,pt)
rVal[rVal<0] <- 0		#replace all negative values to 0 (artifact of extrapolating to edge)

# Combine these extracted results with the lat/lon of 0.1 degree-spaced csv points
write.table(cbind(pt,data.frame(rVal)),file="pluv_daily_spline.csv", append=FALSE, sep= ",", row.names=FALSE, col.names=TRUE)

print("Program complete. Output saved to pluv_daily_spline.csv.",quote=0)
# Program complete.


#   Copyright (C) 2019  Dr. Norbert Bátfai, nbatfai@gmail.com
#
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>
#
# https://youtu.be/Koyw6IH5ScQ

library(neuralnet)

a1    <- c(0,1,0,1)
a2    <- c(0,0,1,1)
OR    <- c(0,1,1,1)

or.data <- data.frame(a1, a2, OR)

nn.or <- neuralnet(OR~a1+a2, or.data, hidden=0, linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.or)

compute(nn.or, or.data[,1:2])

a1    <- c(0,1,0,1)
a2    <- c(0,0,1,1)
OR    <- c(0,1,1,1)
AND   <- c(0,0,0,1)

orand.data <- data.frame(a1, a2, OR, AND)

nn.orand <- neuralnet(OR+AND~a1+a2, orand.data, hidden=0, linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.orand)

compute(nn.orand, orand.data[,1:2])

a1      <- c(0,1,0,1)
a2      <- c(0,0,1,1)
EXOR    <- c(0,1,1,0)

exor.data <- data.frame(a1, a2, EXOR)

nn.exor <- neuralnet(EXOR~a1+a2, exor.data, hidden=0, linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.exor)

compute(nn.exor, exor.data[,1:2])

a1      <- c(0,1,0,1)
a2      <- c(0,0,1,1)
EXOR    <- c(0,1,1,0)

exor.data <- data.frame(a1, a2, EXOR)

nn.exor <- neuralnet(EXOR~a1+a2, exor.data, hidden=c(6, 4, 6), linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.exor)

compute(nn.exor, exor.data[,1:2])


# Method
pow <- function(x, y)
{
   x <- as.numeric(x)
   y <- as.integer(y)
   prod(rep(x, y))
}
#Operator
"%pow%" <- function(x,y) pow(x,y)

pow(3, 4)    # 81
2.5 %pow% 2  # 6.25


fptcdf=function(z,x0max,chi,driftrate,sddrift) {
  if (x0max<1e-10) return(pnorm(chi/z,mean=driftrate,sd=sddrift,lower.tail=F))
  zs=z*sddrift ; zu=z*driftrate ; chiminuszu=chi-zu ; xx=chiminuszu-x0max
  chizu=chiminuszu/zs ; chizumax=xx/zs
  tmp1=zs*(dnorm(chizumax)-dnorm(chizu))
  tmp2=xx*pnorm(chizumax)-chiminuszu*pnorm(chizu)
  1+(tmp1+tmp2)/x0max
}

fptpdf=function(z,x0max,chi,driftrate,sddrift) {
  if (x0max<1e-10) return( (chi/z^2)*dnorm(chi/z,mean=driftrate,sd=sddrift))
  zs=z*sddrift ; zu=z*driftrate ; chiminuszu=chi-zu
  chizu=chiminuszu/zs ; chizumax=(chiminuszu-x0max)/zs
  (driftrate*(pnorm(chizu)-pnorm(chizumax)) +
    sddrift*(dnorm(chizumax)-dnorm(chizu)))/x0max
}

rlba=function(n,b,A,vs,s,t0,st0=0,truncdrifts=TRUE){
  n.with.extras=ceiling(n*(1+3*prod(pnorm(-vs))))
  drifts=matrix(rnorm(mean=vs,sd=s,n=n.with.extras*length(vs)),ncol=length(vs),byrow=TRUE)
  if (truncdrifts) {
    repeat {
      drifts=rbind(drifts,matrix(rnorm(mean=vs,sd=s,n=n.with.extras*length(vs)),ncol=length(vs),byrow=TRUE))
      tmp=apply(drifts,1,function(x) any(x>0))
      drifts=drifts[tmp,]
      if (nrow(drifts)>=n) break
    }
  }
  drifts=drifts[1:n,]
  drifts[drifts<0]=0
  starts=matrix(runif(min=0,max=A,n=n*length(vs)),ncol=length(vs),byrow=TRUE)
  ttf=t((b-t(starts)))/drifts
  rt=apply(ttf,1,min)+t0+runif(min=-st0/2,max=+st0/2,n=n)
  resp=apply(ttf,1,which.min)
  list(rt=rt,resp=resp)
}

dlba=function(t,t0,x0max,chi,v1,v0,sdI,truncdrifts=TRUE) {
  # Generates defective PDF for responses on node #1.
  # "truncdrifts" sets whether that part of the multi-variate
  # normal distribution on drift rates which would otherwise
  # lead to non-terminating trials is truncated.
  if(t < 0){
    drift = c(v0,v1)
  }else{
    drift = c(v1,v0)
  }
  t = abs(t)
  t = t - t0
  x0max = rep(x0max,2)
  chi = rep(chi,2)

  sdI = rep(drift,2)

  N=length(drift) # Number of responses.
  if (N>2) {
    tmp=array(dim=c(length(t),N-1))
    for (i in 2:N) tmp[,i-1]=fptcdf(z=t,x0max=x0max[i],chi=chi[i],
      driftrate=drift[i],sddrift=sdI[i])
    G=apply(1-tmp,1,prod)
  } else {
    G=1-fptcdf(z=t,x0max=x0max[2],chi=chi[2],driftrate=drift[2],sddrift=sdI[2])
  }
  out=G*fptpdf(z=t,x0max=x0max[1],chi=chi[1],driftrate=drift[1],sddrift=sdI[1])
  if (truncdrifts) {
    out=out/(1-prod(pnorm(-drift/sdI)))
    out[t<=0]=0
    out = pmax(out,1e-10)
    return(out)
  } else {
    out = pmax(out,1e-10)
    return(out)
  }
}

n1PDF=function(t,x0max,chi,drift,sdI,st0=0,truncdrifts=TRUE) {
  N=length(drift) # Number of responses
  if (length(x0max)<N) x0max=rep(x0max,length.out=N)
  if (length(chi)<N) chi=rep(chi,length.out=N)
  if (length(sdI)<N) sdI=rep(sdI,length.out=N)
  if (length(st0)>1) st0=st0[1] # Only ONE non-decision time.
  if (st0==0) return(n1PDFfixedt0(t,x0max,chi,drift,sdI,truncdrifts=truncdrifts))
  tmpf=function(t,x0max,chi,drift,sdI,st0,truncdrifts)
    n1PDFfixedt0(t,x0max,chi,drift,sdI,truncdrifts=truncdrifts)/st0
  outs=numeric(length(t))
  for (i in 1:length(outs)) outs[i]=integrate(f=tmpf,lower=t[i]-st0/2,upper=t[i]+st0/2,
    x0max=x0max,chi=chi,drift=drift,sdI=sdI,st0=st0,truncdrifts=truncdrifts)$value
  outs
}

n1CDF=function(t,x0max,chi,drift,sdI,st0=0,truncdrifts=TRUE) {
  # Generates defective CDF for responses on node #1.
  N=length(drift) # Number of responses
  if (length(x0max)<N) x0max=rep(x0max,length.out=N)
  if (length(chi)<N) chi=rep(chi,length.out=N)
  if (length(sdI)<N) sdI=rep(sdI,length.out=N)
  if (length(st0)>1) stop("Only one value of st0 allowed.")
  if (st0<1e-6) st0=0 # Integral can fail for small st0.
  outs=numeric(length(t)) ; bounds=c(-st0/2,t)
  for (i in 1:length(t)) {
    tmp="error"
    repeat {
      if (bounds[i]>=bounds[i+1]) {outs[i]=0;break}
      tmp=try(integrate(f=n1PDF,lower=bounds[i],upper=bounds[i+1],subdivisions=1000,
        x0max=x0max,chi=chi,drift=drift,sdI=sdI,st0=st0,truncdrifts=truncdrifts)$value,silent=T)
      if (is.numeric(tmp)) {outs[i]=tmp;break}
      # Try smart lower bound.
      if (bounds[i]<=0) {
	bounds[i]=max(c((chi-0.98*x0max)/(max(mean(drift),drift[1])+2*sdI)[1],0))
	next
      }
      # Try smart upper bound.
      if (bounds[i+1]==Inf) {
	bounds[i+1]=0.02*max(chi)/(mean(drift)-2*mean(sdI))
	next
      }
      stop("Error in n1CDF that I could not catch.")
    }
  }
  cumsum(outs)
}

n1mean=function(x0max,chi,drift,sdI,truncdrifts=TRUE) {
  # Generates mean RT for responses on node #1.
   pc=n1CDF(Inf,x0max,chi,drift,sdI,truncdrifts=truncdrifts)
   fn=function(t,x0max,chi,drift,sdI,st0=0,truncdrifts,pc)
     t*n1PDF(t,x0max,chi,drift,sdI,st0,truncdrifts=truncdrifts)/pc
   tmp=integrate(f=fn,lower=0,upper=100*chi,x0max=x0max,chi=chi,pc=pc,
     drift=drift,sdI=sdI,st0=st0,truncdrifts=truncdrifts)$value
   list(mean=tmp,p=pc)
}


# Importamos librerías
rm(list=ls())
install.packages("FuzzyR")
library(FuzzyR)

# Iniciamos un nuevo objeto FIS (Fuzzy inference system)
etapa <- newfis("Variables")

# Creamos variables de ingreso con sus rangos
etapa <- addvar(etapa, "input", "edad", c(0,60))
etapa <- addvar(etapa, "input", "salario", c(0,1000))
etapa <- addvar(etapa, "input", "ingreso", c(2000,2021))
etapa <- addvar(etapa, "output", "apellidos", c(0,3))

# Creamos funciones de pertenencia trapezoidales y triangulares (inputs)
# Funciones "edad"
etapa <- addmf(etapa,"input", 1, "Joven", "trapmf", c(0,0,25,35) )
etapa <- addmf(etapa,"input", 1, "Adulto", "trimf", c(25,35,45))
etapa <- addmf(etapa,"input", 1, "Viejo", "trapmf", c(35,45,100,100) )

# Funciones "salario"
etapa <- addmf(etapa,"input", 2, "Bajo", "trapmf", c(0,0,400,650) )
etapa <- addmf(etapa,"input", 2, "Medio", "trimf", c(400,650,700))
etapa <- addmf(etapa,"input", 2, "Alto", "trapmf", c(650,700,1000,1000) )

# Funciones "ingreso"
etapa <- addmf(etapa,"input", 3, "Antiguo", "trapmf", c(0,0,2005,2011) )
etapa <- addmf(etapa,"input", 3, "Medio", "trimf", c(2005,2011,2014))
etapa <- addmf(etapa,"input", 3, "Reciente", "trapmf", c(2011,2014,2021,2021) )

# Funciones "cumple requisitos" (output)
etapa <- addmf(etapa,"output", 1, "no cumple requisitos", "trapmf", c(0,0,1,2) )
etapa <- addmf(etapa,"output", 1, "cumple requisitos", "trapmf", c(1,2,3,3))

# Dibujamos las funciones
plotmf(etapa,"input",1,xlab="Edad",ylab="Pertenencia",main="Edad")
plotmf(etapa,"input",2,xlab="Salario",ylab="Pertenencia",main="Dinero")
plotmf(etapa,"input",3,xlab="Antigüedad",ylab="Pertenencia",main="Ingreso")
plotmf(etapa,"output",1)

# Creamos las reglas que indican qué valor resulta para valores que se encuentren
# en cierto punto de las funciones de pertenencia, respondiendo a la pregunta
# “Cuáles son los apellidos de las personas jóvenes o recientemente empleadas,
# pero con sueldo alto”.
rulelist <- rbind(c(1,3,3,3,1,1),
                  c(1,3,2,2,1,1),
                  c(1,3,1,2,1,1),

                  c(2,3,3,2,1,1),
                  c(2,3,2,1,1,1),
                  c(2,3,1,1,1,1),

                  c(3,3,3,2,1,1),
                  c(3,3,2,1,1,1),
                  c(3,3,1,1,1,1)
        )

# Agregamos reglas al sistema difuso
etapa <- addrule(etapa, rulelist)

# Ingresamos valores a evaluar, que son los incluídos en la tabla del enunciado
matrixInput <- matrix(c(30,800,2010,
                        30,600,2010,
                        25,900,2004,
                        55,700,2016,
                        25,750,2015),ncol=3, byrow=TRUE)

# Realizamos la evaluación de los inputs usando el sistema difuso y sus resultados
# son entregados en la consola de R.
evalfis(matrixInput,etapa)


R version 3.2.2 (2015-08-14) -- "Fire Safety"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
[Workspace loaded from ~/.RData]

 install.packages("markovchain")
 library(markovchain)

 RentalStates <- c("Downtown", "East", "West")

 RentalStates

 RentalTransitionMatrix <- matrix(c(0.3, 0.3, 0.4,
                                     0.4, 0.4, 0.2,
                                     0.5, 0.3, 0.2),
                                   byrow = T, nrow = 3, dimnames = list(RentalStates, RentalStates))

 RentalTransitionMatrix

 mcRental <- new("markovchain", states = RentalStates, byrow = T, transitionMatrix = RentalTransitionMatrix, name = "Rental Cars")

 mcRental

 mcRental[2]

 plot(mcRental)

 transitionProbability(mcRental, "East", "West")

 x <- 0.3 * 0.3
 y <- 0.3 * 0.4
 z <- 0.4 * 0.5
 x + y + z

 mcRental ^ 2

 mcRental^20

 mcRental ^ 30

 70 * steadyStates(mcRental)

 summary(mcRental)

 conditionalDistribution(mcRental, "Downtown")

 conditionalDistribution(mcRental, "West")

 conditionalDistribution(mcRental, "East")

Chapter 08/3Markov Chains - Car Rental Agency Service.r


#clear environment, load runjags.
rm(list = ls())
library(runjags)

#### Generate pseudo data ####
#10 sites, 9 plots per site, 10 observations per plot.
n.site <- 10
n.plot <- 9
n.core <- 10
siteID <- sort(rep(LETTERS[1:n.site],n.plot*n.core))
plotID <- rep(1:n.plot,n.site*n.core)
plotID <-paste(siteID,plotID,sep = '_')
site.means <- runif(n.site,10,25)
plot.means <- list()
for(i in 1:length(site.means)){
  plot.means[[i]] <- rnorm(n.plot,site.means[i],2)
}
plot.means <- unlist(plot.means)

#get observations for each plot, based on a mean, and a sd of 2
obs <- list()
for(i in 1:length(plot.means)){
  obs[[i]] <- rnorm(n.core, mean = plot.means[i], sd = 2)
}
x <- unlist(obs)

#create true data frame.
dat <- data.frame(siteID,plotID)
dat <- dat[order(plotID),]
dat$x <- x

#indexing.
plotindex <- as.factor(dat$plotID)
siteindex <- list()
for(i in 1:n.site){
  siteindex[[i]] <- rep(LETTERS[i],n.plot)
}
siteindex <- as.factor(unlist(siteindex))

#### Specify hierarchical JAGS model ####
jags.model = "
model {
#priors
global ~ dnorm(0,1.0E-4) #global level parameter prior.
site.tau ~ dgamma(0.1,0.1)
plot.tau ~ dgamma(0.1,0.1)
core.tau ~ dgamma(0.1,0.1)

for(i in 1:N.site){ site[i] ~ dnorm(global, site.tau)}            ## estimate global mean
for(j in 1:N.plot){ plot[j] ~ dnorm(site[siteindex[j]],plot.tau)} ## estimate site means
for(k in 1:N.core){ core[k] ~ dnorm(plot[plotindex[k]],core.tau)} ## estimate plot means

} #end model
"
##### specify JAGS data object. ####
jags.data <- list(core = dat$x,
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)

#### Fit JAGS model ####
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('plot','site'))
out <- summary(jags.out)

##### compare estimate plot/site means to true values. All w/in 95% credible interval. ####
par(mfrow = c(1,2))
fit.plot.means <- out[grep('plot',rownames(out)),][,4]
fit.site.means <- out[grep('site',rownames(out)),][,4]
plot(plot.means ~ fit.plot.means, main = 'plot-level fit'); abline(0,1,lwd=2, lty=2)
plot(site.means ~ fit.site.means, main = 'site-level fit'); abline(0,1,lwd=2, lty=2)

##### check uncertainty values #####
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('core.tau','plot.tau','site.tau','global'))
summary(jags.out)

##### create data with missing observations. #####
missing <- dat
#remove 3 observations within a plot in site A.
missing[2:4,3] <- NA
#remove an entire plot in site B.
missing[missing$plotID == 'B_1',3] <- NA
#remove all observations in site C.
missing[missing$siteID == 'C'  ,3] <- NA

##### create new jags data object for fitting missing data model. ####
jags.data <- list(core = missing$x,
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)

##### Fit missing data model. ####
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('core','plot','site'))

out <- summary(jags.out)
comp <- dat
comp$pred <- out[grep('core',rownames(out)),4]
comp$removed <- missing$x
z <- comp[is.na(comp$removed),]

##### how are the core level predcitions compared to true values? in range. #####
cbind(out[2:4,],dat$x[2:4])

##### how about the missing plot? ####
zz <- cbind(out[grep('core',rownames(out)),],missing,dat$x)
zz[zz$plotID == 'B_1',]

##### how about the missing site? ####
zz[zz$siteID == 'C',]


library(nloptr)

get_expected = function(beta, tau1, tau2, N0, A0, observed_I=NULL) {
  "
  Calculates expected new case counts for each step in the time series.

  Parameters
  ----------
  N0 : numeric
    Initial number of contagious patients.
  A0 : numeric
    Initial number of asymptomatic patients.
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  tau1 : numeric
    Probability that an asymptomatic patient will turn contagious in the next
    time step.
  tau : numeric
    (1 / mean) number of days an individual will continue to be infectious.

  Returns
  -------
  expected : list
    Daily expected number of infectious (N), new asymptomatic (A), and new
    infectious (I) patients.
  "
  steps = length(beta)
  expected_I = rep(0, steps)
  expected_N = rep(0, steps)
  expected_A = rep(0, steps)
  N_previous = N0
  A_previous = A0
  for(t in 1:steps) {
    expected_I[t] = (1 - exp(-tau1)) * A_previous
    expected_A[t] = (exp(-tau1) * A_previous) + (beta[t] * N_previous)
    expected_N[t] = (exp(-tau2) * N_previous) + expected_I[t]
    if (is.null(observed_I)) { # history not available
      N_previous = expected_N[t]
    } else { # history available; use it
      N_previous = sum(c(N0, observed_I[1:t]) * rev(pexp(0:t, rate=tau2, lower.tail=FALSE)))
    }
    A_previous = expected_A[t]
  }
  return(list("N"=c(N0, expected_N), "A"=c(A0, expected_A), "I"=expected_I))
}

fit = function(observed_I, beta0, beta_min, beta_max, tau10, tau1_min,
               tau1_max, tau20, tau2_min, tau2_max, N00, N0_min, N0_max, A00,
               A0_min, A0_max, lambda, ignore_beta_diff, use_history, n_nloptr_iter=100000) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, tau10, tau20, N00, A00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), tau1_min, tau2_min, N0_min, A0_min)
  ub = c(rep(beta_max, steps), tau1_max, tau2_max, N0_max, A0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7, "maxeval" = n_nloptr_iter)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    tau1 = x[steps + 1]
    tau2 = x[steps + 2]
    N0 = x[steps + 3]
    A0 = x[steps + 4]
    # calculate loss
    if (use_history) {
      expected = get_expected(beta, tau1, tau2, N0, A0, observed_I)
    } else {
      expected = get_expected(beta, tau1, tau2, N0, A0)
    }

    regularization =  (diff(beta) / beta[1:(steps - 1)]) ^ 2
    regularization = regularization[!1:length(regularization) %in% ignore_beta_diff]
    observed_I = round(observed_I, 0)
    factSum = function(x) {
      return(sum(log(1:round(x, 0))))
    }
    loglikelihood = observed_I*log(expected$I)-expected$I-sapply(as.matrix(observed_I), FUN=factSum)
    loglikelihood[observed_I==0] = -expected$I[observed_I==0]
    return(-mean(loglikelihood) + lambda*mean(regularization))
  }
  result = nloptr(x0=x0, eval_f=loss, lb=lb, ub=ub, opts=opts)
  model = list(
    "R" = result$solution[1:steps] / result$solution[steps + 2],
    "beta" = result$solution[1:steps],
    "tau1" = result$solution[steps + 1],
    "tau2" = result$solution[steps + 2],
    "N0" = result$solution[steps + 3],
    "A0" = result$solution[steps + 4],
    "loss" = result$objective,
    "lambda" = lambda,
    "ignore_beta_diff" = ignore_beta_diff,
    "use_history" = use_history
  )
  regularization =  (diff(model$beta) / model$beta[1:(steps - 1)]) ^ 2
  regularization = regularization[!1:(steps - 1) %in% ignore_beta_diff]
  model$likelihood = (model$loss - lambda * mean(regularization)) * steps
  return(model)
}

fit_robust = function(observed_I, beta_min, beta_max, tau1_min, tau1_max,
                      tau2_min, tau2_max, N0_min, N0_max, A0_min, A0_max, lambda,
                      ignore_beta_diff, use_history, n_robust_iter, n_nloptr_iter) {
  best_loss = Inf
  best_model = NULL
  for (i in 1:n_robust_iter) {
    beta0 = runif(length(observed_I), beta_min, beta_max)
    tau10 = runif(1, tau1_min, tau1_max)
    tau20 = runif(1, tau2_min, tau2_max)
    N00 = runif(1, N0_min, N0_max)
    A00 = runif(1, A0_min, A0_max)
    model = fit(observed_I, beta0=beta0, beta_min=beta_min, beta_max=beta_max,
                tau10=tau10, tau1_min=tau1_min, tau1_max=tau1_max, tau20=tau20,
                tau2_min=tau2_min, tau2_max=tau2_max, N00=N00, N0_min=N0_min,
                N0_max=N0_max, A00=A00, A0_min=A0_min, A0_max=A0_max,
                lambda=lambda, ignore_beta_diff=ignore_beta_diff,
                use_history=use_history, n_nloptr_iter=n_nloptr_iter)
    if (model$loss < best_loss) {
      best_model = model
      best_loss = model$loss
    }
  }
  best_model[["n_robust_iter"]] = n_robust_iter
  return(best_model)
}

search_best_model = function(observed_I, beta_min, beta_max, tau1_min, tau1_max,
                      tau2_min, tau2_max, N0_min, N0_max, A0_min, A0_max,
                      ignore_beta_diff, n_iter,search=FALSE) {
    best_loss = Inf
    best_model = NULL
    for (i in 1:n_iter) {
      beta0 = runif(length(observed_I), beta_min, beta_max)
      tau10 = runif(1, tau1_min, tau1_max)
      tau20 = runif(1, tau2_min, tau2_max)
      N00 = runif(1, N0_min, N0_max)
      A00 = runif(1, A0_min, A0_max)
      model = fit(observed_I, beta0=beta0, beta_min=beta_min, beta_max=beta_max,
                  tau10=tau10, tau1_min=tau1_min, tau1_max=tau1_max, tau20=tau20,
                  tau2_min=tau2_min, tau2_max=tau2_max, N00=N00, N0_min=N0_min,
                  N0_max=N0_max, A00=A00, A0_min=A0_min, A0_max=A0_max,
                  lambda=0, ignore_beta_diff=ignore_beta_diff,n_iter=10000000)
      if (model$loss < best_loss) {
        best_model = model
        best_loss = model$loss
        best_param=list(
          "beta0"=beta0,
          "tau10"=tau10,
          "tau20"=tau20,
          "N00"=N00,
          "A00"=A00
        )
      }
    }
    if(search){
    p_value = 0
    c_left = 0
    c_right = 1e20
    p_values = 0
    cs = c_left
    while( 0.93 > p_value | 0.96 < p_value)
    {
      c = (c_left + c_right)/2
      model = fit(observed_I, beta0=best_model$beta, beta_min=beta_min, beta_max=max(beta_max,best_model$beta),
                  tau10=best_param$tau10, tau1_min=tau1_min, tau1_max=tau1_max, tau20=best_param$tau20,
                  tau2_min=tau2_min, tau2_max=tau2_max, N00=best_param$N00, N0_min=N0_min,
                  N0_max=N0_max, A00=best_param$A00, A0_min=A0_min, A0_max=A0_max,
                  lambda=c, ignore_beta_diff=ignore_beta_diff,n_iter=10)
      LRTest=2*(model$loss-best_loss)
      p_value=pchisq(LRTest,length(best_model$beta), lower.tail=TRUE)
      p_values = c(p_values,p_value)
      cs = c(cs,c)
      if(p_value < 0.95)
      {
       c_left = c
      }
      if(p_value > 0.96)
      {
        c_right = c
      }
    }
      return(model)
    }
    return(best_model)
    }


function(y,yfit,family=binomial(),variance=NULL)
{
  # Calculate the residual for given observed y and its fitted value yfit:
  # the length between y and yfit along the quardratic variance function:
  #           V(mu) = v2*mu^2+v1*mu+v0
  qvresidual<-function(y,yfit,v2,v1)
  {
    vpa <- 2*v2*yfit+v1
    svpa2 <- sqrt(1+vpa*vpa)

    vpb <- 2*v2*y+v1
    svpb2 <- sqrt(1+vpb*vpb)

    vr <- (log((vpb+svpb2)/(vpa+svpa2))+vpb*svpb2-vpa*svpa2)/(4*v2)
    vr
  }

  if( is.character(family) ) {
    cf <- family
    family <- get(family, mode="function", envir=parent.frame())
  } else
    cf <- family$family

  if( pmatch("Negative Binomial",cf,nomatch=F) )
  {
    theta <- as.numeric(gsub("(?<=\\()[^()]*(?=\\))(*SKIP)(*F)|.","", cf, perl=T))
    cf <- "negative.binomial"
  } else if( pmatch("Tweedie",cf,nomatch=F) )
  {
    dv <- Deriv(family$variance,"mu")
    theta <- dv(1)
  }

  if( is.null(variance) )
  {
    switch(cf,
      binomial={DFUN<-function(x) qvresidual(x[1],x[2],-1,1)}, # Need modify for Y~Bin(n,p)
      gaussian={DFUN<-function(x) x[1]-x[2]},
      Gamma={DFUN<-function(x) qvresidual(x[1],x[2],1,0)},
      negative.binomial={DFUN<-function(x) qvresidual(x[1],x[2],1/theta,1)},
      poisson={DFUN<-function(x) x[1]-x[2]},
      quasibinomial={DFUN<-function(x) qvresidual(x[1],x[2],-1,1)},
      quasipoisson={DFUN<-function(x) x[1]-x[2]},
      inverse.gaussian={
        DFUN<-function(x) integrate(function(mu){sqrt(1+9*mu^4)},x[1],x[2])$value},
      Tweedie={ # var.power: 0, 1, (1,2), 2, >2
        if( (theta==0)|(theta==1) )
          DFUN<-function(x) x[1]-x[2]
        else if( theta==2 )
          DFUN<-function(x) qvresidual(x[1],x[2],1,0)
        else
          DFUN<-function(x) integrate(function(mu){sqrt(1+theta^2*mu^(2*theta-2))},x[1],x[2])$value},
      quasi={  # variance for quasi: "constant","mu(1-mu)","mu","mu^2","mu^3", or other
        if( (family$varfun=="constant")|(family$varfun=="mu") )
          DFUN <- function(x) x[1]-x[2]
        else if( family$varfun=="mu(1-mu)" )
          DFUN<-function(x) qvresidual(x[1],x[2],-1,1)
        else if( family$varfun=="mu^2" )
          DFUN<-function(x) qvresidual(x[1],x[2],1,0)
        else
          DFUN<-function(x) integrate(function(mu){sqrt(1+Deriv(family$variance,"mu")^2)},x[1],x[2])$value})
  }
  else
    DFUN<-function(x) integrate(function(mu){sqrt(1+Deriv(variance,"mu")^2)},x[1],x[2])$value

  vresidual <- apply(cbind(y,yfit),1,DFUN)
}