### TITLE: Full Matching Effect Ratio Code ###
### MAINTAINER: Hyunseung Kang (hskang at stanford dot edu)
### LAST UPDATE: Nov. 29, 2015
### SUMMARY: The code implements the full matching IV method
###          described in the paper Kang, Kreuels, May,
###          and Small (2015+). Specifically, the main
###          function, estLambda(), estimates the
###          effect ratio parameter described in the
###          said paper.
### REQUIRES: MASS, optmatch, AER (R packages, install them
###           from CRAN)
### USAGE: Copy-paste the R code below. At the end of
###        the code is a simple running example of
###        the code from simulated data.

### Libraries to Load ####
library(optmatch)
library(AER)

### Functions ###
##### smahal: Obtain rank-based Mahalanobis distance
### FUNCTION: Creates a rank-based Mahalanobis distance.
### INPUT: 1) Z: instruments (n by 1 vector), Z =1 (treated) and Z = 0 (not treated)
###        2) X: covariates  (n by p matrix}
### OUTPUT: 1) n by n rank-based Mahalanobis distance matrix
smahal= function(Z,X){
  X<-as.matrix(X)
  n<-dim(X)[1]
  rownames(X)<-1:n
  k<-dim(X)[2]
  m<-sum(Z)
  for (j in 1:k) X[,j]<-rank(X[,j])
  cv<-cov(X)
  vuntied<-var(1:n)
  rat<-sqrt(vuntied/diag(cv))
  cv<-diag(rat)%*%cv%*%diag(rat)
  out<-matrix(NA,m,n-m)
  Xc<-X[Z==0,]
  Xt<-X[Z==1,]
  rownames(out)<-rownames(X)[Z==1]
  colnames(out)<-rownames(X)[Z==0]
  icov<-ginv(cv)
  for (i in 1:m) out[i,]<-mahalanobis(Xc,Xt[i,],icov,inverted=T)
  out
}

##### addcaliper: adds caliper to the matching matrix
### FUNCTION: Creates a calipered rank-based Mahalanobis distance from a distance matrix.
### INPUT: 1) dmat: distance matrix.
###        2) Z: instruments (n by 1 vector), Z =1 (treated) and Z = 0 (not treated)
###        3) logitp: logit propensity scores from logistic regression (n by 1 vector)
###        4) calipersd, indicator on when to caliper
###        5) penalty, how much penalty for exceeding caliper bounds
### OUTPUT: 1) n by n with caliper added
addcaliper=function(dmat,Z,logitp,calipersd=.2,penalty=1000){
  sd.logitp=sd(logitp)
  adif=abs(outer(logitp[Z==1],logitp[Z==0],"-"))
  adif=(adif-(calipersd*sd.logitp))*(adif>(calipersd*sd.logitp))
  dmat=dmat+adif*penalty
  dmat
}

##### matching: does full matching
### FUNCTION: creates a vector that matches treatment to control
### INPUT: 1) Z: a n-length vector that lists treatment (as 1) and control (as 0)
###        2) X: a n-by-p matrix of covariates
###        3) type: type of matching, defaults to full matching
###        4) ratio: if full matching or 1:m matching, checks to see the control/treatment ratio
###        5) matchInfo: should the function print out the matching information?
### OUTPUT: 1) a n-vector vector containing match numbers.
### NOTE: The matching function (smahal, prop.score, caliper, and fullmatch) are
###       very sensitive to how the observations are ordered. Currentyl, smahal
###       orders the observations by how Z is ordered.
matching = function(Z,X,type=c("full","pair","1:m"),ratio,matchInfo=FALSE) {
  type = match.arg(type)

  # Pre-processing
  Z = as.logical(Z);

  # Rank-based distance matrix
  rank.mat = smahal(Z,X)

  # Propensity scores
  model = glm(Z ~ X,family="binomial"); prop.score = predict(model);

  # Fix rank-based distance matrix by propensity score calipers
  rank.mat.caliper = addcaliper(rank.mat,Z,prop.score)

  # Actual matching
  if(type == "pair") pairmatchvec = pairmatch(rank.mat.caliper,data=1:length(Z))
  if(type == "full") {
  	  if(missing(ratio)) pairmatchvec = fullmatch(rank.mat.caliper,data=1:length(Z))
  	  else pairmatchvec = fullmatch(rank.mat.caliper,data=1:length(Z),min.controls=1/ratio,max.controls=ratio)
  }
  if(type == "1:m") pairmatchvec = pairmatch(rank.mat.caliper,data=1:length(Z),controls=ratio)
  if(matchInfo) print(summary(pairmatchvec))

  # Post-processing
  pairmatchvec = as.numeric(substr(pairmatchvec,start=3,stop=20))
  return(pairmatchvec)
}

##### estLambda: estimates Lambda, provide confidence interval, and p-value
### FUNCTION: provides point est, confidence interval, and p-value
### INPUT: Z: instrument (n by 1 vector)
###        R: response (n by 1 vector)
###        D: dose (n by 1 vector)
###        X: covariate matrix (n by p)
###        matchedNumber: matching vector from matching() function
###        null: the lambda_0 value in H0: lambda = lambda_0
###        alphaLevel: alpha level for the confidence interval
### OUTPUT: point Est, confidence interval, and p-value
estLambda = function(Z,R,D,X,matchedNumber,null = 0,alphaLevel = 0.05) {
  if(alphaLevel >= 0.5) stop("alphaLevel is improperly set")

  X.factorize = model.matrix(~X)
  if(missing(matchedNumber)) matchedNumber = matching(Z,X,"full")

  # Deal with non-matched individuals #
  R.matchedIndiv = R[!is.na(matchedNumber)]
  D.matchedIndiv = D[!is.na(matchedNumber)]
  Z.matchedIndiv = Z[!is.na(matchedNumber)]
  matchedNumber.matchedIndiv = matchedNumber[!is.na(matchedNumber)]

  # Sort individuals in ascending matching order
  matchedNumber.sortedIndex = sort(matchedNumber.matchedIndiv,index.return=TRUE)$ix
  R.sorted = R.matchedIndiv[matchedNumber.sortedIndex]
  D.sorted = D.matchedIndiv[matchedNumber.sortedIndex]
  Z.sorted = Z.matchedIndiv[matchedNumber.sortedIndex]
  matchedNumber.sorted = matchedNumber.matchedIndiv[matchedNumber.sortedIndex]

  # Calculate the size of each matched set and the corresponding weights
  ni = tabulate(matchedNumber.sorted);
  ni = ni[!(ni == 0)] #this cleans up a flaw with matching algorithm
                      #where some matched numbers (e.g. 1:I) are not used between
		      	     	  	  	    #1 to I
  I = length(ni)
  wi = ni^2 / (ni - 1)  #Actual formula: ni^2 /(mi * (ni - mi))

  # Calculate Vi, Gi, and Hi
  # Formula
  # Vi = Gi - lambda * Hi
  # Gi = wi*(Zij - Zimean)(Rij - Rimean) = wi*(ZijRij - ni*Zmean.*Rmean.)
  # Hi = wi*(Zij - Zimean)(Dij - Dimean) = wi*(ZijDij - ni*Zmean.*Dmean.)

  # This requires some thought. Basically, because R,D,Z are all ordered based on matchedset number,
  # we use cumsum to obtain means of R, D, and Z within each group as well as means of RZ and DZ.
  # The key here is using the cumsum(ni), which keeps track of the indices in all the ordered vectors
  ni.cumsum = cumsum(ni)
  RZ.cumsum = cumsum(R.sorted*Z.sorted); DZ.cumsum = cumsum(D.sorted*Z.sorted)
  R.cumsum = cumsum(R.sorted); D.cumsum = cumsum(D.sorted); Z.cumsum = cumsum(Z.sorted)
  R.means = (R.cumsum[ni.cumsum] - c(0,R.cumsum[ni.cumsum[-length(ni.cumsum)]]))/ni
  Z.means = (Z.cumsum[ni.cumsum] - c(0,Z.cumsum[ni.cumsum[-length(ni.cumsum)]]))/ni
  D.means = (D.cumsum[ni.cumsum] - c(0,D.cumsum[ni.cumsum[-length(ni.cumsum)]]))/ni

  RZ.group = RZ.cumsum[ni.cumsum] - c(0,RZ.cumsum[ni.cumsum[-length(ni.cumsum)]])
  DZ.group = DZ.cumsum[ni.cumsum] - c(0,DZ.cumsum[ni.cumsum[-length(ni.cumsum)]])

  Gi = wi * RZ.group - wi * ni * R.means * Z.means
  Hi = wi * DZ.group - wi * ni * D.means * Z.means

  # Compute the point estimate
  pointEst = sum(Gi) / sum(Hi)

  # Compute the p-value under the null
  ViNull = Gi - null * Hi
  testStatNull = mean(ViNull) / sqrt(1/(I *(I-1)) * sum( (ViNull - mean(ViNull))^2) )
  pvalue = 2* (1 - pnorm(abs(testStatNull)))

  # Compute the quadratic terms for CI
  # A*lambda^2 + B*lambda + C = 0 (technically, it's A*lambda^2 + B*lambda + C <= 0)
  q = qnorm(1 - alphaLevel/2)
  A = sum(Hi)^2/I^2 - q^2 /(I * (I-1)) * sum( (Hi - mean(Hi))^2)
  B = -2 * (sum(Hi) * sum(Gi) / I^2 - q^2 / (I * (I-1)) * sum( (Hi - mean(Hi)) * (Gi - mean(Gi))))
  C = sum(Gi)^2/I^2 - q^2/(I * (I-1)) * sum( (Gi - mean(Gi))^2)

  detQuad = round(B^2 - 4*A*C,9) #6 is set for numerical accuracy
  if( detQuad <= 0) {
    if(A < 0) {
      cis = matrix(c(-Inf,Inf),1,2)
      } else {
        cis = matrix(c(NA,NA),1,2)
	}
  }
  if(detQuad > 0) {
    if(A < 0) {
      up.ci = (-B - sqrt(detQuad))/ (2*A)
      low.ci = (-B + sqrt(detQuad)) / (2*A)
        cis = matrix(c(-Inf,low.ci,up.ci,Inf),2,2,byrow=TRUE)
	} else {
	  low.ci = (-B - sqrt(detQuad))/ (2*A)
      up.ci = (-B + sqrt(detQuad)) / (2*A)
        cis = matrix(c(low.ci,up.ci),1,2)
	}
  }
  return(list(pointEst = pointEst,cis = cis,pvalue = pvalue))
}
###### est2SLS
### FUNCTION: computes the 2SLS estimate using the AER package
### INPUT: Z: instrument (n by 1 vector)
###        R: response (n by 1 vector)
###        D: dose (n by 1 vector)
###        X: covariate matrix (n by p)
###        null: null Value under H_0:
### OUTPUT: point Est, confidence interval, and p-value
est2SLS <- function(Z,R,D,X,null=0) {
  library(AER)
  model = ivreg(R ~ D + X | Z + X)
  model.summary = summary(model)
  coefficientTable = model.summary$coefficients
  dfTest = model.summary$df[2]
  estValue = as.numeric(coefficientTable[2,1])
  stdError = as.numeric(coefficientTable[2,2])
  tValue = abs( (estValue - null) / stdError)
  pvalue = 2*(1 - pt(tValue,dfTest))
  confInt = matrix(as.numeric(confint(model)[2,]),1,2)
  return(list(pointEst = estValue,cis = confInt,pvalue = pvalue))
}

###### estOLS
### FUNCTION: computes the OLS estimate
### INPUT: Z: instrument (n by 1 vector), note this is not used in OLS
###        R: response (n by 1 vector)
###        D: dose (n by 1 vector)
###        X: covariate matrix (n by p)
### OUTPUT: point Est, confidence interval, and p-value
estOLS <- function(Z,R,D,X) {
  model = lm(R ~ D + X)
  estValue = as.numeric(coefficients(model))[2]
  pvalue = as.numeric(summary(model)$coefficients[2,4])
  confInt = matrix(as.numeric(confint(model)[2,]),1,2)
  return(list(pointEst = estValue,cis = confInt,pvalue=pvalue))
}

##### sensInt
### FUNCTION: does sensitivity analysis
### INPUT: Gamma: a scalar value
###        Z: binary treatment/control vector (n time 1)
###        R: binary response (n * 1)
###        pairmatchvec: vector of matches (handles no matches)
### OUTPUT: lower and upper bounds for sensitivity analysis
### NOTE: Can only handle sensitivity analysis if there are multiple controls
###      (but not if there are multiple treatments) AND if the response is binary
sensInt <- function(Gamma,Z,R,pairmatchvec) {
  matchedSets = unique(pairmatchvec[!is.na(pairmatchvec)]);
  cs.plus = rep(0,length(I))
  ps.plus = rep(0,length(I))
  ps.minus = rep(0,length(I))
  testStat = rep(0,length(I))
  ds= rep(0,length(I))
  for(i in 1:length(matchedSets)) {
    index = matchedSets[i]
    matchedSetID = which(pairmatchvec == index)
    ni = length(matchedSetID); mi = sum(Z[matchedSetID])
    cs.plus[i] = sum(R[matchedSetID])
    ps.plus[i] = Gamma * cs.plus[i]/(Gamma*cs.plus[i] + ni - cs.plus[i])
    ps.minus[i] = cs.plus[i]/(cs.plus[i] + (ni - cs.plus[i])*Gamma)
    ds[i] = ni/(mi*(ni - mi))
    testStat[i] = ds[i] * sum(Z[matchedSetID] * R[matchedSetID])
  }
  T = sum(testStat)
  lowerBound = (T - sum(ds * ps.plus)) /(sqrt(sum(ds^2 * ps.plus * (1 - ps.plus))))
  upperBound = (T - sum(ds * ps.minus)) /(sqrt(sum(ds^2 * ps.minus * (1 - ps.minus))))
  return(c(lowerBound,upperBound))
}

##### balanceCheck
### FUNCTION: checks the balance of covariates before and after matching
### INPUT: Z: treatment/control vector (n time 1)
###        X: covariates (n * p)
###        pairmatchvec: vector of matches (handles no matches)
### OUTPUT: a table of standardized differences
balanceCheck <- function(Z,X,pairmatchvec) {
   # Before Matching #
   X.C.BeforeMatch = X[Z == 0,]; X.T.BeforeMatch = X[Z == 1,];
   overallSD = sqrt(apply(X.C.BeforeMatch,2,var) + apply(X.T.BeforeMatch,2,var)/2)
   stdDiff.Before = abs((colMeans(X.T.BeforeMatch) - colMeans(X.C.BeforeMatch))/overallSD)
   # After Matching #
   matchedSets = unique(pairmatchvec[!is.na(pairmatchvec)]);
   X.C.AfterMatch = matrix(0,length(matchedSets),ncol(X)); X.T.AfterMatch = matrix(0,length(matchedSets),ncol(X));
   nTreatedAfterMatch = rep(0,length(matchedSets))
   for(i in 1:length(matchedSets)) {
      treatedZ = which(pairmatchvec == matchedSets[i] & Z == 1)
     controlZ = which(pairmatchvec == matchedSets[i] & Z == 0)
     X.C.AfterMatch[i,] = colMeans(X[controlZ,,drop=FALSE]); X.T.AfterMatch[i,] = colMeans(X[treatedZ,,drop=FALSE])
     nTreatedAfterMatch[i] = length(treatedZ)
   }
   stdDiff.After = apply( X.T.AfterMatch - X.C.AfterMatch,2,function(x){ sum(x * nTreatedAfterMatch) / sum(nTreatedAfterMatch)}) / overallSD
   stdDiff.After = abs(stdDiff.After)
   output = cbind(stdDiff.Before,stdDiff.After)
   colnames(output) = c("Standardized differences before matching","Standardized differences after matching")
   return(output)
}

##### effectSampleSize
### FUNCTION: computes the asymptotic variance of effectRatio estimator and the maximum strata size for effectratio estimator
### INPUT: Z: treatment/control vector (n time 1)
###        matchedNumber: vector of matches
### OUTPUT: a two-dimensional vector, the first dimension being the effective sample size and the second dimension being the maximum strata size.
effectSampleSize <- function(Z,matchedNumber) {
  # Deal with non-matched individuals #
  Z.matchedIndiv = Z[!is.na(matchedNumber)]
  matchedNumber.matchedIndiv = matchedNumber[!is.na(matchedNumber)]

  # Sort individuals in ascending matching order
  matchedNumber.sortedIndex = sort(matchedNumber.matchedIndiv,index.return=TRUE)$ix
  Z.sorted = Z.matchedIndiv[matchedNumber.sortedIndex]
  matchedNumber.sorted = matchedNumber.matchedIndiv[matchedNumber.sortedIndex]

  # Calculate the size of each matched set and the corresponding weights
  ni = tabulate(matchedNumber.sorted); I = length(ni)
  ni.max = max(ni)
  asympVarEffectRatio = (sum(ni^3 / (ni - 1)) * 1/I) / (sum(ni) / I)^2
  print(paste("Asymptotic variance of effect ratio estimator is",asympVarEffectRatio))
  print(paste("Maximmum strata size is",ni.max))
  return(c(asympVarEffectRatio,ni.max))
}

##### matchSizeAnalysis
### FUNCTION: analyzes the size of matched Sets as a function of the covariates
### INPUT: pairmatchvec: vector of of matches
###        Z: treatment/control vector
###        X: covariates
### OUTPUT: a two-dimensional vector, the first dimension being the effective sample size and the second dimension being the maximum strata size.
matchSizeAnalysis <- function(pairmatchvec,Z,X) {
  matchedSets = unique(pairmatchvec[!is.na(pairmatchvec)]); I = length(matchedSets)
  Y.sizeMatch = rep(0,I)
  Y.controlMatch = rep(0,I)
  X.covAvg = matrix(0,I,ncol(X))

  for(i in 1:I) {
    set.i = which(matchedSets[i] == pairmatchvec)
    Y.controlMatch[i] = sum(Z[set.i])
    Y.sizeMatch[i] = length(set.i)
    for(j in 1:ncol(X.covAvg)) {
      X.covAvg[i,j] = mean(X[set.i,j])
      }
  }
  colnames(X.covAvg) = colnames(X)
  return(data.frame(Y.sizeMatch = Y.sizeMatch,Y.controlMatch=Y.controlMatch,X.covAvg))
}


# Estadiistica descriptiva (I): Teoría de probabilidades: distribuciones, varianza.

#################################################################
# Limpiemos todo primero.
cat("\014")
rm(list=ls())
graphics.off()

## Este truco instala el paquete si es que no esta instalado, y lo llama usando "library".
## Si NO está instalado, lo instala, y despues lo llama usando "library".
## Es, básicamente, un instalador y cargador CONDICIONAL de paquetes.
## Este paquete que ejecuta esta accion condicional, se llama "pacman".

# Usuarios MAC: asegurarse de tener XQuartz instalado
# https://dl.bintray.com/xquartz/downloads/XQuartz-2.7.11.dmg

install.packages("cem")
library(cem)

if (!require("pacman")) install.packages("pacman"); library(pacman) # Ahora cargaremos "pacman"
p_load(cem) # y aqui le decimos a pacman que revise si tienes el paquete "cem" que utilizaremos para el sgte. ej. Si no lo tienes, lo instalará, y lo llamará.
# En resumen, p_load() reemplaza install.packages("paquete") y "library(paquete)".

# En la libreria "cem" vive una base de datos muy famosa, conocida como LaLonde. Carguemosla para la sgte. actividad.
data(LL)

# Veamos en que consiste.
head(LL)

## Variables

# treated: Indicator variable for whether the participant received the treatment.
# age: Measured in years.
# education: Years of education.
# black: Indicator variable for whether the participant is African-American.
# married: Indicator variable for whether the participant is married.
# nodegree: Indicator variable for not possessing a high school diploma
# re74: Real earnings in 1974. re75:
# Real earnings in 1975.
# re78: Real earnings in 1978.
# hispanic: Indicator variable for whether the participant is Hispanic.
# u74: Indicator variable for unemployed in 1974.
# u75: Indicator variable for unemployed in 1975.

#################################################################
# Estadistica Descriptiva
#################################################################

# En esta seccion revisaremos los estadisticos descriptivos mas usados.

#################################################################
# Promedio (o media) (o "mean" en ingles).
#################################################################

# 1) Es la medida mas usada para medir la centralidad de la distribucion.
# 2) Todos los datos, como vimos, siguen una distribucion. Por ej., veamos la distribucion
# etarea de los sujetos entrevistados en esta base de datos.

## Un histograma
histogram(LL$age) # El promedio debiera ser cercano a 20 años.

## Veamos ahora el promedio de esta variable usando el comando "mean()"
mean(LL$age)

## Redondear numeros usando el comando "round"
round(mean(LL$age), 1) # con un decimal.
round(mean(LL$age), 0) # con 0 decimales.

#################################################################
# Mediana (o "median" en ingles).
#################################################################

# Muestra el valor que vive al medio de la distribucion.
# Ventaja: es mas robusta (o resistente) a los valores extremos, si la comparamos con el promedio.
# Recuerda. Para calcular el promedio, debemos incorporar los valores extremos (los muy altos, y los muy bajos).
# Y esto afecta el promedio. No asi con la mediana: no cambia si agregamos valores extremos.
# En la distribucion normal: mediana = media = moda.

### Primero, ordenemos los numeros de mayor a menor.
LL$age
ll.age.ordenado = sort(LL$age)
ll.age.ordenado

# Calculemos la mediana
median(LL$age)

### OK. Los valores estan ordenados de menor a mayor. Segundo, veamos que largo tiene este vector (usando el comando "lenght", que significa "largo").
length(ll.age.ordenado)

length(ll.age.ordenado)/2 # OK. Ahora, veamos el elemento que vive al medio de esta lista de numeros.
# 361.

## 1) OK. Es un numero impar. Que significa eso?
## 2) Qué pasa con los numeros pares?

## OK. Ahora llamemos al elemento 361
ll.age.ordenado[361]

## Comprobemos que nuestro calculo esta correcto.
median(LL$age) == ll.age.ordenado[361] # OK.

##  Conclusion preliminar # 1
round(mean(LL$age), 0) > median(LL$age)
## Que significa eso?
## "Skewness" positiva. Hay ciertos valores "extremos" que estan inflando el promedio (hacia arriba).

#################################################################
# Un resumen un poco mas completo
#################################################################

summary(LL) # de toda la base
summary(LL$age) # de la variable "age" ("edad")

# 1) Voluntari@ para dibujar un _________ en la pizarra? Usando esta informacioón, cómo se vería este gráfico?

#################################################################
# Tablas de Frecuencia
#################################################################

# Por ej., cuantos estan casados ("married") en nuestra base de datos?
table(LL$married)

# Otro ejemplo, cuantos Afro-Americanos estan casados?
table(LL$married, LL$black) # Siempre es table(FILA, COLUMNA). Ese orden (FILA, COLUMNA) siempre es asi en R.
## En ese sentido, los casados van en la fila, y los Afroamericanos en las columnas.

#################################################################
# Medidas de Dispersion
#################################################################

# Ademas de ver cuan centrada esta nuestra distrubucion, tambien queremos ver
# cuan dispersas estan las observaciones del promedio.
var(LL$age)

# 1) Que significa eso?
# Como lo solucionamos?

# Solucion: desviacion estandard.
sd(LL$age)

## redondear
round(sd(LL$age),0) # 7

# La DS es la raiz cuadrada ("square root", comando "sqrt") de la varianza (comando "var"), que esta en escala cuadrada.
sqrt(var(LL$age)) == sd(LL$age) # Comprobando.

# Qué significa todo esto?
## Existe la regla "68-95-99.7" que aplica sólo a distribuciones normales (nuestra variable de edad NO es normal...).

## 68% de los datos caen dentro del rango de +/- 1 DS  de la media. Es decir:
mean(LL$age) - round(sd(LL$age),0) # rango minimo
mean(LL$age) + round(sd(LL$age),0) # rango maximo

## 95% de los datos caen dentro del rango de +/- 2 DS's  de la media.
mean(LL$age) - 2*(round(sd(LL$age),0)) # rango minimo
mean(LL$age) + 2*(round(sd(LL$age),0)) # rango maximo

## 99.7% de los datos caen dentro del rango de +/- 3 DS's  de la media.
mean(LL$age) - 3*(round(sd(LL$age),0)) # rango minimo
mean(LL$age) + 3*(round(sd(LL$age),0)) # rango maximo


# ----------------------------------------
#  App Title: Benford's Law and Sequences
#     Author: Jimmy Doi
# ----------------------------------------

library(RColorBrewer)
library(shinyIncubator)

########################################
seq.gen <- function(length,val.1,val.2){

  seq <- numeric(length)
  seq[1] <- val.1
  seq[2] <- val.2

  for (i in 3:length) {
    seq[i] <- seq[i-1]+seq[i-2]
  }
  return(seq)
}

########################################
pow.gen <- function(base,length){

  seq <- base**(1:length)

  return(seq)
}

########################################
prime.gen <- function(n){
  n <- as.integer(n)
  if(n > 1e8) stop("n too large")
  primes <- rep(TRUE, n)
  primes[1] <- FALSE
  last.prime <- 2L
  fsqr <- floor(sqrt(n))
  while (last.prime <= fsqr)
  {
    primes[seq.int(2L*last.prime, n, last.prime)] <- FALSE
    sel <- which(primes[(last.prime+1):(fsqr+1)])
    if(any(sel)){
      last.prime <- last.prime + min(sel)
    }else last.prime <- fsqr+1
  }
  which(primes)
}

########################################
string.1st <- function(sequence,max){
  string1 <- substr(as.character(sequence[1:max]),1,1)
  #  string1<-paste(" ",string1,sep="")
  return(string1)
}

########################################
string.2nd <- function(sequence,max){
  string2 <- substr(as.character(sequence[1:max]),2,1000000L)
  string2.a<-paste(string2,", ",sep="")
  string2.a[max]<-string2[max]
  return(string2.a)
}

########################################
print.string <- function(string,num){
  #names(string)<-""
  return(string[num])
}

########################################
goodness.test <- function(sequence){

  string <- substr(as.character(sequence),1,1)

  first.digits <- as.integer(string)

  # In the event any of the 9 possible digits is not observed in the string,
  # table(first.digits) will not display all digits 1, 2, ..., 9. An example is
  #
  # NAME     1  2  3  4  5  6  7  9
  # FREQ    12 11  9  8  6  5  4  2
  #
  # Here, obs <- as.integer(table(first.digits)) would only contain 8 elements.
  # To correct for this, initialize obs to a zero vector, loop through NAME,
  # find FREQ corresponding to NAME,then paste that FREQ in obs[NAME].
  # This will also work for the case when all 9 possible digits are observed.

  Obs <- seq(0,0,,9)

  for (i in as.numeric(names(table(first.digits))))  {
    pos <- which(as.numeric(names(table(first.digits)))==i)
    Obs[i]<- as.numeric(table(first.digits))[pos]
  }
  i <- seq(1,9)

  Exp <- length(sequence)*log10(1+1/i)

  Digit <- seq(1,9)

  #print(info)

  chisq <- sum(((Obs-Exp)**2)/Exp)

  Exp <- round(Exp,3)
  info <- cbind(Digit,Obs,Exp)
  rownames(info)<-rep("",nrow(info))

  #print(chisq)

  p.value <- 1-pchisq(chisq,8)

  text.chi <- paste("Chi Square = ",format(round(chisq,3),nsmall=3),sep="")
  names(text.chi)<-""

  text.pval <- paste("P Value = ",format(round(p.value,3),nsmall=3),sep="")
  names(text.pval)<-""

  print(info)
  print(text.chi,quote=F)
  print(text.pval,quote=F)

}

########################################
pr.goodness.test <- function(sequence,big.n){

  string <- substr(as.character(sequence),1,1)

  first.digits <- as.integer(string)

  # In the event any of the 9 possible digits is not observed in the string,
  # table(first.digits) will not display all digits 1, 2, ..., 9. An example is
  #
  # NAME     1  2  3  4  5  6  7  9
  # FREQ    12 11  9  8  6  5  4  2
  #
  # Here, obs <- as.integer(table(first.digits)) would only contain 8 elements.
  # To correct for this, initialize obs to a zero vector, loop through NAME,
  # find FREQ corresponding to NAME,then paste that FREQ in obs[NAME].
  # This will also work for the case when all 9 possible digits are observed.

  Obs <- seq(0,0,,9)

  for (i in as.numeric(names(table(first.digits))))  {
    pos <- which(as.numeric(names(table(first.digits)))==i)
    Obs[i]<- as.numeric(table(first.digits))[pos]
  }

  i <- seq(1,9)

  alpha <- 1/(log(big.n)-1.10)

  gbl <- 1/(10**(1-alpha)-1)*((i+1)**(1-alpha)-i**(1-alpha))

  Exp <- length(sequence)*gbl

  Digit <- seq(1,9)

  chisq <- sum(((Obs-Exp)**2)/Exp)

  Exp <- round(Exp,3)
  info <- cbind(Digit,Obs,Exp)
  rownames(info)<-rep("",nrow(info))

  p.value <- 1-pchisq(chisq,8)

  text.chi <- paste("Chi Square = ",format(round(chisq,3),nsmall=3),sep="")
  names(text.chi)<-""

  text.pval <- paste("P Value = ",format(round(p.value,3),nsmall=3),sep="")
  names(text.pval)<-""

  print(info)
  print(text.chi,quote=F)
  print(text.pval,quote=F)

}

############################################
pmf.compare<-function(sequence){

  string <- substr(as.character(sequence),1,1)

  first.digits <- as.integer(string)

  # In the event any of the 9 possible digits is not observed in the string,
  # table(first.digits) will not display all digits 1, 2, ..., 9. An example is
  #
  # NAME     1  2  3  4  5  6  7  9
  # FREQ    12 11  9  8  6  5  4  2
  #
  # Here, obs <- as.integer(table(first.digits)) would only contain 8 elements.
  # To correct for this, initialize obs to a zero vector, loop through NAME,
  # find FREQ corresponding to NAME,then paste that FREQ in obs[NAME].
  # This will also work for the case when all 9 possible digits are observed.

  Obs <- seq(0,0,,9)

  for (i in as.numeric(names(table(first.digits))))  {
    pos <- which(as.numeric(names(table(first.digits)))==i)
    Obs[i]<- as.numeric(table(first.digits))[pos]
  }
  i <- seq(1,9)

  pmf.Exp <- cbind(seq(1,9)+0.065,log10(1+1/i))
  pmf.Obs <- cbind(seq(1,9)-0.065,Obs/sum(Obs))

  col1 <- brewer.pal(n = 12, name = "Paired")[8]
  col2 <- brewer.pal(n = 12, name = "Paired")[2]

  par(mar=c(3.5,4.5,2,0))

  my.lwd <- 3.75

  if (max(pmf.Obs[,2])>=max(pmf.Exp[,2])){
    plot(pmf.Obs[,1],pmf.Obs[,2],type="n",col=col1,xlim=c(0.75,9.25), xlab="",ylab="Proportion", xaxt="n", main="Proportion of First Digits")
    axis(1, at=seq(1,9), labels=c("1","2","3","4","5","6","7","8","9"))
    mtext("First Digit",1,line=2.5)
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Obs[i,1],pmf.Obs[i,1]),c(0,pmf.Obs[i,2]),col=col1,lwd=my.lwd)
    }
    for (i in 1:nrow(pmf.Exp)){
      lines(c(pmf.Exp[i,1],pmf.Exp[i,1]),c(0,pmf.Exp[i,2]),col=col2,lwd=my.lwd)
      legend("topright", inset=.02,
             c("Observed Proportion","Benford's Law"), fill=c(col1,col2), horiz=F)
    }
  }

  if (max(pmf.Obs[,2])<max(pmf.Exp[,2])){
    plot(pmf.Exp[,1],pmf.Exp[,2],type="n",col=col2,xlim=c(0.75,9.25), xlab="", ylab="Proportion", xaxt="n", main="Proportion of First Digits")
    axis(1, at=seq(1,9), labels=c("1","2","3","4","5","6","7","8","9"))
    mtext("First Digit",1,line=2.5)
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Exp[i,1],pmf.Exp[i,1]),c(0,pmf.Exp[i,2]),col=col2,lwd=my.lwd)
    }
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Obs[i,1],pmf.Obs[i,1]),c(0,pmf.Obs[i,2]),col=col1,lwd=my.lwd)
    }
    legend("topright", inset=.02,
           c("Observed Proportion","Benford's Law"), fill=c(col1,col2), horiz=F)
  }
}

############################################
pr.pmf.compare<-function(sequence,big.n){

  string <- substr(as.character(sequence),1,1)

  first.digits <- as.integer(string)

  # In the event any of the 9 possible digits is not observed in the string,
  # table(first.digits) will not display all digits 1, 2, ..., 9. An example is
  #
  # NAME     1  2  3  4  5  6  7  9
  # FREQ    12 11  9  8  6  5  4  2
  #
  # Here, obs <- as.integer(table(first.digits)) would only contain 8 elements.
  # To correct for this, initialize obs to a zero vector, loop through NAME,
  # find FREQ corresponding to NAME,then paste that FREQ in obs[NAME].
  # This will also work for the case when all 9 possible digits are observed.

  Obs <- seq(0,0,,9)

  for (i in as.numeric(names(table(first.digits))))  {
    pos <- which(as.numeric(names(table(first.digits)))==i)
    Obs[i]<- as.numeric(table(first.digits))[pos]
  }
  i <- seq(1,9)

  alpha <- 1/(log(big.n)-1.10)

  gbl <- 1/(10**(1-alpha)-1)*((i+1)**(1-alpha)-i**(1-alpha))

  pmf.Exp <- cbind(seq(1,9)+0.065,gbl)

  pmf.Obs <- cbind(seq(1,9)-0.065,Obs/sum(Obs))

  col1 <- brewer.pal(n = 12, name = "Paired")[8]
  col2 <- brewer.pal(n = 12, name = "Paired")[2]

  par(mar=c(3.5,4.5,2,0))

  my.lwd <- 3.75

  if (max(pmf.Obs[,2])>=max(pmf.Exp[,2])){
    plot(pmf.Obs[,1],pmf.Obs[,2],type="n",col=col1,xlim=c(0.75,9.25), xlab="",ylab="Proportion", xaxt="n", main="Proportion of First Digits",
         ylim=c(0.06,
         max(1.05*max(pmf.Obs[,2]),1.05*max(pmf.Exp[,2])))
      )
    axis(1, at=seq(1,9), labels=c("1","2","3","4","5","6","7","8","9"))
    mtext("First Digit",1,line=2.5)
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Obs[i,1],pmf.Obs[i,1]),c(0,pmf.Obs[i,2]),col=col1,lwd=my.lwd)
    }
    for (i in 1:nrow(pmf.Exp)){
      lines(c(pmf.Exp[i,1],pmf.Exp[i,1]),c(0,pmf.Exp[i,2]),col=col2,lwd=my.lwd)
      legend("topright", inset=.02,
             c("Observed Proportion","Generalized Benford's Law"), fill=c(col1,col2), horiz=F)
    }
  }

  if (max(pmf.Obs[,2])<max(pmf.Exp[,2])){
    plot(pmf.Exp[,1],pmf.Exp[,2],type="n",col=col2,xlim=c(0.75,9.25), xlab="", ylab="Proportion", xaxt="n", main="Proportion of First Digits",
         ylim=c(0.06,
      max(1.05*max(pmf.Obs[,2]),1.05*max(pmf.Exp[,2]))))
    axis(1, at=seq(1,9), labels=c("1","2","3","4","5","6","7","8","9"))
    mtext("First Digit",1,line=2.5)
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Exp[i,1],pmf.Exp[i,1]),c(0,pmf.Exp[i,2]),col=col2,lwd=my.lwd)
    }
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Obs[i,1],pmf.Obs[i,1]),c(0,pmf.Obs[i,2]),col=col1,lwd=my.lwd)
    }
    legend("topright", inset=.02,
           c("Observed Proportion","Generalized Benford's Law"), fill=c(col1,col2), horiz=F)
  }
}

##############################################################################
# Shiny Server Contents
##############################################################################

shinyServer(function(input, output, session) {

  #########################################################################
  ## Additive Sequence
  #########################################################################

    withProgress(session, {
      setProgress(message = "Calculating, please wait.",
                  detail = " ", value=1)

  output$val.1st <- renderText({input$seq1})

  output$val.2nd <- renderText({input$seq2})

  output$textlength <- renderText({input$length})

  seqInput <- reactive({
    seq.gen(input$length,input$seq1,input$seq2)
  })

  output$goodness <- renderPrint({
    goodness.test(seqInput())
  })

  firstDigit <- reactive({
    string.1st(seqInput(),50)
  })

  restDigit <- reactive({
    string.2nd(seqInput(),50)
  })

  output$num.1a <- renderText({print.string(firstDigit(),  1)})
  output$num.1b <- renderText({print.string(restDigit(),   1)})
  output$num.2a <- renderText({print.string(firstDigit(),  2)})
  output$num.2b <- renderText({print.string(restDigit(),   2)})
  output$num.3a <- renderText({print.string(firstDigit(),  3)})
  output$num.3b <- renderText({print.string(restDigit(),   3)})
  output$num.4a <- renderText({print.string(firstDigit(),  4)})
  output$num.4b <- renderText({print.string(restDigit(),   4)})
  output$num.5a <- renderText({print.string(firstDigit(),  5)})
  output$num.5b <- renderText({print.string(restDigit(),   5)})
  output$num.6a <- renderText({print.string(firstDigit(),  6)})
  output$num.6b <- renderText({print.string(restDigit(),   6)})
  output$num.7a <- renderText({print.string(firstDigit(),  7)})
  output$num.7b <- renderText({print.string(restDigit(),   7)})
  output$num.8a <- renderText({print.string(firstDigit(),  8)})
  output$num.8b <- renderText({print.string(restDigit(),   8)})
  output$num.9a <- renderText({print.string(firstDigit(),  9)})
  output$num.9b <- renderText({print.string(restDigit(),   9)})
  output$num.10a <- renderText({print.string(firstDigit(),10)})
  output$num.10b <- renderText({print.string(restDigit(), 10)})
  output$num.11a <- renderText({print.string(firstDigit(),11)})
  output$num.11b <- renderText({print.string(restDigit(), 11)})
  output$num.12a <- renderText({print.string(firstDigit(),12)})
  output$num.12b <- renderText({print.string(restDigit(), 12)})
  output$num.13a <- renderText({print.string(firstDigit(),13)})
  output$num.13b <- renderText({print.string(restDigit(), 13)})
  output$num.14a <- renderText({print.string(firstDigit(),14)})
  output$num.14b <- renderText({print.string(restDigit(), 14)})
  output$num.15a <- renderText({print.string(firstDigit(),15)})
  output$num.15b <- renderText({print.string(restDigit(), 15)})
  output$num.16a <- renderText({print.string(firstDigit(),16)})
  output$num.16b <- renderText({print.string(restDigit(), 16)})
  output$num.17a <- renderText({print.string(firstDigit(),17)})
  output$num.17b <- renderText({print.string(restDigit(), 17)})
  output$num.18a <- renderText({print.string(firstDigit(),18)})
  output$num.18b <- renderText({print.string(restDigit(), 18)})
  output$num.19a <- renderText({print.string(firstDigit(),19)})
  output$num.19b <- renderText({print.string(restDigit(), 19)})
  output$num.20a <- renderText({print.string(firstDigit(),20)})
  output$num.20b <- renderText({print.string(restDigit(), 20)})
  output$num.21a <- renderText({print.string(firstDigit(), 21)})
  output$num.21b <- renderText({print.string(restDigit(),  21)})
  output$num.22a <- renderText({print.string(firstDigit(), 22)})
  output$num.22b <- renderText({print.string(restDigit(),  22)})
  output$num.23a <- renderText({print.string(firstDigit(), 23)})
  output$num.23b <- renderText({print.string(restDigit(),  23)})
  output$num.24a <- renderText({print.string(firstDigit(), 24)})
  output$num.24b <- renderText({print.string(restDigit(),  24)})
  output$num.25a <- renderText({print.string(firstDigit(), 25)})
  output$num.25b <- renderText({print.string(restDigit(),  25)})
  output$num.26a <- renderText({print.string(firstDigit(), 26)})
  output$num.26b <- renderText({print.string(restDigit(),  26)})
  output$num.27a <- renderText({print.string(firstDigit(), 27)})
  output$num.27b <- renderText({print.string(restDigit(),  27)})
  output$num.28a <- renderText({print.string(firstDigit(), 28)})
  output$num.28b <- renderText({print.string(restDigit(),  28)})
  output$num.29a <- renderText({print.string(firstDigit(), 29)})
  output$num.29b <- renderText({print.string(restDigit(),  29)})
  output$num.30a <- renderText({print.string(firstDigit(),30)})
  output$num.30b <- renderText({print.string(restDigit(), 30)})
  output$num.31a <- renderText({print.string(firstDigit(), 31)})
  output$num.31b <- renderText({print.string(restDigit(),  31)})
  output$num.32a <- renderText({print.string(firstDigit(), 32)})
  output$num.32b <- renderText({print.string(restDigit(),  32)})
  output$num.33a <- renderText({print.string(firstDigit(), 33)})
  output$num.33b <- renderText({print.string(restDigit(),  33)})
  output$num.34a <- renderText({print.string(firstDigit(), 34)})
  output$num.34b <- renderText({print.string(restDigit(),  34)})
  output$num.35a <- renderText({print.string(firstDigit(), 35)})
  output$num.35b <- renderText({print.string(restDigit(),  35)})
  output$num.36a <- renderText({print.string(firstDigit(), 36)})
  output$num.36b <- renderText({print.string(restDigit(),  36)})
  output$num.37a <- renderText({print.string(firstDigit(), 37)})
  output$num.37b <- renderText({print.string(restDigit(),  37)})
  output$num.38a <- renderText({print.string(firstDigit(), 38)})
  output$num.38b <- renderText({print.string(restDigit(),  38)})
  output$num.39a <- renderText({print.string(firstDigit(), 39)})
  output$num.39b <- renderText({print.string(restDigit(),  39)})
  output$num.40a <- renderText({print.string(firstDigit(),40)})
  output$num.40b <- renderText({print.string(restDigit(), 40)})
  output$num.41a <- renderText({print.string(firstDigit(), 41)})
  output$num.41b <- renderText({print.string(restDigit(),  41)})
  output$num.42a <- renderText({print.string(firstDigit(), 42)})
  output$num.42b <- renderText({print.string(restDigit(),  42)})
  output$num.43a <- renderText({print.string(firstDigit(), 43)})
  output$num.43b <- renderText({print.string(restDigit(),  43)})
  output$num.44a <- renderText({print.string(firstDigit(), 44)})
  output$num.44b <- renderText({print.string(restDigit(),  44)})
  output$num.45a <- renderText({print.string(firstDigit(), 45)})
  output$num.45b <- renderText({print.string(restDigit(),  45)})
  output$num.46a <- renderText({print.string(firstDigit(), 46)})
  output$num.46b <- renderText({print.string(restDigit(),  46)})
  output$num.47a <- renderText({print.string(firstDigit(), 47)})
  output$num.47b <- renderText({print.string(restDigit(),  47)})
  output$num.48a <- renderText({print.string(firstDigit(), 48)})
  output$num.48b <- renderText({print.string(restDigit(),  48)})
  output$num.49a <- renderText({print.string(firstDigit(), 49)})
  output$num.49b <- renderText({print.string(restDigit(),  49)})
  output$num.50a <- renderText({print.string(firstDigit(),50)})
  output$num.50b <- renderText({print.string(restDigit(), 50)})

  output$pmf <- renderPlot({
    pmf.compare(seqInput())
    })

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

  output$powlength <- renderText({input$pow.length})

  e.seqInput <- reactive({
    pow.gen(input$pow.base,input$pow.length)
  })

  output$e.goodness <- renderPrint({
    goodness.test(e.seqInput())
  })

  e.firstDigit <- reactive({
    string.1st(e.seqInput(),20)
  })

  e.restDigit <- reactive({
    string.2nd(e.seqInput(),20)
  })

  output$e.num.1a <- renderText({print.string(e.firstDigit(),  1)})
  output$e.num.1b <- renderText({print.string(e.restDigit(),   1)})
  output$e.num.2a <- renderText({print.string(e.firstDigit(),  2)})
  output$e.num.2b <- renderText({print.string(e.restDigit(),   2)})
  output$e.num.3a <- renderText({print.string(e.firstDigit(),  3)})
  output$e.num.3b <- renderText({print.string(e.restDigit(),   3)})
  output$e.num.4a <- renderText({print.string(e.firstDigit(),  4)})
  output$e.num.4b <- renderText({print.string(e.restDigit(),   4)})
  output$e.num.5a <- renderText({print.string(e.firstDigit(),  5)})
  output$e.num.5b <- renderText({print.string(e.restDigit(),   5)})
  output$e.num.6a <- renderText({print.string(e.firstDigit(),  6)})
  output$e.num.6b <- renderText({print.string(e.restDigit(),   6)})
  output$e.num.7a <- renderText({print.string(e.firstDigit(),  7)})
  output$e.num.7b <- renderText({print.string(e.restDigit(),   7)})
  output$e.num.8a <- renderText({print.string(e.firstDigit(),  8)})
  output$e.num.8b <- renderText({print.string(e.restDigit(),   8)})
  output$e.num.9a <- renderText({print.string(e.firstDigit(),  9)})
  output$e.num.9b <- renderText({print.string(e.restDigit(),   9)})
  output$e.num.10a <- renderText({print.string(e.firstDigit(),10)})
  output$e.num.10b <- renderText({print.string(e.restDigit(), 10)})
  output$e.num.11a <- renderText({print.string(e.firstDigit(),11)})
  output$e.num.11b <- renderText({print.string(e.restDigit(), 11)})
  output$e.num.12a <- renderText({print.string(e.firstDigit(),12)})
  output$e.num.12b <- renderText({print.string(e.restDigit(), 12)})
  output$e.num.13a <- renderText({print.string(e.firstDigit(),13)})
  output$e.num.13b <- renderText({print.string(e.restDigit(), 13)})
  output$e.num.14a <- renderText({print.string(e.firstDigit(),14)})
  output$e.num.14b <- renderText({print.string(e.restDigit(), 14)})
  output$e.num.15a <- renderText({print.string(e.firstDigit(),15)})
  output$e.num.15b <- renderText({print.string(e.restDigit(), 15)})
  output$e.num.16a <- renderText({print.string(e.firstDigit(),16)})
  output$e.num.16b <- renderText({print.string(e.restDigit(), 16)})
  output$e.num.17a <- renderText({print.string(e.firstDigit(),17)})
  output$e.num.17b <- renderText({print.string(e.restDigit(), 17)})
  output$e.num.18a <- renderText({print.string(e.firstDigit(),18)})
  output$e.num.18b <- renderText({print.string(e.restDigit(), 18)})
  output$e.num.19a <- renderText({print.string(e.firstDigit(),19)})
  output$e.num.19b <- renderText({print.string(e.restDigit(), 19)})
  output$e.num.20a <- renderText({print.string(e.firstDigit(),20)})
  output$e.num.20b <- renderText({print.string(e.restDigit(), 20)})

  output$e.pmf <- renderPlot({pmf.compare(e.seqInput())})

  #########################################################################
  ## Power Sequence
  #########################################################################

  pr.seqInput <- reactive({

    pr.big.n <-as.integer(input$my.n)

    prime.gen(pr.big.n)
  })

  output$num.primes <- reactive({length(pr.seqInput())})

  output$pr.goodness <- renderPrint({
    pr.big.n <-as.integer(input$my.n)

    pr.goodness.test(pr.seqInput(),pr.big.n)
  })

  pr.firstDigit <- reactive({
    string.1st(pr.seqInput(),80)
  })

  pr.restDigit <- reactive({
    string.2nd(pr.seqInput(),80)
  })

  output$pr.num.1a <- renderText({print.string(pr.firstDigit(),  1)})
  output$pr.num.1b <- renderText({print.string(pr.restDigit(),   1)})
  output$pr.num.2a <- renderText({print.string(pr.firstDigit(),  2)})
  output$pr.num.2b <- renderText({print.string(pr.restDigit(),   2)})
  output$pr.num.3a <- renderText({print.string(pr.firstDigit(),  3)})
  output$pr.num.3b <- renderText({print.string(pr.restDigit(),   3)})
  output$pr.num.4a <- renderText({print.string(pr.firstDigit(),  4)})
  output$pr.num.4b <- renderText({print.string(pr.restDigit(),   4)})
  output$pr.num.5a <- renderText({print.string(pr.firstDigit(),  5)})
  output$pr.num.5b <- renderText({print.string(pr.restDigit(),   5)})
  output$pr.num.6a <- renderText({print.string(pr.firstDigit(),  6)})
  output$pr.num.6b <- renderText({print.string(pr.restDigit(),   6)})
  output$pr.num.7a <- renderText({print.string(pr.firstDigit(),  7)})
  output$pr.num.7b <- renderText({print.string(pr.restDigit(),   7)})
  output$pr.num.8a <- renderText({print.string(pr.firstDigit(),  8)})
  output$pr.num.8b <- renderText({print.string(pr.restDigit(),   8)})
  output$pr.num.9a <- renderText({print.string(pr.firstDigit(),  9)})
  output$pr.num.9b <- renderText({print.string(pr.restDigit(),   9)})
  output$pr.num.10a <- renderText({print.string(pr.firstDigit(),10)})
  output$pr.num.10b <- renderText({print.string(pr.restDigit(), 10)})
  output$pr.num.11a <- renderText({print.string(pr.firstDigit(),11)})
  output$pr.num.11b <- renderText({print.string(pr.restDigit(), 11)})
  output$pr.num.12a <- renderText({print.string(pr.firstDigit(),12)})
  output$pr.num.12b <- renderText({print.string(pr.restDigit(), 12)})
  output$pr.num.13a <- renderText({print.string(pr.firstDigit(),13)})
  output$pr.num.13b <- renderText({print.string(pr.restDigit(), 13)})
  output$pr.num.14a <- renderText({print.string(pr.firstDigit(),14)})
  output$pr.num.14b <- renderText({print.string(pr.restDigit(), 14)})
  output$pr.num.15a <- renderText({print.string(pr.firstDigit(),15)})
  output$pr.num.15b <- renderText({print.string(pr.restDigit(), 15)})
  output$pr.num.16a <- renderText({print.string(pr.firstDigit(),16)})
  output$pr.num.16b <- renderText({print.string(pr.restDigit(), 16)})
  output$pr.num.17a <- renderText({print.string(pr.firstDigit(),17)})
  output$pr.num.17b <- renderText({print.string(pr.restDigit(), 17)})
  output$pr.num.18a <- renderText({print.string(pr.firstDigit(),18)})
  output$pr.num.18b <- renderText({print.string(pr.restDigit(), 18)})
  output$pr.num.19a <- renderText({print.string(pr.firstDigit(),19)})
  output$pr.num.19b <- renderText({print.string(pr.restDigit(), 19)})
  output$pr.num.20a <- renderText({print.string(pr.firstDigit(),20)})
  output$pr.num.20b <- renderText({print.string(pr.restDigit(), 20)})
  output$pr.num.21a <- renderText({print.string(pr.firstDigit(), 21)})
  output$pr.num.21b <- renderText({print.string(pr.restDigit(),  21)})
  output$pr.num.22a <- renderText({print.string(pr.firstDigit(), 22)})
  output$pr.num.22b <- renderText({print.string(pr.restDigit(),  22)})
  output$pr.num.23a <- renderText({print.string(pr.firstDigit(), 23)})
  output$pr.num.23b <- renderText({print.string(pr.restDigit(),  23)})
  output$pr.num.24a <- renderText({print.string(pr.firstDigit(), 24)})
  output$pr.num.24b <- renderText({print.string(pr.restDigit(),  24)})
  output$pr.num.25a <- renderText({print.string(pr.firstDigit(), 25)})
  output$pr.num.25b <- renderText({print.string(pr.restDigit(),  25)})
  output$pr.num.26a <- renderText({print.string(pr.firstDigit(), 26)})
  output$pr.num.26b <- renderText({print.string(pr.restDigit(),  26)})
  output$pr.num.27a <- renderText({print.string(pr.firstDigit(), 27)})
  output$pr.num.27b <- renderText({print.string(pr.restDigit(),  27)})
  output$pr.num.28a <- renderText({print.string(pr.firstDigit(), 28)})
  output$pr.num.28b <- renderText({print.string(pr.restDigit(),  28)})
  output$pr.num.29a <- renderText({print.string(pr.firstDigit(), 29)})
  output$pr.num.29b <- renderText({print.string(pr.restDigit(),  29)})
  output$pr.num.30a <- renderText({print.string(pr.firstDigit(),30)})
  output$pr.num.30b <- renderText({print.string(pr.restDigit(), 30)})
  output$pr.num.31a <- renderText({print.string(pr.firstDigit(), 31)})
  output$pr.num.31b <- renderText({print.string(pr.restDigit(),  31)})
  output$pr.num.32a <- renderText({print.string(pr.firstDigit(), 32)})
  output$pr.num.32b <- renderText({print.string(pr.restDigit(),  32)})
  output$pr.num.33a <- renderText({print.string(pr.firstDigit(), 33)})
  output$pr.num.33b <- renderText({print.string(pr.restDigit(),  33)})
  output$pr.num.34a <- renderText({print.string(pr.firstDigit(), 34)})
  output$pr.num.34b <- renderText({print.string(pr.restDigit(),  34)})
  output$pr.num.35a <- renderText({print.string(pr.firstDigit(), 35)})
  output$pr.num.35b <- renderText({print.string(pr.restDigit(),  35)})
  output$pr.num.36a <- renderText({print.string(pr.firstDigit(), 36)})
  output$pr.num.36b <- renderText({print.string(pr.restDigit(),  36)})
  output$pr.num.37a <- renderText({print.string(pr.firstDigit(), 37)})
  output$pr.num.37b <- renderText({print.string(pr.restDigit(),  37)})
  output$pr.num.38a <- renderText({print.string(pr.firstDigit(), 38)})
  output$pr.num.38b <- renderText({print.string(pr.restDigit(),  38)})
  output$pr.num.39a <- renderText({print.string(pr.firstDigit(), 39)})
  output$pr.num.39b <- renderText({print.string(pr.restDigit(),  39)})
  output$pr.num.40a <- renderText({print.string(pr.firstDigit(),40)})
  output$pr.num.40b <- renderText({print.string(pr.restDigit(), 40)})
  output$pr.num.41a <- renderText({print.string(pr.firstDigit(), 41)})
  output$pr.num.41b <- renderText({print.string(pr.restDigit(),  41)})
  output$pr.num.42a <- renderText({print.string(pr.firstDigit(), 42)})
  output$pr.num.42b <- renderText({print.string(pr.restDigit(),  42)})
  output$pr.num.43a <- renderText({print.string(pr.firstDigit(), 43)})
  output$pr.num.43b <- renderText({print.string(pr.restDigit(),  43)})
  output$pr.num.44a <- renderText({print.string(pr.firstDigit(), 44)})
  output$pr.num.44b <- renderText({print.string(pr.restDigit(),  44)})
  output$pr.num.45a <- renderText({print.string(pr.firstDigit(), 45)})
  output$pr.num.45b <- renderText({print.string(pr.restDigit(),  45)})
  output$pr.num.46a <- renderText({print.string(pr.firstDigit(), 46)})
  output$pr.num.46b <- renderText({print.string(pr.restDigit(),  46)})
  output$pr.num.47a <- renderText({print.string(pr.firstDigit(), 47)})
  output$pr.num.47b <- renderText({print.string(pr.restDigit(),  47)})
  output$pr.num.48a <- renderText({print.string(pr.firstDigit(), 48)})
  output$pr.num.48b <- renderText({print.string(pr.restDigit(),  48)})
  output$pr.num.49a <- renderText({print.string(pr.firstDigit(), 49)})
  output$pr.num.49b <- renderText({print.string(pr.restDigit(),  49)})
  output$pr.num.50a <- renderText({print.string(pr.firstDigit(),50)})
  output$pr.num.50b <- renderText({print.string(pr.restDigit(), 50)})
  output$pr.num.51a <- renderText({print.string(pr.firstDigit(), 51)})
  output$pr.num.51b <- renderText({print.string(pr.restDigit(),  51)})
  output$pr.num.52a <- renderText({print.string(pr.firstDigit(), 52)})
  output$pr.num.52b <- renderText({print.string(pr.restDigit(),  52)})
  output$pr.num.53a <- renderText({print.string(pr.firstDigit(), 53)})
  output$pr.num.53b <- renderText({print.string(pr.restDigit(),  53)})
  output$pr.num.54a <- renderText({print.string(pr.firstDigit(), 54)})
  output$pr.num.54b <- renderText({print.string(pr.restDigit(),  54)})
  output$pr.num.55a <- renderText({print.string(pr.firstDigit(), 55)})
  output$pr.num.55b <- renderText({print.string(pr.restDigit(),  55)})
  output$pr.num.56a <- renderText({print.string(pr.firstDigit(), 56)})
  output$pr.num.56b <- renderText({print.string(pr.restDigit(),  56)})
  output$pr.num.57a <- renderText({print.string(pr.firstDigit(), 57)})
  output$pr.num.57b <- renderText({print.string(pr.restDigit(),  57)})
  output$pr.num.58a <- renderText({print.string(pr.firstDigit(), 58)})
  output$pr.num.58b <- renderText({print.string(pr.restDigit(),  58)})
  output$pr.num.59a <- renderText({print.string(pr.firstDigit(), 59)})
  output$pr.num.59b <- renderText({print.string(pr.restDigit(),  59)})
  output$pr.num.60a <- renderText({print.string(pr.firstDigit(),60)})
  output$pr.num.60b <- renderText({print.string(pr.restDigit(), 60)})
  output$pr.num.61a <- renderText({print.string(pr.firstDigit(), 61)})
  output$pr.num.61b <- renderText({print.string(pr.restDigit(),  61)})
  output$pr.num.62a <- renderText({print.string(pr.firstDigit(), 62)})
  output$pr.num.62b <- renderText({print.string(pr.restDigit(),  62)})
  output$pr.num.63a <- renderText({print.string(pr.firstDigit(), 63)})
  output$pr.num.63b <- renderText({print.string(pr.restDigit(),  63)})
  output$pr.num.64a <- renderText({print.string(pr.firstDigit(), 64)})
  output$pr.num.64b <- renderText({print.string(pr.restDigit(),  64)})
  output$pr.num.65a <- renderText({print.string(pr.firstDigit(), 65)})
  output$pr.num.65b <- renderText({print.string(pr.restDigit(),  65)})
  output$pr.num.66a <- renderText({print.string(pr.firstDigit(), 66)})
  output$pr.num.66b <- renderText({print.string(pr.restDigit(),  66)})
  output$pr.num.67a <- renderText({print.string(pr.firstDigit(), 67)})
  output$pr.num.67b <- renderText({print.string(pr.restDigit(),  67)})
  output$pr.num.68a <- renderText({print.string(pr.firstDigit(), 68)})
  output$pr.num.68b <- renderText({print.string(pr.restDigit(),  68)})
  output$pr.num.69a <- renderText({print.string(pr.firstDigit(), 69)})
  output$pr.num.69b <- renderText({print.string(pr.restDigit(),  69)})
  output$pr.num.70a <- renderText({print.string(pr.firstDigit(),70)})
  output$pr.num.70b <- renderText({print.string(pr.restDigit(), 70)})
  output$pr.num.71a <- renderText({print.string(pr.firstDigit(), 71)})
  output$pr.num.71b <- renderText({print.string(pr.restDigit(),  71)})
  output$pr.num.72a <- renderText({print.string(pr.firstDigit(), 72)})
  output$pr.num.72b <- renderText({print.string(pr.restDigit(),  72)})
  output$pr.num.73a <- renderText({print.string(pr.firstDigit(), 73)})
  output$pr.num.73b <- renderText({print.string(pr.restDigit(),  73)})
  output$pr.num.74a <- renderText({print.string(pr.firstDigit(), 74)})
  output$pr.num.74b <- renderText({print.string(pr.restDigit(),  74)})
  output$pr.num.75a <- renderText({print.string(pr.firstDigit(), 75)})
  output$pr.num.75b <- renderText({print.string(pr.restDigit(),  75)})
  output$pr.num.76a <- renderText({print.string(pr.firstDigit(), 76)})
  output$pr.num.76b <- renderText({print.string(pr.restDigit(),  76)})
  output$pr.num.77a <- renderText({print.string(pr.firstDigit(), 77)})
  output$pr.num.77b <- renderText({print.string(pr.restDigit(),  77)})
  output$pr.num.78a <- renderText({print.string(pr.firstDigit(), 78)})
  output$pr.num.78b <- renderText({print.string(pr.restDigit(),  78)})
  output$pr.num.79a <- renderText({print.string(pr.firstDigit(), 79)})
  output$pr.num.79b <- renderText({print.string(pr.restDigit(),  79)})
  output$pr.num.80a <- renderText({print.string(pr.firstDigit(),80)})
  output$pr.num.80b <- renderText({print.string(pr.restDigit(), 80)})

  output$pr.pmf <- renderPlot({
    pr.big.n <-as.integer(input$my.n)
        pr.pmf.compare(pr.seqInput(),pr.big.n)
    })

  })#close withProgress

})#close shinyServer


sum_mul <- function(n, m) {
  if( n > 0 && m > 0 ) {
    count <- (m-1) %/% n
    n * count * (count+1) / 2
  } else
    "INVALID"
}


# ......................................................................................
# .........................Cvičení 4 - Spojitá náhodná veličina.........................
# ..................Martina Litschmannová, Adéla Vrtková, Michal Béreš..................
# ......................................................................................

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

# **Obsah tohoto skriptu je pouze jako doplňující ilustrace k cvičení, není nutno znát
# ke zkoušce. Důležité je to umět spočítat ručně.**
# * Numerická integrace v Rku ####
# Rkovská funkce **integrate**
# integrate(f, a, b) = $\int_{a}^{b}f(x)dx$
# - **f** je Rková funkce (námi definovaná) která má jeden vstupní argument - vektor
# hodnot ve kterém má vrátit své hodnoty
# - **a** dolní integrační mez
# - **b** horní integrační mez

f = function(x){return(x*x)} # x^2
a = -1
b = 2
integrate(f, a, b)

#  Příklady ####
# * Příklad 1. ####
# Náhodná veličina X má distribuční funkci
# $F(x)=\begin{cases}
# 0    &      x \leq 0 \\
# cx^2 &  0 < x \leq 1 \\
# 1    &  1 < x
# \end{cases}$
# Jaké hodnoty může nabývat konstanta c?

# derovací F(x) získáme hustotu pravd. f(x)
# příslušná hustota pravděpodobnosti na intrvalu <0,1>
f = function(x){return(2*x)} # f(x) = 2x
a = 0
b = 1
integrate(f, a, b)$value

# c = 1, proto distribuční funkce vypadá takto:
F.dist = function(x){
    res = x*x     # x^2
    res[x<=0] = 0 # 0 pro x<=0
    res[x>1] = 1  # 1 pro x>1
    return(res)
}

x = seq(from = -1, to = 2, by = 0.01) # body na ose x
FX = F.dist(x) # hodnoty F(x)
plot(x, FX, type = 'l') # vykreslit jako čáru

# * Příklad 2. ####
# Rozdělení náhodné veličiny X je dáno hustotou
# $f(x)=\begin{cases}
# 2x+2 & x \in <-1;0> \\
# 0    & x \notin <-1;0>
# \end{cases}$
# Určete:
# ** 2. a) ####
# $F(x)$,

f.dens = function(x){
    res = 2*x + 2
    # pozor na x<-1 protože '<-' je v rku přiřazení
    res[x < -1] = 0 # 0 pro x<=0
    res[x > 0] = 0  # 1 pro x>1
    return(res)
}

x = seq(from = -2, to = 1, by = 0.01) # body na ose x
fx = f.dens(x) # hodnoty f(x)
plot(x, fx, cex=0.2) # vykreslit tečky (cex je velikost)

F.dist = function(x){
    res = x*x+2*x+1     # x^2+2x+1
    res[x < -1] = 0 # 0 pro x<=0
    res[x > 0] = 1  # 1 pro x>1
    return(res)
}

x = seq(from = -2, to = 1, by = 0.01) # body na ose x
FX = F.dist(x) # hodnoty f(x)
plot(x, FX, type='l') # vykreslit tečky (cex je velikost)

# ** 2. b) ####
# P(−2 ≤ X ≤ −0.5), P(−2 ≤ X ≤ −1), P(X > 0.5), P(X = 0.3)

# P(−2 ≤ X ≤ −0.5)
integrate(f.dens, -2, -0.5)$value
integrate(f.dens, -1, -0.5)$value

# P(−2 ≤ X ≤ −1)
integrate(f.dens, -2, -1)$value

# P(X > 0.5)
integrate(f.dens, 0.5, 1e16)$value # tohle nebude vždy fungovat

# P(X = 0.3)
integrate(f.dens, 0.3, 0.3)$value
# je jasné že tato pravděpodobnost je 0
# odpovídá integrálu s a=b tedy s nulovou velikostí na ose x

# ** 2. c) ####
# střední hodnotu, rozptyl a směrodatnou odchylku náhodné veličiny X.

# E(X)
x_fx = function(x){
    fx = f.dens(x)
    return(x*fx)
}
# integrujeme jen tam kde víme, že je f(x) nenulová
E_X = integrate(x_fx, -1, 0)$value
E_X
-1/3

# E(X^2)
xx_fx = function(x){
    fx = f.dens(x)
    return(x*x*fx)
}
# integrujeme jen tam kde víme, že je f(x) nenulová
E_XX = integrate(xx_fx, -1, 0)$value
E_XX
1/6

# D(X)
D_X = E_XX - E_X^2
D_X
1/18

# sigma(x)
std_X = sqrt(D_X)
std_X
sqrt(2)/6

# ** 2. d) ####
# modus $\hat{x}$

# modus = 0

# ** 2. e) ####
# medián $x_{0,5}$

x = seq(from = -2, to = 1, by = 0.001) # body na ose x
FX = F.dist(x)
plot(x, FX, type='l')
lines(c(-2, 1),c(0.5, 0.5))

x[FX >= 0.5][1] # první prvek z x pro který F(x)>=0.5
(-2+sqrt(2))/2

# * Příklad 3. ####
# Náhodná veličina Y je definována jako: Y = 3X+1, kde X je náhodná veličina z
# předcházejícího
# příkladu. Určete:
# ** 3. a) ####
# $F_Y(y)$

FY.dist = function(y){
    # spočteno ze vztahu FY(y) = P(Y < y) = P(3X + 1 < y) = ...
    x = (y-1)/3
    FY = F.dist(x)
    return(FY)
}
y = seq(from = -3, to = 2, by = 0.001) # body na ose x
FY = FY.dist(y)
plot(y, FY, type='l')

# ** 3. b) ####
# $f_Y(y)$

# derivace F_Y
fY.dens = function(y){
    res = 2/9*(y + 2)
    res[y < -2] = 0 # 0 pro x<-2
    res[y > 1] = 0  # 1 pro x>1
    return(res)
}
integrate(fY.dens,-2,1)$value # kontrola celkového integrálu
y = seq(from = -3, to = 2, by = 0.001) # body na ose x
fY = fY.dens(y)
plot(y, fY, cex=0.2)

# ** 3. c) ####
# E(Y), D(Y), σ(Y)

# E(Y)
y_fy = function(y){
    fy = fY.dens(y)
    return(y*fy)
}
# integrujeme jen tam kde víme, že je f(y) nenulová
E_Y = integrate(y_fy, -2, 1)$value
E_Y
0

# alternativně
E_Y = 3*E_X + 1
E_Y

# E(Y^2)
yy_fy = function(y){
    fy = fY.dens(y)
    return(y*y*fy)
}
# integrujeme jen tam kde víme, že je f(y) nenulová
E_YY = integrate(yy_fy, -2, 1)$value
E_YY
1/2

# D(Y)
D_Y = E_YY - E_Y^2
D_Y
1/2

# alternativně
D_Y = 3^2*D_X
D_Y

# sigma(Y)
sqrt(D_Y)
sqrt(2)/2

# * Příklad 4. (není ze sbírky) ####
# Spočtěte $\omega$ takové, aby náhodná veličina X s hustotou pravděpodobnosti:
# $f(x)=\begin{cases}
# 0 & x < 0 \\
# 3e^{-3x}    & x \geq 0
# \end{cases}$
# byla s pravděpodobností 0.3 větší než $\omega$

F.dist = function(x){
    res = 1 - exp(-3*x)
    res[x < 0] = 0 # 0 pro x<=0
    return(res)
}

x = seq(from = -1, to = 3, by = 0.001) # body na ose x
FX = F.dist(x)
plot(x, FX, type='l')
lines(c(-1, 3),c(0.7, 0.7))

x[FX >= 0.7][1]

-1/3*log(0.3)


# Figure to simulate the growth rate of productivity

# Fixed parameters
theta <- .01
lambda <- 1
gR <- .02
phi <- 0

# Initialize dynamic process
Rcurr <- 10 # this stays the same for both
Abase <- 2 # baseline scenario
Aalt  <- 10 # alternative scenario

dfbase = NULL # initialize a dataframe
dfalt = NULL # initialize a dataframe
name = "A" # name of base case is "A"
namealt = "B" # name of alt case is "B"

# This will simulate the process for gA and A period by period
for (t in 1:250) # do for this many periods
{
  # Base case
  gA <- theta*(Rcurr^lambda)/(Abase^(1-phi)) # calculate growth rate of A given current A and R
  dfbase = rbind(dfbase, data.frame(t,Abase,gA,name)) # add this new row to base dataframe
  Abase <- (1+gA)*(Abase) # Update the value of A

  # Alternative case
  gA <- theta*(Rcurr^lambda)/(Aalt^(1-phi)) # calculate growth rate of A given current A and R
  dfalt = rbind(dfalt, data.frame(t,Aalt,gA,namealt)) # add this new row to alt dataframe
  Aalt <- (1+gA)*(Aalt) # Update the value of A

  # Update the value of R for both cases
  Rcurr <- (1+gR)*Rcurr
}

colnames(dfalt) <- c("t","Abase","gA","name") # rename cols of alt DF to match base DF
dfgraph = rbind(dfbase,dfalt) # bind these two for graphing
dfgraph$ratio <- dfgraph$gA/theta # solve for ratio of R/A

# Create animated figure
fig <- plot_ly(dfgraph,
    x = ~ratio,
    y = ~gA,
    color = ~name,
    frame = ~t,
    text = ~t,
    hoverinfo = "text",
    type = 'scatter',
    mode = 'markers',
    marker = list(size = 15)
  ) %>% animation_opts(frame=0, transition=0)
fig <- fig %>% animation_slider(
  hide = T
)
fig <- fig %>% animation_button(
  x = 1, xanchor = "right", y = 0.4, yanchor = "bottom"
)
fig <- layout(fig, title = list(text = 'Dynamics of productivity growth', x=0),
              xaxis = list(title = 'Ratio of R/A'),
              yaxis = list (title = 'Growth rate',range=c(0,.06))
)

api_create(fig, filename = "me-gA-dynamics")


 ZGGSVD Example Program Results

 Number of infinite generalized singular values (K)
     2
 Number of finite generalized singular values (L)
     2
 Numerical rank of (A**H B**H)**H (K+L)
     4

 Finite generalized singular values
       2.0720E+00   1.1058E+00

 Unitary matrix U
                              1                           2
 1  ( -1.3038E-02, -3.2595E-01) ( -1.4039E-01, -2.6167E-01)
 2  (  4.2764E-01, -6.2582E-01) (  8.6298E-02, -3.8174E-02)
 3  ( -3.2595E-01,  1.6428E-01) (  3.8163E-01, -1.8219E-01)
 4  (  1.5906E-01, -5.2151E-03) ( -2.8207E-01,  1.9732E-01)
 5  ( -1.7210E-01, -1.3038E-02) ( -5.0942E-01, -5.0319E-01)
 6  ( -2.6336E-01, -2.4772E-01) ( -1.0861E-01,  2.8474E-01)

                              3                           4
 1  (  2.5177E-01, -7.9789E-01) ( -5.0956E-02, -2.1750E-01)
 2  ( -3.2188E-01,  1.6112E-01) (  1.1979E-01,  1.6319E-01)
 3  (  1.3231E-01, -1.4565E-02) ( -5.0671E-01,  1.8615E-01)
 4  (  2.1598E-01,  1.8813E-01) ( -4.0163E-01,  2.6787E-01)
 5  (  3.6488E-02,  2.0316E-01) (  1.9271E-01,  1.5574E-01)
 6  (  1.0906E-01, -1.2712E-01) ( -8.8159E-02,  5.6169E-01)

                              5                           6
 1  ( -4.5947E-02,  1.4052E-04) ( -5.2773E-02, -2.2492E-01)
 2  ( -8.0311E-02, -4.3605E-01) ( -3.8117E-02, -2.1907E-01)
 3  (  5.9714E-02, -5.8974E-01) ( -1.3850E-01, -9.0941E-02)
 4  ( -4.6443E-02,  3.0864E-01) ( -3.7354E-01, -5.5148E-01)
 5  (  5.7843E-01, -1.2439E-01) ( -1.8815E-02, -5.5686E-02)
 6  (  1.5763E-02,  4.7130E-02) (  6.5007E-01,  4.9173E-03)

 Unitary matrix V
                              1                           2
 1  (  9.8930E-01,  1.9041E-19) ( -1.1461E-01,  9.0250E-02)
 2  ( -1.1461E-01, -9.0250E-02) ( -9.8930E-01,  1.9041E-19)

 Unitary matrix Q
                              1                           2
 1  (  7.0711E-01,  0.0000E+00) (  0.0000E+00,  0.0000E+00)
 2  (  0.0000E+00,  0.0000E+00) (  7.0711E-01,  0.0000E+00)
 3  (  7.0711E-01,  0.0000E+00) (  0.0000E+00,  0.0000E+00)
 4  (  0.0000E+00,  0.0000E+00) (  7.0711E-01,  0.0000E+00)

                              3                           4
 1  (  6.9954E-01,  4.7274E-19) (  8.1044E-02, -6.3817E-02)
 2  ( -8.1044E-02, -6.3817E-02) (  6.9954E-01, -4.7274E-19)
 3  ( -6.9954E-01, -4.7274E-19) ( -8.1044E-02,  6.3817E-02)
 4  (  8.1044E-02,  6.3817E-02) ( -6.9954E-01,  4.7274E-19)

 Nonsingular upper triangular matrix R
                              1                           2
 1  ( -2.7118E+00,  0.0000E+00) ( -1.4390E+00, -1.0315E+00)
 2                              ( -1.8583E+00,  0.0000E+00)
 3
 4

                              3                           4
 1  ( -7.6930E-02,  1.3613E+00) ( -2.8137E-01, -3.2425E-02)
 2  ( -1.0760E+00,  3.1016E-02) (  1.3292E+00,  3.6772E-01)
 3  (  3.2537E+00,  0.0000E+00) ( -6.3858E-17,  6.3858E-17)
 4                              ( -2.1084E+00,  0.0000E+00)

 Estimate of reciprocal condition number for R
       1.3E-01

 Error estimate for the generalized singular values
       1.7E-15


###PCA3d on a data frame names f_table2, without the two first columns used for grouping
### with one column named "group"
for (i in 1: nrow(f_table)){
  f_table$sum[i]=sum(f_table[i,4:14])
}

require(rgl)
#####PCA
create.mean.table <- function(data_table,groups,data_cols=1,group_col=ncol(data_table)) {
  mean_table = data.frame()
	sd_table = data.frame()
	se_table = data.frame()
	for (g in groups) {
		data = data_table[data_table[group_col]==g,]
		mean_table = rbind(mean_table,data.frame(t(colMeans(data[data_cols],na.rm=TRUE))))
		sd_table = rbind(sd_table,data.frame(t(sd(data[data_cols],na.rm=TRUE))))
		se_table = sd_table/sqrt(nrow(data))
	}
	rownames(mean_table) = groups
	rownames(sd_table) = groups

	erg <- list(mean_table,sd_table,se_table)
	names(erg) <- c("means","sds","ses")
	return(erg)
}
##

h_table<-f_table2[,c(3:(length(f_table2)))]
rownames (h_table) = paste (c(1:length(f_table2[,1])),f_table2[,2])
#h_table<-f_table2[,c(3:13,16:length(f_table2))]
g_table <- na.omit(h_table)
 head(g_table)
mydata.pca <- prcomp(g_table, retx= TRUE, center= TRUE, scale.=TRUE)
sd <- mydata.pca$sdev
loadings <- mydata.pca$rotation
rownames(loadings) <- colnames(g_table)
scores <- mydata.pca$x

PCA_res= data.frame(scores)
PCA_res$group = i_table[,2]

PCA1to3 = data.frame(PCA_res$PC1,PCA_res$PC2,PCA_res$PC3,PCA_res$group)
Mean_PCA_3d = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),1:3)

scalingfact=15
###
### Plot variables plot in 3D (arrow plot)

plot3d(loadings[,1]*scalingfact,loadings[,3]*scalingfact,loadings[,2]*scalingfact,
       type = "n",box =FALSE,axes=TRUE,xlab="PC1",ylab="PC3",zlab="PC2")

for (j in 1:nrow(loadings)){
A=matrix (c(0,0,0,loadings[j,1]*scalingfact,loadings[j,3]*scalingfact,loadings[j,2]*scalingfact),2,3,byrow =TRUE)
segments3d(A, col=j)

text3d(loadings[j,1]*scalingfact*1.1,loadings[j,3]*scalingfact*1.1,loadings[j,2]*scalingfact*1.1,
     rownames(loadings)[j], col=j+1, cex=0.7, add=TRUE)
}

###
### Plot data, mean +- ses on the 3 axes, and ellipse of X=20% confidence interval
## beware: no legend
LEV=0.7
plot3d(loadings[,1]*scalingfact,loadings[,3]*scalingfact,loadings[,2]*scalingfact,
       type = "n",box =FALSE,axes=TRUE,xlab="PC1",ylab="PC3",zlab="PC2")

  for (i in 1:length(levels(PCA_res$group))){
  X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
  points= data.frame(X$PC1, X$PC3,X$PC2)
  plot3d(points, col=i,type= "p",add=TRUE)
  #plot3d(X$PC1, X$PC3,X$PC2, col=i,type= "p",add=TRUE)
  #Ell= sd(points)/sqrt(nrow(points))
  plot3d(ellipse3d(cor(points), centre = mean(points), level=LEV), col=i, alpha=0.3 , add=TRUE)

  plot3d(ellipse3d(cov(points), centre = mean(points), level=LEV), col=i+2, alpha=0.3 , add=TRUE)

x=Mean_PCA_3d$means$PCA_res.PC1[i]
y=Mean_PCA_3d$means$PCA_res.PC3[i]
z=Mean_PCA_3d$means$PCA_res.PC2[i]
x2=Mean_PCA_3d$ses$PCA_res.PC1[i]
y2=Mean_PCA_3d$ses$PCA_res.PC3[i]
z2 =Mean_PCA_3d$ses$PCA_res.PC3[i]
  A= matrix (c(x-x2,y,z,x+x2,y,z,x,y-y2,z,x,y+y2,z,x,y, z-z2,x,y,z+z2),6,3, byrow =TRUE)
  segments3d(A, col=i)
  }

 # text3d(max(points[1]),max(points[3]),max(points[2]),
 #    levels(PCA_res$group)[i], col=i, cex=0.7, add=TRUE)

#################
###################
#################
########## code to move the visualisation
 rgl.viewpoint(theta = 0, phi = 0, fov = 45, zoom = 0.8)

########## code for making a snapshot

######## multiple snapshot to transform into a video
for (i in 0:180) {
   rgl.viewpoint(theta = -180+2*i, phi =-90+(i ), fov = 45, zoom = 1)
   filename <- paste("pic1_",1000+i,".png",sep="")

  #rgl.snapshot(filename, fmt="png")
}
for (k in 0:90) {

   rgl.viewpoint(theta = 0, phi =k, fov = 45, zoom = 1)
   filename <- paste("pic2_",1000+k,".png",sep="")
  #rgl.snapshot(filename, fmt="png")
                     }

# F=c()
# for (g in 1: nrow(loadings)) F=c(F,0)
#
# loadings2= rbind(loadings,F)


#' Jacobian transformation adjustment
#'
#' compute the Jacobian adjustment for transformations as done in the X-13ARIMA-SEATS program
#'
#' @param Y numeric vector, original time series.
#' @param Nspobs Integer scalar, Length of \code{Y}.
#' @param Nintvl Integer scalar, Number of differences in model used. Default is 2.
#' @param Adj numeric vector, prior adjustment factor time series. Default is NULL, which indicates there is no prior adjustment.
#' @param Logit logical scalar, if TRUE the logit transformation is used. Default is FALSE.
#' @param Trans logical scalar, if TRUE a Box-Cox transform is used. Default is TRUE
#' @param Lam numeric scalar, Box-Cox transformation parameter. Default is 0 (Log transform).
#' @return Jacobean adjustment to the likelihood of estimated models to allow AIC and other likelihood statistics to be compared for different transformations.
#' @examples
#' Nspobs <- length(ic_obs)
#' ic_jacadj_log   <- jacobian_trans_adj(ic_obs, Nspobs, 2, Trans = TRUE, Lam = 0.0)
#' @import stats
#' @export
jacobian_trans_adj <- function(Y, Nspobs, Nintvl = 2, Adj = NULL, Logit = FALSE, Trans = TRUE, Lam=0.0) {
    # Author: Brian C. Monsell (OEUS), Version 2.5, 3/2/2022
   this_index <- seq(Nintvl+1, Nspobs)
   if (is.null(Adj)) {
      Adj <- rep(1.0, Nspobs)
   } else {
      nadj <- length(Adj)
      if (nadj != Nspobs) {
         stop("series and prior adjustments not the same length")
      }
   }

   yi   <- Y[this_index]
   jaci <- Adj[this_index]

#           logit adjustment : jaci=jaci/(jaci*Y(i)-Y(i)**2)
   if (Logit) {
      jacadj <- sum(log(jaci/(yi - yi*yi)))
   } else {
#  transformation adjustment : jaci=(abs(yi)**(Lam-ONE))/jaci
      if (Trans) {
         jacadj <- sum(log((abs(yi)^(Lam-1))/jaci))
      } else {
         jacadj <- 0
      }
   }

   return(jacadj)
}


# computing likelihood intervals at certain alpha levels
li<- function(th,like,alpha=0.15){
  that <- mean(th[like==max(like)])
  lowth <- th[th < that]
  lowlik <- like[th < that]
  if (length(lowth)<2) {lowval <- min(th) }
  if (length(lowth)>1)
      {  lowval <- approx(lowlik,lowth,xout=alpha)$y}

  upth <- th[th > that]
    if (length(upth)<2 ) {return(c(lowval,max(th))) }
   if (length(upth)> 1){
    uplik <- like[th > that]
    upval <- approx(uplik,upth,xout=alpha)$y
    return(c(lowval,upval))
  }
  }


#Find factors

print_factors = function(n) {
print(paste("The factors of",n,"are:"))
for(i in 1:n) {
if((n %% i) == 0) {
print(i)
}
}
}
print_factors(4)
print_factors(7)
print_factors(12)


#This script will compute the bulk modulus from a plot of pressure vs volumetric strain.
#
#License information:
#
#MIT License
#
#Copyright (c) 2019 Will Pisani
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

if (Sys.info()['sysname']=="Linux"){
  setwd("/path/to/directory/on/linux")
} else {
# Paths in Windows in R require \\ instead of \
 setwd("C:\\path\\to\\directory\\on\\Windows")

}

#Read in csv file
bkfile <-"your_file_name_here_BK_RData.csv"
bkdat <- read.csv(bkfile)
bkfilename <- strsplit(bkfile,"\\.")[[1]]

#create vectors for pressure and volumetric strain
bkpress <- bkdat[,1] *1.01325*10^5/1000000 # Converting atm to MPa
bkvolstrain <- bkdat[,2]
bkendpoint <- length(bkpress)
bkpress <- bkpress[1:bkendpoint]
bkvolstrain <- bkvolstrain[1:bkendpoint]

#fit a regular linear model to data, this is for the segmented command
lin.mod <- lm(bkpress ~ bkvolstrain)

#use segmented package to calculated breakpoint (bk)
segmented.mod <- segmented::segmented(lin.mod, seg.Z = ~bkvolstrain, psi=-0.05)
#Define moving average function
#mav <- function(x,n=1000){filter(x,rep(1/n,n),sides=2)}

#bkdens_ma <- mav(bkdens,1500)

# Get point at bk_value
# Get slope of first line
bk_modulus <- summary(segmented.mod)$coefficients[2,1]/1000 # Going from MPa to GPa
bk_modulus <- abs(round(bk_modulus,2)) # Round to 2 decimal places
bk_value <- segmented.mod$psi[2]
bk_value_stderror <- segmented.mod$psi[3]
bk_y_value <- segmented.mod$coefficients[2]*bk_value+segmented.mod$coefficients[1]

# Save regular plot to pdf
pdf(paste(bkfilename[1],"pdf",sep="."))
plot(bkvolstrain,bkpress,col="blue",xlim=c(0,min(bkvolstrain)),ylim=c(-2000,3500),main = paste("Bulk Modulus=",bk_modulus,"GPa"),xlab = 'Volumetric strain',ylab = 'Pressure (MPa)')
#plot(bktemp,bkdens)
par(new = TRUE)
plot(segmented.mod,col="red",xlim=c(0,min(bkvolstrain)),ylim=c(-2000,3500),xlab = '',ylab = '',rug=FALSE)
par(new = TRUE)
plot(bk_value,bk_y_value,pch=24,col="white",bg="white",xlim=c(0,min(bkvolstrain)),ylim=c(-2000,3500),xlab = '',ylab = '')
dev.off()


#' Rotate global coordinates in a data frame to model coordinates.
#'
#' This function reads in a data frame that contains
#' X and Y coordinates and converts those coordinates to a model coordinate system (i.e., zero rotation and X_off = Y_off = 0).
#' @param df This is the data frame containing the X and Y coordinates
#' @param X_off This is the global X coordinate offset
#' @param Y_off This is the global Y coordinate offset
#' @param ROT This is the rotation angle in units of degrees
#' @param Xin This is the dataframe column containing the X coordinate location
#' @param Yin This is the dataframe column containing the Y coordinate location
#' @export
#' @examples
#' obk_demo
#' # A tibble: 19 x 6
#'       ID     LITHO    K_cms           K       X       Y
#'    <chr>     <chr>    <dbl>       <dbl>   <dbl>   <dbl>
#'  1 MW-07      <NA> 5.88e-04  1.66677165 2980417 1927119
#'  2 MW-09        SW 2.58e-03  7.31338583 2980038 1927879
#'  3 MW-10      <NA> 2.51e-03  7.11496063 2980659 1927796
#'  4 MW-13      <NA> 2.22e-03  6.29291339 2980753 1927708
#'  5 MW-15        GM 2.00e-02 56.69291339 2980915 1927664
#'  6 MW-16        SW 6.07e-03 17.20629921 2981707 1928835
#'  7 MW-18        GM 3.91e-03 11.08346457 2981401 1929334
#'  8 MW-21        GM 9.10e-04  2.57952756 2981287 1928896
#'  9 MW-25        GM 1.25e-03  3.54330709 2981012 1928750
#' 10 MW-26     ML/GM 2.55e-03  7.22834646 2981059 1928830
#' 11 MW-27        GM 1.60e-03  4.53543307 2980973 1929291
#' 12 MW-29        GM 1.75e-04  0.49606299 2980824 1928950
#' 13 MW-30 sandstone 6.55e-04  1.85669291 2980486 1929689
#' 14 MW-31        ML 1.04e-05  0.02948031 2980409 1929362
#' 15 MW-32        ML 1.03e-02 29.19685039 2979395 1928257
#' 16 PZ-04     SP/ML 9.41e-06  0.02667402 2980207 1927028
#' 17 PZ-05     SP/GM 2.80e-04  0.79370079 2981367 1928068
#' 18 PZ-06        SW 3.06e-04  0.86740157 2981831 1927966
#'
#' X_off <- 2970450
#' Y_off <- 1926010
#' rot   <- -45
#' obk_demo %>% rot2mod(X_off = X_off, Y_off = Y_off, ROT = -45)
#' # A tibble: 19 x 8
#'       ID     LITHO    K_cms           K       X       Y     Xout      Yout
#'    <chr>     <chr>    <dbl>       <dbl>   <dbl>   <dbl>    <dbl>     <dbl>
#'  1 MW-07      <NA> 5.88e-04  1.66677165 2980417 1927119 6263.672  7831.879
#'  2 MW-09        SW 2.58e-03  7.31338583 2980038 1927879 5458.256  8100.912
#'  3 MW-10      <NA> 2.51e-03  7.11496063 2980659 1927796 5955.897  8481.173
#'  4 MW-13      <NA> 2.22e-03  6.29291339 2980753 1927708 6085.184  8486.123
#'  5 MW-15        GM 2.00e-02 56.69291339 2980915 1927664 6230.735  8569.561
#'  6 MW-16        SW 6.07e-03 17.20629921 2981707 1928835 5962.466  9957.563
#'  7 MW-18        GM 3.91e-03 11.08346457 2981401 1929334 5393.075 10093.737
#'  8 MW-21        GM 9.10e-04  2.57952756 2981287 1928896 5621.676  9703.563
#'  9 MW-25        GM 1.25e-03  3.54330709 2981012 1928750 5530.678  9405.567
#' 10 MW-26     ML/GM 2.55e-03  7.22834646 2981059 1928830 5507.973  9495.461
#' 11 MW-27        GM 1.60e-03  4.53543307 2980973 1929291 5120.889  9760.895
#' 12 MW-29        GM 1.75e-04  0.49606299 2980824 1928950 5256.879  9413.974
#' 13 MW-30 sandstone 6.55e-04  1.85669291 2980486 1929689 4495.396  9698.061
#' 14 MW-31        ML 1.04e-05  0.02948031 2980409 1929362 4671.784  9412.086
#' 15 MW-32        ML 1.03e-02 29.19685039 2979395 1928257 4736.611  7913.883
#' 16 PZ-04     SP/ML 9.41e-06  0.02667402 2980207 1927028 6179.576  7619.259
#' 17 PZ-05     SP/GM 2.80e-04  0.79370079 2981367 1928068 6264.471  9174.908
#' 18 PZ-06        SW 3.06e-04  0.86740157 2981831 1927966 6664.969  9430.704

rot2mod <- function(df,
                X_off = 0,
                Y_off = 0,
                ROT = 0,
                Xin = X,
                Yin = Y){

                Xin <- enquo(Xin)
                Yin <- enquo(Yin)
                RAD <- -ROT * pi / 180
                mutate(df,
                       Xout = ((!!Xin) - X_off) * cos(RAD) - ((!!Yin) - Y_off) * sin(RAD),
                       Yout = ((!!Xin) - X_off) * sin(RAD) + ((!!Yin) - Y_off) * cos(RAD)
                       )
                }


LISP Interpreter Run

[[[[[

 Proof that the halting problem is unsolvable by using
 it to construct a LISP expression that halts iff it doesn't.

]]]]]

define (turing x)
[Insert supposed halting algorithm here.]
let (halts? S-exp) false [<=============]
[Form ('x)]
let y [be] cons "' cons x nil [in]
[Form (('x)('x))]
let z [be] display cons y cons y nil [in]
[If (('x)('x)) has a value, then loop forever, otherwise halt]
if (halts? z) [then] eval z [loop forever]
              [else] nil [halt]

define      turing
value       (lambda (x) ((' (lambda (halts?) ((' (lambda (y) (
            (' (lambda (z) (if (halts? z) (eval z) nil))) (dis
            play (cons y (cons y nil)))))) (cons ' (cons x nil
            ))))) (' (lambda (S-exp) false))))

[
 (turing turing) decides whether it itself has a value,
 then does the opposite!

 Here we suppose it doesn't have a value,
 so it turns out that it does:
]

(turing turing)

expression  (turing turing)
display     ((' (lambda (x) ((' (lambda (halts?) ((' (lambda (
            y) ((' (lambda (z) (if (halts? z) (eval z) nil)))
            (display (cons y (cons y nil)))))) (cons ' (cons x
             nil))))) (' (lambda (S-exp) false))))) (' (lambda
             (x) ((' (lambda (halts?) ((' (lambda (y) ((' (lam
            bda (z) (if (halts? z) (eval z) nil))) (display (c
            ons y (cons y nil)))))) (cons ' (cons x nil))))) (
            ' (lambda (S-exp) false))))))
value       ()

define (turing x)
[Insert supposed halting algorithm here.]
let (halts? S-exp) true [<==============]
[Form ('x)]
let y [be] cons "' cons x nil [in]
[Form (('x)('x))]
let z [be] [[[[display]]]] cons y cons y nil [in]
[If (('x)('x)) has a value, then loop forever, otherwise halt]
if (halts? z) [then] eval z [loop forever]
              [else] nil [halt]

define      turing
value       (lambda (x) ((' (lambda (halts?) ((' (lambda (y) (
            (' (lambda (z) (if (halts? z) (eval z) nil))) (con
            s y (cons y nil))))) (cons ' (cons x nil))))) (' (
            lambda (S-exp) true))))

[
 And here we suppose it does have a value,
 so it turns out that it doesn't.

 It loops forever evaluating itself again and again!
]

(turing turing)

expression  (turing turing)
Storage overflow!


# ************************************************
### simon munzert
### time series
# ************************************************

source("packages.r")
source("functions.r")

## CRAN Task View on time series analysis
browseURL("https://cran.r-project.org/web/views/TimeSeries.html")

# ************************************************
# Working with times using the lubridate package -

library(lubridate)

# create a year-month-day variable
dates_char <- c("2017-09-01", "2017-08-31", "2017-08-30")
#dates_char <- c("20170901", "20170831", "20170830")
#dates_char <- c("2017/09/01", "2017/08/31", "2017/08/30")
class(dates_char)
plot(dates_char)
dates <- ymd(dates_char) # ymd() function to deal with year-month-day input
dates
plot(dates)

# other formats work, too
mdy("09-24-2017")
dmy("24.09.2017")

# there are many other things you can do with the package, for instance
  # work with time zones
  # compute time intervals
  # do arithmetic with date times (durations, periods)

# check out the following vignette for more info!
browseURL("https://cran.r-project.org/web/packages/lubridate/vignettes/lubridate.html")

# ************************************************
# Managing time series data with the xts package -

library(xts) # also loads zoo package

# import fertility data from Wooldridge
?fertil3
names(fertil3)
View(fertil3)
dat <- fertil3

# plot time series
plot(dat$gfr)

# create xts time series object
dat_ts <- ts(dat, frequency = 1, start = 1913) # creat time-series object: provide time of the first observation and frequency
dat_xts <- as.xts(dat_ts)

# dat_xts <- xts(dat, yearmon(dat$year)) # alternative assignment of time scheme with yearmon() function from the zoo package
plot(dat_xts$gfr)

# create lag variables
dat$gfr
lag(dat$gfr, 1)
lag(dat$gfr, 2)
lead(dat$gfr, 1)

# ************************************************
# Exercise: The Efficient Markets Hypothesis -----

data(nyse)
?nyse

# plot time series
plot(nyse$price, type = "l")
plot(nyse$return, type = "l")

# do past returns help explain future returns?
summary(lm(return ~ lag(return), data = nyse))

# Augmented Dickey-Fuller test
plot(nyse$t, nyse$return, type = "l")
adf.test(nyse$return[-1])

# How does the Dickey-Fuller test work?
  # tests the predictive power of an autoregressive process on the integrated time series
  # the null hypothesis for the test is that the time-series has a unit root (i.e. is not stationary).
  # the more negative it is, the stronger the rejection of the hypothesis that there is a unit root at some level of confidence
x <- rnorm(1000)  # no unit-root = stationary
adf.test(x)
y <- diffinv(x)   # contains a unit-root = non-stationary
adf.test(y)

# assess autocorrelation
acf(nyse$return, na.action = na.pass)
acf(nyse$price, na.action = na.pass, lag.max = 200)

# assess autocorrelation in disturbances using the Durbin-Watson test for autocorrelation
model <- lm(price ~ lag(price), data = nyse)
summary(model)
dwtest(model) # be careful; in LDV models, the DW test statistic uses to underestimate autocorrelation

# ************************************************
# Finite distributed lag (FDL) models ------------

# scatterplot
plot(dat$pe, dat$gfr)

# parallel time series
par(mfrow = c(2, 1))
plot(dat_xts$gfr)
plot(dat_xts$pe)

# OLS
model_out <- lm(gfr ~ pe, data = dat) # static model; only impact propensity assessed
summary(model_out)
model_out <- lm(gfr ~ pe + lag(pe, 1) + lag(pe, 2), data = dat) # assess long-run propensity with two lags
summary(model_out)

# ************************************************
# Lag dependent variable (LDV) models ------------

# check for autocorrelation
acf(dat$gfr, na.action = na.pass)
cor(dat$gfr, lag(dat$gfr), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 2), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 3), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 4), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 10), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 11), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 12), use = "pairwise.complete")

# build simple LDV model
summary(lm(gfr ~ lag(gfr, 1) + lag(gfr, 2), data = dat))

# ************************************************
# Seasonal adjustment ----------------------------

unemp <- read_csv("../data/unemployment-ger-monthly.csv")
head(unemp)
names(unemp) <- c("month", "total")

unemp_ts <- ts(unemp$total, start=c(1948,1), frequency = 12)
plot(unemp_ts)
unemp_stl <- stl(unemp_ts, s.window = "periodic")
plot(unemp_stl)

summary(unemp_stl)
unemp_stl_df <- unemp_stl$time.series

# ************************************************
# Modeling linear trends; de-trending ------------

model_out <- lm(gfr ~ pe + ww2 + pill + t + I(t^2), data = dat) # static model
summary(model_out)

# add linear trend!
# fertility increasing or decreasing in sample period?
# add quadratic trend!
# replicate results via de-trending
# test for lagged effect of personal exemption


#' Power calculations in an experiment with group clusters.
#'
#' @param unclustered Results from twomeans not adjusting for clusters
#' @param rho Specifies the intraclass correlation coefficient
#' @param obsclus Number of observations in each cluster
#' @param numclus Maximum number of clusters
#' @return returns an object with all the study parameters
#' @export
#' @importFrom magrittr %>%
#' @examples
#' twomeans(m1 = 12, m2 = 16, sd = 5) %>% clustered(obsclus = 10, rho = 0.3)
clustered <- function(unclustered, rho, obsclus = NULL, numclus = NULL) {

  if(is.null(numclus)) {
    deff    <- 1 + (obsclus - 1) * rho
    n1clus  <- unclustered$n1 * deff
    n2clus  <- unclustered$n2 * deff
    numclus <- (n1clus + n2clus) / obsclus
  }

  if(is.null(obsclus)) {
    tot <- (unclustered$n1 * (1 - rho) + unclustered$n2 * (1 - rho)) /
           (1 - (unclustered$n1 * rho / numclus) -
           (unclustered$n1 * rho / numclus))
    if(tot <= 0) {
      stop("Number of clusters is too small.")
    }
    obsclus <- ceiling(tot / numclus)
    deff    <- 1 + (obsclus - 1) * rho
    n1clus  <- unclustered$n1 * deff
    n2clus  <- unclustered$n2 * deff
  }

  # Round everyone
  n1clus  <- ceiling(n1clus)
  n2clus  <- ceiling(n2clus)
  obsclus <- ceiling(obsclus)
  numclus <- ceiling(numclus)

  METHOD = "Two-sample t-test power calculation"
  NOTE   = paste("m1 and m2 are the means of group 1 and 2, respectively.",
                 "n1 and n2 are the obs. of group 1 and 2, respectively.",
                 sep = "\r\n")

    structure(list(m1                           = unclustered$m1,
                   m2                           = unclustered$m2,
                   "n1 (unadjusted)"            = unclustered$n1,
                   "n2 (unadjusted)"            = unclustered$n2,
                   rho                          = rho,
                   "Average per cluster"        = obsclus,
                   "Minimum number of clusters" = numclus,
                   "n1 (adjusted)"              = n1clus,
                   "n2 (adjusted)"              = n2clus,
                   sig.level                    = unclustered$sig.level,
                   power                        = unclustered$power,
                   alternative                  = "two.sided",
                   method                       = METHOD,
                   note                         = NOTE),
                   class                        = "power.htest")

}

.check.clustered <- function(unclustered, rho, obsclus = NULL, numclus = NULL) {
  if(all(is.null(obsclus), is.null(numclus))) {
    stop("Either obsclus or numclus must be specified.")
  }
}


#' Weight of Evidence and Information Value in Credit Scoring
#'
#' Calculate Information Value and Weight of Evidence for variables in data frame. Information Value is used in credit scoring to compare predictive power among variables.
#' Weight of Evidence (WoE): \deqn{WoE = \ln(\frac{\%good_i}{\%bad_i})}
#' Information Value:
#' \deqn{IV = \Sigma_{i=1}^{n}(\ln(\frac{\%good_i}{\%bad_i})*(\%good_i - \%bad_i))}
#' @docType package
#' @name woe
#' @import ggplot2
#' @importFrom plyr rbind.fill
#' @importFrom RColorBrewer brewer.pal
#' @import rpart
#' @importFrom sqldf sqldf
NULL


# Adapted from http://horn.tau.ac.il/software/qc.m
#
# David Horn and Assaf Gottlieb.  Algorithm for Data Clustering Pattern
# Recognition Problems Based on Quantum Mechanics (Physical Review Letters
# 88, 2002).

#' Summarize standard deviation
#'
#' Summarize the standard deviation of a data set with multiple columns into a single value.  This function accomplishes this task by finding the length of a vector containing the standard deviation of each column.  This function may be useful in establishing a \code{sigma} for qc().
#'
#' @param dataset The cleaned input data to be clustered in either data.frame or matrix format.  This should contain only numeric data and must not have any factors, strings, NAs, etc.  It also should not contain any irrelevant columns such as observation ID or redundant data.
#'
#' @return The function returns a double containing the approximated standard deviation of the entire data set.
#'
#' @examples
#' data(iris)
#' iris_data <- iris[, -5] # Drop the species factor
#' sigma <- 0.4 * calcSD(iris_data)
#'
#' @export
calcSD <- function(dataset) {
    sd <- c()
    p <- ncol(dataset)

    if(is.null(p)) {
        sd <- sd(dataset)
    } else {
        for(i in seq(1, p)) {
            sd <- c(sd, sd(dataset[, i]))
        }
        sd <- (sum(sd^2)) ^ (1/2)
    }

    sd
}

#' Cluster data
#'
#' Cluster data using a non-linear clustering algorithm which finds organic groups of data from eigenfunctions and does not suffer from the curse of dimensionality.  The algorithm is approximately O(n^2).
#'
#' @param dataset The cleaned input data to be clustered in either data.frame or matrix format.  This should contain only numeric data and must not have any factors, strings, NAs, etc.  It also should not contain any irrelevant columns such as observation ID or redundant data.
#' @param sigma A double which controls how closely related data in clusters should be.  The smaller the number, more clusters will be created with fewer observations in each.  If sigma is too small, observations either will not be clustered or will be in their own individual clusters.  If sigma is too large, most -- if not all -- observations will be in the first cluster.
#' @param steps An integer specifying the number of expectation-maximization steps to take.  If faster, less accurate results are required, this may be reduced from the default of 21.
#' @param min_d_factor A double which controls how close data points must be in order to be considered in the same cluster.  Specifically, this value is the number of sigmas of distance to be within said threshold.  This value should probably not be changed unless there is a strong reason to do so.
#' @param n_clusters_max An integer specifying the maximum number of clusters to return.  These clusters will always be the most common clusters with the most observations in them.
#' @param verbose A boolean value which toggles the algorithm's verbosity for details as to how far along it is.
#'
#' @return The function returns a vector of the numeric clusters assigned to each row in \code{dataset}.
#'
#' @examples
#' # Set up parallel execution
#' library(doMC)
#' registerDoMC(cores=2) # Replace `2` with the number of cores in your machine
#'
#' data(iris)
#' iris_data <- iris[, -5] # Remove the classification of the iris data set
#' clusters <- qc(iris_data, 1.0)
#' secondary_cluster_rows <- which(clusters == 2)
#' print(iris[secondary_cluster_rows, ])
#'
#' @export
qc <- function(dataset, sigma, steps=21, min_d_factor=2,
               n_clusters_max=1000, verbose=FALSE) {

    ETA_DECAY <- 0.9

    main <- function(dataset, sigma, steps, min_d_factor,
                     n_clusters_max) {
        min_d <- getMinD(sigma, min_d_factor)
        eta <- getEta(sigma)
        q <- getQ(sigma)

        qc_log(paste0("Starting gradient decent with sigma ", sigma,
                      " and q ", q))
        D <- gradDesc(dataset, dataset, q, steps, eta, steps)
        qc_log("Gradient descent done")

        derived_clusters <- assignClusters(D, min_d, n_clusters_max)
        derived_clusters
    }

    gradDesc <- function(data_points, D, q, init_steps, eta, steps) {

        vecNorm <- function(v) {
            squared_sum <- sum(v^2)
            if(squared_sum == 0) {
                return(v)
            }

            # A new variable would be preferred, but for performance purposes,
            # overwrite in order to avoid reallocating a new vector
            v <- v / sqrt(squared_sum)
            v
        }

        start <- Sys.time()
        dV <- gradient(data_points, q, D)
        dV <- t(apply(dV, MARGIN=1, FUN=vecNorm))
        qc_log(paste0("Gradient descent step: ", (init_steps - steps) + 1,
                      " done"))
        endtime <- Sys.time()
        qc_log(endtime - start)

        # Faster to overwrite and avoid allocating a new matrix
        D <- D - eta * dV
        eta <- eta * ETA_DECAY

        if (steps <= 1) {
            D
        }
        else {
            gradDesc(data_points, D, q, init_steps, eta, (steps - 1))
        }
    }

    gradient <- function(ri, q, r=ri) {
        n <- nrow(ri)
        p <- ncol(ri)

        V <- matrix(0, n, 1)
        dP2 <- matrix(0, n, 1)
        P <- matrix(0, n, 1)

        dV1 <- matrix(0, n, p)
        dV2 <- matrix(0, n, p)
        dV <- matrix(0, n, p)

        point_iter <- seq(1, n)
        results <- foreach(point=point_iter,
                           .combine=c, .inorder=TRUE) %dopar% {
            calcPoint(point, r, ri, n, q, p)
        }

        # Merge the results from the list returned above
        # (No clean multiple assignment in R working with foreach results)
        result_offset <- 4
        for(point in point_iter) {
            list_index <- point - 1
            curr_index <- list_index * result_offset

            P[point] <- results[[curr_index + 1]]
            dP2[point] <- results[[curr_index + 2]]
            dV1[point, ] <- results[[curr_index + 3]]
            dV2[point, ] <- results[[curr_index + 4]]
        }

        P_zero_ind = which(P == 0)
        if(length(P_zero_ind) > 0) {
            P_non_zero_min <- min(P[-P_zero_ind])
            P[P_zero_ind] <- P_non_zero_min
        }

        V <- -p/2 + q*dP2/P
        E <- -min(V)
        V <- V + E

        for(dim in seq(1, p)) {
            dV[, dim] <- -q*dV1[, dim] + (V - E + (p + 2) / 2) * dV2[, dim]
        }
        dV[P_zero_ind, ] <- 0

        dV
    }

    calcPoint <- function(point, r, ri, n, q, p) {

        repRow <- function(X, row_reps, col_reps){
            p <- length(X)
            matrix(X, row_reps, p, byrow=T)
        }

        empty_col <- matrix(0, n, 1)
        empty_row <- matrix(0, 1, p)
        empty_matrix <- matrix(0, n, p)

        single_laplace <- empty_col
        dV1 <- empty_row
        dV2 <- empty_row

        squared_matrix <- repRow(r[point, ], n, 1)
        squared_matrix <- squared_matrix - ri
        unsquared_mat <- squared_matrix
        squared_matrix <- squared_matrix^2

        D2 <- apply(squared_matrix, MARGIN=1, FUN=sum)
        single_point <- exp(-q * D2)

        for(dim in seq(1, p)) {
            single_laplace <- single_laplace + squared_matrix[, dim] *
                              single_point
        }

        for(dim in seq(1, p)) {
            curr_col <- unsquared_mat[, dim]
            dV1[, dim] <- dV1[, dim] + sum(curr_col * single_laplace)
            dV2[, dim] <- dV2[, dim] + sum(curr_col * single_point)
        }

        P <- sum(single_point)
        dP2 <- sum(single_laplace)

        results <- list(P=P, dP2=dP2, dV1=dV1, dV2=dV2)
        results
    }

    assignClusters <- function(data_points, min_d, n_clusters_max) {

        isAssigned <- function(clusters, index) {
            clusters[index] != 0
        }

        qc_log("Assigning clusters")

        n <- nrow(data_points)
        p <- ncol(data_points)
        clusters <- rep(0, n)
        label <- 1
        start_index = 1

        for (start_index in seq(1, n)) {

            if (min(clusters) > 0) {
                break
            }

            if (!isAssigned(clusters, start_index)) {

                clusters[start_index] <- label
                for(row in seq(start_index, n)) {
                    if (!isAssigned(clusters, row)) {
                        ref_dist <- distance(data_points[start_index, ],
                                             data_points[row, ])
                        if (ref_dist <= min_d) {
                            clusters[row] <- label
                        }
                    }
                }

                label <- label + 1
            }
        }

        clusters
    }

    getMinD <- function(sigma, min_d_factor=2) {
        min_d_factor * sigma
    }

    getEta <- function(sigma) {
        sigma / 2.5
    }

    getQ <- function(sigma) {
        1 / (2 * sigma^2)
    }

    distance <- function(x, y) {
        sqrt(sum((x - y) ^ 2))
    }

    qc_log <- function(out_text) {
        if(verbose) {
            print(out_text)
        }
    }

    orderClusters <- function(training, derived_clusters, n_clusters_max) {

        getPopularClusters <- function(derived_clusters, n_clusters_max) {
            popular_clusters_table <- tail(sort(table(derived_clusters)),
                                           n=n_clusters_max)
            popular_clusters <- rev(as.integer(names(popular_clusters_table)))
            popular_clusters
        }

        popular_clusters <- getPopularClusters(derived_clusters,
                                               n_clusters_max)

        clusters <- rep(0, nrow(training))
        i <- 1
        for(label in popular_clusters) {
            clusters[which(derived_clusters == label)] <- i
            i <- i + 1
        }

        clusters
    }

    dataset <- as.matrix(dataset)
    derived_clusters <- main(dataset, sigma, steps, min_d_factor,
                             n_clusters_max)
    ordered_clusters <- orderClusters(dataset, derived_clusters,
                                      n_clusters_max=n_clusters_max)
    ordered_clusters
}


#Series temporais e analises preditivas - Fernando Amaral
library(urca)
library(forecast)

#teste de estacionariedade
x = ur.kpss(AirPassengers)
print(x)

#faz a diferenciacao
z = diff(AirPassengers)
#testa novamente
x = ur.kpss(z)
print(x)

split.screen( figs = c( 2, 1 ) )
screen(1)
plot(AirPassengers)
screen(2)
plot(z)
close.screen( all = TRUE )

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/5.2.Teste de Estacionariedade.r


# Sum-product and beliefs update examples
A=matrix(c(.8,.2),2,1)
B=matrix(c(.6,.4,.3,.7),2,2)
C=matrix(c(.5,.5,.8,.8),2,2)
D=matrix(c(.3,.7,.4,.6),2,2)

Bs = t(A) %*% t(B)
Cs = Bs %*% t(C)
Ds = Cs %*% t(D)
Ds


#' p_atm_z
#'
#' Calculate local air ressure as function of elevation/altitude in meters and sea-level pressure.
#'
#' @param z       numeric elevation/altitude (m).
#' @param p_sl    numeric pressure at sea level, per weather report (hPa),Default 101235 Pa.
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references    2005 ASHRAE Handbook - Fundamentals (SI) ch.6 (3)
#' @return        numeric pressure (Pa)
#' @export
#'

p_atm_z <- function(z, p_sl = 1013.25) {
                    p_sl * (1 - 2.25577e-5 * z)^5.2559
}


m = 10000
a = 5
b = 3

beta = rbeta(m, shape1=a, shape2=b)

success = beta/(1-beta)

mean(beta/(1-beta))

ind = success > 1

mean(ind)

m = 100000
a = 0
b = 1
norm = rnorm(m,a,b)

qnorm(0.3,mean=a,sd=b)

quantile(norm, prob=0.3)