##### Chapter 9: Clustering with k-means -------------------

# 군집화는 데이터를 cluster로 자동 분리하는 머신 러닝 작업이다.
# 찾고 있는 것이 무엇인지 모르기 때문에, 군집화는 예측보다는 지식의 발견에 사용된다.

# 모델은 데이터 내에 존재하는 패턴을 설명한다.
# 이와 대조적으로 군집화는 새로운 데이터를 생성한다.

# 주목할 점은 자율 분류기(=군집기)에서 얻은 클래스 레이블은 본질적인 의미가 없다는 것이다.
  # 군집화는 어떤 예시 그룹이 긴밀하게 연관되어 있는지는 말해 주지만,
  # 실행 가능하고 의미 있는 레이블을 적용하는 것은 사람의 책임이다.

# k- 평균 알고리즘은 n개의 예시를 k개의 클러스터 중 하나에 할당하는데, 이 때 k는 사전에 결정됨
  # 이 알고리즘의 목표는 클러스터 내의 차이를 최소화하고, 클러스터 간의 차이를 최대화하는 것이다.

# k-평균 알고리즘은 클러스터 중심의 출발 위치에 매우 민감하다.
  # k-평균의 초기 중심을 선택하는 방법을 다르게 할 수 있다. 거리는 보통 유클리드 거리를 사용한다.

# k를 크게 설정하면 클러스터의 동질성이 향상 but overfitting 위험 커진다.
  # 이상적으로는 실제 그룹에 대한 선험적(a priori)지식이 있을 것이며, 이 정보를 클러스터 개수를 선택하는데 적용가능
  # 사전 지식이 없다면 k를 n/2의 제곱근과 동일하도록 설정해보자.
  # 엘보법
    # 다양한 k값에 대해 클러스터 내의 동질성과 이질성이 어떠헥 변하는지를 측정한다.
## Example: Finding Teen Market Segments ----
## Step 2: Exploring and preparing the data ----
setwd("D:/R_LAB/MlwR/Chapter 09")
teens <- read.csv("snsdata.csv")
str(teens)

# look at missing data for female variable
table(teens$gender)
table(teens$gender, useNA = "ifany")

# look at missing data for age variable
summary(teens$age)

# eliminate age outliers
teens$age <- ifelse(teens$age >= 13 & teens$age < 20,
                     teens$age, NA)

summary(teens$age)

# reassign missing gender values to "unknown"
teens$female <- ifelse(teens$gender == "F" &
                         !is.na(teens$gender), 1, 0)
teens$no_gender <- ifelse(is.na(teens$gender), 1, 0)

# check our recoding work
table(teens$gender, useNA = "ifany")
table(teens$female, useNA = "ifany")
table(teens$no_gender, useNA = "ifany")

# finding the mean age by cohort
mean(teens$age) # doesn't work
mean(teens$age, na.rm = TRUE) # works

# age by cohort
# aggregate() 함수는 데이터의 하위 그룹에 대한 통계를 계산한다.
aggregate(data = teens, age ~ gradyear, mean, na.rm = TRUE)

# create a vector with the average age for each gradyear, repeated by person
# ave() 함수는 결과가 원 벡터의 길이와 같아지게 그룹의 평균이 반복되는 벡터를 반환한다.
ave_age <- ave(teens$age, teens$gradyear,
                 FUN = function(x) mean(x, na.rm = TRUE))

teens$age <- ifelse(is.na(teens$age), ave_age, teens$age) # 결측치에 ave_age 넣

# check the summary results to ensure missing values are eliminated
summary(teens$age)

## Step 3: Training a model on the data ----
interests <- teens[5:40]
interests_z <- as.data.frame(lapply(interests, scale))

set.seed(13123313)
teen_clusters <- kmeans(interests_z, 5)

## Step 4: Evaluating model performance ----
# look at the size of the clusters
teen_clusters$size

# look at the cluster centers :각 클러스터의 동질성을 살펴보자. 중심점의 좦를 알아보자.
teen_clusters$centers
# 양수는 모든 십대에 대한 전체 평균 이상, 음수는 전체 평균 이하.
# 클러스터가 각 관심 범주에 대해 평균 이상인지 이앟인지 검토 > 클러스터는 서로 구별하는 패턴 인식.

## Step 5: Improving model performance ----
# apply the cluster IDs to the original data frame

# 이 클러스터를 전체 데이터셋에 역을 ㅗ적용하자.
# kmeans() 함수에 의해 생성된 teen_cluster객체는 cluster라는 이름의 component를 포함한다.
# cluster component에는 전체 30000명 개인에 대한 클러스터 할당이 포함되어 있다.
# 다음 명령으로 cluster component를 teens 데이터 프레임의 열로 추가할 수 있다.
teens$cluster <- teen_clusters$cluster

# look at the first five records
teens[1:5, c("cluster", "gender", "age", "friends")]

# mean age by cluster # aggregate()로 인구통계학적 특성 살펴보
aggregate(data = teens, age ~ cluster, mean)

# proportion of females by cluster
aggregate(data = teens, female ~ cluster, mean) # 여성 비율은 상당한 차이가 있다(성별 데이터 사용 않았음에도)

# mean number of friends by cluster
aggregate(data = teens, friends ~ cluster, mean) # 공주, 범죄자, 그리고 무력한 사람

# k-평균 알고리즘 뿐만 아니라, 작업에 고유한 편향과 휴리스틱을 제공하는 다른 여러 군집 알고리즘 변형이 있다.


#!/usr/bin/Rscript

########################################################################################
# script name: calculate_probabilities.r
# developed by: Haris Zafeiropoulos, Savvas Paragkamian
# framework: PREGO - WP4
########################################################################################
# GOAL:
# this script aims to calculate PREGO association scores
########################################################################################
#
# usage: Rscript calculate_probabilities.r
#
########################################################################################

# Dependencies
library(Rfast)

######################################################
### Regarding the NCBI IDs and their probabilities
######################################################

# read the background file
x<- read.csv("/data/databases/scripts/gathering_data/mgnify/ncbi_background.tsv", header = FALSE, sep = "\t")

# keep the values of each id occurence
mydata_x <- x$V2

# build a model using the negative binomial distribution
mod_x <- negbin.mle(mydata_x)

# calculate the probability of each ncbi id to come with respect to the non binomial distribution we built
x$new_x <- dnbinom(x = mydata_x, size = mod_x$param[2], prob = mod_x$param[1])

# write an output file with the probabilities of each NCBI ID to come
write.table(x, file='/data/databases/scripts/gathering_data/mgnify/probabilities_ncbi.tsv', quote=FALSE, sep='\t', row.names = FALSE, col.names = FALSE)

########################################################
### Regarding the metadata terms and their probabilities
########################################################

# read the background file
y <- read.csv("/data/databases/scripts/gathering_data/mgnify/metadata_background.tsv", header = FALSE, sep = "\t")

# keep the values of each id occurence
mydata_y <- y$V2

# build a model using the negative binomial distribution
mod_y <- negbin.mle(mydata_y)

# calculate the probability of each ncbi id to come with respect to the non binomial distribution we built
y$new_y <- dnbinom(x = mydata_y, size = mod_y$param[2], prob = mod_y$param[1])

# write an output file with the probabilities of each metadata ter to come
write.table(y, file='/data/databases/scripts/gathering_data/mgnify/probabilities_metadata.tsv', quote=FALSE, sep='\t', row.names = FALSE, col.names = FALSE)


# A general Brownian motion with mean non necessarily 0
# and non-necessarily unit variance.
# 23-04-2015
# Killian Martin--Horgassan

generalBM = function(mu, sigma,h) {

	# Number of time steps
	t <- ceiling(1/h)

	# Generating a t-uplet Gaussian vector and taking the sum
	vect <- cumsum(rnorm(t, mu*h, sigma*h))

	return(vect)
}


#' pGLS model comparison using phylogenetic analysis of covariance (gls.ancova)
#'
#' Computes F-ratio test of GLS models that include different sets of indicator variables.
#' @param form Model formula.
#' @param Sigma Matrix describing the covariance among data points. For the phylogenetic regression, this is based on a phylogeny (vcv(tree)).
#' @param ReducedModel The GLS model that includes the fewest indicator variables.
#' @param FullModel The GLS model that includes the fewest indicator variables.
#' @return Anova table.
#' @references Smaers & Rohlf (2016) Testing species' deviations from allometric preductions using the phylogenetic regression. Evolution. 70 (5): 1145-1149.
#' @examples see https://smaerslab.com/software/
#' @export

gls.ancova<-function (form, Sigma, ReducedModel, FullModel)
{
    Y<-c(data[,which(colnames(data)==all.vars(form)[1])])
    n <- length(Y); tr <- sum(diag(Sigma)); Sigma <- n * Sigma/tr; invSigma <- solve(Sigma)
    df_ReducedModel <- c(length(ReducedModel[1, ])); df_FullModel <- c(length(FullModel[1, ]))

    C <- solve(t(ReducedModel) %*% invSigma %*% ReducedModel)
    B <- C %*% t(ReducedModel) %*% invSigma %*% Y
    SS_unexpl_ReducedModel <- (t(Y - (ReducedModel %*% B)) %*% invSigma %*% (Y - (ReducedModel %*% B)))
    MS_unexpl_ReducedModel <- SS_unexpl_ReducedModel/c(n-df_ReducedModel)

    C <- solve(t(FullModel) %*% invSigma %*% FullModel)
    B <- C %*% t(FullModel) %*% invSigma %*% Y
    SS_unexpl_FullModel <- (t(Y - (FullModel %*% B)) %*% invSigma %*% (Y - (FullModel %*% B)))
    MS_unexpl_FullModel <- SS_unexpl_FullModel/c(n-df_FullModel)

    Fs <- ((SS_unexpl_ReducedModel - SS_unexpl_FullModel)/(c(n-df_ReducedModel) - c(n-df_FullModel)))/(SS_unexpl_FullModel/c(n-df_FullModel))
    P <- 1 - pf(Fs, (c(n-df_ReducedModel) - c(n-df_FullModel)), c(n-df_FullModel))

    Output <- as.data.frame(cbind(rbind(df_FullModel, df_ReducedModel),
        rbind(round(SS_unexpl_FullModel, 4), round(SS_unexpl_ReducedModel, 4)), rbind(round(MS_unexpl_FullModel, 4), round(MS_unexpl_ReducedModel, 4)), rbind(round(Fs, 4), ""), rbind(round(P, 4), "")))
    colnames(Output) <- c("df", "Sum Sq", "Mean Sum Sq", "F value", "Pr(>F)")
    rownames(Output) <- c("FullModel", "ReducedModel")
    return(Output)
}


# Test de hipótesis (t test), errores Tipo I y II, significancia estadística (p-values).
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

#################################################################
# Motivacion
#################################################################

# Hasta el momento sabemos interpretar las primeras dos columnas de nuestra tabla de regresion.
# Es decir, (a) los betas (Estimadores o Coeficientes) y (b) el error estandard.
# Tambien sabemos (c) que son los intervalos de confianza y cual es su relacion con los
# errores estandard. Sin embargo, hasta el momento no sabemos que son esas estrellas
# que aparecen en nuestra tabla.

# Esto es lo que aprenderemos hoy. El coeficiente nos dice el tamano del efecto.
# Sin embargo, hay una posibildiad de que estemos equivocados. Recuerda,
# nuestra logica es frecuentista. El 95% de confianza significa que si
# el mismo fenomeno se repitiera 100 veces, 95 veces sucederia lo que estamos
# prediciendo.

# Como hacemos este calculo? Esto esta muy relacionado a los intervalos de confianza.
# Para esto, necesitamos hacer tests de hipotesis y CALCULAR
# CUAN CERCANOS O LEJANOS ESTAMOS DE QUE NUESTROS BETAS SEAN LO QUE NOSOTROS
# CREEMOS QUE SON.

#################################################################
# Estimemos un modelo
#################################################################

# Cargar paquete para cargar bases que no son de R.
# install.packages("foreign")
library(foreign) # significa "foraneo"
options(scipen = 1000000) # apagar notacion cientifica.
dat = read.dta("https://github.com/hbahamonde/OLS/raw/master/Datasets/cow.dta")

# Hoy pensaremos en que factores ayudan a subir la poblacion en los paises.

# (1) Que relacion podria haber entre poblacion y democracia?
# (2) Que relacion podria haber entre poblacion y represion politica?

# Modelo
modelo.1 = lm(pop ~ democracy + repression, dat)

# resumen del modelo
options(scipen = 1000000) # apagar notacion cientifica.
summary(modelo.1)

# (1) Que podemos deducir de nuestro modelo? (Interpreta la tabla)

# Checklist: (SIEMPRE EJECUTAR ESTE CHECKLIST)
## (1) Interpretar estimadores.
summary(modelo.1)

## (2) Observar los errores estandard.
summary(modelo.1)

## (3) Checkear normalidad de los residuos: y' con residuos.
plot(modelo.1$fitted.values, modelo.1$residuals)

## (4) Checkear significancia estadistica (asunto de hoy).
summary(modelo.1)

#################################################################
# Significancia Estadistica: p-values
#################################################################

## Significancia: en simple, es la probabilidad de que nuestros betas sean 0.
## Es decir, la probabilidad de que, por ej., beta(1) no sea 2345, si no que 0.
## En este caso, hay un 69,84% de probabilidad de que el efecto sea 0.
## Asi mismo, hay un 24.41% de que beta(2) no sea 18707, si no que sea 0.

## (1) Hasta que punto debieramos rechazar la idea de que b1=0? Cual es el
## % "magico" que nos diga "ok, estoy segur@ de que b1=0 y no b1=2345?

## Estrellas denotan significancia.
### * = la probabilidad de que el beta sea 0 es igual/menor al 1%
### ** = la probabilidad de que el beta sea 0 es igual/menor al 0.1%
### *** = la probabilidad de que el beta sea 0 es igual a 0%

## Otros niveles:
### . = la probabilidad de que el beta sea 0 es igual al 5%

## (4) Checkear significancia estadistica:
### Que podemos decir de la significancia estadistica de nuestros coeficientes?

#################################################################
# Apliquemos lo que sabemos respecto a Intervalos de Confianza
#################################################################

# p-values e intervalos de confianza estan altamente relacionados.

# Plotear modelo
# install.packages("coefplot")
library(coefplot)
coefplot(modelo.1, strict = T) # plot de coeficientes

# mostrar el detalle de los intervalos de confianza
confint(modelo.1, strict = T)

#################################################################
# Pero ocurre algo muy raro aqui....?
#################################################################

# (1) Que similitudes encontramos entre nuestra tabla de regresion,
# "confint" y "coefplot"? Las tres herramientas nos estan comunicando el mismo
# mensaje de alerta.... o no?

# (2) Pero que diferencias encontramos entre la tabla, coefplot/confint?

# Veamos mas en detalle el problema...
# install.packages("effects")
library(effects)
plot(allEffects(modelo.1))

# otro ejemplo
options(scipen = 999999) # apagar notacion cientifica.
library(ggeffects)
mydf <- ggpredict(modelo.1)

mydf # ve los resultados.

plot(mydf$democracy)
plot(mydf$repression)

# (3) Que podemos concluir?

#################################################################
# OK, misterio resuelto. Y es por esto que necesitamos pensar en P-values
#################################################################

# En nuestra tabla de regresion, el "p-value" esta dado por la probabildiad de que
# el "valor t" ("t value") sea mayor al numero absoluto de t (en la tabla,
# esta denotado por "Pr(>|t|)").

# Volvamos a mirar la tabla
summary(modelo.1)

# Vamos por parte.
# Primero, veamos lo que el p-value es (los numeros en la columna  "Pr(>|t|)").

# (1) Un p-value es la probabilidad de que nuestro efecto sea "falso".
# Esto en matematicas significa que nuestro efecto sea realmente "0".

# (2) Como es una probabilidad, el p-value (o valor "p") es una escala
# que va de 0 a 1.

# (3) En ciencias sociales, existe la convencion de que un p-value
# superior al 5%, se cuenta como "falso." Es decir, cuando nuestro p-value,
# que es nuestra probabilidad de que nuestro efecto sea falso/cero, es mayor a 5%,
# concluimos que el efecto es "realmente" cero. Ahora, si el p-value es menor
# a 5%, consideramos que la probabilidad de que sea falso es chica, y podemos
# creer que nuestro efecto en realidad es "verdadero" o mas bien "no-cero" o "no falso".

# Recuerda: 5% significa 5/100=0.05. Entonces, un p-value menor a 0.05 indica que
# nuestro efecto es verdadero o "no-falso", y un p-value mayor a 0.05 indica que nuestro efecto es falso/0. Es por esto que los p-values de los coeficientes que son iguales o menores a 0.05 tienen estrellas, y los que son mayores no tienen.

#################################################################
# Estadistico T
#################################################################

# Lo siguiente es el "t value" o "valor t" (o "estadistico t").
# El t value es el coeficiente/error estandard.

48303/19052
2345/6036
18707/15973

# Esto significa que cuando el error estandard es grande (lo que es "malo"),
# t value se vuelve mas chico. Nosotros queremos lo contrario. Ojala t values
# que son cercanos a dos. En general, esos t values tienen un p-value < 0.05.

# En otras palabras, el t value es una medida de dispersion de nuestra estimacion.
# Mientras mas dispersa, mas alta es la probabilidad de que--en su dispersion--
# nuestra estimacion toque el cero.

#################################################################
# Al pensar en los p-values y los intervalos de confianza,
# hemos tratado de minimizar nuestros Errores Tipo 1 y 2.
#################################################################

# La logica en investigacion en ciencias sociales tiene que ver con la idea de
# ver si hay suficiente evidencia en contra de la "hipotesis nula" (es decir, no hay efecto). En otras palabras, un@ no trata de buscar "verdades" (o estimaciones estadisticamente
# significativas). Un@ trabaja con estimaciones que son hasta 5% falsas (o 95% verdaderas).

# En concreto, un@ trata de minimizar la posibildiad del error "Tipo 1".

# Error Tipo 2: falsos negativos.
# Error Tipo 1: falsos positivos.

# Definir ambos.

#################################################################
# Pensamiento Critico
#################################################################

# P-values.
#----

## (1) Criticas al p-value. Por que 5% y no 3% por ejemplo?
## (2) Comunicando resultados: tablas con CI en vez de estrellas.

# install.packages("texreg")
library(texreg)
screenreg(modelo.1, ci.force = F)

### Tabla que incorpora estas criticas
# install.packages("texreg")
library(texreg)
screenreg(modelo.1, ci.force = T) # nuestro paquete "screenreg" que ya conocemos,
# pero ahora, forzando los intervalos de confianza ("confidence intervals"), por
# eso, "ci.force = T" ("T" por "true").

# Asintotica
#----

## Asintotica, recordemos, es la idea frecuentista de tener
## una base de datos infinita. Como esto es imposible,
## "el mal menor" es tener la mayor cantidad de datos: mientras mas, mejor.

### Demostrar en la pizarra que esto puede llegar a conducir a otros problemas.
### Mas datos, varianza es mas chica, el valor esperado mas preciso.

#### (1) Mientras mas datos tenemos, nuestras distribuciones se ponen mas perfectas,
#### delgadas, y precisas. Eso hace que encontremos independencia estadistica mas facil.
#### (2) Falsos positivos!

hist(rnorm(10,0,1))
hist(rnorm(50,0,1))
hist(rnorm(250,0,1))
hist(rnorm(2500000,0,1))


#optim function minimizes 'f'; c vector are starting values; lower is the
#constraint; I choose a null gradient because it was easiest to get up and running
#note that here the beta parameter is hard coded in as equal to 1
rm(list = ls())
#ap5 = .17
#a0 = ap5 + .5
#anp5 = ap5 + 1

ap5 = 1.27
a0 = 1.27
anp5 = 1.27

h <- function(WB,al) {

sy=1
sz=1

f <- function(B,WB,al) {
  Bp5 <- B[1]
  B0 <- B[2]
  Bnp5 <- B[3]
  -WB*((1/(1+exp(al - B0 + a0)))*(1/(1+exp((al - .5 - Bnp5 + anp5)/sy))) + (1/(1+exp(al - B0 + a0)))*(1/(1+exp((al + .5 - Bp5 + ap5)/sz))) + (1/(1+exp((al + .5 - Bp5 + ap5)/sz)))*(1/(1+exp((al - .5 - Bnp5 + anp5)/sy))) - 2*(1/(1+exp(al - B0 + a0)))*(1/(1+exp((al - .5 - Bnp5 + anp5)/sy)))*(1/(1+exp((al + .5 - Bp5 + ap5)/sz)))) + B0 + Bp5 + Bnp5
}

o <- optim(c(1,1,1,WB,al),function(B) f(B,WB,al),gr=NULL,method = "L-BFGS-B", lower = c(0,0,0), control = list(maxit=100000))
#o <- constrOptim(c(0.01,0.01,0.01,WB,al),function(B) f(B,WB,al),gr=NULL,method = "Nelder-Mead", ui = rbind(c(1,0,0),c(0,1,0),c(0,0,1)),ci=c(0,0,0))

X = round(- al -a0 + o$par[2], digits = 2)       #B0   these are shorthand variables for the exponents
Y = round(.5 - al -anp5 + o$par[3], digits = 2)    #Bnp5  in the logistic CDFs; I don't use them in the function
Z = round(-.5 - al - ap5 + o$par[1], digits=2)   #Bp5 but I've pasted in values here to check

pos <- c(Z,X,Y)
bribes <- c(o$par,-o$value)
#note I haven't fixed the win probability to include a's bribes
win <- c(((1/(1+exp(-X)))*(1/(1+exp(-Y/sy))) + (1/(1+exp(-X)))*(1/(1+exp(-Z/sz))) + (1/(1+exp(-Z/sz)))*(1/(1+exp(-Y/sy))) - 2*(1/(1+exp(-X)))*(1/(1+exp(-Y/sy)))*(1/(1+exp(-Z/sz)))))
out <- list("solns" = o$par[1:3], "pos" = pos, "objMax" = -o$value, "a" = al, "wb" = WB, "winProb" = win)
return(out)
}

# Create a dataframe of parameter values
wb_vector <- 5:20
a_vector <- seq(0.0, 0.0, 0.0)
params <- expand.grid("wb" = wb_vector, "a" = a_vector)

# Use "Map" to evaluate the "h" function at each pair of parameter values
results <- Map(h, al = params$a, WB = params$wb)

# Extract positions and bind to the parameter values
# WOULD LIKE TO HAVE BOTH SOLUTIONS AND POSITIONS IN OUTPUT VECTOR BUT DON'T KNOW HOW
solns <- lapply(seq_along(results), function(x) results[[x]]$solns)
netpos <- lapply(seq_along(results), function(x) results[[x]]$pos)
val <- lapply(seq_along(results), function(x) results[[x]]$objMax)
winProb <- lapply(seq_along(results), function(x) results[[x]]$winProb)
solns <- do.call("rbind", solns)
netpos <- do.call("rbind", netpos)
val <- do.call("rbind", val)
winProb <- do.call("rbind", winProb)
colnames(solns) <- c("foe", "middle", "friend")
colnames(netpos) <- c("Z", "X", "Y")
colnames(val) <- c("value")
colnames(winProb) <- c("winProb")
solns <- cbind(params, solns,netpos,val,winProb)
View(solns)


########################################################################
#                                                                      #
#   finite-set.rb                                                      #
#                                                                      #
########################################################################
=begin
[((<index-ja|URL:index-ja.html>))]
[((<finite-map-ja|URL:finite-map-ja.html>))]
((<Algebra::Set>))
/
((<Enumerable>))

= Algebra::Set
((*集合のクラス*))

集合を表現するクラスです。２つの集合 ((|s|)), ((|t|)) に関して、
((|s|)) が ((|t|)) に含まれる事は ((<all?>)) を使って、

  s.all?{|x| t.member?(x)}

で表現されます。

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

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

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

* ((|Enumerable|))

== クラスメソッド:

--- ::[]([obj0, [obj1, [obj2, ...]]])
    引数の列から ((|Set|)) オブジェクトを生成します。

    例: 全て {"a", [1, 2], 0} を生成する。
      require "finite-set"
      p Algebra::Set[0, "a", [1, 2]]
      p Algebra::Set.new(0, "a", [1, 2])
      p Algebra::Set.new_a([0, "a", [1, 2]])
      p Algebra::Set.new_h({0=>true, "a"=>true, [1, 2]=>true})

--- ::new([obj0, [obj1, [obj2, ...]]])
    引数の列から ((|Set|)) オブジェクトを生成します。

--- ::new_a(a)
    配列 ((|a|)) から ((|Set|)) オブジェクトを生成します。

--- ::new_h(h)
    ((|Hash|)) から ((|Set|)) オブジェクトを生成します。

--- self.empty_set
    空集合を生成する。

--- ::phi
--- ::null
    ((<::empty_set>)) のエイリアスです。

--- ::singleton(x)
    ((|x|)) 一元のみで構成される集合を生成します。

== メソッド:

--- empty_set
    空集合を生成する。

--- phi
--- null
    ((<empty_set>)) のエイリアスです。

--- empty?
    空集合であるとき真を返します。

--- phi?
--- empty_set?
--- null?
    ((<empty?>)) のエイリアスです。

--- singleton(x)
    ((|x|)) 一元のみで構成される集合を生成します。

--- singleton?
    一元のみで構成される集合であるとき真を返します。

--- size
    集合の大きさを返します。

--- each
    集合の各要素に関して繰り返します。繰り返しの順番は不定です。

    例:
      require "finite-set"
      include Algebra
      Set[0, 1, 2].each do |x|
        p x #=> 1, 0, 2
      end

--- separate
    集合の各要素をブロックパラメータに渡し、ブロックの値を真にする
    もので構成される集合を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].separate{|x| x % 2 == 0} #=> {2, 0}

--- select_s
--- find_all_s
    ((<separate>)) のエイリアスです。

--- map_s
    集合の各要素をブロックパラメータに渡し、ブロックの値によって
    構成される集合を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].map_s{|x| x % 2 + 1} #=> {2, 1}

--- pick
    集合の要素から一つ選んで値とします。どの要素が選ばれるかは
    不定です。空集合に対しては ((|nil|)) を返します。

--- shift
    集合の要素から一つ選んで取り出し値とします。どの要素が選ばれる
    かは不定です。

    例:
      require "finite-set"
      include Algebra
      s = Set[0, 1, 2, 3]
      p s.shift #=> 2
      p s #=> {0, 1, 3}

--- dup
    集合の複製を返します。（内部の Hash の複製によります。）

--- append!(x)
    集合に要素 ((|x|)) を付け加えます。返り値は ((|self|)) です。

--- push
--- <<
    ((|append!|)) のエイリアスです。

--- append(x)
    集合に要素 ((|x|)) を付け加えた複製を返します。

--- concat(other)
    集合に別の集合 ((|other|)) の要素を付け加えます。
    （((|+|)) の破壊版です。）

--- rehash
    内部の ((|Hash|)) オブジェクトを ((|rehash|)) します。

--- eql?(other)
    集合 ((|other|)) と等しいとき、真を返します。
    (({ self >= other and self <= other})) と同値です。

--- ==
    ((<eql?>)) のエイリアスです。

--- hash
    自身が ((|Hash|)) あるいは ((|Set|)) の要素となるときに利用される
    ハッシュ値関数です。

--- include?(x)
    集合が ((|x|)) を要素としているとき、真を返します。

--- member?
--- has?
--- contains?
    ((<include?>)) のエイリアスです。

--- superset?(other)
    集合が他の集合 ((|other|)) を包含するとき真を返します。
    (({other.all{|x| member?(x)}})) と同値です。

--- >=
--- incl?
    (({superset?})) のエイリアスです。

--- subset?(other)
    集合が他の集合 ((|other|)) の部分集合であるとき真を返します。
    (({self.all{|x| other.member?(x)}})) と同値です。

--- <=
--- part_of?
    ((|subset?|)) のエイリアスです。

--- <(other)
    ((|self|)) が ((|other|)) の真部分集合の時真を返します。

--- >(other)
    ((|self|)) が ((|other|)) を真に含む時真を返します。

--- union([other])
    ((|self|)) と ((|other|)) の合併集合を返します。
    ((|other|)) が省略された場合、自身を集合の集合とみなし、全ての
    要素の合併を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cup Set[1, 3] #=> {0, 1, 2, 3, 4}
      s = Set[*(0...15).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].union #=> {1, 7, 11, 13}

--- |
--- +
--- cup
    ((|union|)) のエイリアスです。

--- intersection([other])
    ((|self|)) と ((|other|)) の交わりの集合を返します。
    ((|other|)) が省略された場合、自身を集合の集合とみなし、全ての
    要素の共通部分を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cap(Set[4, 2, 0]) #=> {0, 2, 4}
      s = Set[*(0..30).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].cap #=> {0, 30}

--- &
--- cap
    ((|intersection|)) のエイリアスです。

--- difference(other)
    ((|self|)) から ((|other|)) に含まれる要素を取り除いたものを返します。

--- -
    ((|difference|)) のエイリアスです。

--- each_pair
    集合から異なる２つの要素を取り出して、ブロックパラメータに
    代入して繰り返します。

    例:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_pair do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_member(n)
    集合から異なる ((|n|)) 個の要素を取り出して、ブロックパラメータに
    代入して繰り返します。

    例:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_member(2) do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_subset
    集合の全ての部分集合をブロックパラメータに代入して繰り返します。

    例:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_subset do |t|
        s.append! t
      end
      p s.size = 2**3 #=> true

--- each_non_trivial_subset
    集合の空集合でない真部分集合をブロックパラメータに代入して繰り返します。

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

--- each_product(other)
    ((|self|)) と ((|other|)) の全ての要素 ((|x|)), ((|y|)) に
    ついて、繰り返します。

   例:
      require "finite-set"
      include Algebra
      Set[0, 1].each_prodct(Set[0, 1]) do |x, y|
        p [x, y] #=> [0,0], [0,1], [1,0], [1,1]
      end

--- product(other)
    ((|self|)) と ((|other|)) の積集合を返します。積集合の各元
    は配列 (({[x, y]})) です。ブロックが与えられた時は、ブロック
    を評価した値で構成される集合を返します。

    例:
      require "finite-set"
      include Algebra
      p Set[0, 1].product(Set[0, 1]) #=> {[0,0], [0,1], [1,0], [1,1]}
      p Set[0, 1].product(Set[0, 1]){|x, y| x + 2*y} #=> {0, 1, 2, 3]

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

--- equiv_class([equiv])
    集合を同値関係で割った商集合を返します。同値関係の与え方は次の３通りあります。

    (1) ブロックの評価値を真にする同値関係
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class{|a, b| (a - b) % 3 == 0} #=> {{0, 3}, {1, 4}, {2, 5}}
    (2) 引数に与えられたオブジェクトに対するメソッド ((|call(x, y)|))
        の真偽値による同値関係
          require "finite-set"
          include Algebra
          o = Object.new
          def o.call(x, y)
            (x - y) % 3 == 0
          end
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class(o) #=> {{0, 3}, {1, 4}, {2, 5}}
    (3) 引数に与えられた ((|Symbol|)) に応じたメソッドによる同値関係
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          def q(x, y)
            (x - y) % 3 == 0
          end
          p s.equiv_class(:q) #=> {{0, 3}, {1, 4}, {2, 5}}

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

--- to_a
    集合を配列にして返します。要素の並びの順は不定です。

--- to_ary
    ((<to_a>)) のエイリアスです。

--- sort
    ((<to_a>)) の値をソートして返します。

--- power(other)
    ((|other|)) から ((|self|)) への写像全ての集合を返します。
    写像は ((<Map|URL:finite-map-ja.html>)) の元として表現されます。

    例:
      require "finite-map"
      include Algebra
      a = Set[0, 1, 2, 3]
      b = Set[0, 1, 2]
      s =
      p( (a ** b).size )      #=> 4 ** 3 = 64
      p b.surjections(a).size #=> S(3, 4) = 36
      p a.injections(b).size  #=> 4P3 = 24

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

--- identity_map
    自分への恒等写像を返します。

--- surjections(other)
    ((|other|)) から ((|self|)) への全射全ての集合を返します。

#--- injections0(other)

--- injections(other)
    ((|other|)) から ((|self|)) への単射全ての集合を返します。

--- bijections(other)
    ((|other|)) から ((|self|)) への全単射全ての集合を返します。

#--- monotonic_series #what is this?

= Enumerable

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

== メソッド:

--- any?
    ブロックを真にする要素があるとき、真を返します。
    ((|Enumerable#find|)) の別名です。(built-in of ruby-1.8)

--- all?
    全ての要素についてブロックが真であるとき、真を返します。

      !any?{|x| !yield(x)}

    と定義されています。(built-in of ruby-1.8)

=end


require(nleqslv)
require(xlsx)
library(rgl)

# Aaia?e?oai aoiaiua aaiiua
generate <- function(n, tet, sigma1=0.05, sigma2=0.5, sigma3=0.05, sigma4=0.8) {
  m <- length(tet)
  c(runif(n, -1, 1)) -> ksi
  eta <- apply(sapply(1:m, function(i) ksi^(i-1)), 1, function(r) sum(r * tet))

  rbinom(n, 1, 0.05) -> rb1
  rbinom(n, 1, 0.05) -> rb2

  sapply(rb1, function(x) rnorm(1, 0, switch(x + 1, sigma1, sigma2))) -> delta
  sapply(rb2, function(x) rnorm(1, 0, switch(x + 1, sigma3, sigma4))) -> eps
  X <- cbind(rep(1,n), apply(sapply(2:m, function(i) ksi^(i-1)), 2, function(r) r + delta))
  list(X = matrix(X, nrow = n, ncol = m), y = eta + eps, outliersX = rb1, outliersY = rb2)
}

mnk <- function (X, y) {
  c(solve(t(X) %*% (X)) %*% t(X) %*% matrix(y))
}

# Au?eneyai aaooa
rcr <- function(X, y, tet.init, g0=0.001, h=0.001, eps=1.e-8, g=NULL) {
  b0 <- tet.init[2:length(tet.init)]
  p <- length(tet.init) - 1

  r <- sqrt(apply(sapply(1:p, function(i) (X[,i+1] - mean(X[,i+1]))^2), 1, sum) + (y - mean(y))^2)
  fSxx <- function (i, j) sum((X[,i+1]-mean(X[,i+1])) * (X[,j+1]-mean(X[,j+1])) / r^2)
  fSxy <- function (j) sum((X[,j+1]-mean(X[,j+1])) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)

  Sxx <- matrix(0, nrow = p, ncol = p)
  Sxy <- numeric(p)
  for (i in 1:p) {
    for (j in 1:p) {
      Sxx[i,j] <- fSxx(i, j)
    }
    Sxy[i] <- fSxy(i)
  }

  SS <- function(b, gamma) {
    #gamma0 <- 1 - sum(gamma)
    gamma0 <- gamma[1]
    gamma.other <- gamma[2:length(gamma)]
    Sxx.sum <- 0
    Sxy.sum <- 0
    for (i in 1:p) {
      for (j in 1:p) {
        Sxx.sum <- Sxx.sum + b[i] * b[j] * Sxx[i, j]
      }
      Sxy.sum <- Sxy.sum + b[i] * Sxy[i]
    }
    #sum(sapply(1:5, function (j) sum(sapply(1:5, Sxx, j=j))))
    (gamma0 + sum(gamma.other / b^2)) * (Syy + Sxx.sum - 2 * Sxy.sum)
  }
# f <- function(v) SS(v[1:p], v[(p+1):(2*p)])
  fg <- function(b) function(g) SS(b, g)
  fb <- function(g) function(b) SS(b, g)
  df <- function(f) {
    function (v) {
      l <- length(v)
      grad <- numeric(l)
      for (i in 1:l) {
        v.plus.h <- v
        v.plus.h[i] <- v.plus.h[i] + h
        grad[i] <- (f(v.plus.h) - f(v)) / h
      }
      grad
    }
  }
  norm <- function(x) sqrt(sum(x^2))
  basis <- function(n, i) {
  	a <- numeric(n)
  	a[i] <- 1
  	a
  }

  g.init <- rep(g0, p)
  b.init <- b0
  calc_b <- function (g, b.init=b0) {
  	res <- nleqslv(b.init, df(fb(g)), method = "Newton")
  	res$x
  }

  F <- function(g.p) {
  	g <- c((1-sum(g.p)), g.p)
    b <- calc_b(g, b.init)
    b.init <- b
    #for (i in 1:(p+1)) if (g[i] < 0 || g[i] > 1) return(1000000.0)
    -sum(sapply(1:(p+1), function(i) SS(calc_b(basis(p+1, i), b.init), basis(p+1, i)) / SS(b, basis(p+1, i))))
  }

  theta <- function(gamma) {
  	b <- calc_b(gamma)
  	alpha <- mean(y) - sum(b * sapply(1:p, function(i) (mean(X[,i+1]))))
    c(alpha, b)
  }

 # plot ((1:100) / 100, sapply((1:100) / 100, F))
 #  x <- (1:100) / 100
 #  xn = length(x)
 #  z <- matrix(0, nrow = xn, ncol = xn)
 #  for (i in 1:xn){
 #  for (j in 1:xn){
 #    z[i,j] <- f(x[i], x[j])
 #  	}
	# }
 #  persp3d(z)
  if (!is.null(g)) return(theta(g))

  res <- optim(par=g.init, F)
  #res <- optimize(F, interval=c(0,1))
  g <- c((1-sum(res$par)), res$par)
  #g <- c((1-res$minimum), res$minimum)
  print(c(g, sum(g)))
  #print(c(-F(res$minimum),F(numeric(p)), theta(g)))
  print(c(-F(res$par), -F(numeric(p))))
  theta(g)

  # repeat {
  #   f <- fg(b)
  #   plot (sapply((0:100) / 100, f), (0:100) / 100)

  #   res <- nleqslv(g, df(fg(b)), method = "Newton")
  #   g <- res$x
  #   print (g)
  #   res <- nleqslv(b, df(fb(g)), method = "Newton")
  #   b_new <- res$x
  #   if (norm(b_new - b) / norm(b) <= eps) {
  #     break
  #   }
  #   b <- b_new
  # }

  # psi <- function (gamma) {
  #   t <- theta(gamma)
  #   sum((t - te)^2 /  te^2)
  # }

  # for (g in (1:100) / 100) {
  #   print(c(g, psi(c(1-g,g)), -F(g), theta(c(1-g,g))))
  # }

	# for (g1 in (0:100) / 100) {
	# 	for (g2 in (0:10) / 10) {
	# 		g <- c(1-g1-g2, g1, g2)
	# 		print(c(g, psi(g), -F(c( g1, g2)), theta(g)))
	# 	}
	# }

  #plot(psi, 0, 1)

  # g <-
  # p <- sapply(g, psi)
  # a <- sapply(g,

  # x <- data.frame(g = g, psi = p)
  # write.table(x, file = "rcr.csv", sep = ",",  qmethod = "double")

  # for (g1 in (0:10) / 50) {
  #   for (g2 in (0:10) / 50) {
  #     g <- c(g1, g2)
  #     print(c(g, psi(g), theta(g)))
  #   }
  # }

# F <- function(gamma) {
# t <- theta(gamma)
# b <- t[2]
# ((Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy) - gamma)^2
# }

# o = optimize(F, interval=c(-1, 100000))
# o$minimum

# repeat {

# gamma_new <- (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)

# f <- function(b) (gamma0 + gamma_new / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
# df <- function(b) (f(b + h) - f(b)) / h
# res <- nleqslv(b0, df, method = "Newton")
# b_new <- res$x

# print(gamma)
# if (abs(b_new - b) / abs(b) <= eps || k > 100) {
# break
# }
# #print(k)
# #print(abs(b_new - b) / abs(b))
# b <- b_new
# gamma <- gamma_new
# #k = k+1

# }
}

rcr_err <- function(X, y, tet.init, g0=0.001, h=0.001, eps=1.e-8, g=NULL) {
  b0 <- tet.init[2:length(tet.init)]
  p <- length(tet.init) - 1
  n <- length(y)

  r <- sqrt(apply(sapply(1:p, function(i) (X[,i+1] - mean(X[,i+1]))^2), 1, sum) + (y - mean(y))^2)
  fSxx <- function (i, j) sum((X[,i+1]-mean(X[,i+1])) * (X[,j+1]-mean(X[,j+1])) / r^2)
  fSxy <- function (j) sum((X[,j+1]-mean(X[,j+1])) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)

  Sxx <- matrix(0, nrow = p, ncol = p)
  Sxy <- numeric(p)
  for (i in 1:p) {
    for (j in 1:p) {
      Sxx[i,j] <- fSxx(i, j)
    }
    Sxy[i] <- fSxy(i)
  }

  SS <- function(b, gamma) {
    #gamma0 <- 1 - sum(gamma)
    gamma0 <- gamma[1]
    gamma.other <- gamma[2:length(gamma)]
    Sxx.sum <- 0
    Sxy.sum <- 0
    for (i in 1:p) {
      for (j in 1:p) {
        Sxx.sum <- Sxx.sum + b[i] * b[j] * Sxx[i, j]
      }
      Sxy.sum <- Sxy.sum + b[i] * Sxy[i]
    }
    (gamma0 + sum(gamma.other / b^2)) * (Syy + Sxx.sum - 2 * Sxy.sum)
  }

  fg <- function(b) function(g) SS(b, g)
  fb <- function(g) function(b) SS(b, g)
  df <- function(f) {
    function (v) {
      l <- length(v)
      grad <- numeric(l)
      for (i in 1:l) {
        v.plus.h <- v
        v.plus.h[i] <- v.plus.h[i] + h
        grad[i] <- (f(v.plus.h) - f(v)) / h
      }
      grad
    }
  }
  norm <- function(x) sqrt(sum(x^2))
  basis <- function(n, i) {
    a <- numeric(n)
    a[i] <- 1
    a
  }

  g.init <- rep(g0, p)
  b.init <- b0
  calc_b <- function (g, b.init=b0) {
    res <- nleqslv(b.init, df(fb(g)), method = "Newton")
    res$x
  }

  theta <- function(gamma) {
    b <- calc_b(gamma)
    alpha <- mean(y) - sum(b * sapply(1:p, function(i) (mean(X[,i+1]))))
    c(alpha, b)
  }

  F <- function(g.p) {
    g <- c((1-sum(g.p)), g.p)
    b <- calc_b(g, b.init)
    y.est <- X %*% matrix(theta(g))
    for (i in 1:(p+1)) if (g[i] < 0 || g[i] > 1) return(1000000.0)
    sum(abs(y - y.est)) / n
  }

  res <- optim(par=g.init, F)
  #res <- optimize(F, interval=c(0,1))
  g <- c((1-sum(res$par)), res$par)
  #g <- c((1-res$minimum), res$minimum)
  print(c(g, sum(g)))
  #print(c(-F(res$minimum),F(numeric(p)), theta(g)))
  print(c(F(res$par), F(numeric(p))))
  theta(g)
}

rcr_g0 <- function(X, y, tet.init) {
  m <- length(tet.init)
  g <- numeric(m)
  g[1] <- 1
  rcr(X, y, tet.init, g=g)
}

rcr2 <- function(x, y, b0=0.001, h=0.001, eps=1.e-8, k=0) {
  r <- sqrt((x-mean(x))^2 + (y - mean(y))^2)
  Sxx <- sum((x-mean(x))^2 / r^2)
  Sxy <- sum((x-mean(x)) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)
  my <- mean(y)
  mx <- mean(x)

  theta <- function() {
    f <- function(b) ((1 - (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)) + ((Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)) / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
    df <- function(b) (f(b + h) - f(b)) / h
    res <- nleqslv(b0, df, method = "Newton")
    b <- res$x
    c(my - b * mx, b)
  }

# for (g in (1:100) / 100) {
# print(c(g, theta(g)))
# }

  theta()
# repeat {

# gamma_new <- (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)

# f <- function(b) (gamma0 + gamma_new / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
# df <- function(b) (f(b + h) - f(b)) / h
# res <- nleqslv(b0, df, method = "Newton")
# b_new <- res$x

# print(gamma)
# if (abs(b_new - b) / abs(b) <= eps || k > 100) {
# break
# }
# #print(k)
# #print(abs(b_new - b) / abs(b))
# b <- b_new
# gamma <- gamma_new
# #k = k+1

# }
}

rcr3 <- function(x, y, gamma_init=0.1, b0=0.001, h=0.001, eps=1.e-8) {

  r <- sqrt((x-mean(x))^2 + (y - mean(y))^2)
  Sxx <- sum((x-mean(x))^2 / r^2)
  Sxy <- sum((x-mean(x)) * (y - mean(y)) / r^2)
  Syy <- sum((y-mean(y))^2 / r^2)

  gamma <- gamma_init
  gamma0 <- 1 - gamma
  f  <- function(b) (gamma0 + gamma / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
  df <- function(b) (f(b + h) - f(b)) / h
  res <- nleqslv(b0, df, method = "Newton")
  b <- res$x

  repeat {

    gamma_new <- (Syy - b * Sxy) / (Syy - b * Sxy + b^4 * Sxx - b^3 * Sxy)

    gamma0 <- 1 - gamma_new
    f  <- function(b) (gamma0 + gamma_new / b^2) * (Syy + b^2 * Sxx - 2 * b * Sxy)
    df <- function(b) (f(b + h) - f(b)) / h
    res <- nleqslv(b0, df, method = "Newton")
    b_new <- res$x

    #print(gamma)
    if (abs(b_new - b) / abs(b) <= eps) {
      break
    }
    b <- b_new
    gamma <- gamma_new
  }
  c(mean(y) - b * mean(x), b)
}

als <- function(X, y, tet.init, sigma_init=0.01, eps=1.e-8) {
  m <- length(tet.init)
  n <- length(y)
  matrix(1, nrow=n, ncol=2*m) -> t
  matrix(0, nrow=m, ncol=m) -> P
  rep(1,m) -> R

  t[,2] <- X[,2]

  theta <- function(sd2) {
    for (i in 3:(2*m)) { t[,i] <- X[,2] * t[,i-1] - (i - 2) * sd2 * t[,i-2] }
    for (i in 1:m) { R[i] <- sum(t[,i] * y) }
    for (i in 1:m) { for (j in 1:m) { P[i,j] <- sum(t[,i+j-1]) } }
    c(solve(P) %*% matrix(R))
  }
  # F <- function(sd2) {
  #   tet <- theta(sd2)
  #   #((n * sd2)/(sum(y^2) - sum(R * tet)) - (var(x) / var(y)))^2
  #   #y.est <- apply(sapply(1:m, function(i) x^(i-1) * tet[i]), 1, sum)
  #   y.est <- apply(sapply(1:m, function(i) x^(i-1)), 1, function(r) sum(r * tet))
  #   (((n-m) * sd2)/sum((y - y.est)^2) - var(x)/var(y))^2
  #   #(((n-m) * sd2)/sum((y - sum(R * tet))^2) - 1)^2
  # }

  tet <- tet.init

  norm <- function(x) sqrt(sum(x^2))

  theta(0.01^2)

  #g <- var(x) / var(y)
  # g <- 1

  # print (c(var(x) / var(y), 1))
  # repeat {

  #   y.est <- apply(sapply(1:m, function(i) x^(i-1)), 1, function(r) sum(r * tet))

  #   # print (c(y- y.est))
  #   # break
  #   sd2 <- g * sum((y - y.est)^2) / (n - m)
  #   tet_new <- theta(sd2)
  #   nev <- norm(tet_new - tet) / norm(tet)
  #   print(c(nev, sd2))
  #   if (nev < eps) {
  #     break
  #   }
  #   tet <- tet_new
  # }
  # tet

  # o = optimize(F, interval=c(0, 10))
  # #o = BBoptim(par=0, fn=F)
  # sd2 <- o$minimum
  # print(sd2)
  # print(F(sd2))
  # #plot(F, 0, 10)
  # theta(0.0001)
}

err <- function (data, tet) {
  m <- length(tet)
  n <- length(data$y)
  y.est <- apply(sapply(1:m, function(i) data$X[,i]), 1, function(r) sum(r * tet))
  c(sum((data$y - y.est)^2) / n, sum(abs(data$y - y.est)) / n)
}

report <- function (N, te) {
  psi <- function (tet) sum((tet - te)^2 /  te^2)
  m <- length(te)
  out <- matrix(0, nrow=N, ncol=(m+2)*4)
  for (i in 1:N) {
    data <- generate(500, te)
    tet.mnk <- mnk(data$X, data$y)
    tet.als <- als(data$X, data$y, tet.init=tet.mnk)
    tet.rcr <- rcr(data$X, data$y, tet.init=tet.mnk)
    tet.rcr_g0 <- rcr_g0(data$X, data$y, tet.init=tet.mnk)
    out[i,] <- c(tet.mnk, err(data, tet.mnk), tet.als, err(data, tet.als), tet.rcr, err(data, tet.rcr), tet.rcr_g0, err(data, tet.rcr_g0))
  }
  x <- data.frame(out)
  write.xlsx(x, file = "report.xlsx")
}

model <- function(tet) {
  m <- length(tet)
  Vectorize(function (x) sum(sapply(1:m, function(i) x^(i-1)) * tet))
}

research <- function(f, m=3) {
  dx <- read.table(sprintf("data/x_%s.txt", f))
  dy <- read.table(sprintf("data/y_%s.txt", f))
  data <- list(X = sapply(1:m, function(i) dx$V1^(i-1)), y = dy$V1)

  tet.mnk <- mnk(data$X, data$y)
  print(sprintf("tet.mnk = (%s), err = %f", paste(tet.mnk, collapse=", "), err(data, tet.mnk)[2]))
  plot(model(tet.mnk), 0, 1)

  tet.als <- als(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.als = (%s), err = %f", paste(tet.als, collapse=", "), err(data, tet.als)[2]))
  plot(model(tet.als), 0, 1)

  tet.rcr <- rcr(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.rcr = (%s), err = %f", paste(tet.rcr, collapse=", "), err(data, tet.rcr)[2]))
  plot(model(tet.rcr), 0, 1)

  tet.rcr_err <- rcr_err(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.rcr_err = (%s), err = %f", paste(tet.rcr_err, collapse=", "), err(data, tet.rcr_err)[2]))
  plot(model(tet.rcr_err), 0, 1)

  tet.rcr_g0 <- rcr_g0(data$X, data$y, tet.init=tet.mnk)
  print(sprintf("tet.rcr_g0 = (%s), err = %f", paste(tet.rcr_g0, collapse=", "), err(data, tet.rcr_g0)[2]))
  plot(model(tet.rcr_g0), 0, 1)
}

outliersPlot <- function(te) {
  data <- generate(50, te)
  X.clean = data$X[data$outliersX == 0 & data$outliersY == 0,]
  y.clean = data$y[data$outliersX == 0 & data$outliersY == 0]
  X.outliers = data$X[data$outliersX == 1 | data$outliersY == 1,]
  y.outliers = data$y[data$outliersX == 1 | data$outliersY == 1]

  tet.mnk <- mnk(data$X, data$y)
  tet.als <- als(data$X, data$y, tet.init=tet.mnk)
  tet.als.clean <- als(X.clean, y.clean, tet.init=tet.mnk)

  plot(X.clean[,2], y.clean, col="black")
  plot(model(tet.als), -1, 1, col="red", lwd=2, add=TRUE)
  plot(model(tet.als.clean), -1, 1, col="black", lwd=2, add=TRUE)
  points(X.outliers[,2], y.outliers, col="red")
}

te <- c(1.3, 2.1, 0.4)
#report(1, te)

#research("2_year_421")
outliersPlot(te)

#data <- generate(500, te)
# plot(data$X[,2], data$y)
#b0 <- mnk(data$x, data$y, te=te)
#tet <- rcr(data$x, data$y, te=te, tet.init=b0)


x = seq(-1,1,0.01)
fs = 1.8
fsc = 1.8

#complEx simple box, on differences
pdf("complex_simple_box.pdf",width=7,height=7)
op <- par(mar = c(5,5.5,2,2) +0.1)
contour(x,x,outer(x,x, function(x,y) pmax(0,x) + pmax(x,abs(y))),nlevels=10,cex.lab=fs+0.4, cex.axis=fs, cex.main=fs, cex.sub=fs, labcex=fsc, xlab=expression(Re(theta['b, i']- theta['r, i'])), ylab=expression(Im(theta['b, i'] - theta['r, i'])))
dev.off()

#complex simple sphere
pdf("complex_simple_sphere.pdf",width=7,height=7)
op <- par(mar = c(5,5.5,2,2) +0.1)
contour(x,x,outer(x,x, function(x,y) sqrt(x*x + y*y)),nlevels=10,cex.lab=fs+0.4, cex.axis=fs, cex.main=fs, cex.sub=fs, labcex=fsc, xlab=expression(Re(theta['b, i'] - theta['r, i'])), ylab=expression(Im(theta['b, i'] - theta['r, i'])))
dev.off()


 DPBEQU Example Program Results

 Matrix A
               1            2            3            4
 1    5.4900E+00   2.6800E+10
 2                 5.6300E+20  -2.3900E+10
 3                              2.6000E+00  -2.2200E+00
 4                                           5.1700E+00

 SCOND = 6.8E-11, AMAX = 5.6E+20

 Diagonal scaling factors
     4.3E-01    4.2E-11    6.2E-01    4.4E-01

 Scaled matrix
             1          2          3          4
 1      1.0000     0.4821
 2                 1.0000    -0.6247
 3                            1.0000    -0.6055
 4                                       1.0000


/*

 here's what you can expect to learn. The characteristics of binomial outcome variables, such as buys versus doesn't buy,
 and recovers or get worse, any kind of situation which you might have to make a decision between two or more alternatives
 is an appropriate kind of context for this course. You'll also learn about the reasons that binomial outcome variables create
 problems for standard analysis procedures such as simple and multiple regression.

You'll see how simple transformations that involve odds ratios and logarithms can solve the problems that binomial outcomes
bring to regression analysis. Now I use Excel in this course mainly to show you what goes on inside logistic regression's
black box. You'll be able to see the intermediate calculations involving those odds and those logarithms, and I use R to show
you how to reach the end point of the analysis quickly so that you can skip over those intermediate kinds of calculations.

*/


########## tento skript je nasim uvodnim seznamenim s Rkem ##########
#####################################################################
# povsimnete si, ze v tomto softwaru jsou komentare opatreny (alespon jednim) dvojitym krizkem
# a nezapomente, ze Rko rozeznava velka a mala pismena

### ulozeni cisla do promenne:
##############################
pocet<-30  ## to je pocet studentu zapsanych na pondelni cviceni

### vypsani hodnoty promenne na obrazovku:
##########################################
pocet

### SAMI: a) do promenne VEK ulozte svuj vek (v rocich)
###       b) vypiste promennou VEK
VEK <- 21
VEK

### prace s promennymi... jako by to byla konkretni cisla
#########################################################

XX<-13   ## pocet devcat na cvicenich
XY<-17   ## pocet kluku na cvicenich

XX+XY    ## (by se melo rovnat "poctu")

### SAMI: a) vytvorte promennou NOVA a dosadte do ni podil promennych XX a XY
###       b) vypiste promennou NOVA
###       c) spoctete rozdil mezi promennymi pocet a NOVA

NOVA <- XX/XY
NOVA
pocet - NOVA

######## dalsi dulezita vec pro nas bude prace s vektory ########
#################################################################

### vektor zadany primo
#######################

hele <- c(1, 5, 4, 9, 0)
length(hele)                ## funkce, vypise delku (dimenzi, pocet souradnic) vektoru hele

delka<-length(hele)         ## i funkcni hodnota muze byt ulozena do promenne
delka

### vektor zadany operatorem (muze se hodit)
############################################

x <- 1:7
x

y <- 2:-2
y
### vektor jako konecna posloupnost (i to se hodi)
##################################################

seq(1, 3, by=0.2)          # urcen pocatkem, koncem a velikosti kroku
seq(1, 5, length.out=4)    # urcen                  a poctem elementu

### SAMI: a) vytvorte vektor VEKT_1 s prvky -1,0,0.25,11
###       b) vytvorte vektor VEKT_2 jehoz prvky jsou cisla -2...23
###       c) kolik prvku ma (jak je dlouhy) VEKT_2?

VEKT_1 <- c(-1,0,0.25,11)
VEKT_1

VEKT_2 <- -2:23
VEKT_2
length(VEKT_2)

### prace s prvky vektoru
#########################

x<-c(0,2,4,6,8,10)
x[3]           # vypise 3. prvek

x[c(2, 4)]     # vypise 2. a 4. prvek
y<-x[c(2,4)]    # vytvori vektor z 2. a 4. prvku vektoru x
y

x[-1]          # vsechny prvky krome 1.
y<-x[-1]       # vektor, ktery vznikne z x vynechanim 1. prvku
y

x[c(2, -4)]    # zahlasi chybu, pozice prvku jsou kladna cisla
x[c(2.4, 3.54)]    # zaokrouhli index dolu!!

### SAMI:    uvazujte svuj vektor VEKT_2:
###       a) vypiste 10. prvek
###       b) sectete 13. a 18. prvek
###       c) vydelte 20. prvek prvkem 6.
###       d) do vektoru VEKT_3 ulozte 3.,11., 13. a 20. prvek vektoru VEKT_2

VEKT_2[10]
VEKT_2[13] + VEKT_2[13]
VEKT_2[20] / VEKT_2[6]

VEKT_3 <- VEKT_2[c(3, 11, 13, 20)]
VEKT_3

#uprava vektoru
x[2]<- -10     # prepise druhou souradnici

x[-c(2,4)]     # vypise vsechny prvky vektoru x BEZ 2. a 4. prvku
x[c(-2,-4)]

x<-x[-c(2,4)]  # PRIMO z promene x vymaze druhy a ctvrty element
length(x)
x
x<-NULL        # vymaze "vnitrek" promenne x

### SAMI: a) z vektoru VEKT_2 vytvorte VEKT_4 odebranim 3., 10, a 14. prvku
###       b) jak je dlouhy vektor VEKT_4?

VEKT_4 <- VEKT_2[-c(3, 10, 14)]
VEKT_4
length(VEKT_4)

### ooperace s vektory

y<-c(-3,-2,-1,0,1,2)

x+y     ## soucet po souradnicich
x*y     ## soucin po souradnicich
x-y     ## rozdil po souradnicich
x/y     ## podil po souradnicich, pozor na deleni nulou!!!!

### funkce na vektorech
#######################

length(x)   ## delka vektoru x (uz jsme si ukazali)
sum(x)      ## soucet prvku vektoru x
mean(x)     ## prumer z hodnot ulozenych v x

### spojeni vektoru
###################
novy_vektor<-c(x,y)      ## spoji vektory x a y do jednoho
novy_vektor2<-c(novy_vektor,x)  ## vytvori vektor obsahujici prvky vektoru
                         ## novy_vektor a x

### SAMI: a) vytvorte vektor VEKT_5 spojenim vektoru y a novy_vektor
          b) urcete delku VEKT_5
          c) soucet prvku vektoru VEKT_5 a jejich prumer

VEKT_5 <- c(y, novy_vektor)
VEKT_5
length(VEKT_5)
sum(VEKT_5)
mean(VEKT_5)


## Function file to fit discrete Lee-Carter with Newton-Raphson
## Modified by Giancarlo Camarda 25-11-2009 for teaching purposes
## (EDSD 220)

###################################################
## Update Alpha
Update.alpha <- function(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit){
  difD <- Dth - D.fit
  Alpha <- Alpha + difD %*% One / (D.fit %*% One)
  Eta <- Alpha %*% t(One) + Beta %*% t(Kappa)
  D.fit <- Exp * exp(Eta)
  list(Alpha = Alpha, D.fit = D.fit)
}

###################################################
## Update Beta
Update.beta <- function(Alpha, Beta, Kappa,
                        One, Dth, Exp, D.fit){
  difD <- Dth - D.fit
  Kappa2 <- Kappa * Kappa
  Beta <- Beta + difD %*% Kappa / (D.fit %*% Kappa2)
  Eta <- Alpha %*% t(One) + Beta %*% t(Kappa)
  D.fit <- Exp * exp(Eta)
  list(Beta = Beta, D.fit = D.fit)
}

###################################################
## Update Kappa
Update.kappa <- function(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit){
  difD <- Dth - D.fit
  Beta2 <- Beta * Beta
  Kappa <- Kappa + t(difD) %*% Beta / (t(D.fit) %*% Beta2)
  Kappa <- Kappa - mean(Kappa)
  Kappa <- Kappa / sqrt(sum(Kappa * Kappa))
  Kappa <- matrix(Kappa, ncol = 1)
  Eta <- Alpha %*% t(One) + Beta %*% t(Kappa)
  D.fit <- Exp * exp(Eta)
  list(Kappa = Kappa, D.fit = D.fit)
}

###################################################
##     MAIN FUNCTION for fitting the Lee-Carter
LCpoi <- function(Dth, Exp){
  # dimensions
  m <- nrow(Dth)
  n <- ncol(Dth)
  # Initialise
  One <- matrix(1, nrow=n, ncol = 1)
  Fit.init <- log((Dth + 1)/(Exp + 2))
  Alpha <- Fit.init %*% One / n
  Beta <- matrix(1 * Alpha, ncol = 1)
  sum.Beta <- sum(Beta)
  Beta <- Beta / sum.Beta
  Kappa <- matrix(seq(n, 1, by = -1), nrow = n, ncol = 1)
  Kappa <- Kappa - mean(Kappa)
  Kappa <- Kappa / sqrt(sum(Kappa * Kappa))
  Kappa <- Kappa * sum.Beta
  # Iteration
  D.fit <- Exp * exp(Fit.init)
  for (iter in 1:50){
    Alpha.old <- Alpha
    Beta.old <- Beta
    Kappa.old <- Kappa
    #
    temp <- Update.alpha(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit)
    D.fit <- temp$D.fit
    Alpha <- temp$Alpha
    #
    temp <- Update.beta(Alpha, Beta, Kappa,
                        One, Dth, Exp, D.fit)
    D.fit <- temp$D.fit
    Beta <- temp$Beta
    #
    temp <- Update.kappa(Alpha, Beta, Kappa,
                         One, Dth, Exp, D.fit)
    D.fit <- temp$D.fit
    Kappa <- temp$Kappa
    crit <- max(max(abs(Alpha - Alpha.old)),
                max(abs(Beta - Beta.old)),
                max(abs(Kappa - Kappa.old)))
    if(crit < 1e-04) break
  }
  # constraints
  sum.Beta <- sum(Beta)
  Beta <- Beta / sum.Beta
  Kappa <- Kappa * sum.Beta
  # output
  out <- list(Alpha=Alpha, Beta=Beta, Kappa=Kappa)
}


# Create case study figures

#########################################################################
# Pull PWT into dataframe
data("pwt9.1")

# Basic calculations
p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$lntfp <- log(p$rtfpna)
p$ky <- round(p$rnna/p$rgdpna,digits=2) # create K/Y ratio
p$phil <- round(p$labsh*p$rgdpna/(p$labsh*p$rgdpna+.05*p$rnna),digits=2) # create kludge cost share of labor

# Calculate growth rate of population
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag1.pop = dplyr::lag(pop, n = 1, default = NA))
p$g1.pop <- (log(p$pop) - log(p$lag1.pop))/1
p$si<- round(p$csh_i,digits=2)

# subset PWT into stable and catchup groups
usa <- p[which(p$isocode %in% c("USA")),]
deu <- p[which(p$isocode %in% c("DEU")),]
kor <- p[which(p$isocode %in% c("KOR")),]
chn <- p[which(p$isocode %in% c("CHN")),]
comp <- p[which(p$isocode %in% c("USA","CHN","KOR")),]

#########################################################################
# Simple TS regressions for fitted BGP for USA
#########################################################################
m1 <- lm(usa$lngdppc~usa$year, data=usa)
m2 <- lm(usa$lngdppc~usa$year, data=usa, subset=(year<2001))
usa$fitted <- predict(m2,usa)

fig <- plot_ly(usa, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = fitted(m1), name = 'BGP All',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted, name = 'BGP 20th',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for United States', x=0),
               xaxis = list(title = 'Year', tick0=1950, dtick=10),
               yaxis = list (title = 'Log GDP per capita', range=c(9,12)),
               hovermode="x unified")
api_create(fig, filename = "pwt-apply-usa")

#########################################################################
# Simple TS regressions for fitted BGP for DEU
#########################################################################
m2 <- lm(deu$lngdppc~deu$year, data=deu, subset=(year>1990))
deu$fitted <- predict(m2,deu)

fig <- plot_ly(deu, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted, name = 'BGP',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for Germany', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(7,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-deu")

fig <- plot_ly(deu, x = ~year, y = ~ky, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output for Germany', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Capital/output ratio', range=c(3,5)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply--ky-deu")

#########################################################################
# Simple TS regressions for fitted BGP for KOR
#########################################################################
m1 <- lm(kor$lngdppc~kor$year, data=kor, subset=(year<1963))
kor$fitted1 <- predict(m1,kor)
m2 <- lm(kor$lngdppc~kor$year, data=kor, subset=(year>2009))
kor$fitted2 <- predict(m2,kor)

fig <- plot_ly(kor, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted1, name = 'BGP before',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted2, name = 'BGP after',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(6.5,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-kor")

fig <- plot_ly(kor, x = ~year, y = ~csh_i, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital formation share of GDP for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Capital formation share of GDP', range=c(0,0.6)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-si-kor")

fig <- plot_ly(kor, x = ~year, y = ~g1.pop, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Population growth for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Population growth rate', range=c(0,0.05)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gl-kor")

#########################################################################
# Simple TS regressions for fitted BGP for China
#########################################################################
m1 <- lm(chn$lngdppc~chn$year, data=chn, subset=(year<1970))
chn$fitted1 <- predict(m1,chn)
chn$fitted2 <- predict(m2,chn) # use Korea's current BGP as comparison

fig <- plot_ly(chn, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted1, name = 'BGP before',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted2, name = 'S. Korea BGP',mode = 'lines')
fig <- layout(fig, title = list(text = 'Log GDP per capita for China', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(6.5,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-chn")

fig <- plot_ly(chn, x = ~year, y = ~csh_i, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital formation share of GDP for China', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Capital formation share of GDP', range=c(0,0.6)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-si-chn")

fig <- plot_ly(chn, x = ~year, y = ~g1.pop, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Population growth for China', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Population growth rate', range=c(-.01,0.05)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gl-chn")

#########################################################################
# Comparison of GDP p.c. in USA, China, Korea
#########################################################################
fig <- plot_ly(comp, x = ~year, y = ~lngdppc, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita ', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita', range=c(6.5,12)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-comp")

#########################################################################
# Simple TS regressions for TFP path in China
#########################################################################
f <- p[which(p$isocode %in% c("CHN")),] # re-grab initial data
f <- f[which(f$year>1960),]

m2 <- lm(f$lntfp~f$year, data=f, subset=(year>1960 & year<2000))
m3 <- lm(f$lntfp~f$year, data=f, subset=(year>2013))
f$fitted2 <- predict(m2,f)
f$fitted3 <- predict(m3,f)

fig <- plot_ly(f, x = ~year, y = ~lntfp, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted2, name = 'Early BGP?',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted3, name = 'New BGP?',mode = 'lines')
fig <- layout(fig, title = list(text = 'Level of productivity', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log productivity'),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gtfp-chn")

#########################################################################
# Simple TS regressions for TFP path in Japan
#########################################################################
f <- p[which(p$isocode %in% c("JPN")),]
m1 <- lm(f$lntfp~f$year, data=f, subset=(year<1995))
m3 <- lm(f$lntfp~f$year, data=f, subset=(year>2000))
f$fitted1 <- predict(m1,f)
f$fitted3 <- predict(m3,f)
fig <- plot_ly(f, x = ~year, y = ~lntfp, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~fitted1, name = 'Pre-1995 BGP',mode = 'lines')
fig <- fig %>% add_trace(y = ~fitted3, name = 'Post-2000 BGP',mode = 'lines')
fig <- layout(fig, title = list(text = 'Level of productivity', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log productivity', range=c(-.75,.25)),
              hovermode="x unified")
api_create(fig, filename = "pwt-apply-gtfp-jpn")


#------------------------------------------------------------------------------
#Copyright (c) 2017 Tijana Vujcic

source("DBDA2E-utilities.R")

#===============================================================================

  require(rstan)
  #-----------------------------------------------------------------------------
  # THE DATA.
  myData = read.table(file="BloodDataGeneratorOutput.txt",header=T,sep=" ")
  yName = "HeartAttack"
  xName = c( "Systolic", "Diastolic", "Weight", "Cholesterol",
                      "Height", "Age" )
  y = myData[,yName]
  x = myData[,xName]
  # Do some checking that data make sense:
  if ( any( !is.finite(y) ) ) { stop("All y values must be finite.") }
  #if ( any( !is.finite(x) ) ) { stop("All x values must be finite.") }
  #Ntotal = length(y)
  # Specify the data in a list, for later shipment to JAGS:
  dataList = list(
    x = x ,
    y = y ,
    N = length(y) ,
	p  = 7,
	systolic = x[,1],
	dias = x[,2],
	weight = x[,3],
	cholesterol = x[,4],
	height = x[,5],
	age = x[,6]
  )

  #-----------------------------------------------------------------------------
  # THE MODEL.
  modelString = "
	data {
		int<lower=0> N;
		int<lower=0> p;
		int y[N];
		int<lower=0>  systolic[N];
		int<lower=0>  dias[N];
		real<lower=0> weight[N];
		int<lower=0>  cholesterol[N];
		real<lower=0> height[N];
		int<lower=0>  age[N];
	}

	parameters {
		real beta[p];
	}

	transformed parameters  {

	real<lower=0> odds[N];
	real<lower=0, upper=1> prob[N];

	for (i in 1:N) {
		odds[i] = exp(beta[1] + beta[2]*systolic[i] + beta[3]*dias[i] + beta[4]*weight[i] + beta[5]*cholesterol[i] + beta[6]*height[i] +  beta[7]*age[i]);
		prob[i] = odds[i] / (odds[i] + 1);
	}
	}

	model {
		y ~ bernoulli(prob);
	}

  " # close quote for modelString
  # Write out modelString to a text file

resStan <- stan(model_code = modelString, data = dataList,
                chains = 3, iter = 20000/3, warmup = 1000, thin = 1)


# Clear environment
rm(list = ls())

# Clear console
cat("\014")  # ctrl+L

library(devtools)
# import digest library to hash the value as sha256
library("digest")

# to use sample digest function, you can run this line:
# digest("this is an example string" ,"sha256")

# Before you start building your blockchain,
# you need to start the chain somewhere. This is done
# using a so-called Genesis Block. It contains no data and
# arbitrary values for proof and previous hash (as there is no previous block).

# Define Genesis Block (index 1 and arbitrary previous hash)
# in other words, first block(dummy node).
block_genesis <-  list(index = 1,
                       timestamp = Sys.time(),
                       data = "Genesis Block",
                       previous_hash = "0",
                       proof = 1)

#Function that creates a hashed "block"
hash_block <- function(block){
  block$new_hash <- digest(c(block$index,
                             block$timestamp,
                             block$data,
                             block$previous_hash), "sha256")
  return(block)
}

### Simple Proof of Work Algorithm
proof_of_work <- function(last_proof){
  proof <- last_proof + 1

  # Increment the proof number until a number is found that is divisable by 99 and by the proof of the previous block
  while (!(proof %% 99 == 0 & proof %% last_proof == 0 )){
    proof <- proof + 1
  }

  return(proof)
}

#A function that takes the previous block and normally some data
# (in our case the data is a string indicating which block in the chain it is)
gen_new_block <- function(previous_block){

  #Proof-of-Work
  new_proof <- proof_of_work(previous_block$proof)

  #Create new Block
  new_block <- list(index = previous_block$index + 1,
                    timestamp = Sys.time(),
                    data = paste0("this is block ", previous_block$index +1),
                    previous_hash = previous_block$new_hash,
                    proof = new_proof)

  #Hash the new Block
  new_block_hashed <- hash_block(new_block)

  return(new_block_hashed)
}

# create a list named blockchain whose first node is block_genesis
blockchain <- list(block_genesis)
previous_block <- blockchain[[1]]

# How many blocks should we add to the chain after the genesis block
num_of_blocks_to_add <- 5

# Add blocks to the chain with generated data.
for (i in 1: num_of_blocks_to_add){
  block_to_add <- gen_new_block(previous_block)
  blockchain[i+1] <- list(block_to_add)
  previous_block <- block_to_add

  print(cat(paste0("Block ", block_to_add$index, " has been added", "\n",
                   "\t", "Proof: ", block_to_add$proof, "\n",
                   "\t", "Hash: ", block_to_add$new_hash)))
}

blockchain
build("~/Desktop/adsız klasör/blockchain_R")


model_ptsoil <- function (evapoTranspirationPriestlyTaylor = 120.0,
         Alpha = 1.5,
         tau = 0.9983,
         tauAlpha = 0.3){
    #'- Name: PtSoil -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: PtSoil EnergyLimitedEvaporation Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA Montpellier
    #'            * ExtendedDescription: Evaporation from the soil in the energy-limited stage
    #'            * ShortDescription: Evaporation from the soil in the energy-limited stage
    #'- inputs:
    #'            * name: evapoTranspirationPriestlyTaylor
    #'                          ** description : evapoTranspiration Priestly Taylor
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 120
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: Alpha
    #'                          ** description : Priestley-Taylor evapotranspiration proportionality constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.5
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: tau
    #'                          ** description : plant cover factor
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.9983
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: tauAlpha
    #'                          ** description : Fraction of the total net radiation exchanged at the soil surface when AlpaE = 1
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.3
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'- outputs:
    #'            * name: energyLimitedEvaporation
    #'                          ** description : energy Limited Evaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    if (tau < tauAlpha)
    {
        AlphaE <- 1.0
    }
    else
    {
        AlphaE <- Alpha - ((Alpha - 1.0) * (1.0 - tau) / (1.0 - tauAlpha))
    }
    energyLimitedEvaporation <- evapoTranspirationPriestlyTaylor / Alpha * AlphaE * tau
    return (list('energyLimitedEvaporation' = energyLimitedEvaporation))
}


 ZHEGV Example Program Results

 Eigenvalues
       -5.9990    -2.9936     0.5047     3.9990
 Eigenvectors
             1          2          3          4
 1      1.7405    -0.6626     0.2835     1.2378
        0.0000     0.2258    -0.5806     0.0000

 2     -0.4136    -0.1164    -0.3769    -0.5608
       -0.4689    -0.0178    -0.3194    -0.3729

 3     -0.8404     0.9098    -0.3338    -0.6643
       -0.2483     0.0000    -0.0134    -0.1021

 4      0.3021    -0.6120     0.6663     0.1589
        0.6103    -0.5348     0.0000     0.8366

 Estimate of reciprocal condition number for B
        2.5E-03

 Error estimates for the eigenvalues
        6.7E-13    4.1E-13    1.9E-13    5.0E-13

 Error estimates for the eigenvectors
        1.2E-12    1.1E-12    8.5E-13    9.4E-13


#This takes a matrix of x values, fits c/p/s hierarchically.
#clear environment, load runjags.
rm(list = ls())
library(runjags)

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

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

#create true data frame.
dat <- data.frame(siteID,plotID)
dat <- dat[order(plotID),]
dat$x1 <- x1
dat$x2 <- x2
X <- as.matrix(dat[,c('x1','x2')])

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

jags.model = "
model {
  #priors
  for(m in 1:n.X){
      global[m] ~ dnorm(0,1.0E-4) #global level parameter prior.
    site.tau[m] ~ dgamma(0.1,0.1)
    plot.tau[m] ~ dgamma(0.1,0.1)
    core.tau[m] ~ dgamma(0.1,0.1)
    }

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

} #end model
"
#specify data object.
jags.data <- list(core = X, n.X = ncol(X),
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)
#fit model.
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                               monitor = c('plot','site'))
out <- summary(jags.out)
#compare estimate plot/site means to true values. All w/in 95% credible interval.
par(mfrow = c(2,2))
fit.plot.means <- out[grep('plot',rownames(out)),][,4]
fit.site.means <- out[grep('site',rownames(out)),][,4]
plot(plot.means ~ fit.plot.means[1:90], main = 'plot-level fit x1'); abline(0,1,lwd=2, lty=2)
plot(plot.means ~ fit.plot.means[91:180], main = 'plot-level fit x2'); abline(0,1,lwd=2, lty=2)
plot(site.means ~ fit.site.means[1:10], main = 'site-level fit x1'); abline(0,1,lwd=2, lty=2)
plot(site.means ~ fit.site.means[11:20], main = 'site-level fit x2'); abline(0,1,lwd=2, lty=2)

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

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

X <- as.matrix(missing[,3:4])

#creat new jags data object.
jags.data <- list(core = X, n.X = ncol(X),
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)

#fit, see what the model estimates for core level values.
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('core','plot','site'))

out <- summary(jags.out)
comp <- dat

###FROM here on has not been modded for multivariate case.
comp$pred <- out[grep('core',rownames(out)),4]
comp$removed <- missing$x
z <- comp[is.na(comp$removed),]

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

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

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

testing_development/implement_missing_data_ddirch/matrix of missing data.r


pca.analyse.data = function( X, t0=NULL, t1=NULL,
  fname="sorted.anomalies", title="Years", vars=NULL, newnames=NULL,
  colscheme="redgreen", addscores=TRUE, sortdecreasing=FALSE, scaledata=TRUE, plotdata=TRUE) {

  if (!is.null(vars)) X = X[, vars ]
  if (!is.null(newnames) ) names(X) = newnames

  if (!is.null(t0) & !is.null(t1)) {
    X = X[ which( rowSums( X, na.rm=T) !=0 ) ,]
    X = X[ which( as.numeric(rownames(X)) >= t0 ) ,]
    X = X[ which( as.numeric(rownames(X)) <= t1 ) ,]
  }

  if (scaledata) X = scale( X, center=TRUE, scale=TRUE )

  yvals=rownames(X)
  vars =colnames(X)
  years= as.numeric(yvals)
  yrange = range(years)

  of1 = paste(fname, "PC1.pdf", sep=".")
  of2 = paste(fname, "PC2.pdf", sep=".")
  of3 = paste(fname, "anomalies.pdf", sep=".")

  cm = cor( X, use="pairwise.complete.obs" ) # set up a correlation matrix ignoring NAs
  cm[ is.na(cm) ] = 0

  s = svd(cm)  # eigenanalysis via singular value decomposition
  evec = s$v # eigenvectors
  eval = s$d # eigenvalues

  # i.e., X %*% evec  .. force a multiplication ignoring NAs
  nfac = 2
  ndat = dim(X)[1]
  scores = matrix(0, nrow=ndat, ncol = nfac)
  for (j in 1:nfac) {
    for (i in 1:ndat) {
      scores[i,j] = sum ( X[i,] * t(evec[,j]), na.rm=T )
    }
  }

  x = cbind( scores[,1] / sqrt(eval[1] ), scores[,2] / sqrt( eval[2]) )
  y = cbind( evec[,1] * sqrt(eval[1] ) , evec[,2] * sqrt( eval[2]) )

  outscores = data.frame(x)
  outscores$yr = as.numeric(yvals)

  X.stats = list( id=yvals, vars=vars, correlation.matrix=cm,
    eigenvectors=evec, eigenvalues=eval, projections.id=x, projections.vars=y )

  print( str( X.stats))

  if (plotdata) {

    par(cex=2, lty=2)

    plot.new()
    plot( yvals, x[,1], xlab="Years", ylab=paste("PCA1 (", round(eval[1]/sum(eval)*100, 1), "%)", sep="") )
    lines( lowess(yvals, x[,1], f=1/5 ) )
    dev.print ( pdf, file=of1, width=12, height=8 )
    dev.off()

    plot.new()
    plot( yvals, x[,2], xlab="Years", ylab=paste("PCA2 (", round(eval[2]/sum(eval)*100, 1), "%)", sep="" ) )
    lines( lowess(yvals, x[,2], f=1/5) )
    dev.print ( pdf, file=of2, width=12, height=8 )
    dev.off()

    # form residual variations figure based upon a sorting of ordination scores
    varloadings = NULL
    varloadings = as.data.frame( cbind( y, vars ) )

    q = as.data.frame( t( as.matrix( X ) ) )
    q$vars = rownames( q )
    q = merge( x=q, y=varloadings, by.x="vars", by.y="vars", all=T )
    ordered = sort( as.numeric( as.character( q$V1 ) ), index.return=T, decreasing=sortdecreasing )
    qq = q[ ordered$ix, ]

    if (addscores) {
      varnames = paste(qq$vars, " {", round(as.numeric(as.character(qq$V1)),2), ", ",
                 round(as.numeric(as.character(qq$V2)),2), "}", sep="")
    } else {
      varnames = qq$vars
    }

    qq$vars = qq$V1 = qq$V2 = NULL
    qq = as.data.frame( t( qq ) )
    colnames( qq ) = varnames
    Z = as.matrix( qq )

    a = max( abs( min(Z, na.rm=T) ), abs( max( Z, na.rm=T) ) )
    br = seq( -a, a, .1)

    plot.new()
    par( mai=c(2, 6, 1, 0.5), cex=2 )

    if (colscheme=="rainbow")  {
      cols=rainbow(length(br)-1, start=0, end=1/3)
    } else if (colscheme=="redgreen") {
      cols=rev(green.red(length(br)))
    } else if (colscheme=="bluered") {
      cols=rev(blue.red(length(br)))
    } else if (colscheme=="heat") {
      cols=rev(heat.colors(length(br)-1))
    } else {
      cols=colscheme
    }

    image(z=Z, x=years, breaks=br, col=cols, xlab=title, ylab="", axes=F )

    for (i in seq(range(yrange)[1], range(yrange)[2], by=10)) abline( v=i-0.5, col="slategray")
    for (i in seq(range(yrange)[1], range(yrange)[2], by=1)) abline( v=i-0.5, col="slategray1")

    z = 1/(dim(Z)[2] - 1)
    for (i in seq(0, 1, by=z*10)) abline( h=i-(z/2), col="slategray")
    for (i in seq(0, 1, by=z)) abline( h=i-(z/2), col="slategray1")

    par(las=1)
    axis( 1 )

    vars = colnames(Z)
    par(cex=1.4)
    axis( 2, at=seq(0,1,length=length(vars)), labels=vars)
    write.table(Z, file="anomalies.dat", quote=F, sep=";")
    dev.print (pdf, file=of3, width=20, height=20)
    dev.off()
  }

  return( X.stats )
}


##########################################################################
# github : https://github.com/jiankaiwang/DetailScience
# classification : math
# description : calculate the network in matrix
#
# class description :
# - networkAfterRemoveNodesRetData
#		(1) net : perserve the network after removing nodes recursively
#		(2) sel : perserve the origin nodes for absolutely deletion
#		(3) rmv : perserve nodes for deletion finally
#
# function description :
# - networkAfterRemoveNodes
#   (1) directed : row is the source and column is the target (or destination)
#		(2) return : returned object is "networkAfterRemoveNodesRetData" data type
#
# function usage :
# - networkAfterRemoveNodesRetData networkAfterRemoveNodes(matrix originNetwork, vector selectedNodes, logical isDirected)
#   (1) originNetwork (as matrix) : a matrix conserving edge information
#   (2) selectedNodes (as vector) : a vector listing all nodes are removed
#   (3) isDirected (as boolean) : whether the matrix is directed or not
#
# function example :
# - leftNetwork <- networkAfterRemoveNodes(net,selected,TRUE)
#
# > net
#    A B C D E F G H I
#  A 0 0 1 1 0 0 0 1 0
#  B 0 0 0 0 0 0 0 0 0
#  C 0 0 0 0 0 1 0 0 0
#  D 0 1 0 0 1 0 0 0 0
#  E 0 0 0 0 0 0 0 1 0
#  F 0 0 0 0 0 0 1 0 0
#  G 0 0 0 1 1 0 0 0 0
#  H 0 0 0 0 0 0 0 0 0
#  I 0 0 0 0 0 0 0 0 0
#
# > leftNetwork
# An object of class "classNetAfterNodeRevData"
#	Slot "net":
#		A B C D E F G H I
#	A 0 0 0 1 0 0 0 1 0
#	B 0 0 0 0 0 0 0 0 0
#	C 0 0 0 0 0 0 0 0 0
#	D 0 0 0 0 0 0 0 0 0
#	E 0 0 0 0 0 0 0 0 0
#	F 0 0 0 0 0 0 0 0 0
#	G 0 0 0 0 0 0 0 0 0
#	H 0 0 0 0 0 0 0 0 0
#	I 0 0 0 0 0 0 0 0 0

#	Slot "sel":
#	[1] "B" "C" "E"

#	Slot "rmv":
#	[1] "B" "C" "E" "F" "G"
##########################################################################

networkAfterRemoveNodesRetData <- setClass(
  # Set the name for the class
  "classNetAfterNodeRevData",

  # Define the slots
  slots = c(
    net = "matrix",
    sel = "vector",
    rmv = "vector"
  ),

  # Set the default values for the slots. (optional)
  prototype=list(
    net = matrix(c(1:4),nrow=2,ncol=2,dimnames = list(c("A","B"),c("A","B"))),
    sel = c("A"),
    rmv = c("A")
  ),

  # Make a function that can test to see if the data is consistent.
  # This is not called if you have an initialize function defined!
  validity=function(object)
  {
    if((length(object@net) < 1) || (length(object@sel) < 1) || (length(object@rmv) < 1)) {
      return("Either one of net, selected or removed is not empty.")
    }
    return(TRUE)
  }
)

networkAfterRemoveNodes <- function(originNetwork, selectedNodes, isDirected) {

  # continuously reconstruct the network
  net <- originNetwork

  # construct mask network
  maskOperated <- originNetwork

  # selected items
  selected <- selectedNodes

  # initial flag
  continueFlag = 1

  while(continueFlag == 1) {

    # initial mask matrix
    maskOperated[,] <- 0

    # drug would cause edge missing
    maskOperated[selected,] <- 1
    if(! isDirected) {
      maskOperated[,selected] <- 1
    }

    left <- matrix(
      bitwAnd(net,maskOperated),
      nrow=nrow(net),
      ncol=ncol(net),
      dimnames = list(
        rownames(net),
        colnames(net)
      )
    )

    fetNew <- which(left[,] == 1)
    sourceName <- rownames(net)
    itemName <- colnames(net)
    newSelect <- selected

    # check whether new node is found
    for(item in fetNew) {
      # r default is column-based, not row-based
      sourceNode <- sourceName[item %% nrow(net)]
      checkNode <- itemName[ceiling(item / nrow(net))]

      if(length(which(net[,checkNode] == 1)) > 1) {
        # there are others existing source
        # origin Network must be modified to remove the edge singlely
        # but the node does not be removed
        net[sourceNode,checkNode] <- 0
        next
      }

      # no matter whether node is removed, edge must be removed
      net[sourceNode,checkNode] <- 0

      # there are no other source, this node should be added for removing
      if(checkNode %in% newSelect) {
        next
      } else {
        # add new selected nodes
        newSelect <- c(newSelect,checkNode)
      }

    }

    if(length(newSelect) != length(selected)) {
      # new nodes are added
      selected <- newSelect
    } else {
      # not found new nodes
      continueFlag <- 0
    }

    #print(newSelect)
  }

  # restore the network
  mask <- originNetwork
  mask[,] <- 1
  mask[selected,] <- 0
  # if the destination node is removed
  # the edge between the source and the destination is also removed
  mask[,selected] <- 0
  leftNet <- matrix(
    bitwAnd(originNetwork,mask),
    nrow=nrow(originNetwork),
    ncol=ncol(originNetwork),
    dimnames = list(
      rownames(originNetwork),
      colnames(originNetwork)
    )
  )

  return(networkAfterRemoveNodesRetData(net=leftNet,sel=selectedNodes,rmv=selected))
}


#testing calculating DIC from deviance scores vs. dic.samples()
#clear environment, load packages
rm(list=ls())
library(runjags)

#generate a linear relatioship
set.seed(1234)
n <- 100
x <- rnorm(n)
y <- x + rnorm(n)

#make JAGS data object
jags.data <- list(n = n, x =  x, y = y)

#write JAGS model
jags.model = "
model {
  #parameter priors
      m  ~ dnorm(0, 1E-3)
    tau <- pow(sigma, -2)
  sigma  ~ dunif(0, 100)

  #model
  for(i in 1:n){
        y[i]  ~ dnorm(y.hat[i], tau)
    y.hat[i] <- x[i]*m
  }
} #end model loop.
"

#model for running with fixed parameter values.
fix.model = "
model {
  #model
  for(i in 1:n){
        y[i]  ~ dnorm(y.hat[i], tau)
    y.hat[i] <- x[i]*m
  }
} #end model loop.
"

jags.out <- run.jags(model = jags.model,
                    data = jags.data,
                    n.chains = 3,
                    adapt = 100,
                    burnin = 100,
                    sample = 1000,
                    monitor = c('m','deviance','tau'))
jags.sum <- summary(jags.out)

#grab mean deiviance and parameter means.
jags.deviance.mu <- jags.sum[2,4]
               m <- jags.sum[1,4]
             tau <- jags.sum[3,4]

#new jags data
jags.data <- list(y=y, x=x, n=n, m=m, tau = tau)

#get pD which is deviance at mean parameter values.
pD.out <- run.jags(model = fix.model,
                   data = jags.data,
                   n.chains = 3,
                   adapt = 100,
                   burnin = 100,
                   sample = 1000,
                   monitor = c('deviance'))
pD.sum <- summary(pD.out)
pD <- pD.sum[1,3]

#Calculate DIC.
dic_A <- 2*jags.deviance.mu - pD

#get deviance using dic.samples
dic_B <- extract(jags.out,'DIC')

#compare calculated DIC scores.
dic_A #deviance calculated by rerunning model with parameters set to their mean values.
dic_B #deviance calculated from dic.samples()


wtd.t.test <- function(x, y=0, weight=NULL, weighty=NULL, samedata=TRUE){
  if(is.null(weight)){
    weight <- rep(1, length(x))
  }
  if(length(y)!=length(x) & length(y)>1){
    samedata <- FALSE
    warning("Treating data for x and y separately")
    if(is.null(weighty)){
       warning("y has no weights")
     }
  }
  if(is.null(weighty) & samedata==TRUE){
    weighty <- weight
  }
  if(is.null(weighty) & samedata==FALSE){
    weighty <- rep(1, length(y))
  }
  require(Hmisc)
  n <- sum(!is.na(x))
  mx <- wtd.mean(x, weight, na.rm=TRUE)
  vx <- wtd.var(x, weight, na.rm=TRUE)
  if(length(y)==1){
    dif <- mx-y
    sx <- sqrt(vx)
    se <- sx/sqrt(n)
    t <- (mx-y)/se
    df <- n-1
    p.value <- (1-pt(abs(t), df))*2
    coef <- c(t, df, p.value)
    out2 <- c(dif, mx, y, se)
    names(coef) <- c("t.value", "df", "p.value")
    names(out2) <- c("Difference", "Mean", "Alternative", "Std. Err")
    out <- list("One Sample Weighted T-Test", coef, out2)
    names(out) <- c("test", "coefficients", "additional")
  }
  if(length(y)>1){
    n2 <- sum(!is.na(y))
    my <- wtd.mean(y, weighty, na.rm=TRUE)
    vy <- wtd.var(y, weighty, na.rm=TRUE)
    dif <- mx-my
    sxy <- sqrt((vx/n)+(vy/n2))
    df <- (((vx/n)+(vy/n2))^2)/((((vx/n)^2)/(n-1))+((vy/n2)^2/(n2-1)))
    t <- (mx-my)/sxy
    p.value <- (1-pt(abs(t), df))*2
    coef <- c(t, df, p.value)
    out2 <- c(dif, mx, my, sxy)
    names(coef) <- c("t.value", "df", "p.value")
    names(out2) <- c("Difference", "Mean.x", "Mean.y", "Std. Err")
    out <- list("Two Sample Weighted T-Test (Welch)", coef, out2)
    names(out) <- c("test", "coefficients", "additional")
  }
  out
}


# 3.2. land use regression
mod.min  <- lm(pm25 ~ 1, data=mon.data)
mod.full <- lm(pm25 ~ long + lat + log10.m.to.a1 + log10.m.to.a2 + log10.m.to.a3
                + log10.m.to.road + km.to.coast + s2000.pop.div.10000, data=mon.data)

step(mod.min, direction="both", scope=list(lower = ~1, upper = mod.full), test="F")

# output of step has the coefficients.  Can use that to get the list??

mod <- lm(pm25 ~ km.to.coast + log10.m.to.a1 + log10.m.to.a2 + lat, data=mon.data)

# 3.2.1. leave-one-out cross-validation
for(i in 1:nrow(mon.data)){
  train <- mon.data[-i,]
  test <- mon.data[i,]
  train.lm <- lm(pm25 ~ km.to.coast + log10.m.to.a1 + log10.m.to.a2 + lat, data=train)
  X <- cbind(1,matrix(unlist(test[,names(train.lm$model)[-1]]),nrow=1))
  pred.1 <- X %*% train.lm$coef
  if(i==1) pred <- pred.1 else pred <- c(pred,pred.1)
}

mse.lur <- mean( (mon.data$pm25 - pred)^2 )
r2.lur <- 1 - mse.lur/var(mon.data$pm25)
mse.lur
r2.lur


###################################################################################
# R-script submitted as Supplementary Information to Seebens et al. (2016) No
# saturation in the accumulation of alien species worldwide. Nature Communications ....
#
# The script is called by the file Rcode_Seebens-etal_InvasionModel_PropPress_MAIN.r
# which reproduces the modelling results shown in Supplementary Fig. 5 of the article.
#
# This file simulates the model scenario: linear increase.
#
# The model implemented here describes the temporal development of the
# accumulation of alien species on an island, which were randomly depicted
# from an arbitrary mainland community. The probability of depicting a species
# may change during the simulation depending on the scenario to account for increases
# in propagule and colonisation pressures due to e.g. increases of trade volumes.
# For further details, consult the article.
# Five scenarios were simulated assuming different increases in the rate of
# introduction (constant, linear or exponential increase, related to import
# volumes or the number of founded botanic gardens).
#
# The code is free of use as long as the article is properly cited.
#
# Author of code: Hanno Seebens, Frankfurt, Germany
# 25. August, 2016
###################################################################################

##### Defintion of objects/variables for simulation ###########################################################

n_spec <- 50000 # number of species of the mainland community
t_max <- 202000 # max simulation time

n_bins <- 1000 # number of steps abundances of the mainland community are stored

add <- "lininc" # type of increase in propagule pressure, required for output file; here: linear increase

## Define temporal development of propagule pressure ###########################################################
m <- seq(0,mean(m)*2,length.out=t_max) # linear increase
timeaxis <- seq(1,t_max/1000,length.out=t_max) # for plotting

# define basic characteristics of community size #############################################################
mlog <- seq(-3,1,length.out=5) # size of communities (defined as mean of log-normal distribution) for different model scenarios
sdlog <- 300 # standard deviation of log-normal distribution, constant
run_tot <- length(mlog)*length(sdlog) # number of model scenarios

######### SIMULATION #########################################################################################

island <- matrix(0,nr=t_max,nc=run_tot+1) # results file
island[,1] <- 1:t_max # include time axis in first column
all_main <- matrix(0,nr=n_bins,nc=run_tot) # store communities (abundances and species)
x <- 0 # counter
for (j in 1:length(mlog)){# loop through model scenarios depending on the number of defined means
  for (i in 1:length(sdlog)){# loop through model scenarios depending on the number of defined standard deviations
    x <- x + 1 # increase counter

    ## define mainland community ###############################################
    specabund <- dlnorm((seq(0.1,2,length.out=n_bins)),meanlog=mlog[j],sdlog=1)*10000
    axis1 <- seq(10,10000,length.out=n_bins) # steps of storing individuals per species (for plotting)
    specabund <- ceiling(specabund) # avoid decimals in abundances
    specabund <- round(specabund/sum(specabund)*n_spec) # rescale numbers

    tot_spec <- sum(specabund) # number of species
    abundances <- rep(axis1,round(specabund)) # set abundances
    tot_abund <- sum(abundances) # number of individuals
    all_main[,x] <- specabund # store community
    print(tot_spec)
    print(tot_abund)

    #### simulation ############################################################################
    for (t in 1:t_max){ # loop through time steps

      ## select individual from mainland community and transfer it on the island
      if (runif(1)<m[t]){  # determine if new individual arrives, depending on propagule pressure m at time t
        ind <- runif(1)*tot_abund # if individual arrives, determine new individual
        spec <- max(which(c(0,cumsum(abundances))<=ind)) # select species accordingly
        # if (spec==-Inf) break #
        island[t,x+1] <- spec # store species entry at time t and scenario x
      }
    }
    ## process time series of arriving individuals
    dupl <- duplicated(island[,x+1]) # identify duplicated entries of species in time series
    island[which(dupl),x+1] <- 0 # set all duplicated entries to zero (i.e., remove all entries after the first occurrence of that species)
    island[which(!dupl),x+1] <- 1  # set all species numbers to 1 (species identity is not required any more)
  }
}

## calculate number of first records per year #####################
ts_round <- round(timeaxis) # get an annual time axis
isl_agg <- matrix(NA,nr=length(unique(ts_round)),nc=dim(island)[2]-1) # results files
for (i in 2:dim(island)[2]){
  isl_agg[,i-1] <- tapply(island[,i],ts_round,sum) # sum up number of new species per year
}

### output (only the information which is required to create the plot) ######################################
write.table(isl_agg,paste("SimInvAcc_VarMain_island_",add,".csv",sep=""),sep=";",row.names=F)
write.table(unique(ts_round),paste("SimInvAcc_VarMain_realtime_",add,".csv",sep=""),sep=";",row.names=F)
write.table(all_main,paste("SimInvAcc_VarMain_allmain_",add,".csv",sep=""),sep=";",row.names=F)
write.table(axis1,paste("SimInvAcc_VarMain_axis1_",add,".csv",sep=""),sep=";",row.names=F)
write.table(timeaxis[seq(1,t_max,length.out=200)],paste("SimInvAcc_VarMain_timeaxis_",add,".csv",sep=""),sep=";",row.names=F)
write.table(m[seq(1,t_max,length.out=200)],paste("SimInvAcc_VarMain_PropPress_",add,".csv",sep=""),sep=";",row.names=F)

information/Seebens - 2017 - No saturation in the accumulation of alien species/Rcode_Seebens-etal_InvasionModel_Linear.r


##### Chapter 9: Clustering with k-means -------------------

## Example: Finding Teen Market Segments ----
## Step 2: Exploring and preparing the data ----
teens <- read.csv("snsdata.csv")
str(teens)

# look at missing data for female variable
table(teens$gender)
table(teens$gender, useNA = "ifany")

# look at missing data for age variable
summary(teens$age)

# eliminate age outliers
teens$age <- ifelse(teens$age >= 13 & teens$age < 20,
                     teens$age, NA)

summary(teens$age)

# reassign missing gender values to "unknown"
teens$female <- ifelse(teens$gender == "F" &
                         !is.na(teens$gender), 1, 0)
teens$no_gender <- ifelse(is.na(teens$gender), 1, 0)

# check our recoding work
table(teens$gender, useNA = "ifany")
table(teens$female, useNA = "ifany")
table(teens$no_gender, useNA = "ifany")

# finding the mean age by cohort
mean(teens$age) # doesn't work
mean(teens$age, na.rm = TRUE)

# age by cohort
aggregate(data = teens, age ~ gradyear, mean, na.rm = TRUE)

# calculating the expected age for each person
ave_age <- ave(teens$age, teens$gradyear,
                 FUN = function(x) mean(x, na.rm = TRUE))

teens$age <- ifelse(is.na(teens$age), ave_age, teens$age)

# check the summary results to ensure missing values are eliminated
summary(teens$age)

## Step 3: Training a model on the data ----
interests <- teens[5:40]
interests_z <- as.data.frame(lapply(interests, scale))

teen_clusters <- kmeans(interests_z, 5)

## Step 4: Evaluating model performance ----
# look at the size of the clusters
teen_clusters$size

# look at the cluster centers
teen_clusters$centers

## Step 5: Improving model performance ----
# apply the cluster IDs to the original data frame
teens$cluster <- teen_clusters$cluster

# look at the first five records
teens[1:5, c("cluster", "gender", "age", "friends")]

# mean age by cluster
aggregate(data = teens, age ~ cluster, mean)

# proportion of females by cluster
aggregate(data = teens, female ~ cluster, mean)

# mean number of friends by cluster
aggregate(data = teens, friends ~ cluster, mean)