########################################################################
#                                                                      #
#   lib/finite-group.rb                                                #
#                                                                      #
########################################################################
=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::OperatorDomain>))
/
((<Algebra::Set>))
/
((<Algebra::Group>))
/
((<Algebra::QuotientGroup>))

= Algebra::OperatorDomain

群が作用する集合の性質を集めたモジュールです。
((<Group>)) クラスがインクルードしています。

== ファイル名:
* ((|finite-group.rb|))

== メソッド:

--- right_act(other)
    ((|self|)) と ((|other|)) の積を返します。すなわち ((|self|))
    の元 ((|x|)) と ((|other|)) の元 ((|y|)) に対して (({x * y})) の
    形の元の集合（((|Set|))）を返します。

--- act
    ((<right_act>)) のエイリアスです。

--- left_act(other)
    ((|self|)) と ((|other|)) の積を返します。すなわち ((|self|))
    の元 ((|x|)) と ((|other|)) の元 ((|y|)) に対して (({y * x})) の
    形の元の集合（((|Set|))）を返します。

--- right_quotient(other)
    ((|self|)) を ((|other|)) で割った右剰余類の集合（((|Set|))）
    を返します。

--- quotient
--- right_coset
--- coset
    ((<right_quotient>)) のエイリアスです。

--- left_quotient(other)
    ((|self|)) を ((|other|)) で割った左剰余類の集合（((|Set|))）
    を返します。

--- left_coset
    ((<left_quotient>)) のエイリアスです。

--- right_representatives(other)
    右剰余類 ((<right_quotient>)) から取った代表元の集合を返します。

--- representatives
    ((<right_representatives>)) のエイリアスです。

--- left_representatives(other)
    左剰余類 ((<left_quotient>)) から取った代表元の集合を返します。

--- right_orbit!(other)
    ((|self|)) を ((|other|)) を繰り返し右から作用させて広げます。
    作用は ((|*|)) によります。

--- orbit!
    ((<right_orbit!>)) のエイリアスです。

--- left_orbit!(other)
    ((|self|)) を ((|other|)) を繰り返し左から作用させて広げます。
    作用は ((|*|)) によります。

= Algebra::Set

== ファイル名:
* ((|finite-group.rb|))
  ここでは ((|finite-set.rb|)) で定義された ((<Set|URL:finite-set.html>))
  に付け加えるべきメソッドを定義しています。

== インクルードしているモジュール:

* ((|OperatorDomain|))

== メソッド:

--- *
    ((<act>)) のエイリアスです。

--- /
    ((<quotient>)) のエイリアスです。

--- %
    ((<representatives>)) のエイリアスです。

--- increasing_series([x])
    ((|x|)) から始まる増大列の配列を返します。これは次のコードと同値
    です。

      def increasing_series(x = unit_group)
        a = []
        loop do
          a.push x
          if x >= (y = yield x)
            break
          end
          x = y
        end
        a
      end

--- decreasing_series([x])
    ((|x|)) から始まる減少の配列を返します。これは次のコードと同値
    です。

      def decreasing_series(x = self)
        a = []
        loop do
          a.push x
          if x <= (y = yield x)
            break
          end
          x = y
        end
        a
      end

= Algebra::Group

== ファイル名:
* ((|finite-group.rb|))

== スーパークラス:
* ((|Set|))

== クラスメソッド:

--- ::new(u, [g0, g1, ...]])
    ((|u|)) を単位元とし、((|g0|)), ((|g1|)), ... で構成される群を
    返します。

--- ::generate_strong(u, [g0, [g1, ...]])
    単位元を ((|u|))、強生成元を ((|g0|)), ((|g1|)), ... として、
    生成される群を返します。

== メソッド:

--- quotient_group(u)
    正規部分群 ((|u|)) による剰余群を返します。

--- separate
    ブロックを真とする元からなる部分群を返します。

--- to_a
    各要素を配列にして返します。最初の要素は単位元です。

--- unity
    単位元を返します。

--- unit_group
    単位元で生成される単位群を返します。

--- semi_complete!
    現在の要素を掛け合わせて半群を構成します。

--- semi_complete
    現在の要素を掛け合わせて半群を構成たものを返します。

--- complete!
    現在の要素を掛け合わせて群を構成します。

--- complete
    現在の要素を掛け合わせて群を構成たものを返します。

--- closed?
    群として閉じているとき真を返します。

--- subgroups
    全ての部分群の集合を返します。

--- centralizer(s)
    ((|self|)) における ((|s|)) の中心化群を返します。

--- center
    ((|self|)) の中心化群を返します。

--- center?(x)
    ((|self|)) の中で元 ((|x|)) が中心に含まれているとき、真を返します。

--- normalizer(s)
    ((|self|)) における ((|s|)) の正規化群を返します。

--- normal?(s)
    ((|s|)) が ((|self|)) の正規部分群であるとき真を返します。

--- normal_subgroups
    全ての正規部分群の集合を返します。

--- conjugacy_class(x)
    元 ((|x|)) の共役類を返します

--- conjugacy_classes
    ((|self|)) の全ての共役類の集合を返します。

--- simple?
    単純群であるとき、真を返します。

--- commutator([h])
    ((|self|)) と ((|h|)) との交換子群を返します。((|h|)) を省略
    すると ((|self|)) が用いられます。

--- D([n])
    ((|n|)) 番目の交換子群を返します。(({D(0) = 自分自身})),
    (({D(n+1) = [D[n], D[n]]})) で定義されています。
    ((|n|)) を省略すると 1 が用いられます。

--- commutator_series
    (({[D(0), D(1), D(2),..., D(n)]})) という配列を返します。この配列は
    (({D(n) == D(n+1)})) となる ((|n|)) で停止します。

--- solvable?
    可解群であるとき真を返します。

--- K([n])
    (({K(0) = 自分自身})),
    (({K(n+1) = [self, K[n]]})) で定義される群を返します。
    ((|n|)) を省略すると 1 が用いられます。

--- descending_central_series
    降中心列
    (({[K(0), K(1), K(2),..., K(n)]})) という配列を返します。この配列は
    (({K(n) == K(n+1)})) となる ((|n|)) で停止します。

--- Z([n])
    (({Z(0) = 単位群})),
    (({Z(n+1) = separate{|x| commutator(Set[x]) <= Z(n-1)}}))
    で定義される群を返します。
    ((|n|)) を省略すると 1 が用いられます。

--- ascending_central_series
    昇中心列
    (({[Z(0), Z(1), Z(2),..., Z(n)]})) という配列を返します。この配列は
    (({Z(n) == Z(n+1)})) となる ((|n|)) で停止します。

--- nilpotent?
    冪零群であるとき真を返します。

--- nilpotency_class
    冪零クラスを返します。冪例群でないとき ((|nil|)) を返します。

= Algebra::QuotientGroup

== ファイル名:
* ((|finite-group.rb|))

== スーパークラス:
* ((|Group|))

== クラスメソッド:
--- new(u, [g0, [g1,...]])
    ((|self|)) の正規部分群を ((|u|)) として、
    ((|u|)), ((|g0|)), ((|g1|)), .. を剰余類とする剰余群を返します。

== メソッド:

--- inverse
    逆元を返します

--- inv
    ((<inverse>)) のエイリアスです。

=end


#' HSI_index
#'
#' Computes the Heat Strain Index. HSI is the ratio of the demand for sweat evaporation to capacity of evaporation (Ereq on Emax).
#' This denotes also the percent of skin wettedness, which is a good predictor of warm discomfort.
#'

#' @param t numeric    Air temperature in degC.
#' @param rh numeric   Relative humidity in percentage.
#' @param wind numeric Windspeed in meter per second.
#' @param tr numeric Mean radiant temperature in degC.
#' @param M numeric    Metabolic work in Watt per mq of the subject.
#' @param W   numeric  Mechanical work rate in Watt per mq of the subject.
#' @param clo numeric  Available basic clothing insulation in clo.
#' @param param character Index requested HSI or AET Allowable exposure time in minutes.
#' @return HSI index
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords HSI
#' @references Belding et al 1955. Index for evaluating heat stress in terms of resulting physiological strain. Heat Pip Air Condit 27, 129 36.
#' @export
#'
HSI_index=function(t,rh,wind,tr,M,W,clo,param="HSI") {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("vel", as.array(wind))
                         ct$assign("tr", as.array(tr))
                         ct$assign("M", as.array(M))
                         ct$assign("W", as.array(W))
                         ct$assign("clo", as.array(clo))
                         ct$assign("param", as.array(param))
                         ct$eval("var res=[]; for(var i=0, len=ta.length; i < len; i++){ res[i]=HSI_index(ta[i],rh[i],vel[i],tr[i],M[0],W[0],clo[0],param[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);
		  ### +log(1-normal_cdf(0.08*u,u,0.01))*(b0>0.08*u);   #### +log(b0>0.08*u); (b0>0.08*u)
  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b0;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function
#mu[1] <- exp(u*exp(-b0)+e[1]);

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u*exp(-b0*n)+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.04,0.01);
b0 ~ normal(0.004,0.001);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

M=50   ###, 75, 100, .... till 193

####### read new data Y
setwd("./covid19modelrisk/output/forecast")

##  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[1:M,2]

setwd("./covid19modelrisk/output/model_with_E")

###########
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_GM.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_IT.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_JP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_SP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_UK.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_US.csv")
  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_AU.csv")

################
  E=E[1:M,4]
###  E5=E[,5]

#### no E
## E=rep(1,M)

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.04,b0=0.004,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

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

### Germany
u=0.24
b0=0.031#u*0.08 ###

## Italy
u=0.24
b0=0.03#u*0.08 ###

## Japan
u=0.05
b0=0.0055

## Spain
u=0.3
b0=0.037

## UK
u=0.3
b0=0.037

## US
u=0.1
b0=0.0067

## AU
u=0.04
b0=0.004

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

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=1

pdf(paste("M2_IQR_5_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b0","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2"), inc_warmup = T,  nrow = 2, ncol = 1, window = NULL, include = TRUE)
dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

Epars_m=Epars_m*E

Epars_5=Epars_5*E
Epars_9=Epars_9*E

pdf(paste("M2_IQR_5_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

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

### Germany
u=0.24
b0=0.031#u*0.08 ###

## Italy
u=0.24
b0=0.03#u*0.08 ###

## Japan
u=0.05
b0=0.0055

## Spain
u=0.3
b0=0.037

## UK
u=0.3
b0=0.037

## US
u=0.1
b0=0.0067

## AU
u=0.04
b0=0.004


correlogI <- function(x, dt, method = "euclidean", nc = NULL, thresh = NULL, alpha = 0.05, tail = "upper", seq.bonferroni = TRUE){
  if(!is.vector(x)) stop("\"x\" must be a vector")
  if(!is.data.frame(dt) & !is.matrix(dt)) stop("\"dt\" must be a data frame or matrix")
  if(length(dt[1, ]) != 2) stop("\"dt\" must have two columns")
  if(length(x) != length(dt[ ,1])) stop("number of \"dt\" rows must be iqual to \"x\" length")
  if(!(is.null(nc) | is.null(thresh))) stop("one of \"nc\" or \"thresh\" must be specified")
  if(sum(tail %in% c("two", "upper", "lower")) == 0) stop("tail must be one of: \"two\", \"upper\", \"lower\"")

  # Distance matrix
  D <- as.matrix(dist(dt, method = "euclidean"))

  # Number of observations
  n <- dim(D)[1]

  if(is.null(nc) & is.null(thresh)){
    # Number of classes: Sturges' rule
    nc <- round(1 + (1/log10(2)) * log10(length(D[upper.tri(D, diag = FALSE)])), 0)
    thresh <- (max(D) / nc)
  }

  if(!is.null(thresh)){
    if(thresh >= max(D)) stop(paste("\"thresh\" must be less than maximum distance:", round(max(D), 2)))
    # Define nc by informed threshold distance
    nc <- round(max(D) / thresh, 0)
  }

  if(!is.null(nc)){
    # Ensure that nc is integer
    nc <- round(nc, 0)
    thresh <- (max(D) / nc)
  }

  # Distance classses (equal length)
  d <- array((1:nc) * thresh, nc, list(1:nc))

  # Data frame with variables to each class
  res <- data.frame(class = 1:nc, distMax = d, I = NA, W = NA, varI = NA)
  if(tail == "two" | tail == "upper"){
    res$Ia.up <- NA
    if(seq.bonferroni == TRUE) res$Ia.up.bonf <- NA
  }
  if(tail == "two" | tail == "lower"){
    res$Ia.lo <- NA
    if(seq.bonferroni == TRUE) res$Ia.lo.bonf <- NA
  }
  res$pvalue <- NA
  res[ ,"."] <- NA

  # Correction to bicaucal test
  if(tail == "two") alpha <- alpha / 2

  # Expected I
  EI <- -(n - 1)^-1

  # For each distance classes
  for(cl in 1:nc){
    # Binary weight
    if(cl == 1) w <- D <= d[cl]
    else w <- D > d[cl - 1] & D <= d[cl]

    # Convert logical to numeric and dicart upper triangle, including diagonal (simetric weight matrix)
    w[upper.tri(w, diag = TRUE)] <- 0

    # Number of pais in distance class
    res$W[cl] <- sum(w)

    # Checking if there are pairs in distance classe
    if(res$W[cl] != 0){
      # Moran I
      res$I[cl] <- ((1 / res$W[cl]) * sum(w * ((x - mean(x)) %o% (x - mean(x))))) / ((1/n) * sum((x - mean(x))^2))

      # Variance
      S1 <- (1/2) * sum((w + t(w)) ^ 2)

      S2 <- sum((apply(w, 1, sum) + apply(w, 2, sum)) ^ 2)

      b2 <- (n * sum((x - mean(x)) ^ 4)) / ((sum((x - mean(x)) ^ 2)) ^ 2)

      num1 <- n * ( (((n^2) - (3*n) + 3) * S1) - (n*S2) + (3 * (res$W[cl]^2)) )
      num2 <- b2 * ( (((n^2) - n) * S1) - (2*n*S2) + (6 * (res$W[cl]^2)) )
      den <- (n-1) * (n-2) * (n-3) * (res$W[cl]^2)

      res$varI[cl] <- ((num1 - num2) / den) - (EI ^ 2)

      # Correction to small n
      if((4 * (n - sqrt(n))) < res$W[cl] & res$W[cl] <= (4 * ((2*n) - (3*sqrt(n)) + 1)))
        kalpha <- sqrt(10 * alpha)
      else kalpha <- 1

      # Critical Ialpha with correction to small n
      if(tail == "two" | tail == "upper"){
        res$Ia.up[cl] <- (kalpha * EI) + abs(qnorm(alpha, 0, 1)) * sqrt(res$varI[cl])
        if(seq.bonferroni == TRUE)
          res$Ia.up.bonf[cl] <- (kalpha * EI) + abs(qnorm(alpha / cl, 0, 1)) * sqrt(res$varI[cl])
      }
      if(tail == "two" | tail == "lower"){
        res$Ia.lo[cl] <- (kalpha * EI) - abs(qnorm(alpha, 0, 1)) * sqrt(res$varI[cl])
        if(seq.bonferroni == TRUE)
          res$Ia.lo.bonf[cl] <- (kalpha * EI) - abs(qnorm(alpha / cl, 0, 1)) * sqrt(res$varI[cl])
      }

      # Probability
      if(tail == "two")
        res$pvalue[cl] <-  2 * pnorm(res$I[cl], (kalpha * EI), sqrt(res$varI[cl]), lower.tail = ifelse(res$I[cl] >= EI, FALSE, TRUE))

      if(tail == "upper")
        res$pvalue[cl] <- pnorm(res$I[cl], (kalpha * EI), sqrt(res$varI[cl]), lower.tail = FALSE)

      if(tail == "lower")
        res$pvalue[cl] <- pnorm(res$I[cl], (kalpha * EI), sqrt(res$varI[cl]))

      # Significance
      if(seq.bonferroni == TRUE)
        res[cl, "."] <- ifelse(res$pvalue[cl] < (ifelse(tail == "two", (alpha * 2), alpha) / cl), "*", "")
      else res[cl, "."] <- ifelse(res$pvalue[cl] < ifelse(tail == "two", (alpha * 2), alpha), "*", "")
    }
  }

  return(list(EI = EI,
              alpha = alpha,
              tail = tail,
              seq.bonferroni = seq.bonferroni,
              result = res))
}


#' Simple single-parameter adaptive metropolis
#' @param target Target function (returning log unnormalised posterior density);
#' 	this function should take the parameter as its first argument and a data list as its second
#' @param initial Initial value of the parameter
#' @param data Data to pass to the target
#' @param iter Number of iterations
#' @param scale Scale for the proposal distribution, if NA, the algorithm will adaptively
#' 		choose a scale
#' @param ... Additional named parameters to pass to m_adapt
#'
#' @return A list, with three components: 'chain' is the markov chain, 'scale'
#' 		is the scale parameter used, and 'accept' is the acceptance rate
metropolis = function(target, initial, data, iter = 5000, scale = NA, ...) {

	# check that the target distribution is defined at the initial value
	if(!is.finite(target(initial, data)))
		stop("Target distribution undefined at the initial value, choose better inits")

	# adaptation, if needed
	if(is.na(scale))
		scale = m_adapt(target, initial, data, ...)

	# do the sampling
	result = m_sample(target, initial, data, scale, iter)

	# save the scale as well, because this allows resuming the chain
	result$scale = scale
	return(result)
}

#' Worker function to actually do the sampling
#' @param target Target function (returning log unnormalised posterior density);
#' 	this function should take the parameter as its first argument and a data list as its second
#' @param state Initial state (parameter value)
#' @param data Data to pass to the target
#' @param iter Number of iterations
#' @param scale Scale for the proposal distribution
#' @return A list with two elements, chain (the markov chan) and accept, the acceptance rate
m_sample = function(target, state, data, scale, iter) {
	# set up the markov chain
	chain = numeric(iter)

	# keep track of how many times we accept the proposals
	# the acceptance rate is an important diagnostic
	accept = 0

	for(i in 1:iter) {
		# propose a value and accept/reject, updating the chain with the new value
		chain[i] = m_propose(state, scale, target, data)

		if(chain[i] != state) {
			# if the value changed, that was an acceptance
			# increment the accept variable, and update state
			accept = accept + 1
			state = chain[i]
		}
	}

	return(list(chain = chain, accept = accept/iter))
}

#' Runs the adaptation phase of the metropolis sampler
#' @param target Target function
#' @param initial Initial value of the parameter
#' @param data Data to pass to the target
#' @param chunk_size Number of iterations in each chunk before adapting
#' @param max_chunk Maximum number of chunks before stopping adaptation
#' @param accept_range Target range of acceptance rates
#' @param scale Initial guess for the scale
#' @param scale_step By how much should we multiply the scale if the acceptance is too large,
#' 		or divide if the acceptance rate is too small
#' @return Scale parameter after adaptation
m_adapt = function(target, initial, data, chunk_size = 100, max_chunk = 100,
			accept_range = c(0.2, 0.4), scale = 1, scale_step = 1.1) {

	accept_rate = 0
	nchunk = 0
	while(nchunk < max_chunk & (accept_rate < min(accept_range) |
							accept_rate > max(accept_range))) {
		chunk = m_sample(target, initial, data, scale, iter = chunk_size)
		accept_rate = chunk$accept
		initial = chunk$chain[length(chunk$chain)]

		if(accept_rate < min(accept_range)) {
			scale = scale / scale_step
		} else if(accept_rate > min(accept_range)) {
			scale = scale * scale_step
		}
		nchunk = nchunk + 1
	}
	cat("Finished adaptation after", nchunk, "chunks of", chunk_size,
		"iterations; acceptance rate:\n", "   ", accept_rate, "\n")
	return(scale)
}

#' Simpler adaptation phase, converges around 50% acceptance
#' @param target Target function
#' @param initial Initial value of the parameter
#' @param data Data to pass to the target
#' @param scale Initial guess for the scale
m_adapt_simple = function(target, initial, data, scale = 1, adapt_iter = 5000) {
	accept = 0
	chain = numeric(adapt_iter)

	state = initial
	for(i in 1:adapt_iter) {
		# propose a value and accept/reject, updating the current state with the new value
		chain[i] = m_propose(state, scale, target, data)

			if(chain[i] == state) {
				## rejection, decrease the scale
				scale = scale / 1.1
			} else {
				## acceptance, increase the scale, acceptance rate, and update state
				scale = scale * 1.1
				accept = accept + 1
				state = chain[i]
			}
	}
	cat("Finished adaptation; acceptance rate = ", accept/adapt_iter, "\n")
	return(scale)
}

#' Propose and select candidate values for the metropolis algorithm
#' @param state Current state of the chain
#' @param scale Scale of the proposal distribution
#' @param target Target distribution density function
#' @param data Data for the target distribution
#' @return New value in the chain
m_propose = function(state, scale, target, data) {
	# choose a candidate value from the proposal distribution
	candidate = rnorm(1, state, scale)

	# compute the log posterior density at the current state and the candidate value
	ld_cand = target(candidate, data)
	ld_current = target(state, data)

	# compute the acceptance probability r, making sure the density is finite
	# r is the ratio of densities: (d_cand / d_current)
	# because r should be the exponential of the difference of log densities
	if(!is.finite(ld_cand)) {
		r = 0
	} else {
		r = exp(ld_cand - ld_current)
	}

	# now choose a value such that the chance of choosing d_cand is equal to r
	# the easiest way is to draw a random uniform number U on (0,1) and compare it to r
	# pr(U < r) = r (acceptance), pr(U >= r) = 1 - r (rejection)
	# could also use sample() to do this, but it's slower
	U = runif(1)
	if(U < r) {
		val = candidate
	} else {
		val = state
	}
	return(val)
}

#' Compute highest posterior density interval for a single parameter
#' @param samples A vector of mcmc samples
#' @param density The (minimum) probability density contained in the interval
hpdi = function(samples, density = 0.9) {
	n = length(samples)
	samples = sort(samples)
	n_include = ceiling(density * n)
	lower = 1:(n - n_include)
	upper = lower + n_include
	width = samples[upper] - samples[lower]
	i = which.min(width)
	c(samples[lower[i]], samples[upper[i]])
}


# ......................................................................................
# ............................ Cvičení 12. Vícevýběrové testy...........................
# .................. Michal Béreš, Martina Litschmannová, Adéla Vrtková.................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

# * Testovací data pro ukázku volání funkcí ####

# vyrobím data framy o jednom sloupci z náh. dat
a = as.data.frame(rnorm(n = 35, mean = 107, sd = 10))
b = as.data.frame(rnorm(n = 30, mean = 105, sd = 10))
c = as.data.frame(rnorm(n = 40, mean = 102, sd = 10))
d = as.data.frame(rnorm(n = 32, mean = 101, sd = 10))

# přejmenuju název sloupce
colnames(a) = c("hodnota")
colnames(b) = c("hodnota")
colnames(c) = c("hodnota")
colnames(d) = c("hodnota")

# doplním typ pro všechny data framy
a$typ = "a"
b$typ = "b"
c$typ = "c"
d$typ = "d"

# slepím po řádcích dohromady
data = rbind(a,b,c,d)
# převedu typ na typ factor
data$typ = as.factor(data$typ)

head(data)

boxplot(data$hodnota ~ data$typ)
# pokud jsou k dispozici nějaká OP, budu je igrorovat
# (vím, že data jsou z normálního rozdělení!)
# (vím i že mají stejný rozptyl)

#  Přehled funkcí  ####
# * Míry variability ####
# ** Bartlettův test ####
# - ověřuje shodu rozptylů
#     - $H_0: \sigma^2_1 = \sigma^2_2 = \sigma^2_3 = \ldots$
#     - $H_A: \neg H_0$
# - předpokladem je normalita dat (a samozřejmě nezávislost a spojitost)

bartlett.test(data$hodnota ~ data$typ)

# ** Leveneův test ####
# - ověřuje shodu rozptylů
#     - $H_0: \sigma^2_1 = \sigma^2_2 = \sigma^2_3 = \ldots$
#     - $H_A: \neg H_0$
# - předpokladem je pouze nezávislost a spojitost

car::leveneTest(data$hodnota ~ data$typ)

# ** Cochranův a Hartleyův test ####
# - také ověřují shodu rozptylů
# - požadují normalitu dat a tzv. vyvážené třízení
#     - vyvážené třízení znamená, že máme přibližně stejné množství dat v každé skupině
# - nebudeme je používat
#
# * Míry polohy ####
# ** ANOVA (analýza rozptylu) ####
# - ověřuje shodu polohy (středních hodnot)
#     - $H_0: \mu_1 = \mu_2 = \mu_3 = \ldots$
#     - $H_A: \neg H_0$
# - předpoklady:
#     - normalita dat
#     - homoskedasticita (shodné rozptyly)
#     - (a samozřejmě nezávislost a spojitost)
# - pokud zamítáme $H_0$ je vyžadována Post-Hoc analýza
#     - pomocí TukeyHSD testu

# Základní ANOVA
# H0: mu1 = mu2 = mu3 = mu4
# HA: ~H0 (negace H0)

res = aov(data$hodnota ~ data$typ)
summary(res)

# Post-Hoc analýza

TukeyHSD(res)

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(data$hodnota)
prumer_vsech

# průměry ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(mean_skup = mean(hodnota))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# ** Kruskalův - Wallisův test ####
# - ověřuje shodu polohy (mediánů)
#     - $H_0: X_{0.5,1} = X_{0.5,2} = X_{0.5,3} = \ldots$
#     - $H_A: \neg H_0$
# - předpoklady:
#     - symetrie dat
#     - (a samozřejmě nezávislost a spojitost)
# - pokud zamítáme $H_0$ je vyžadována Post-Hoc analýza
#     - pomocí Dunnové testu/metody

# Základní KW test
# H0: X0.5,1 = X0.5,2 = X0.5,3 = X0.5,4
# HA: ~H0 (negace H0)

kruskal.test(data$hodnota ~ data$typ)

# Post-Hoc analýza

# altP = T nastavuje p-hodnotu tak,aby se při rozhodování
# o statistické významnosti srovnávala s alfa
# (defaultně: altp = FALSE, pak srovnáváme s alfa/2)

# install.packages("dunn.test")

dunn.test::dunn.test(x = data$hodnota, g = data$typ,
          method = "bonferroni", altp = TRUE)

# počítání efektů

# celkový median
median_vsech = median(data$hodnota)
median_vsech

# mediany ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(median_skup = median(hodnota))

# efekty
efekty$efekt = efekty$median_skup - median_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

#  Příklady ####
# * Příklad 1. ####
# Testujeme nulovou hypotézu µ1 = µ2 = µ3. Bylo zjištěno, že data, která máme k
# dispozici jsou výběry z normálního rozdělení splňující předpoklad homoskedasticity
# (shody rozptylů). Na základě údajů získaných explorační analýzou doplňte tabulku ANOVA
# a vyplývající závěry.
# Obrázek viz sbírka úloh.

n = c(40,40,42)          # rozsahy výběrů
prum = c(300,290,310)    # průměry v jednotlivých skupinách / třídách
s = c(33,34,31)          # směr. odchylky v jednotlivých skup. / třídách

n.total = sum(n)         # celkový rozsah výběrů
k = 3                    # počet tříd
df.b = k-1               # počet stupňů volnosti - meziskupinový
df.e = n.total-k         # počet stupňů volnosti - reziduální

# celkový průměr (pomocí váženého průměru)
prum.total = weighted.mean(x = prum, w = n)
prum.total

# meziskupinový součet čtverců
ss.b = sum(n*(prum - prum.total)^2)
ss.b

# reziduální součet čtverců
ss.e = sum((n - 1)*s^2)
ss.e

# celkový součet čtverců
ss.b + ss.e

# rozptyl mezi skupinami / třídami
ms.b = ss.b/df.b
ms.b

# rozptyl uvnitř skupin / tříd
ms.e = ss.e/df.e
ms.e

# F-poměr
F = ms.b/ms.e
F

# p-hodnota
p = 1 - pf(F,df.b,df.e)
p

# Na hladině významnosti 0,05 zamítáme hypotézu o shodě středních hodnot
# tj. střední hodnoty alespoň jedné dvojice skupin se stat. významně liší.

# odhady skupinových efektů
efekt = prum - prum.total
efekt

# Oproti celkovému průměru vykazuje nejvíce podprůměrné výsledky skupina 2
# (o cca 10 jednotek nižší než celkový průměr). Naopak průměr skupiny 3 je
# o cca 10 jednotek vyšší než celkový průměr. Průměrné výsledky skupiny 1
# odpovídají celkovému průměru.

# * Příklad 2. ####
# 122 pacientů, kteří podstoupili operaci srdce, bylo náhodně rozděleno do tří
# skupin.
# **Skupina 1:** Pacienti dostali 50 % oxidu dusného a 50 % kyslíkové směsi nepřetržitě
# po dobu 24 hodin.
# **Skupina 2:** Pacienti dostali 50 % oxidu dusného a 50 % kyslíkové směsi pouze během
# operace.
# **Skupina 3:** Pacienti nedostali žádný oxid dusný, ale dostali 35-50 % kyslíku po
# dobu 24 hodin.
# Data v souboru kyselina listova.xls odpovídají koncentracím soli kyseliny listové v
# červených krvinkách ve všech třech skupinách po uplynutí 24 hodin ventilace. Ověřte,
# zda pozorované rozdíly mezi koncentracemi soli kyseliny listové jsou statisticky
# významné, tj. zda existuje vliv složení směsi na sledovaný parametr.

kysel = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx", sheet=1)
colnames(kysel) = c("sk1","sk2","sk3")   # přejmenování sloupců
kysel

# převod do standardního datového formátu
kysel.s = stack(kysel)
colnames(kysel.s) = c("hodnoty","skupina")
kysel.s = na.omit(kysel.s)
head(kysel.s)

boxplot(kysel.s$hodnoty ~ kysel.s$skupina)
# Data neobsahují odlehlá pozorování.

# otestujeme normalitu pomocí S.-W. testu
library(dplyr)

kysel.s %>% group_by(skupina) %>%
    summarise(norm.pval = shapiro.test(hodnoty)$p.value)

# Informace potřebné pro nastavení zaokrouhlování

kysel.s %>% group_by(skupina) %>%
    summarise(len = length(hodnoty), st.dev = sd(hodnoty))

# sd zaokrouhlujeme na 3 platné cifry
# sd a míry polohy zaokrouhlujeme na desetiny

# Ověření shody rozptylů
s2 = kysel.s %>% group_by(skupina) %>%
        summarise(var = sd(hodnoty)^2)
s2 # výběrové rozptyly

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího
# rozptylů (<2) nepředpokládáme, že se rozptyly statisticky významně liší

# Předpoklad normality nebyl zamítnut -> Bartlettův test
bartlett.test(kysel.s$hodnoty ~ kysel.s$skupina)

# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů
# (Bartlettův test, x_OBS = 0,878, df = 2, p-hodnota = 0,645).

# Chceme srovnávat stř. hodnoty nezávislých výběrů z normálních rozdělení
# se stejnými rozptyly -> ANOVA
# příkaz aov() vyžaduje data ve standardním datovém formátu

vysledky = aov(kysel.s$hodnoty ~ kysel.s$skupina)
summary(vysledky)

# Na hladině významnosti 0,05 zamítáme hypotézu o shodě středních hodnot
# (ANOVA, p-hodnota<<0,001) -> mnohonásobné porovnávání

# post-hoc analýza
TukeyHSD(vysledky)

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(kysel.s$hodnoty)
prumer_vsech

# průměry ve skupinách
efekty = kysel.s %>% group_by(skupina) %>%
    summarize(mean_skup = mean(hodnoty))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# Považujeme-li vysoký obsah kyseliny listové za pozitivní, pak statisticky
# významně nejlepších výsledků dosáhli pacienti ze skupiny 1 (průměrný obsah
# kys. listové o cca 27 jednotek vyšší než prům. obsah kys. listové v krvi
# všech testovaných pacientů) a statisticky významně nejhorších výsledků
# dosáhli pacienti ze skup. 2 (průměrný obsah kys. listové o cca 26 jednotek
# nižší než průměrný obsah kys. listové v krvi všech testovaných pacientů).
# Obsah kys. listové v krvi pacientů ze skupiny 3
# odpovídá celkovému průměru. Všechny tři skupiny pacientů jsou navzájem dle
# obsahu kys. listové v krvi statisticky významně odlišné.

# * Příklad 3. ####
# Na farmě jsou chována tři plemena králíků. Byl proveden pokus kralici.xls, jehož cílem
# bylo zjistit, zda i když chováme a vykrmujeme všechny králíky po stejnou dobu a za
# stejných podmínek, existuje statisticky významný (průkazný) rozdíl mezi plemeny v
# hmotnostech králíků. Ověřte.

kralici = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx", sheet=2)
colnames(kralici) = c("viden","cesky","kalif")   # přejmenování sloupců
kralici

# převod do standardního datového formátu
kralici.s = stack(kralici)
colnames(kralici.s) = c("hodnoty","skupina")
kralici.s = na.omit(kralici.s)
head(kralici.s)

boxplot(kralici.s$hodnoty ~ kralici.s$skupina)
# data obsahojí OP

# Odstranění odlehlého pozorování
pom = boxplot(kralici.s$hodnoty ~ kralici.s$skupina, plot = FALSE)
pom$out

kralici.s$hodnoty.bez = kralici.s$hodnoty
kralici.s$hodnoty.bez[kralici.s$hodnoty.bez %in% pom$out]=NA

# Krabicový graf
boxplot(kralici.s$hodnoty.bez ~ kralici.s$skupina)

library(dplyr)

kralici.s %>% group_by(skupina) %>%
    summarise(norm.pval = shapiro.test(hodnoty.bez)$p.value)

# Na hladině významnosti 0,05 nezamítáme předpoklad normality.

# Informace potřebné pro nastavení zaokrouhlování
kralici.s %>% group_by(skupina) %>%
    summarize(len = sum(!is.nan(hodnoty.bez)),
              sd = sd(hodnoty.bez, na.rm = TRUE))

# sd zaokrouhlujeme na 2 platné cifry
# sd a míry polohy zaok. na setiny (sjednocení napříč druhy králíků)

# Ověření shody rozptylů
s2 = kralici.s %>% group_by(skupina) %>%
        summarize(var = sd(hodnoty.bez, na.rm = TRUE)^2)
s2

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího rozpt.
# (blízký 2, avšak rozsah výběrů < 30) je těžší odhadnout, zda lze
# předpokládat shodu rozptylů. Rozhodnout nám pomůže test.

# Předpoklad normality nebyl zamítnut -> Bartlettův test
bartlett.test(kralici.s$hodnoty.bez ~ kralici.s$skupina)

# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů
# (Bartlettův test, x_OBS = 3,1, df = 2, p-hodnota = 0,217).

# Chceme srovnávat stř. hodnoty nezávislých výběrů z normálních
# rozdělení se stejnými rozptyly -> ANOVA
# příkaz aov() vyžaduje data ve standardním datovém formátu

vysledky = aov(kralici.s$hodnoty.bez ~ kralici.s$skupina)
summary(vysledky)

# Na hladině významnosti 0,05 zamítáme hypotézu o shodě středních hodnot
# (p-hodnota<<0,001, ANOVA) -> mnohonásobné porovnávání

# post-hoc analýza
TukeyHSD(vysledky)

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(kralici.s$hodnoty.bez, na.rm = TRUE)
prumer_vsech

# průměry ve skupinách
efekty = kralici.s %>% group_by(skupina) %>%
    summarize(mean_skup = mean(hodnoty.bez, na.rm = TRUE))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# * Příklad 4. ####
# Soutěž o nejlepší jakost výrobků obeslali čtyři výrobci A, B, C, D celkem 66 výrobky.
# Porota sestavila pořadí (uvedeno pouze pořadí výrobku od nejlepšího k nejhoršímu), jež
# je uvedené v souboru jakost.xls. Na základě uvedených údajů posuďte, zda původ výrobků
# má vliv na jeho jakost.

jakost.s = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx", sheet = 3)
colnames(jakost.s) = c("poradi", "skupina")   # přejmenování sloupců
head(jakost.s)
# data již jsou v standardním formátu

boxplot(jakost.s$poradi ~ jakost.s$skupina)

# Ověření normality nemá smysl provádět - z povahy jde o diskr. data-pořadí

# Informace potřebné pro nastavení zaokrouhlování
jakost.s %>% group_by(skupina) %>%
    summarize(len = length(poradi),
              sd = sd(poradi))

# sd zaokrouhlujeme na 2 platné cifry
# sd a míry polohy zaokrouhlujeme na celá čísla

# Ověření shody rozptylů
s2 = jakost.s %>% group_by(skupina) %>% summarize(var = sd(poradi)^2)
s2

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího
# rozptylů (<2) ze předpokládat shodu rozptylů.
# (Kruskalův - Wallisův test má větší sílu testu, jsou-li data homosk.)

# Jde o "pořadová" data, nemá smysl uvažovat o předpokladu norm.
# -> Leveneův test
car::leveneTest(jakost.s$poradi ~ jakost.s$skupina)
# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů
# (Leveneho test, x_OBS = 0,4, df_num = 3, df_denom = 62, p-hodnota = 0,750)

# Ověření symetrie

jakost.s %>% group_by(skupina) %>%
    summarize(sikmost = moments::skewness(poradi),
              test.pval = lawstat::symmetry.test(poradi,boot=FALSE)$p.value)

# Chceme srovnávat mediány nezávislých výběrů -> Kruskalův-Wallisův test
kruskal.test(jakost.s$poradi ~ jakost.s$skupina)

# Na hladině významnosti 0,05 nelze zamítnout hypotézu o shodě mediánů
# (Kruskalův-Wallisův test, x_OBS = 3,7, df = 3, p-hodnota=0,295).
# Tj. statisticky významné rozdíly mezi výrobci (z hlediska pořadí
# výrobků v soutěži) neexistují.

# * Příklad 5. ####
# Byl sledován vliv tří preparátů na srážlivost krve. Kromě jiných ukazatelů byl
# zjišťován tzv. trombinový čas. Údaje o 42 sledovaných osobách jsou zaznamenány v
# souboru trombin.xls. Závisí velikost trombinového času na tom, jaký byl použit
# preparát?

trombin.s = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx",
                               sheet=4, skip = 1)
colnames(trombin.s) = c("hodnoty","skupina")   # přejmenování sloupců

head(trombin.s)
# data jsou již ve standardním formátu

# explorační analýza - ověření OP
boxplot(trombin.s$hodnoty ~ trombin.s$skupina)
# neobsahuje OP

# ověření normality
library(dplyr)

trombin.s %>% group_by(skupina) %>%
    summarize(norm.pval = shapiro.test(hodnoty)$p.value)

# Na hladině významnosti 0,05 zamítáme předpoklad normality (u Ačka)

# Informace potřebné pro nastavení zaokrouhlování

trombin.s %>% group_by(skupina) %>%
    summarize(len = length(hodnoty), stdev = sd(hodnoty))

# sd zaokrouhlujeme na 2 platné cifry
# sd a míry polohy zaokrouhlujeme na setiny (sjednocení napříč skupinami)

# Ověření shody rozptylů (není nutné - stejně musíme použít KW)
s2 = trombin.s %>% group_by(skupina) %>%
        summarize(var = sd(hodnoty)^2)
s2

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího
# rozptylů (>>2) nelze předpokládat shodu rozptylů.

# Předpoklad normality byl zamítnut -> Leveneho test

#trombin.s$skupina = as.factor(trombin.s$skupina)

car::leveneTest(trombin.s$hodnoty ~ trombin.s$skupina)

# předpoklad homoskedasticity byl zamítnut

# Ověření symetrie
trombin.s %>% group_by(skupina) %>%
  summarize(sikmost = moments::skewness(hodnoty),
            test.pval = lawstat::symmetry.test(hodnoty, boot=FALSE)$p.value)
# nezamítáme přepoklad symetrie dat

# Chceme srovnávat mediány nez. výběrů, která nemají norm. rozdělení
# -> Kruskalův - Wallisův test

kruskal.test(trombin.s$hodnoty,trombin.s$skupina)
# Na hladině významnosti 0,05 zamítáme hypotézu o shodě mediánů
# Tj. trombinový čas je statisticky významně
# ovlivněn preparátem. -> mnohonásobné porovnávání

# altP = T nastavuje p-hodnotu tak,aby se při rozhodování
# o statistické významnosti srovnávala s alfa
# (defaultně: altp = FALSE, pak srovnáváme s alfa/2)

dunn.test::dunn.test(trombin.s$hodnoty,trombin.s$skupina,
          method = "bonferroni", altp = TRUE)

# počítání efektů
library(dplyr)

# celkový průměr
median_vsech = median(trombin.s$hodnoty)
median_vsech

# průměry ve skupinách
efekty = trombin.s %>% group_by(skupina) %>%
    summarize(median_skup = median(hodnoty))

# efekty
efekty$efekt = efekty$median_skup - median_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# * Příklad 6. (více skupin) ####
# Co se Sněhurka dostala k sedmi trpaslíkům vycítila příležitost nemalého výdělku.
# Trpaslíci Sněhurce v podstatě zobou z ruky a veškeré vydolované zlato jí ihned
# předávají. Sněhurce však ani toto úplně nestačí a má pocit, že by mohla z trpaslíků
# benefitovat více. Proto si začla zaznamenávat kolik kilogramů zlata denně od každého z
# trpaslíků obdrží (snehurka.xlsx). Ověřte, zda se trpaslíci liší v množství vytěženého
# zlata, pokud ano sestave homogenní skupiny z hlediska vytěženého zlata.

zlato = readxl::read_excel("./CV12/data/snehurka.xlsx")
head(zlato)
# data jsou ve standardním dtovém formátu

boxplot(zlato$hodnota ~ zlato$typ)
# data neobsahují OP

# ověření normality
library(dplyr)

zlato %>% group_by(typ) %>%
    summarize(p.hodnota = shapiro.test(hodnota)$p.value)

# Na hladině významnosti 0,05 ne zamítáme předpoklad normality

# Předpoklad normality nebyl zamítnut -> Bartlettův test
bartlett.test(zlato$hodnota ~ zlato$typ)

# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů

# ANOVA
vysledky = aov(zlato$hodnota ~ zlato$typ)
summary(vysledky)
# Zamítáme předpoklad o shodě
# -> existují stat. významné rozdíly ve středních hodnotách

# POST-HOC
res = TukeyHSD(vysledky)[[1]]
res

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(zlato$hodnota)
prumer_vsech

# průměry ve skupinách
efekty = zlato %>% group_by(typ) %>%
    summarize(mean_skup = mean(hodnota))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty.s = efekty %>% arrange(desc(efekt))
efekty.s


#########################################################
#####  Main file: estimate radiation, conductance,  #####
#####  photosynthesis, and evapotranspiration with  #####
#####             process based model               #####
#########################################################

# Load model functions
source('eco_model.r')
library(pracma)

# Load data
dat <- read.table('./data/TdrTsoilWindLaiPrecParTaVpdMay2001-Daytime.txt')
names(dat) <- c('Month', 'Day','Hour','Minute','Tdr','Tsoil','Wind','Lai','Prec','Par','Ta','Vpd')
dat$Year <- 2001

# Convert VPD from kPa to Pa
dat$Vpd <- dat$Vpd*1000

# Define global variables and model parameters
define_global_variables()

# Calculate solar zenith, elevation, azimuth, and declination angles
sun <- compute_sun_angles(LATI, LONGI, dat$Year, dat$Month, dat$Day, dat$Hour, dat$Minute)

# Calculate top of canopy diffuse/direct components of PAR and NIR
rad <- compute_toc_down_rad(dat$Par, sun$zenith, sun$jday)

# calculate sunlit and shaded components of LAI
i <- seq(from=0, to=89, by=1)
kb <- sqrt(x^2 + tan(i*pi/180)^2 / (x + 1.774 * (x+1.182)^-0.733))
beer <- function(lai, kb, omega) exp(-kb * omega * lai) # Beer's law
trans_D <- outer(dat$Lai, kb, beer, omega=omega) # apply function across all LAIs and angles
trans_d <- apply(trans_D, 1, function(trans_D, i) trapz(i, 2*trans_D*sin(i*pi/180.0)*cos(i*pi/180.0)*(pi/180)), i=i) # integrate across all angles

Kd <- -log(trans_d)/dat$Lai
Kb <- omega * sqrt(x^2 + tan(sun$zenith)^2) / (x + 1.774*(x+1.182)^-0.733)

sunlit_lai <- (1 - exp(-Kb*dat$Lai)) / Kb
shaded_lai <- dat$Lai - sunlit_lai

# Compute canopy shortwave radiation
canopy_shortwave <- compute_canopy_intercepted_shortwave_rad(rad$par_D,
                                                             rad$par_d,
                                                             rad$nir_D,
                                                             rad$nir_d,
                                                             dat$Lai,
                                                             Kb,
                                                             Kd)

# Compute canopy longwave radiation
canopy_longwave <- compute_longwave_rad(dat$Ta, dat$Tsoil, dat$Vpd, rad$cloud)

# Compute net radiation
canopy_net_rad <- compute_canopy_net_rad(canopy_shortwave,
                                         canopy_longwave,
                                         rad,
                                         sunlit_lai,
                                         shaded_lai,
                                         Kb,
                                         Kd)

# Estimate aerodynamic resistance and conductance
ra <- canopy_aerodynamic_resistance(dat$Wind, hs, h2)
ra[dat$Wind <= 0] <- 1.0 / g1_blayer
ga <- 1/ra

# Compute soil resistance
rs_u <- compute_soil_surface_resistance(dat$Tdr)
ra_u <- ra

# Estimate photosynthesis parameters
psn_para <- compute_psn_parameters(dat$Ta, Kb, sunlit_lai, shaded_lai)
fsoil_theta <- 1.0

# Calcuate photosynthesis and stomatal conductance for sunlit leaves
sunlit <- 1;
psn_sunlit <- compute_bwb_farq_psn(psn_para,
                                   canopy_shortwave$sunlit_apar,
                                   dat$Ta,
                                   dat$Vpd,
                                   fsoil_theta,
                                   sunlit)

out <- canopy_bwb_stomatal_conductance(psn_sunlit, dat$Ta, m, dat$Vpd)
gs_sunlit <- out$gs
gc_sunlit <- out$gc

rs_sunlit <- 1/gs_sunlit
rs_sunlit[gs_sunlit<=0] <- 1e6

# Calculate photosynthesis and stomatal conductance for shaded leaves
sunlit <- 0
psn_shaded <- compute_bwb_farq_psn(psn_para,
                                   canopy_shortwave$shaded_apar,
                                   dat$Ta,
                                   dat$Vpd,
                                   fsoil_theta,
                                   sunlit)

out <- canopy_bwb_stomatal_conductance(psn_shaded, dat$Ta, m, dat$Vpd)
gs_shaded <- out$gs
gc_shaded <- out$gc

rs_shaded <- 1/gs_shaded
rs_shaded[gs_shaded<=0] <- 1e6

# Calculate evapotranspiration using Penman-Monteith model
ET_sunlit <- penman_monteith(dat$Ta,
                             canopy_net_rad$Rnet_sunlit,
                             gs_sunlit,
                             ga,
                             dat$Vpd)

ET_shaded <- penman_monteith(dat$Ta,
                             canopy_net_rad$Rnet_shaded,
                             gs_shaded,
                             ga,
                             dat$Vpd)

ET_understory <- penman_monteith(dat$Ta,
                                 canopy_net_rad$Rnet_floor,
                                 1/rs_u,
                                 1/ra_u,
                                 dat$Vpd)

S <- dat$Tdr / porosity

Exfil_soil <- compute_potential_exfiltration(S,
                                             soil_depth,
                                             Ksat,
                                             m_z,
                                             p1,
                                             p2,
                                             p_0,
                                             porosity)

ET_understory <- pmin(Exfil_soil, ET_understory)

# Add outputs to data frame
dat$apar <- canopy_shortwave$sunlit_apar*sunlit_lai +
  canopy_shortwave$shaded_apar*shaded_lai
dat$rnet <- canopy_net_rad$Rnet_stand
dat$psn <- (psn_sunlit*sunlit_lai + psn_shaded*shaded_lai)*0.012
dat$A <- psn_sunlit*sunlit_lai + psn_shaded*shaded_lai # um/m^2/s
dat$gc <- 1000000*(gc_sunlit*sunlit_lai + gc_shaded*shaded_lai) / (22.4/1000.0) # um/m^2/s
dat$et <- ET_sunlit*sunlit_lai + ET_shaded*shaded_lai + ET_understory


### R script to demonstrate RFF version of time delay GP model

## Define imagined data generating process and draw a mock dataset

Nobs_quasar_image_A <- 150
observation_times_quasar_image_A <- sort(runif(Nobs_quasar_image_A,0,10))
Nobs_quasar_image_B <- 75
observation_times_quasar_image_B <- sort(runif(Nobs_quasar_image_B,0,10))

true_time_delay <- 1
true_GP_bandwidth <- 1
true_GP_scale <- 0.5
true_expected_counts_quasar_image_A <- 40
true_expected_counts_quasar_image_B <- 30
true_expected_background_counts <- 5

true_cov_matrix <- true_GP_scale^2*exp(-true_GP_bandwidth*as.matrix(dist(sort(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)),upper = TRUE,diag = TRUE))^2)
true_cov_matrix <- true_cov_matrix+diag(Nobs_quasar_image_A+Nobs_quasar_image_B)*0.0001

library(MASS)
true_latent_curve <- exp(mvrnorm(1,rep(0,Nobs_quasar_image_A+Nobs_quasar_image_B),true_cov_matrix))
plot(true_latent_curve)

true_latent_curve_quasar_image_A <- true_latent_curve[which(sort.list(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)) %in% 1:(Nobs_quasar_image_A))]
true_latent_curve_quasar_image_B <- true_latent_curve[which(!(sort.list(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)) %in% 1:(Nobs_quasar_image_A)))]
observed_counts_quasar_image_A <- rpois(Nobs_quasar_image_A,true_expected_background_counts+true_expected_counts_quasar_image_A*true_latent_curve_quasar_image_A)
observed_counts_quasar_image_B <- rpois(Nobs_quasar_image_B,true_expected_background_counts+true_expected_counts_quasar_image_B*true_latent_curve_quasar_image_B)

plot(observation_times_quasar_image_A,observed_counts_quasar_image_A,ylim=c(0,50))
points(observation_times_quasar_image_B,observed_counts_quasar_image_B,col="red")

## Construct Bayesian model with RFF approximation of latent Gaussian process and prepare derivatives with PyTorch

library(randtoolbox)
library(reticulate)

k_RFF <- 500 # Number of RFF bases (will use sin&cos orthogonal pairs)
omega_qmc_RFF <- t(qnorm(halton(k_RFF,1)))

torch <- import("torch")
np <- import("numpy")
Variable <-  torch$autograd$Variable

omega_qmc_RFF <- torch$from_numpy(omega_qmc_RFF)$float()
observation_times_quasar_image_A <- torch$from_numpy(np$array(observation_times_quasar_image_A))$float()
observation_times_quasar_image_B <- torch$from_numpy(np$array(observation_times_quasar_image_B))$float()

observed_counts_quasar_image_A <- torch$from_numpy(np$array(observed_counts_quasar_image_A))$float()
observed_counts_quasar_image_B <- torch$from_numpy(np$array(observed_counts_quasar_image_B))$float()

time_delay <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_GP_bandwidth <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_GP_scale <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_expected_counts_quasar_image_A <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_expected_counts_quasar_image_B <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_expected_background_counts <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
RFF_slopes <- Variable(torch$ones(as.integer(2*k_RFF)),requires_grad=TRUE)$float()

optimizer <- torch$optim$Adam(list(time_delay,log_GP_bandwidth,log_GP_scale,log_expected_counts_quasar_image_A,log_expected_counts_quasar_image_B,log_expected_background_counts,RFF_slopes),lr=0.05)

for (j in 1:200) {
GP_bandwidth <- torch$exp(log_GP_bandwidth)
GP_scale <- torch$exp(log_GP_bandwidth)
expected_background_counts <- torch$exp(log_expected_background_counts)

omega_QMC_RFF_scaled <- torch$mul(omega_qmc_RFF,GP_bandwidth$unsqueeze(as.integer(1)))
RFFprojections_A <- torch$matmul(observation_times_quasar_image_A$unsqueeze(as.integer(1)),omega_QMC_RFF_scaled)
RFFprojections_B <- torch$matmul(observation_times_quasar_image_B$add(time_delay)$unsqueeze(as.integer(1)),omega_QMC_RFF_scaled)
RFFs_A <- torch$cat(c(torch$sin(RFFprojections_A),torch$cos(RFFprojections_A)),as.integer(1))
RFFs_B <- torch$cat(c(torch$sin(RFFprojections_B),torch$cos(RFFprojections_B)),as.integer(1))
latent_GP_A <- torch$matmul(RFFs_A,RFF_slopes)$mul(GP_scale$mul(1.0/k_RFF))
latent_GP_B <- torch$matmul(RFFs_B,RFF_slopes)$mul(GP_scale$mul(1.0/k_RFF))

latent_signal_A <- torch$exp(latent_GP_A$add(log_expected_counts_quasar_image_A))
latent_signal_B <- torch$exp(latent_GP_B$add(log_expected_counts_quasar_image_B))
obs_signal_A <- latent_signal_A$add(expected_background_counts)
obs_signal_B <- latent_signal_B$add(expected_background_counts)

likelihood_fn_A <- torch$distributions$Poisson(obs_signal_A)
likelihood_A <- likelihood_fn_A$log_prob(observed_counts_quasar_image_A)
likelihood_fn_B <- torch$distributions$Poisson(obs_signal_B)
likelihood_B <- likelihood_fn_B$log_prob(observed_counts_quasar_image_B)
prior_slopes_fn <- torch$distributions$Normal(0,1)
prior_slopes <- prior_slopes_fn$log_prob(RFF_slopes)
prior_time_delay_fn <- torch$distributions$Normal(0,1)
prior_time_delay <- prior_time_delay_fn$log_prob(time_delay)
prior_log_GP_bandwidth_fn <- torch$distributions$Normal(0,1)
prior_log_GP_bandwidth <- prior_log_GP_bandwidth_fn$log_prob(log_GP_bandwidth)
prior_log_GP_scale_fn <- torch$distributions$Normal(0,1)
prior_log_GP_scale <- prior_log_GP_scale_fn$log_prob(log_GP_scale)
prior_log_expected_background_counts_fn <- torch$distributions$Normal(0,1)
prior_log_expected_background_counts <- prior_log_expected_background_counts_fn$log_prob(log_expected_background_counts)

posterior_log_prob_part_i <- likelihood_A$sum()
posterior_log_prob_part_ii <- torch$add(posterior_log_prob_part_i,likelihood_B$sum())
posterior_log_prob_part_iii <- torch$add(posterior_log_prob_part_ii,prior_slopes$sum())
posterior_log_prob_part_iv <- torch$add(posterior_log_prob_part_iii,prior_time_delay)
posterior_log_prob_part_v <- torch$add(posterior_log_prob_part_iv,prior_log_GP_bandwidth)
posterior_log_prob_part_vi <- torch$add(posterior_log_prob_part_v,prior_log_expected_background_counts)
posterior_log_prob <- torch$add(posterior_log_prob_part_vi,prior_log_GP_scale)$mul(-1)

optimizer$zero_grad()
if (j==1) {posterior_log_prob$backward(retain_graph=TRUE)}
else {posterior_log_prob$backward()}
optimizer$step()
print(posterior_log_prob,"\n")

}

latent_fn_all_Aobs <- exp(c(as.numeric(latent_GP_A$detach()$numpy()),as.numeric(latent_GP_B$detach()$numpy()))+as.numeric(log_expected_counts_quasar_image_A$detach()$numpy()))+as.numeric(expected_background_counts$detach()$numpy())
relative_obs_times_to_A <- c(as.numeric(observation_times_quasar_image_A$detach()$numpy()),as.numeric(observation_times_quasar_image_B$detach()$numpy())+as.numeric(time_delay$detach()$numpy()))
latent_fn_all_Bobs <- exp(c(as.numeric(latent_GP_A$detach()$numpy()),as.numeric(latent_GP_B$detach()$numpy()))+as.numeric(log_expected_counts_quasar_image_B$detach()$numpy()))+as.numeric(expected_background_counts$detach()$numpy())

layout(1:2)
plot(observation_times_quasar_image_A$detach()$numpy(),observed_counts_quasar_image_A$detach()$numpy(),xlim=c(0,10),ylim=c(0,125),xlab='Observation Times A',ylab="Observed Counts A")
lines(sort(relative_obs_times_to_A),latent_fn_all_Aobs[sort.list(relative_obs_times_to_A)],col="red")

plot(observation_times_quasar_image_B$detach()$numpy(),observed_counts_quasar_image_B$detach()$numpy(),xlim=c(0,10),ylim=c(0,125),xlab='Observation Times B',ylab="Observed Counts B")
lines(sort(relative_obs_times_to_A)-as.numeric(time_delay$detach()$numpy()),latent_fn_all_Bobs[sort.list(relative_obs_times_to_A)],col="red")

cat("True time delay = ",true_time_delay,"\n",sep="")
cat("Estimated time delay = ",as.numeric(time_delay$detach()$numpy()),"\n",sep="")


rangeExpand <- function(text) {
  lst <- gsub("(\\d)-", "\\1:", unlist(strsplit(text, ",")))
  unlist(sapply(lst, function (x) eval(parse(text=x))), use.names=FALSE)
}

rangeExpand("-6,-3--1,3-5,7-11,14,15,17-20")
 [1] -6 -3 -2 -1  3  4  5  7  8  9 10 11 14 15 17 18 19 20


#################################
# Define the model
#################################
model = function(t,y,params) {
	with(as.list(c(y,params)), {

		# Fraction of empty patches converted into the different states following a disturbance
		pB = alphab*(B+M)
		pT = alphat*(T+M)
		pM = pB*pT
		pB_ = pB*(1-pT)
		pT_ = pT*(1-pB)

		# Regeneration state
		R = 1 - B - T - M

		# Differential equations describing the dynamics of the state variables
		dBdt = pB_*R + theta*(1-thetat)*M - betat*(T+M)*B - eps*B
		dTdt = pT_*R + theta*thetat*M - betab*(B+M)*T - eps*T
		dMdt = pM*R + betab*(B+M)*T + betat*(T+M)*B - theta*M - eps*M
		list(c(dBdt,dTdt,dMdt))
		})
	}

#################################
# Local stability
#################################
get_eq = function(params) {

	library(rootSolve)
	library(deSolve)

	# Initial conditions
	y = c(B = 0.25, T = 0.25, M = 0.25)

	# Get the equilibrium
	eq0 = ode(y=y, func=model, parms=params,times = seq(0,10,0.1))
	eq = stode(y=eq0[101,2:4], func=model, parms=params, positive = TRUE)

	return(eq$y)
}
#################################
# Wrapper to collect parameters for a given set of environmental conditions
#################################
logit_reverse <- function(x) exp(x)/(1+exp(x))

get_pars = function(ENV1,ENV2,params,int) {

	logit_alphab 	= params["ab0",1] + params["ab1",1]*ENV1 + params["ab2",1]*ENV2 + params["ab3",1]*ENV1^2 + params["ab4",1]*ENV2^2
	logit_alphat 	= params["at0",1] + params["at1",1]*ENV1 + params["at2",1]*ENV2 + params["at3",1]*ENV1^2 + params["at4",1]*ENV2^2
	logit_betab 	= params["bb0",1] + params["bb1",1]*ENV1 + params["bb2",1]*ENV2 + params["bb3",1]*ENV1^2 + params["bb4",1]*ENV2^2
	logit_betat 	= params["bt0",1] + params["bt1",1]*ENV1 + params["bt2",1]*ENV2 + params["bt3",1]*ENV1^2 + params["bt4",1]*ENV2^2
	logit_theta		= params["th0",1] + params["th1",1]*ENV1 + params["th2",1]*ENV2 + params["th3",1]*ENV1^2 + params["th4",1]*ENV2^2
	logit_thetat	= params["tt0",1] + params["tt1",1]*ENV1 + params["tt2",1]*ENV2 + params["tt3",1]*ENV1^2 + params["tt4",1]*ENV2^2
	logit_eps 		= params["e0",1]  + params["e1",1]*ENV1 + params["e2",1]*ENV2  + params["e3",1]*ENV1^2 + params["e4",1]*ENV2^2

	alphab = 1-(1-logit_reverse(logit_alphab))^int
	alphat = 1-(1-logit_reverse(logit_alphat))^int
	betab = 1-(1-logit_reverse(logit_betab))^int
	betat = 1-(1-logit_reverse(logit_betat))^int
	theta = 1-(1-logit_reverse(logit_theta))^int
	thetat = 1-(1-logit_reverse(logit_thetat))^int
	eps = 1-(1-logit_reverse(logit_eps))^int

	return(c(alphab = alphab, alphat = alphat, betab = betab, betat = betat, theta = theta, thetat = thetat, eps = eps))

}

#################################
# SOLVE STM
#################################

solve_stm <- function(clim,pars){

	# Scale the data to match the scaling of the parameters
	T = clim$tp
	PP = clim$pp
  # Loop around all cells
	pSTM = matrix(nr = nrow(clim), nc = 3)
	  for(x in 1:nrow(clim)) {
			print(x)
			if(all(T[x] != -9999 && PP[x] != -9999 && !is.na(T[x]) && !is.na(PP[x]))){
				local_pars = get_pars(T[x],PP[x],pars,int=5)
				pSTM[x,] = get_eq(local_pars)
			} else {
				pSTM[x,] <- rep(NA,3)
			}
	  }

	pSTM <- as.data.frame(pSTM)
  names(pSTM) <- c("B","T","M")

  return(pSTM)
}


#хипотези
#имаме случайна величина X, която е с някакво разпределение, но не знаем някой параметър tita
#формулираме хипотеза Ho: tita = нещо срещу алтернатива Н1:tita =/= нещо / Н1:tita < нещо / Н1:tita > нещо
#грешка от първи род: хипотезата е вярна, но ние я отхвърляме
#грешка от втори род: хипотезата е грешна, но ние я приемаме
#alpha-ниво на значимост -> най-голята вероятност, с която можем да допуснем грешка от първи род
#p-value - измерва вероятността за близост на измерваното разпределение до приетата за вярна нулева хипотеза
#ако p-value е по-малко от 1 - alpha (1 - alpha в случая е малко число - възможност за грешка(0.05) ) -> отхвърляме нулевата хипотеза (значи е вярна алтернативана)
#ако p-value е по-голямо от 1 - alpha -> не можем да отхвърлим нулевата хипотеза (значи е вярна хипотезата)

#сравняване на пропорции - проверява дали пропорцията на една нормално разпределена група отговаря на пропорцията в друга нормално разпределена група
#функция prop.test() -> с conf.level може да се зададе ниво на значимост (по подразбиране е 0.95), alternative = c("two.sided", "less", "greater") - H1: =/= или < или >
#подава се вектор с брой успехи или двумерна матрица с две колони, задаваща броя успехи и неуспехи
sexsmoke<-matrix(c(70,120,65,140),ncol=2,byrow=T)
rownames(sexsmoke)<-c("male","female")
colnames(sexsmoke)<-c("smoke","nosmoke")
#H0: двете групи имат еднакви пропорции
#H1: двете групи нямат еднакви пропорции
prop.test(sexsmoke) #p-value е по-голямо от 0.05, значи отхвърляме нулевата хипотеза -> нямат еднакви пропорции
prop.test(c(70,65),c(190,205)) # Идентично изпълнение
prop.test(c(70,65),c(190,205),conf.level=0.99) # смяна на нивото на значимост
prop.test(c(70,65),c(190,205),c(0.33,0.33)) # предварително заложени пропорциии

#t-тест - при анализ на очакването за извадка с неизвестни очкаване(mu) и средно отклонение(sigma)
#функцията t.test(x, mu, alternative = c("two.sided", "less", "greater")) проверява хипотезата  H0: очакването да е равно на mu срещу алтернативата H1: =/= или < или >
mpg= c(11.4,13.1,14.7,14.7,15.0, 15.5,15.6,15.9,16.0,16.8)
#пресмятане на ръка, което не е нужно
xbar=mean(mpg); s=sd(mpg); n=length(mpg)
SE=s/sqrt(n)
est=(xbar-17)/SE
pt(est,df=n-1, lower.tail=T)
#автоматично пресмятане
#H0: mu = 17
#H1: mu < 17
t.test(mpg,mu=17,alt="less") #p-value e много по-мално от 0.05, значи не можем да отхвърлим нулевата хипотеза -> е вярно че очакването на тази извадка е 17

#тестове с медиани - когато голяма част от измерените стойности са струпани в едния край, но има и няколко в другия край, статистическото очакване (mean(xi)) ще даде неточни резултати, затова ползваме медина вместо очакване
#функцията wilcox.test(x,y,alternative) се използва, когато се оценява медианата (а не очакването)
#също в повторни измервания X и Y , когато се сравняват данните поелементно
#H0: данните са еднакви X = Y
#H1: X=/=Y или X<Y или X>Y

#хи-квадрат тест - ползва се за проверяване на goodness of fit и зависимост на случайни величини
#функцията chisq.test()
#goodness of fit: chisq.test(x, p , rescale.p = TRUE) -> проверява х (вектор от вероятности за наблюдавани стойности), колко са близо по разпределение към p (вектор от други наблюдавани или теоретични вероятности), сбора на p трябва да равен на 1, ако не е rescale.p = TRUE (или се добавя още една стойност, съдържаща 1 - sum(p))
#колкото по-голямо е p-value -> толкова по-добър е goodness of fit-a
#зависимост на случайни велични: chisq.test(matrix) -> matrix съдържа два реда със стойностите на величините, които искаме да проверим дали са завсими
#H0: величините са независими
#Н1: величините са зависими
#ако p-value е по-малко от 1-alpha (alpha - ниво на значимост), значи отхвърляме нулевата хипотеза -> величините са зависими
#ако p-value е по-голямо от 1-alpha (alpha - ниво на значимост), значи не можем да отхвърлиме нулевата хипотеза -> величините са независими

#f-тест - когато диспериите на две извадки са значително различни sigma1^2 и sigma2^2
#H0: sigma1^2 = sigma2^2
#H1: sigma1^2 < sigma2^2 или sigma1^2 > sigma2^2 или sigma1^2 =/= sigma2^2
#функция var.test()
#???
F = 3^2 / 2^2 # F - statistics
df(F,9,14) # p-value
qf(0.975,9,14)

#quantil-quantil plot - графичен метод за определяне дали две извадки произхождат от множества с еднакви разпределения
#функция qqplot(x,y) - ако искаме да сравним разппределението на извадките x и y
#финкция qqnorm(x) - ако искаме да сравним извадката х с нормално разпределение
y <- rnorm(2000)*4
qqnorm(y) #сравняваме y (стандартно нормално разпределено) с нормално разпределение
qqline(y, col = 2,lwd=2,lty=2) #ако точните много се изкривяват от тази права, значи не са еднакво разпределени

y <- rnorm(2000)*4 - 4
qqnorm(y)
qqline(y, col = 2,lwd=2,lty=2)

y <- rexp(2000,1)
qqnorm(y) #сравняваме у (експоненциално разпределение) с нормално разпределение
qqline(y, col = 2,lwd=2,lty=2) #точките много се разминават от правата -> доказателство, че не са еднакво разпределени

x <- rpois(2000,1)
y <- rbinom(2000,size=10,prob=1/10)
qqplot(x,y) #сравняваме х(поасоново разпределение) с у(биномно разпределение)
qqline(y, col = 2,lwd=2,lty=2)

y <- rbinom(2000,size=10,prob=1/2)
qqplot(x,y)
qqline(y, col = 2,lwd=2,lty=2)

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

#01
library("MASS")
q = quine
tb=table(q$Eth,q$Sex)
prop.test(tb, correct=FALSE)

#02
x=c(170, 167, 174, 179, 179, 156, 163, 156, 187, 156, 183, 179, 174, 179, 170, 156, 187, 179, 183, 174, 187, 167, 159, 170, 179)
#H0: m = 170 and H1:m < 170
t.test(x,mu=170,alt="less")
#H0: m=170 and H1:m > 170
t.test(x,mu=170,alt="greater")

#03
x=c(7.65, 7.60 ,7.65, 7.70, 7.55, 7.55, 7.40, 7.40, 7.50, 7.50)
m=7.5
t.test(x,mu=m,alt="two.sided")

#04
x = c(12.8,3.5,2.9,9.4,8.7,0.7,0.2,2.8,1.9,2.8,3.1,15.8)
#H0: медианата = 5
#H1: медианата > 5
wilcox.test(x,mu=5.0,alt="greater")

#05
library("MASS")
tbl = table(survey$Smoke, survey$Exer)
chisq.test(tbl)

#По-добра оценка
ctbl = cbind(tbl[,"Freq"], tbl[,"None"] + tbl[,"Some"])
chisq.test(ctbl)

#06
#вариант 1
n=567
k = seq(0,5)
nk=c(229,221,93,35,7,1)
lambda = 0.93
nn=nk/n
pk = dpois(k,lambda)
pk[7] = 1 - sum(pk)
chi2 = sum(((nk - n*pk)^2)/n*pk)
pchisq(chi2,df = 5, lower.tail = FALSE)

#вариант 2
n=c(229,221,93,35,7,1)
nn=n/sum(n)
p=dpois(0:4,0.93)
p[6] = 1 - sum(p)
chisq.test(nn,p = p)

#07
a = rnorm(100,0,1)
b = rnorm(100,1,1)
var.test(a,b)


matriceH <- matrix(0, ncol=400, nrow=400)

for(i in 1:20){
	for(j in 1:20){
		matriceH[((i - 1) * 20 + j), ((i - 1) * 20 + j)] <- 2 #Signe dans l'hamiltonien
		if(i > 1){
			matriceH[((i - 1) * 20 + j), ((i - 2) * 20 + j)] <- -0.5
		}
		if(i < 20){
			matriceH[((i - 1) * 20 + j), (i * 20 + j)] <- -0.5
		}
		if(j > 1){
			matriceH[((i - 1) * 20 + j), ((i - 1) * 20 + j - 1)] <- -0.5
		}
		if(j < 20){
			matriceH[((i - 1) * 20 + j), ((i - 1) * 20 + j + 1)] <- -0.5
		}
	}
}

decomposition <- eigen(matriceH)

sortie <- data.frame("Energies"=decomposition$values)

write.table(sortie, "data/energiesPartLibres.txt", row.names=FALSE)


# Function 'meanAndVariance'
# Killian Martin--Horgassan
# 01-06-2015

# Computes the mean and variance for the supposedly normal
# log-gross returns (Black-Scholes model) from the empirical
# data on the stock

meanAndVariance <- function(x) {
	RESULT <- rep(0,2)
	mu_emp <- mean(x)
	sigma2_emp <- var(x)
	RESULT <- c(mu_emp + 0.5*sigma2_emp, sigma2_emp)
	output <- RESULT
}


#!/usr/bin/env Rscript
#
# Combine results from genome scans using Fisher's method.
#
# Assumes the input files are tab-delimited with no headers and that the
# 1st column is the chromosome, the 2nd column is the position, the
# 3rd column is the p-value, and the 4th column is whether or not the
# site is a fixed difference. Additional columns are fine.
#

library(data.table)

fisher_combine_p = function(ps) {
        chi_sq = -2 * sum(log(ps[!is.na(ps)]))
    df = 2 * sum(!is.na(ps))
        pchisq(chi_sq, df, lower.tail=FALSE)
}

check_site_matches = function(cmat, pmat) {
    pass = TRUE
    pass = pass && all(apply(cmat, 1,
                             function(x) all(x[1] == x[2:length(x)])))
    pass = pass && all(apply(pmat, 1,
                             function(x) all(x[1] == x[2:length(x)])))
    pass
}

cargs = commandArgs(trailingOnly=TRUE)

data_list = lapply(lapply(cargs, fread, sep='\t'),
                   function(x) { names(x)[1:4] = c('chrom', 'pos', 'p', 'fix'); x })
f_matrix = sapply(data_list, function(x) x[['fix']])
p_matrix = sapply(data_list, function(x) x[['p']])
colnames(p_matrix) = basename(dirname(cargs))
chr_matrix = sapply(data_list, function(x) x[['chrom']])
pos_matrix = sapply(data_list, function(x) x[['pos']])

if(!check_site_matches(chr_matrix, pos_matrix))
    stop('Sites and positions do not match')

combined_ps = apply(p_matrix, 1, fisher_combine_p)
combined_fs = rowSums(f_matrix, na.rm=TRUE)

write.table(data.frame(chrom=chr_matrix[, 1], pos=pos_matrix[, 1],
                       p=combined_ps, fixed=combined_fs,
                       p_matrix),
            file=stdout(), sep='\t', col.names=TRUE,
            row.names=FALSE, quote=FALSE)


 E04NCJ Example Program Results

 Varbl  Istate   Value         Lagr Mult

 V   1   1         0.000E+00     1.572E-01
 V   2   0         4.153E-02     0.000E+00
 V   3   0         5.872E-01     0.000E+00
 V   4   1         0.000E+00     8.782E-01
 V   5   0         9.964E-02     0.000E+00
 V   6   1         0.000E+00     1.473E-01
 V   7   0         4.906E-02     0.000E+00
 V   8   1         0.000E+00     8.603E-01
 V   9   0         3.056E-01     0.000E+00

 L Con  Istate   Value         Lagr Mult

 L   1   1         2.000E+00     3.777E-01
 L   2   2         2.000E+00    -5.791E-02
 L   3   1         1.000E+00     1.075E-01

 Final objective value =       8.134E-02


############################################################################################
#
# DESCRIPTION
#    Functions for determination of R-indicators and coefficients of variation.
#    A manual of the functions is found in
#
#    de Heij, V., Schouten, B., and Shlomo, N. (2015), RISQ manual 2.1, Tools in
#        SAS and R for the computation of R-indicators, partial R-indicators
#        and partial coefficients of variation, available at www.risq-project.eu
#
# HISTORY
#    2010/05/10    1.0    V. de Heij      ---
#    2011/02/16    1.1    V. de Heij      Option withBiasAndVar added.
#    2013/07/25    2.0    V. de Heij      Standard error approximations for partial R-indicators,
# 										  coefficient of variation and increased flexibility in models
#    2014/12/15    2.1    B. Schouten     Inclusion of partial coefficients of variation
#
#
############################################################################################

getRIndicator <-
    function(formula,
             sampleData,
             sampleWeights  = rep(1, nrow(sampleData)),
             sampleStrata   = NULL,
             family         = c('binomial', 'gaussian'),
             withPartials   = TRUE,
			 withPartialCV  = TRUE,
             otherVariables = character())
{ #++
    # Determines the R-indicators and the partial R-indicators for a sample.
    #
    # ARGUMENTS
    #   formula        : the respons model which will be used to determine the
    #                    R-indicators; the left hand side of the formula states
    #                    the respons variabele, the right hand side states the
    #                    lineair model of auxiliary variabeles which will be
    #                    used to describe the respons;
    #
    #   sampleData     : a data frame containing the sample data;
    #
    #   sampleWeights  : (optional) a vector with the inclusion weights of the
    #                    sampling units;
    #
    #   sampleStrata   : (optional) a vector with the strata membership of the
    #                    sampling units;
    #
    #   family         : (optional) a string either 'binomial' for logistic
    #                    regression or 'gaussian' for lineair regression;
    #
    #   withPartials   : (optional) a boolean value, indicating if partial
    #                    R-indicators have to be determined (TRUE) or
    #                    not (FALSE);
    #   withPartialCV  : (optional) a boolean value, indicating if partial
    #                    coefficients of variation have to be determined (TRUE) or
    #                    not (FALSE);
	#
    #   otherVariables : (optional).
    #
    # VALUE
    #   getRIndicator returns a list of which the most important components
    #   are described in the manual.

    nSample = nrow(sampleData)
    stopifnot(length(sampleWeights) == nSample)
    stopifnot(is.numeric(sampleWeights))

    # If sampleStrata is not defined, use sampleWeights to guess the values of
    # sampleStrata.
    if (is.null(sampleStrata))
        sampleStrata <- getSampleStrata(sampleWeights)

    stopifnot(is.factor(sampleStrata))
    stopifnot(length(sampleStrata) == nSample)

    sampleDesign <- getSampleDesign(sampleWeights, sampleStrata)

    family <- match.arg(family)
    model <- switch(family,
            'binomial' = list(
                    formula = formula,
                    grad    = function(mu)  exp(mu) / (1 + exp(mu))^2,
                    family  = binomial(link = 'logit')),
            'gaussian' = list(
                    formula = formula,
                    grad    = function(mu) 1,
                    family  = gaussian(link = 'identity')))

    indicator <- getRSampleBased(model, sampleData, sampleDesign)

    if ((withPartials) | (withPartialCV))
        estpartials <- getPartialRs(
                indicator, sampleData, sampleDesign, otherVariables)
	if (withPartials)
        indicator$partialR <- estpartials$partialR
    if (withPartialCV)
        indicator$partialCV <- estpartials$partialCV

    return (indicator)
} #--

#############################################################################
#
#  Private functions for the estimation of the sample-based indicators.
#
#############################################################################

getRSampleBased <-
        function(model,
                 sampleData,
                 sampleDesign)
{ #++
    # Determines the sample-based R-indicator.

    #  See 9.9 from Regression Modelling Strategies (Harrell, 2001) for a
    #  motivation for the factor
    #
    #    mean(sampleWeights) = sum(sampleWeights) / length(sampleWeights).

    sampleData <- within(sampleData, {
            sampleWeights <- sampleDesign$weights
            sampleWeights <- sampleWeights / mean(sampleWeights) })

    modelfit <- glm(model$formula, model$family, sampleData, sampleWeights)
    prop     <- predict(modelfit, type = 'response')
    propMean <- weighted.mean(prop, sampleDesign$weights)
    propVar  <- weightedVar(prop, sampleDesign$weights)

    # Because estimaters of bias and variance both use the following vectors
    # and matrix, they are calculated only once and passed to the functions.
    sigma <- vcov(modelfit)
    x <- model.matrix(model$formula, sampleData)[, colnames(sigma)]
    z <- model$grad(predict(modelfit, type = 'link')) * x

    withBiasAndVar <- !is.null(sigma) && all(!is.na(sigma))
    if (withBiasAndVar) {
        RBias <- getBiasRSampleBased(prop, z, sigma, sampleDesign)
        RVar  <- getVarianceRSampleBased(prop, z, sigma, sampleDesign)

        # To simplify formulas the bias correction of the variance will be
        # written as a factor, 1 - bias / (variance of propensities).
        if (RBias > propVar)
            RBiasFactor <- 0
        else
            RBiasFactor <- 1 - RBias / propVar
    } else {
        RBias <- NA
        RBiasFactor <- NA
        RVar <- NA
    }

    CVUnadj <- sqrt(propVar) / propMean
	CV <- sqrt(propVar * RBiasFactor)/propMean
    CVVar <- 0.25 * RVar / propMean^2 + CV^4 / nrow(sampleData)

    indicator <- list(
            type          = 'R-indicator, sample based',
            sampleDesign  = sampleDesign,
            prop          = prop,
            propMean      = propMean,
            model         = model,
            modelfit      = modelfit,
            sigma         = sigma,
            z             = z,
            R             = 1 - 2 * sqrt(propVar * RBiasFactor),
            RUnadj        = 1 - 2 * sqrt(propVar),
            RSE           = sqrt(RVar),
            RBiasFactor   = RBiasFactor,
            CVUnadj       = CVUnadj,
			CV			  = CV,
            CVSE          = sqrt(CVVar))

    return (indicator)
} #--

getBiasRSampleBased <-
        function(prop,
                 z,
                 sigma,
                 sampleDesign)
{ #++
    # Estimates the bias of the estimator for the variance of the
    # propensities.

    nPopulation <- sum(sampleDesign$weights)
    propVar <- sampleDesign$getVarTotal(sampleDesign, prop)
    z <- z * sqrt(sampleDesign$weights)

    lambda1 <- sum(apply(z, 1, function(zi) return(t(zi) %*% sigma %*% zi)))
    lambda2 <- propVar / nPopulation
    bias <- (lambda1 - lambda2) / nPopulation

    return (bias)
} #--

getVarianceRSampleBased <-
        function(prop,
                 z,
                 sigma,
                 sampleDesign)
{ #++
    # Estimates the variance of the estimator for the R-indicator.

    weights <- sampleDesign$weights
    nSample <- length(weights)
    nPopulation <- sum(weights)

    propMean <- weighted.mean(prop, weights)
    propVar <- weightedVar(prop, weights, method = 'ML')
    propZ <- cbind(prop, z)

    A <- cov.wt(propZ, wt = weights, method = 'ML')$cov[-1, 1]
    B <- cov.wt(z, wt = weights, method = 'ML')$cov
    C <- sampleDesign$getVarTotal(sampleDesign, (prop - propMean)^2)

    variance <- numeric()
    variance[1] <- 4 * t(A) %*% sigma %*% A
    variance[2] <- 2 * getTrace(B %*% sigma %*% B %*% sigma)
    variance[3] <- C / nPopulation^2
    variance <- sum(variance) / propVar

    return (variance)
} #--

#############################################################################
#
#  Private functions for the estimation of the sample-based, partial
#  indicators.
#
#############################################################################

getPartialRs <-
        function(indicator,
                 sampleData,
                 sampleDesign,
                 otherVariables = character())
{ #++
    # Estimates both unconditional and conditional partial R-indicators.

    RR <- indicator$propMean
    modelVariables <- getVariables(indicator$model$formula, FALSE)
    variables <- unique(c(modelVariables, otherVariables))

    byVariablesR  <- NULL
	byVariablesCV  <- NULL
    byCategoriesR <- list()
    byCategoriesCV <- list()

    for (variable in variables) {
       pConditional <-
                getPartialRConditional(
                        indicator, variable, sampleData, sampleDesign)

       pUnconditional <-
                getPartialRUnconditional(
                        indicator, variable, sampleData, sampleDesign)

       byVariableR <- data.frame(
                variable   = variable,
                Pu         = pUnconditional$Pu,
                PuUnadj    = pUnconditional$PuUnadj,
                PuSE       = pUnconditional$PuSE,
                Pc         = pConditional$Pc,
                PcUnadj    = pConditional$PcUnadj,
                PcSEApprox = pUnconditional$PuSE)

       byVariableCV <- data.frame(
                variable   = variable,
                CVu         = pUnconditional$Pu/RR,
                CVuUnadj    = pUnconditional$PuUnadj/RR,
                CVuSE       = pUnconditional$PuSE/RR,
                CVc         = pConditional$Pc/RR,
                CVcUnadj    = pConditional$PcUnadj/RR,
                CVcSEApprox = pUnconditional$PuSE/RR)

        byVariablesR <- rbind(byVariablesR, byVariableR)
        byVariablesCV <- rbind(byVariablesCV, byVariableCV)

        byCategoryR <- merge(
                pUnconditional$byCategory,
                pConditional$byCategory)

        byCategoryCV <- byCategoryR
		names(byCategoryCV) <- c("category","CVuUnadj","CVuUnadjSE","CVcUnadj","CVcUnadjSE")
		byCategoryCV$CVuUnadj <- byCategoryCV$CVuUnadj/RR
		byCategoryCV$CVuUnadjSE <- byCategoryCV$CVuUnadjSE/RR
		byCategoryCV$CVcUnadj <- byCategoryCV$CVcUnadj/RR
		byCategoryCV$CVcUnadjSE <- byCategoryCV$CVcUnadjSE/RR

        byCategoriesR <- c(byCategoriesR, list(byCategoryR))
		byCategoriesCV <- c(byCategoriesCV, list(byCategoryCV))
    }

    names(byCategoriesR) <- byVariablesR$variable
    names(byCategoriesCV) <- byVariablesCV$variable

    partialR <- list(
            byVariables  = byVariablesR,
            byCategories = byCategoriesR)

	partialCV <- list(
            byVariables  = byVariablesCV,
            byCategories = byCategoriesCV)

	partials <- list(
            partialR  = partialR,
            partialCV = partialCV)

    return (partials)
} #--

getPartialRUnconditional <-
        function(indicator,
                 variable,
                 sampleData,
                 sampleDesign)
{ #++
    # Estimates unconditional partial R-indicators.

    stopifnot(variable %in% names(sampleData))

    categories  <- sampleData[[variable]]
    RBiasFactor <- indicator$RBiasFactor
    nPopulation <- sum(indicator$sampleDesign$weights)
    propMean    <- indicator$propMean

    arg <- with(indicator,
            data.frame(
                    n    = sampleDesign$weights,
                    prop = sampleDesign$weights * prop))

    byCategory <- within(
            aggregate(arg, list(category = categories), sum), {
                    prop     <- prop / n
                    propSign <- sign(n * (prop - propMean))
                    propVar  <- n * (prop - propMean)^2 / nPopulation
                    PuUnadj  <- propSign * sqrt(propVar) })

    model <- within(indicator$model,
            formula <- replaceRHSByVariable(formula, variable))

    propVar <- sum(byCategory$propVar)
    Pu      <- sqrt(propVar * RBiasFactor)
    PuUnadj <- sqrt(propVar)
    PuSE    <- 0.5 * getRSampleBased(model, sampleData, sampleDesign)$RSE

    partialIndicator <- list(
            type       = 'Unconditional partial R-indicator, sample based',
            variable   = variable,
            Pu         = Pu,
            PuUnadj    = PuUnadj,
            PuSE       = PuSE,
            byCategory = byCategory)

    partialIndicator <- getVariancePartialRUnconditional(
            partialIndicator, indicator, sampleData, sampleDesign)

    partialIndicator$byCategory <-
            partialIndicator$byCategory[c('category', 'PuUnadj', 'PuUnadjSE')]

    return (partialIndicator)
} #--

getVariancePartialRUnconditional <-
        function(partialIndicator,
                 indicator,
                 sampleData,
                 sampleDesign)
{ #++
    # Calculate the variance of the partial-R indicators.

    nPopulation <- sum(sampleDesign$weights)
    variable    <- partialIndicator$variable
    byCategory  <- partialIndicator$byCategory
    prop        <- indicator$prop

    V1 <- numeric()
    V2 <- numeric()

    nSample <- nrow(sampleData)

    for (index in seq(nrow(byCategory))) {
        label  <- byCategory[index, 'category']
	    delta  <- ifelse(sampleData[[variable]] == label, 1, 0)
        deltaC <- 1 - delta

        V1[index] <- sampleDesign$getVarTotal(sampleDesign, delta * prop)
        V2[index] <- sampleDesign$getVarTotal(sampleDesign, deltaC * prop)
    }

    partialIndicator$byCategory <- within(byCategory, {
            PuUnadjSE <- sqrt(n / nPopulation * (
                    V1 * (1 / n - 1 / nPopulation)^2 +
                    V2 * (1 / nPopulation)^2)) })

    return (partialIndicator)
} #--

getPartialRConditional <-
        function(indicator,
                 variable,
                 sampleData,
                 sampleDesign)
{ #++
    # Estimates conditional partial R-indicators.

    stopifnot(variable %in% names(sampleData))

    sampleWeights <- indicator$sampleDesign$weights
    modelVariables  <- getVariables(indicator$model$formula, FALSE)
    otherVariables  <- modelVariables %sub% variable
    otherCategories <- as.list(sampleData[otherVariables])

    propMeanByOthers <- with(indicator,
            ave(sampleWeights * prop, otherCategories, FUN = sum) /
            ave(sampleWeights, otherCategories, FUN = sum))

    zMeanByOthers <- apply(
            indicator$z, 2,
            FUN = function(x) return (
                    ave(sampleWeights * x, otherCategories, FUN = sum) /
                    ave(sampleWeights, otherCategories, FUN = sum)))

    categories  <- sampleData[[variable]]
    RBiasFactor <- indicator$RBiasFactor
    weights     <- sampleWeights / sum(sampleWeights)

    arg <- with(indicator,
            data.frame(
                    n       = sampleWeights,
                    propVar = weights * (prop - propMeanByOthers)^2))

    byCategory <- within(
            aggregate(arg, list(category = categories), sum), {
                    PcUnadj <- sqrt(propVar) } )

    propVar <- sum(byCategory$propVar)
    Pc      <- sqrt(propVar * RBiasFactor)
    PcUnadj <- sqrt(propVar)

    partialIndicator <- list(
            type             = 'Conditional partial R-indicator, sample based',
            variable         = variable,
            Pc               = Pc,
            PcUnadj          = PcUnadj,
            byCategory       = byCategory,
            propMeanByOthers = propMeanByOthers,
            zMeanByOthers    = zMeanByOthers)

    partialIndicator <- getVariancePartialRConditional(
            partialIndicator, indicator, sampleData, sampleDesign)

    partialIndicator$byCategory <-
            partialIndicator$byCategory[c('category', 'PcUnadj', 'PcUnadjSE')]

    return (partialIndicator)
} #--

getVariancePartialRConditional <-
        function(partialIndicator,
                 indicator,
                 sampleData,
                 sampleDesign)
{ #++
    byCategory  <- partialIndicator$byCategory
    variable    <- partialIndicator$variable
    sigma       <- indicator$sigma
    weights     <- sampleDesign$weights
    nPopulation <- sum(weights)

    propDelta <- indicator$prop - partialIndicator$propMeanByOthers
    zDelta <- indicator$z - partialIndicator$zMeanByOthers

    variance <- numeric()
    for (index in seq(nrow(byCategory))) {
        label <- byCategory[index, 'category']
        delta <- ifelse(sampleData[[variable]] == label, 1, 0)
        zDeltaWeight <- zDelta * delta * weights
        propDelta2 <- propDelta * propDelta * delta

        A <- matrix(propDelta, nrow = 1) %*% zDeltaWeight
        B <- t(zDelta) %*% zDeltaWeight

        V1 <- 4 * A %*% sigma %*% t(A)
        V2 <- 2 * getTrace(B %*% sigma %*% B %*% sigma)
        V3 <- sampleDesign$getVarTotal(sampleDesign, propDelta2)

        variance[index] <-
                0.25 * (V1 + V2 + V3) /
                (nPopulation * sum(propDelta2 * weights))
    }

    partialIndicator$byCategory <- within(byCategory,
            PcUnadjSE <- sqrt(variance))

    return (partialIndicator)
} #--

#############################################################################
#
#  Other private functions, ... .
#
#############################################################################

getSampleStrata <-
        function(sampleWeights,
                 nMaxStrata = 20)
{ #++
    # Guesses a definition of the sample strata, using the values of the sample
    # weights.

    weights <- sort(unique(sampleWeights))
    indices <- seq(along = sampleWeights)
    strata <- factor(seq(along = weights))

    if (length(weights) <= nMaxStrata) {
        values <- merge(
                data.frame(weight = sampleWeights, index = indices),
                data.frame(weight = weights, stratum  = strata),
                all.x = TRUE)

        sampleStrata <- values[order(values$index), 'stratum']
    } else
        sampleStrata <- factor(rep(1, length(sampleWeights)))

    return (sampleStrata)
} #--

getSampleDesign <-
        function(sampleWeights,
                 sampleStrata)
{ #++
    # Guesses which type of sample desing is used, using the following rules.
    # (1) A single stratum and constant weights implies SI sampling.
    # (2) More than one stratum and constant weights per stratum implies STSI
    #     sampling.
    minmax <- sapply(split(sampleWeights, sampleStrata), range)
    constantWeights <- all(minmax[1,] == minmax[2,])

    nStrata <- length(levels(sampleStrata[, drop = TRUE]))

    if (constantWeights) {
        type <- ifelse(nStrata == 1, 'SI', 'STSI')
        getVarTotal <- getSampleVarTotalSTSI

    } else {
        type <- ''
        getVarTotal <- getSampleVarTotalPPS
    }

    sampleDesign <- list(
            type        = type,
            weights     = sampleWeights,
            strata      = sampleStrata,
            getVarTotal = getVarTotal)

    return (sampleDesign)
} #--

getSampleVarTotalSTSI <-
        function(sampleDesign,
                 y)
{ #++
    # return (getSampleCovTotalSTSI(sampleDesign, y, y))

    getStratumVarTotal <-
            function(sample)
    { #++
        N <- sum(sample$weights)
        n <- nrow(sample)

        return (N^2 * (1 - n / N) * var(sample$y) / n)
    } #--

    sample <- data.frame(y = y, weights = sampleDesign$weights)
    strataVar <- sapply(split(sample, sampleDesign$strata), getStratumVarTotal)
    sampleVar <- sum(strataVar)

    return (sampleVar)
} #--

getSampleVarTotalPPS <-
        function(sampleDesign,
                 y)
{ #++
    # If the sample design is neither SI nor STSI, use the formulae of the SE
    # of a PPS design.

    # return (getSampleCovTotalPPS(sampleDesign, y, y))

    n <- length(sampleDesign$weights)
    y <- y * sampleDesign$weights
    sampleVar <- sum((n * y - sum(y))^2) / n / (n - 1)

    return (sampleVar)
} #--

getVariables <-
        function(formula,
                 leftHandSide = FALSE)
{ #++
    # Returns the names of the variables used either in the left hand side of
    # the formula or in the right hand side of the formula.

    if (leftHandSide)
        formula <- update.formula(formula, . ~ 1)
    else
        formula <- update.formula(formula, 1 ~ .)

    variables <- all.vars(formula)

    if (length(variables) == 1 && variables == '.')
        variables <- NA

    return (variables)
} #--

replaceRHSByVariable <-
        function(formula,
                 variable)
{ #++
    replacement <- as.formula(paste('. ~ ', variable, sep = ''))
    formula <- update.formula(formula, replacement)

    return (formula)
} #--

getTrace <-
        function(m)
{ #++
    # Returns the trace of the matrix m.

    return (sum(m[col(m) == row(m)]))
} #--

weightedVar <-
        function(x,
                 weights = rep(1, length(x)),
                 method = c('unbiased', 'ML'))
{ #++
    # Returns the weighted variance of the vector x.

    xMean <- weighted.mean(x, weights)
    xVar <- sum(weights * (x - xMean)^2)
    xVar <- switch(match.arg(method),
                'unbiased' = xVar / (sum(weights) - 1),
                'ML'       = xVar / sum(weights))

    return (xVar)
} #--

'%sub%' <-
        function(x,
                 y)
{ #++
    # Returns all elements of the set operation x - y.
    #     > c(1, 2, 3, 4, 5) %sub% c(2, 4)
    #     [1] 1 3 5

    return (x[! x %in% y])
} #--


score <- function(input) {
    return((((((((((((((37.13534685269026) + ((input[1]) * (-0.10859102499053891))) + ((input[2]) * (0.04419889872599562))) + ((input[3]) * (0.017466905407308372))) + ((input[4]) * (2.832321087004625))) + ((input[5]) * (-18.48374869795793))) + ((input[6]) * (3.835495548436564))) + ((input[7]) * (0.00014091650900214126))) + ((input[8]) * (-1.5040340046693192))) + ((input[9]) * (0.31061748524339455))) + ((input[10]) * (-0.012306650033752073))) + ((input[11]) * (-0.9736183984588207))) + ((input[12]) * (0.009403964809694718))) + ((input[13]) * (-0.5203427347180726)))
}


a <- -3.36
b <- 3.62
q <- 0.24
d <- -1.56

print((a+b)/2)
print(sqrt((b-a)^2/12))
print(qunif(q, a, b))
bprimo <- (b-((a+b)/2))/(sqrt((b-a)^2/12))
aprimo <- (a-((a+b)/2))/(sqrt((b-a)^2/12))
print(ifelse(d>=aprimo && d<=bprimo, (1/(bprimo-aprimo)),0))


### calculate the power for testing H0 when under H_beta in three ways: TSLS, AR, ARsens
### some parameter values are inferred from the ivmodel

IVpower=function(ivmodel, n=NULL, alpha=0.05, beta=NULL, type="TSLS", deltarange=NULL, delta=NULL){
  esti = para(ivmodel)
  if(is.null(n))
    n = ivmodel$n
  if(is.null(beta))
    beta = esti$beta
  if(is.null(deltarange))
    deltarange = ivmodel$deltarange

  if(type=="TSLS"){
     return(TSLS.power(n, beta, cor(ivmodel$Zadj, ivmodel$Dadj), esti$sigmau, var(ivmodel$Dadj), alpha))
  }
  if(type=="AR"){
    return(AR.power(n, ivmodel$p, ivmodel$L, beta, esti$gamma, var(ivmodel$Zadj), esti$sigmau, esti$sigmav, esti$rho, alpha))
  }

  if(type=="ARsens"){
    return(ARsens.power(n, ivmodel$p, beta, esti$gamma, var(ivmodel$Zadj), esti$sigmau, esti$sigmav, esti$rho, alpha, deltarange, delta))
  }
  print("Input error.")
  return(NULL)
}