source('ifm_func.r')

# Strategy E - trend trading:
# Moving Average Convergence Divergence (MACD) is used in the strategy, which is
# calculated by subtracting the 90-day simple moving average (SMA) of closing p-
# rice of the given stock from the 65-day counterpart. The MACD's signal line is
# the 21-day SMA of itself. When the MACD crosses above its signal line (golden
# cross), we buy in at opening price on the next day, and then hold to sell out
# at opening price on the following day when the MACD crosses below its signal
# line(death cross).
strategy <- function(stock) {
    # Strategy.
    MA_TYPE <- 'SMA'
    SIGNAL_DAYS_N <- 21
    LMA_DAYS_N <- 90
    SMA_DAYS_N <- 65
    M_START <- LMA_DAYS_N + SIGNAL_DAYS_N

    # Prepare data.
    opp <- Op(stock) # [op]en [p]rices
    clp <- Cl(stock) # [cl]ose [p]rices
    macd <- MACD(clp, nFast=SMA_DAYS_N, nSlow=LMA_DAYS_N, nSig=SIGNAL_DAYS_N, maType=MA_TYPE) # [m]oving [a]verage [c]onvergence [d]ivergence
    decision <- macd[, 'macd'] - macd[, 'signal']
    yesterday <- nrow(stock) - 1

    # Execute the strategy.
    pl <- setNames( rep( 0, length(clp) ), time(stock) )
    is_bought <- FALSE
    for (m in M_START:yesterday) {
        if ( !is_bought
             && as.numeric( decision[m-1] ) <  0
             && as.numeric( decision[m]   ) >= 0 ) {
            bought <- long( as.numeric( opp[m+1] ) )
            is_bought <- TRUE
        }
        else if ( is_bought
                  && as.numeric( decision[m-1] ) >  0
                  && as.numeric( decision[m]   ) <= 0 ) {
            pl[m] <- -bought + short( as.numeric( opp[m+1] ) )
            is_bought <- FALSE
        }
    }

    # Return [p]rofit-[l]oss.
    return(pl)
}


# Databricks notebook source
# load library
library(SparkR)

# COMMAND ----------

df <- createDataFrame(faithful)

# Displays the content of the DataFrame to stdout
head(df)

# COMMAND ----------

# Creating SparkR dataframe
df <- createDataFrame(faithful)
# Display the dataframe
head(df)

# COMMAND ----------

# The general method for creating DataFrames from data sources is read.df. This method takes the path for the file to load and the type of data source. SparkR supports reading CSV, JSON, Text and Parquet files natively and through Spark Packages you can find data source connectors for popular file formats like CSV and Avro.
diamondsDF <- read.df("/databricks-datasets/Rdatasets/data-001/csv/ggplot2/diamonds.csv",
                    source = "csv", header="true", inferSchema = "true")
head(diamondsDF)

# COMMAND ----------

printSchema(diamondsDF)

# COMMAND ----------

display(diamondsDF)

# COMMAND ----------

str(diamondsDF)

# COMMAND ----------

# Split data into Training set and Test set
trainingData <- sample(diamondsDF, FALSE, 0.7)
testData <- except(diamondsDF, trainingData)

# Exclude rowIDs
trainingData <- trainingData[, -1]
testData <- testData[, -1]

print(count(diamondsDF))
print(count(trainingData))
print(count(testData))

# COMMAND ----------

head(trainingData)

# COMMAND ----------

# Indicate family = "gaussian" to train a linear regression model
lrModel <- glm(price ~ ., data = trainingData, family = "gaussian")

# Print a summary of trained linear regression model
summary(lrModel)

# COMMAND ----------

# Generate predictions using the trained Linear Regression model
predictions <- predict(lrModel, newData = testData)

# View predictions against mpg column
display(select(predictions, "price", "prediction"))

# COMMAND ----------

# Model evaluation
errors <- select(predictions, predictions$price, predictions$prediction, alias(predictions$price - predictions$prediction, "error"))
display(errors)

# COMMAND ----------

# Calculate the RMSE
head(select(errors, alias(sqrt(sum(errors$error^2 , na.rm = TRUE) / nrow(errors)), "RMSE")))

# COMMAND ----------

# We can create a Logistic Regression on the same dataset. Let’s see if we can predict a diamond’s cut based on some of its features.  As of Spark 1.6, Logistic Regression in MLlib only supports binary classification. To test out the algorithm with our dataset in this example, we will subset our data so as to work with only 2 labels

# Subset data to include rows where diamond cut = "Premium" or diamond cut = "Very Good"
trainingDataSub <- subset(trainingData, trainingData$cut %in% c("Premium", "Very Good"))
testDataSub <- subset(testData, testData$cut %in% c("Premium", "Very Good"))

# COMMAND ----------

# Indicate family = "binomial" to train a logistic regression model
logrModel <- glm(cut ~ price + color + clarity + depth, data = trainingDataSub, family = "binomial")

# Print summary of Logistic Regression model
# Note: This only works in Spark 1.6+
summary(logrModel)

# COMMAND ----------

# Generate predictions using the trained Linear Regression model
predictionsLogR <- predict(logrModel, newData = testDataSub)

# View predictions against label column
display(select(predictionsLogR, "label", "prediction"))

# COMMAND ----------

# Evaluate Logistic Regression model
errorsLogR <- select(predictionsLogR, predictionsLogR$label, predictionsLogR$prediction, alias(abs(predictionsLogR$label - predictionsLogR$prediction), "error"))
display(errorsLogR)

# COMMAND ----------


# read the data
meat <- read.table('meat.txt',header=T,as.is=T)

# and create a log time variable
meat$logtime <- log(meat$time)

# set up a new data set with points to make predictions at
meat.new <- data.frame(time=seq(1,5,0.5))
meat.new$logtime <- log(meat.new$time)

# fit the regression, logtime is NOT a factor
meat.lm <- lm(ph~logtime,data=meat)

# print a summary.  There are also functions to print
#  coefficients, coef(), and anova table (anova()

summary(meat.lm)

# make predictions at each point in the original data set
meat.pred <- predict(meat.lm)

# make predictions at each point in the new data set
# returns a vector, convenient for plotting
meat.pred <- predict(meat.lm,newdata=meat.new)
meta.pred

# include se.fit with the predictions, returns a list
meat.pred <- predict(meat.lm,newdata=meat.new,se.fit=T)
meat.pred

# additional arguments to predict provide intervals
#  either confidence intervals
meat.pred <- predict(meat.lm,newdata=meat.new,interval='confidence')
meat.pred

# or prediction intervals
meat.pred <- predict(meat.lm,newdata=meat.new,interval='prediction')
meat.pred

# matplot is convenient for plotting these
matplot(meat.new$logtime,meat.pred,type='l',lty=c(1,2,2),col=c(1,2,2))

# the ANOVA lack of fit test is easy to do in R.
# The appropriate F test is the test of the as.factor(X) term

# doing lof test when X = time
meat.lof <- lm(ph~time+as.factor(time),data=meat)
anova(meat.lof)

# doing lof test and again when X = log(time)
meat.lof <- lm(ph~logtime+as.factor(time),data=meat)
anova(meat.lof)

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


#preliminaries
rm(list = ls())
setwd("")

#Real value of theta
theta <- 5
#sample size
n <- 25

#Generating 1000 samples of size n
simul <- 1000
sample <- matrix(runif(1000*n, max = theta),
                 nrow = n)

thetahat <- (n+1)/n*apply(sample, 2, max)

ll <- thetahat/(0.95^(1/n)*(n+1)/n)
ul <- thetahat/(0.05^(1/n)*(n+1)/n)
thetain <- (thetahat>=ll & theta<=ul)
mean(thetain)


# Function to detect uncertainty in local peaks in a GAM and return the number and location of them after sampling from parameter uncertainty
# Arguments:
#	mod: the GAM model (produced by mgcv)
#	newdat: a data.frame of the new data on which to predict
#	xvar: the name of the variable over which peaks should be detected
#	xtol: the sliding window within which peaks are detected. Only one peak found per window. Width measured in # data points.
#	findmaxima: TRUE if goal is to find peaks. FALSE if goal is to find valleys.
# Returns a data.frame with

findPeaksGAM_CI <- function(mod, newdat, n, xvar, xtol, findmaxima=TRUE){
	library(mgcv)
	Xp <- predict(mod,newdat,type="lpmatrix") # prediction decomposed into the linear predictors
	br <- rmvn(n,coef(mod),mod$Vp) ## n replicate parameter vectors sampled with uncertainty
	res <- matrix(NA, ncol=n, nrow=nrow(newdat)) # to hold the predictions
	for(i in 1:n) res[,i] <- Xp %*% br[i,] ## replicate predictions

#	ord <- order(newdat[[xvar]]) # find order by xvar
#	yord <- newdat[[xvar]][ord] # order explanatory variable (xvar)
#	resord <- res[ord,] # order rows or res by xvar
	peaks <- data.frame(npeaks=rep(NA, n), peaklocs=I(vector('list', n)), y=I(vector('list', n))) # hold the number and location of peaks
	for(i in 1:n){
		temp <- find_peaks(res[,i], m=xtol, findmaxima)
		peaks$npeaks[i] <- length(temp)
		peaks$peaklocs[[i]] <- newdat[[xvar]][temp]
		peaks$y[[i]] <- res[,i]
	}
	return(peaks)
}

# Same function, but from the mean prediction (no uncertainty)
findPeaksGAM <- function(mod, newdat, xvar, xtol, findmaxima=TRUE){
	library(mgcv)
	res <- predict(mod,newdat) # prediction

	peaks <- data.frame(npeaks=rep(NA, 1), peaklocs=I(vector('list', 1)), y=I(vector('list', 1))) # hold the number and location of peaks
	temp <- find_peaks(res, m=xtol, findmaxima)
	peaks$npeaks <- length(temp)
	peaks$peaklocs[[1]] <- newdat[[xvar]][temp]
	peaks$y[[1]] <- res

	return(peaks)
}

## produce multivariate normal random deviates needed by findPeaksGAM
rmvn <- function(n,mu,sig) {
	L <- mroot(sig)
	m <- ncol(L)
	t(mu + L%*%matrix(rnorm(m*n),m,n))
}

# find peaks in a vector
# from https://stats.stackexchange.com/questions/22974/how-to-find-local-peaks-valleys-in-a-series-of-data
find_peaks <- function (x, m = 3, findmaxima=TRUE){
	shape <- diff(sign(diff(x, na.pad = FALSE)))
	if(findmaxima){
		pks <- sapply(which(shape < 0), FUN = function(i){
			z <- i - m + 1
			z <- ifelse(z > 0, z, 1)
			w <- i + m + 1
			w <- ifelse(w < length(x), w, length(x))
			if(all(x[c(z : i, (i + 2) : w)] <= x[i + 1])) return(i + 1) else return(numeric(0))
		})
	}
	if(!findmaxima){
		pks <- sapply(which(shape > 0), FUN = function(i){
			z <- i - m + 1
			z <- ifelse(z > 0, z, 1)
			w <- i + m + 1
			w <- ifelse(w < length(x), w, length(x))
			if(all(x[c(z : i, (i + 2) : w)] >= x[i + 1])) return(i + 1) else return(numeric(0))
		})
	}
	pks <- unlist(pks)
	return(pks)
}

# Example using findPeaksGAM
#library(mgcv)
#n <- 200
#sig <- 2
#dat <- gamSim(1,n=n,scale=sig) # an example dataset
#mod<-gam(y~s(x0)+s(I(x1^2))+s(x2)+offset(x3),data=dat) # fit a gam
#newdat <- data.frame(x0=(0:60)/60,x1=(0:60)/60,x2=(0:60)/60,x3=(0:60)/60) # new data for projection
#
#peaks <- findPeaksGAM(mod, newdat, 500, 'x0', 5)
#
#hist(peaks$npeaks) # almost all find 2 peaks
#
#
#plot(newdat$x0, predict(mod, newdat), type='l', ylim=range(res)) # plot the basic prediction
#for(i in 1:nrow(peaks)) lines(newdat$x0, peaks$y[[i]], col=rgb(0,0,0,0.05), lty=1) # plot the uncertainty
#
#
#plot(newdat$x0, predict(mod, newdat), type='l', ylim=range(res)) # plot the basic prediction
#inds <- which(peaks$npeaks == 1)
#for(i in 1:length(inds)) lines(newdat$x0, peaks$y[[inds[i]]], col=rgb(1,0,0,0.5), lty=1) # plot the lines with 1 peak
#inds <- which(peaks$npeaks == 3)
#for(i in 1:length(inds)) lines(newdat$x0, peaks$y[[inds[i]]], col=rgb(0,1,0,0.5), lty=1) # plot the lines with 3 peaks


## Map dissimilarities
# Look at Z-transformed R^2 values for blink map correlations

filt_asr <- read.table(file = "data/ztrans_blink_corr_FILT_ASR_.csv",header = FALSE, dec = ".", col.names = "corr", sep=",")
filt_asr$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
filt_asr$subj      <- c(1:27)
filt_asr$method    <- c(rep("filt_asr", 27*2))

filt_riem <- read.table(file = "data/ztrans_blink_corr_FILT_RIEM_.csv",header = FALSE, dec = ".", col.names = "corr", sep=",")
filt_riem$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
filt_riem$subj      <- c(1:27)
filt_riem$method    <- c(rep("filt_riem", 27*2))

### testing time
library(ez)
library(effsize)

# combine all for ANOVA
all <- rbind(filt_asr,filt_riem)
aov_group <- ezANOVA(data=all, dv = corr, within = .(condition, method), wid=subj)
print(aov_group)

# plot
a <- mean(all$corr[all$condition== "inside" & all$method == "filt_asr"])
b <- mean(all$corr[all$condition== "inside" & all$method == "filt_riem"])
# this should be transformed back when reported
plot(c(a,b), xlab = "methods", ylab = "mean r^2 corr values (transformed!)", xaxt = "n")
# Changing x axis
axis(1, at=1:2, labels=c("uncorr ~ ASR","uncorr ~ rASR"))

# interaction effect
# outside
one <- filt_asr$corr[filt_asr$condition == "outside"];
two <- filt_riem$corr[filt_riem$condition == "outside"];
x <- c(one, two);
grouping <- c(c(rep("filt asr outside", 27)),c(rep("filt rasr outside", 27)));
source("pairwise.t.test.with.t.and.df.R")
result <- pairwise.t.test.with.t.and.df(x, grouping, adjust.method="bonf", paired=TRUE)
# print t-test result
print(result)
# Print t-values
print(c("t-value: ", result[[5]]))
# Print dfs
print(c("Df: ", result[[6]]))

print(c("mean of filt_asr outside: ", mean(one)))
print(c("mean of filt_riem outside: ", mean(two)))

cohen.d(x, as.factor(grouping))

# inside
one <- filt_asr$corr[filt_asr$condition == "inside"];
two <- filt_riem$corr[filt_riem$condition == "inside"];
x <- c(one, two);
grouping <- c(c(rep("filt asr inside", 27)),c(rep(" filt rasr inside", 27)));
source("pairwise.t.test.with.t.and.df.R")
result <- pairwise.t.test.with.t.and.df(x, grouping, adjust.method="bonf", paired=TRUE)
# print t-test result
print(result)
# Print t-values
print(c("t-value: ", result[[5]]))
# Print dfs
print(c("Df: ", result[[6]]))

print(c("mean of filt_asr inside: ", mean(one)))
print(c("mean of filt_riem inside: ", mean(two)))


#!/usr/bin/env Rscript

## Item Response Theory (IRT) - Partial Credit Model (PCM)
# Copyright 2021 Enrico Glerean
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

# In this script we fit the PCM for polytomous data as implemented
# by the R packages eRm
# We report
# 1. summary statistics for the fitted model
# 2. Item Characteristic Curves (ICC) for each item
# 3. Wright map
# 4. Item fit summary statistics and item map
# 5. Person fit summary statistics and person fit map
# 6. test for the unidimensionality of the data
# 7. test for local dependence of items

# We use the eRm package
library("eRm")

dfA <- read.table("../results/scores/scores_sorted.csv",header=TRUE, sep=',', colClasses = "integer")
dfA <- dfA + 1 # We have values from 0 to 2 as required by eRM packages with polytomous data

# 1. model fitting and summary statistics for the fitted model
PC_model <- PCM(df)
summary(PC_model)
th <- thresholds(PC_model)
th

# 2. Item Characteristic Curves (ICC) for each item
#    TODO: legends and title could be improved
lab <- labels(df)[[2]]
for(n in lab){
  print(paste("Plotting item ",n))
  # figures are stored in ../results/figures/
  pdf(paste('../results/figures/',n,'-ICC.pdf',sep=""))
  plotICC(PC_model,item.subset=n)
  dev.off()
}

# 3. Person-Item map (Wright map)
pdf('../results/figures/PImap.pdf')
plotPImap(PC_model)
dev.off()
pdf('../results/figures/PImap_C1.pdf')
plotPImap(PC_model,item.subset = c(1,2,3,4,5,6,7,8,9,10,11,12))
dev.off()
pdf('../results/figures/PImap_C2.pdf')
plotPImap(PC_model,item.subset = c(13,14,15,16,17,18,19,20,21,22))
dev.off()
pdf('../results/figures/PImap_C3.pdf')
plotPImap(PC_model,item.subset = c(23,24,25,26,27,28,29,30,31,32,33,34))
dev.off()
pdf('../results/figures/PImap_C4.pdf')
plotPImap(PC_model,item.subset = c(35,36,37,38,39,40))
dev.off()

# 4. Item fit summary statistics and item fit map
pres <- person.parameter(PC_model)
itfi <- itemfit(pres)
itfi
pdf('../results/figures/PW_itemMap.pdf')
plotPWmap(PC_model)
dev.off()

# 5. Person fit summary statistics and person fit map
pefi <- personfit(pres)
pdf('../results/figures/PW_personsMap.pdf')
plotPWmap(PC_model,pmap=TRUE, imap=FALSE)
dev.off()

# 6. test for the unidimensionality of the data
utest <- MLoef(PC_model)
utest

# 7. test for local dependence of items
res <- residuals(pres)
Q3 <- cor(res,method="pearson")
diag(Q3)<-NA
Q3star=Q3 - mean(Q3, na.rm = TRUE)
ii = which(abs(Q3star) > 0.2)
m = 40
for(ind in ii){
  rid = ((ind-1) %% m) + 1
  cid = floor((ind-1) / m) + 1
  print(paste(labels(df)[[2]][rid],labels(df)[[2]][cid],Q3star[rid,cid],sep=" "))
}


require(Hmisc)
if(FALSE) .Fortran('jrank', as.double(1:5), as.double(1:5), 5L,
                   double(5), double(5), double(5))
hoeffd(1:6, c(1,3,2,4,5,6))
y <- 1:20; y[3] <- 17; y[17] <- 3
hoeffd(1:20, y)$D
set.seed(5)
x <- runif(800); y <- runif(800)
hoeffd(x,y)$D

for(n in c(50,100,200,400,1000)) {
  set.seed(1)
  x <- seq(-10,10,length=n)
  y <- x*sign(runif(n,-1,1))
  h <- hoeffd(x,y)
  print(c(h$D[1,2], h$aad[1,2], h$maxad[1,2]))
}
#[1] 0.06812286   in old version (real*4 in places)
#[1] 0.04667929
#[1] 0.05657654
#[1] 0.07048487
#[1] 0.06323746

# From http://www.sciencemag.org/content/suppl/2011/12/14/334.6062.1518.DC1/Reshef.SOM.pdf
# Table S2: Definitions of functions used for Figure 2A in the Science article

w <- function(y) {
  ylab <- deparse(substitute(y))
  plot(x, y, ylab=substitute(y), type='l')
  h <- hoeffd(x, y)
  cat(ylab, '\n')
  print(c(D=h$D[1,2],P=h$P[1,2],aDif=h$aad[1,2],mDif=h$maxad[1,2]))
}

x <- seq(0, 1, length=320)
par(mfrow=c(3,3))
w(x)
w(4*(x-.5)^2)
w(128*(x-1/3)^3 -48*(x-1/3)^2 - 12*(x-1/3) + 2)
w(10^(10*x) - 1)
w(sin(10*pi*x) + x)
w(sin(16*pi*x))
w(sin(13*pi*x))
w(sin(7*pi*x*(1+x)))
w(runif(320))


Mean=c(2.2, 4.6 ,21.2 ,31.4)
Standard_deviation=c(1.476,2.119,4.733,5.52)
s_min=min(Standard_deviation)
s_max=max(Standard_deviation)
# test statistic
F=s_max^2/s_min^2
print(F)
# The critical value of F > F.alpha
#  we reject the hypothesis of homogeneity
#of the population variances.

distance_1km=c(1,5,2,1,2,2,4,3,0,2)
distance_5km=c(4,8,2,3,8,5,6,4,3,3)
distance_10km=c(20,26,24,11,28,20,19,19,21,24)
distance_20km=c(37,30,26,24,41,25,36,31,31,33)
print(Standard_deviation[1]^2/Mean[1])
print(Standard_deviation[2]^2/Mean[2])
print(Standard_deviation[3]^2/Mean[3])
print(Standard_deviation[4]^2/Mean[4])
i=1
while(i<11){
  distance_1km[i]=sqrt(distance_1km[i]+0.375)
  i=i+1
}
i=1
while(i<11){
  distance_5km[i]=sqrt(distance_5km[i]+0.375)
  i=i+1
}
i=1
while(i<11){
  distance_10km[i]=sqrt(distance_10km[i]+0.375)
  i=i+1
}
i=1
while(i<11){
  distance_20km[i]=sqrt(distance_20km[i]+0.375)
  i=i+1
}
combined_group=data.frame(cbind(distance_1km,distance_5km,distance_10km,distance_20km))
combined_group


# https://www.r-bloggers.com/testing-rsi2-with-r-first-steps/
# We will need the quantmod package for charting and pulling
# data and the TTR package to calculate RSI(2).

library(quantmod)
library(TTR)

# Pull SPL data from Yahoo! Finance
getSymbols("SPL.AX", from="2007-01-01", to="2018-01-09")
SPL<-SPL[complete.cases(SPL),]                                                  # Delete NA

# Calculate the RSI indicator
rsi <- RSI(Cl(SPL),2) # Create the long (up) and short (dn) signals
sigup <- ifelse(rsi < 10, 1, 0)
sigdn <- ifelse(rsi > 90, -1, 0)

# Lag signals to align with days in market,
# not days signals were generated
#sigup <- Lag(sigup,1) # Use lag() to avoid Toby's error
#sigdn <- Lag(sigdn,1) # Use lag() to avoid Toby's error
sigup <- lag(sigup,1) # Note k=1 implies a move *forward*
sigdn <- lag(sigdn,1) # Note k=1 implies a move *forward* # Replace missing signals with no position
# (generally just at beginning of series)
sigup[is.na(sigup)] <- 0
sigdn[is.na(sigdn)] <- 0 # Combine both signals into one vector
sig <- sigup + sigdn # Calculate Close-to-Close returns
ret <- ROC(Cl(SPL))
ret[1] <- 0 # Calculate equity curves
eq_up <- cumprod(1+ret*sigup)
eq_dn <- cumprod(1+ret*sigdn*-1)
eq_all <- cumprod(1+ret*sig) # Replicate Michael’s nice chart
plot.zoo(cbind(eq_up, eq_dn),
ylab = c("Long", "Short"), col=c("green","red"),
main="Simple RSI(2) Strategy: 2007-01-02 through 2018-010-09")

# Wait a few seconds before making next chart…
#Sys.sleep(5)

# Create a chart showing the S&P500
#chartSeries(SPL, type="line")

# Add the total equity line
#addTA(eq_all)


cat("Last updated:", date(), "(PT)")

# The R-package `renv` was used to create an R virtual environment.
# To install `renv`, do `install.packages('renv')`.
# To initialize an R environment, `renv::init()`.
# This will create a directory called `renv` in the current dir.

# See also:
# renv::init()
# renv::activate()
# renv::settings$snapshot.type('all')
# renv::status()
# renv::snapshot()
# renv::restore()

# Activate the virtual env.
renv::activate("../../..")

# Import libraries
library(nimble)
library(rjson)

# Define DP mixture of Gaussians model

# NOTE: From NIMBLE docs: https://r-nimble.org/html_manual/cha-bnp.html
#
# Nimble doesn't allow dynamic allocation of new clusters. So, K is an upperbound
# for the number of clusters for computational and memory convenience. K should
# be much less than N.
model.code = nimbleCode({
    # CRP priors of class labels.
    z[1:N] ~ dCRP(alpha, size=N)

    # DP concentration parameter.
    alpha ~ dgamma(1, 100)

    # Base distribution.
    # Note that dynamic allocation of clusters is not allowed.
    # So, an upperbound (K) is specifeid.
    for(k in 1:K) {
        mu[k] ~ dnorm(0, 3)
        sig2[k] ~ dinvgamma(2, 0.05)
    }

    # Sampling distribution.
    for(i in 1:N) {
        y[i] ~ dnorm(mu[z[i]], var=sig2[z[i]])
    }
})

# Read and visualize data.
path_to_simdata = "../data/gmm-data-n200.json"
simdata = fromJSON(file=path_to_simdata)
hist(simdata$y, breaks=30)

# Set seed for reproducibility.
set.seed(2)

# Define data.
data = list(y=simdata$y)

# Define model constants.
constants = list(N=length(data$y), K=10)

# Initialize model (optional).
inits = list(mu=rnorm(constants$K, 0, 3),
             sig2=rep(0.01, constants$K),
             z=rep(1, constants$N),
             alpha=0.1)

# One liner version.

# burn = 1000
# nsamples = 1000
# samples = nimbleMCMC(code=model.code,
#                      constants=constants,
#                      data=data,
#                      inits=inits,
#                      monitors=c('mu', 'sig2', 'alpha', 'z'), setSeed=1,
#                      nburnin=burn, niter=burn + nsamples, progressBar=TRUE)

# Compile model.

system.time({
    dp_crp_gmm <- nimbleModel(model.code, constants, data, inits)
    compiled_dp_crp_gmm <- compileNimble(dp_crp_gmm)
    mcmc <- buildMCMC(compiled_dp_crp_gmm, monitors=c('alpha', 'sig2', 'mu', 'z'))
    compiled_dp_crp_gmm <- compileNimble(mcmc)
})

# Run MCMC and get samples from joint posterior.

system.time({
    samples <- runMCMC(compiled_dp_crp_gmm, nburnin=1000, niter=2000, setSeed=1)
})

# See names of parameters and dimensions.
colnames(samples)
dim(samples)

# Number of observations.
N = constants$N

# Posterior of mu
mu = samples[, 2:11]

# Posterior of sigma^2
sig2 = samples[, 12:21]

# Posterior of concentration parameter
alpha = samples[, 'alpha']

# Posterior of class labels
z = samples[, 22:(22+N-1)]

# Posterior of number of clusters
num_clus = apply(z, 1, function(row) length(unique(row)))

# Plot posteriors
options(repr.plot.width=15, repr.plot.height=11)
par(mfrow=c(2, 2))

# Plot posterior probability of number of clusters
plot(table(num_clus)/NROW(num_clus), xlab="Number of Clusters", ylab="Posterior Probability")

# Plot marginal posterior distribution of each mu component.
# NOTE: Some of the components do not get updated under the CRP
# representation because they never get used.
boxplot(mu, main="Boxplot of mu")
abline(h=simdata$mu, lty=2)

# Plot marginal posterior distribution of each sigma component.
boxplot(sqrt(sig2), main="Boxplot of sigma", ylim=c(0, 0.4))
abline(h=simdata$sig, lty=2)

# Plot posterior distribution of each alpha.
hist(alpha, prob=TRUE)
par(mfrow=c(1, 1))

# Sanity check. Plot proportion of mixture components for one sample of z.
# They should match the simulation truth.
options(repr.plot.width=6, repr.plot.height=6)
plot(table(z[1000,])/constants$N, xlab="mixture component", ylab="count", main="proportion for one sample from posterior")
abline(h=simdata$w, lty=2)  # simulation truth.


#' Assess rotational imbalance of a scan
#'
#' A good quality of 3d scans is crucial for an assessment of similarity of
#' striation marks between different bullets.
#' Here, we assess rotational imbalance - we measure this as the ratio between
#' the difference in the number of missing values on the left and the right of a scan at two different heights.
#' A ratio of 1 would indicate a balance in the proportion of missing values between the left hand side and the right hand side of a scan.
#' Large deviations of 1 indicate an imbalance to the left or right. A log transform of the ratio akes the result symmetric around 0. Large deviations from 0 indicate a stronger deviation.
#' @param x3p scan in x3p format
#' @param width how wide are the bands that we want to compare on the left and the right?
#' @return absolute value of the log of the ratio of the number of missing values on the left compared to the right side at the bottom and the middle of the scan.
#' @export
#' @examples
#' data(fau277_bb_l2)
#' assess_rotation(fau277_bb_l2) # this scan has a particularly high percentage of missing values
#' assess_rotation(fau001_ba_l1) # good scan
assess_rotation <- function(x3p, width=0.2) {
  stopifnot(class(x3p) == "x3p")
  stopifnot(width > 0, width < 0.5)

  dims <- dim(x3p$surface.matrix)
  band <- max(floor(width*dims[1]),1) # round down, but make sure we have at least one column of values
  half <- round(dims[2]/2)

  middle <- rowMeans(x3p$surface.matrix[,half+(-5:5)], na.rm=TRUE)
  bottom <- rowMeans(x3p$surface.matrix[,dims[2]-0:10], na.rm=TRUE)

  na_left <- sum(is.na(middle[1:band]))
  na_right <- sum(is.na(middle[dims[2]+1-band:1]))
#browser()
  na_left_bottom <- sum(is.na(bottom[1:band]))
  na_right_bottom <- sum(is.na(bottom[dims[2]+1-band:1]))

  return(abs(log((na_left+1)/(na_left_bottom+1)/((na_right+1)/(na_right_bottom+1)) )))
}


library("MASS")
data("OME")

dat = subset(OME, OME != "N/A")
dat$OME = factor(dat$OME) # relabel OME
dat$ID = as.numeric(factor(dat$ID)) # relabel ID so there are no gaps in numbers (they now go from 1 to 63)

## Original reference model and covariate matrix
mod_glm = glm(Correct/Trials ~ Age + OME + Loud + Noise, data=dat, weights=Trials, family="binomial")
X = model.matrix(mod_glm)[,-1]

## Original model (that needs to be extended)
mod_string = " model {
	for (i in 1:length(y)) {
		y[i] ~ dbin(phi[i], n[i])
		logit(phi[i]) = a[ID[i]] + b[1]*Age[i] + b[2]*OMElow[i] + b[3]*Loud[i] + b[4]*Noiseincoherent[i]
	}

    for (k in 1:max(ID)){
        a[k] ~ dnorm(a0, tau_prec)
    }

	a0 ~ dnorm(0.0, 1.0/10.0^2)
    tau_prec ~ dgamma(1.0/2.0, 1.0/2.0)
    tau = 1.0/tau_prec

	for (j in 1:4) {
		b[j] ~ dnorm(0.0, 1.0/4.0^2)
	}

} "

data_jags = as.list(as.data.frame(X))
data_jags$y = dat$Correct
data_jags$n = dat$Trials
data_jags$ID = dat$ID

library("rjags")

set.seed(113)

params = c("a0", "tau", "a", "b")

mod = jags.model(textConnection(mod_string), data=data_jags, n.chains=3)
update(mod, 1e3)

mod_sim = coda.samples(model=mod,
                       variable.names=params,
                       n.iter=5e3)
mod_csim = as.mcmc(do.call(rbind, mod_sim))

## convergence diagnostics
plot(mod_sim)

gelman.diag(mod_sim)
autocorr.diag(mod_sim)
autocorr.plot(mod_sim)
effectiveSize(mod_sim)

## compute DIC
dic = dic.samples(mod, n.iter=1e3)


library(optparse)
library(lattice)
library(ggplot2)
# library(caret)
# library(tree)
library(rpart)

max_reg <- function(model_obj, testing = NULL, target = NULL) {
    #Calculates rmse for a regression decision tree
    #Arguments:
    # testing - test data set
    # target  - target variable (length 1 character vector)
    yhat <- predict(model_obj, newdata = testing)
    actual <- testing[[target]]
    max(yhat-actual)
}

rmse_reg <- function(model_obj, testing = NULL, target = NULL) {
    #Calculates max_error for a regression decision tree
    #Arguments:
    # testing - test data set
    # target  - target variable (length 1 character vector)
    yhat <- predict(model_obj, newdata = testing)
    actual <- testing[[target]]
    sqrt(mean((yhat-actual)^2))
}

parse.path <- function(path) {
    if (is.null(path)){
        print_help(opt_parser)
        stop("path is a mandatory argument", call.=FALSE)
    }
    return(path)
}

parse.target <- function(target) {
    if (is.null(target)){
        print_help(opt_parser)
        stop("target is a mandatory argument", call.=FALSE)
    }
    return(target)
}

parse.maximum_depth <- function(maximum_depth) {
    if (is.null(maximum_depth)) {
        print_help(opt_parser)
        stop("maximum_depth is a mandatory argument", call.=FALSE)
    }
    if (!is.numeric(maximum_depth)) {
        print_help(opt_parser)
        stop("maximum_depth must be a number", call.=FALSE)
    }
    return(maximum_depth)
}

load.data <- function(type, path, target) {
    x <- read.csv(paste(path, "/features_", type, ".csv", sep = ""))
    y <- read.csv(paste(path, "/labels_", type, ".csv", sep = ""))

    data = x
    data[length(x) + 1] = y

    #data[[target]] = as.factor(data[[target]])
    data = as.data.frame(data)
    return(data)
}

option_list = list(
    make_option(c("-p", "--path"), type="character", default=NULL, help="path to features and labels files", metavar="character"),
    make_option(c("-t", "--target"), type="character", default=NULL, help="target feature", metavar="character"),
    make_option(c("-i", "--maximum_depth"), type="integer", default=100, help="maximum depth of the tree", metavar="integer")
)

opt_parser = OptionParser(option_list=option_list)
opt = parse_args(opt_parser)

path = parse.path(opt$path)
target = parse.target(opt$target)
maximum_depth = parse.maximum_depth(opt$maximum_depth)

train = load.data("train", path, target)
test = load.data("test", path, target)

common <- intersect(names(train), names(test))
for (p in common) {
    if (class(train[[p]]) == "factor") {
        levels(test[[p]]) <- levels(train[[p]])
    }
}

# tr <- tree(formula(paste(target, "~.")), data=train)
# tr <- rpart( formula(paste(target, "~.")), method = "class", data = train)
# rmse = rmse_reg(tr, test, target)
# max_error = max_reg(tr, test, target)

modelDT<- rpart ( formula(paste(target, "~.")), method="anova", data = train)
predictionsDT <- predict(modelDT, newdata = test)
test$dt = predictionsDT
rmseDT = sqrt(mean((as.numeric(test$dt)-as.numeric(test[[target]]))^2))
maxerrorDT = max(as.numeric(test$dt)-as.numeric(test[[target]]))

y_true = as.numeric(test[[target]])
rss = sum((predictionsDT - y_true) ^ 2)
tss = sum((y_true - mean(y_true)) ^ 2)
rsq = 1 - rss / tss

result <- paste("rmse:", rmseDT, ":r2_score:", rsq, ":max_error:", maxerrorDT, sep = "")
cat(result)


library(dplyr)
library(reshape2)
library(ggplot2)

bnames <- read.csv("../data/bnames.csv", stringsAsFactors = FALSE)

# Focus on the last 60 years
recent <- filter(bnames, year >= 1950)

# Still a lot of names, so pull out those names which are both moderately
# popular (> 1 / 1000) and in top 1000 for at least 30 years.  In a real
# analysis you'd probably want to analyse more data.

per_name <- recent %>% group_by(sex, name) %>% summarise(years = length(name), percent_avg = mean(percent))
long <- filter(per_name, years >= 30 & percent_avg > 0.001)
bnames_long <- inner_join(recent, long[c("sex", "name")], by = c("sex", "name"))

# To cluster, we need to reshape the data so that each year forms a column.
# We'll have to do this a few times, so we'll create a function to do this
# specifically for this data.  To learn more about how this works, see the
# documentation for the reshape package.
widen <- function(variable) {
  select(dcast(bnames_long, sex + name ~ year, fill = 0,
    value.var = variable), -sex, -name)
}

long$cluster1 <- kmeans(widen('percent'), 20)$cluster

bnames_cl <- inner_join(bnames_long, long, by = c("sex", "name"))
ggplot(bnames_cl, aes(year, percent)) +
  geom_line(aes(group = interaction(sex, name))) +
  facet_wrap(~ cluster1)

#long %>% group_by(cluster1) %>% do(names=.$name)

# Hmmmm.  Maybe be clustering too much based on absolute size, and not
# on relative shape.  Lets rescale percent to 0,1

library(mgcv)
smooth <- function(var, date) {
  predict(gam(var ~ s(date)))
}
scale01 <- function(x) (x - min(x)) / diff(range(x))

bnames_long <- bnames_long %>% group_by(sex, name) %>%
  mutate(percent_std = scale01(percent),
         percent_smo = scale01(smooth(percent, year)))

long$cluster2 <- kmeans(widen("percent_std"), 20)$cluster
long$cluster3 <- kmeans(widen("percent_smo"), 20)$cluster

bnames_cl <- inner_join(bnames_long, long, by = c("sex", "name"))
qplot(year, percent_std, data = bnames_cl, group = interaction(name, sex), geom = "line") +
  facet_wrap(~ cluster2)

qplot(year, percent_smo, data = bnames_cl, group = interaction(name, sex), geom = "line", colour = sex) +
  facet_wrap(~ cluster2)

#long %>% group_by(cluster2) %>% do(names=.$name)

tab <- table(long[c("cluster2", "cluster3")])

library(e1071)
match <- matchClasses(tab)
print.table(tab[, match], zero.print = ".")


##### Chapter 11: Improving Model Performance -------------------

# load the credit dataset
credit <- read.csv("credit.csv")
library(caret)

## Creating a simple tuned model ----
# automated parameter tuning of C5.0 decision tree
set.seed(300)
m <- train(default ~ ., data = credit, method = "C5.0")

# summary of tuning results
m

# apply the best C5.0 candidate model to make predictions
p <- predict(m, credit)
table(p, credit$default)

# obtain predicted classes
head(predict(m, credit, type = "raw"))

# obtain predicted probabilities
head(predict(m, credit, type = "prob"))

## Customizing the tuning process ----
# use trainControl() to alter resampling strategy
ctrl <- trainControl(method = "cv", number = 10,
                     selectionFunction = "oneSE")

# use expand.grid() to create grid of tuning parameters
grid <- expand.grid(.model = "tree",
                    .trials = c(1, 5, 10, 15, 20, 25, 30, 35),
                    .winnow = "FALSE")

# look at the result of expand.grid()
grid

# customize train() with the control list and grid of parameters
set.seed(300)
m <- train(default ~ ., data = credit, method = "C5.0",
           metric = "Kappa",
           trControl = ctrl,
           tuneGrid = grid)
m

## Bagging ----
# Using the ipred bagged decision trees
library(ipred)
set.seed(300)
mybag <- bagging(default ~ ., data = credit, nbagg = 25)
credit_pred <- predict(mybag, credit)
table(credit_pred, credit$default)

# estimate performance of ipred bagged trees
library(caret)
set.seed(300)
ctrl <- trainControl(method = "cv", number = 10)
train(default ~ ., data = credit, method = "treebag",
      trControl = ctrl)

# Using caret's more general bagging function
# create a bag control object using svmBag
str(svmBag)
svmBag$fit

bagctrl <- bagControl(fit = svmBag$fit,
                      predict = svmBag$pred,
                      aggregate = svmBag$aggregate)

# fit the bagged svm model
set.seed(300)
svmbag <- train(default ~ ., data = credit, "bag",
                trControl = ctrl, bagControl = bagctrl)

svmbag

## Boosting ----
# Using AdaBoost.M1
# (please note that this example is not in the text)
library(adabag)
set.seed(300)
bst <- boosting.cv(default ~ ., data = credit, mfinal = 50)
bst$confusion
bst$error

## Random Forests ----
# random forest with default settings
library(randomForest)
set.seed(300)
rf <- randomForest(default ~ ., data = credit)
rf

library(caret)
ctrl <- trainControl(method = "repeatedcv",
                     number = 10, repeats = 10)

# auto-tune a random forest
grid_rf <- expand.grid(.mtry = c(2, 4, 8, 16))

set.seed(300)
m_rf <- train(default ~ ., data = credit, method = "rf",
              metric = "Kappa", trControl = ctrl,
              tuneGrid = grid_rf)
m_rf

# auto-tune a boosted C5.0 decision tree
grid_c50 <- expand.grid(.model = "tree",
                        .trials = c(10, 20, 30, 40),
                        .winnow = "FALSE")

set.seed(300)
m_c50 <- train(default ~ ., data = credit, method = "C5.0",
                metric = "Kappa", trControl = ctrl,
               tuneGrid = grid_c50)
m_c50


#' Breaks data by quantile
#'
#' @description Breaks data by quantile
#'
#' @param x numeric vector.
#' @param q numeric vector of quantiles.
#'
#' @return breaks
#' @export
#'
#' @examples
#' x <- rnorm(100)
#' cut_quantile(x)
#'

cut_quantile <- function(x, q = seq(0,1,by = .20),...) {

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(is.numeric(q) == F){
    stop("q must be numeric")
  }

  if((min(q) < 0) | (max(q) > 1)){
    stop("q range must be [0;1]")
  }

  if(length(q) <= 1){
    stop("q length must be > 1")
  }

  if(length(x) <= 1){
    stop("x length must be > 1")
  }

  cut(x,
      breaks = quantile(x,probs = q,na.rm = T),
      ...,
      include.lowest = T,
      right = T
      )

}


require("deSolve")

f = function(r, x) {
  return(  r[1] - r[2]*x - exp(-1*x)  )
}

sequencer <- function(seq.range, fragments) {
  return(seq(from=seq.range[1], to=seq.range[2], by=(seq.range[2]-seq.range[1])/fragments))
}

plot.phase <- function(f, range.main, ranges, fragments=1000, no.runs=100, ylim=c(-100, 100), color.var=2) {
  num.params = nrow(ranges)
  values = apply(ranges, 1, sequencer, fragments)
  values = data.frame(values)

  color.mul = no.runs/(ranges[color.var,]$high - ranges[color.var,]$low)

  x = sequencer(range.main, fragments)

  colors = rainbow(n=1.2*no.runs, alpha=1)
  plot(x=0, type="n", xlim=c(min(x), max(x)), ylim=ylim)

  for (r in seq(no.runs)) {
    samples = apply(values, 2, sample, 1)
    lines(x=x, y=f(samples, x), col=colors[samples[color.var]*color.mul + no.runs/2])
  }

  lines(y=c(0,0), x=c(min(x), max(x)))
  lines(x=c(0,0), y=ylim)

  # dev.new()
}

plot.bifurcation = function() {
}

plot.phase(f, c(-20, 20), ranges=data.frame(low=c(-10, -10), high=c(10, 10)), no.runs=1000)


## The function to calculate the likelihood values.

Calculation<-function(Simulation,Measurement,Variance)
{
Constant=10000;
#A constant to amplify the likelihood values in case of beyond computer precision becasue the vasues may be very small.

Likelihood<-Constant*(1/sqrt(2*pi*Variance))*exp(-(Measurement-Simulation)^2/(2*Variance));
# The likelihood function derived from the normal distribution.

return(Likelihood);

}


# Auther: 	Yuqian Shi
# Date:		4 Jul 2018
# Name: 	randomForest  in R

require(randomForest)
require(MASS)# the Boston housing dataset
attach(Boston)

set.seed(101)

dim(Boston)

#select 300 instances for training
train=sample(1:nrow(Boston),300)
?Boston  #to search on the dataset

Boston.rf=randomForest(medv ~ . , data = Boston , subset = train)
Boston.rf

plot(Boston.rf)

oob.err	=double(13)
test.err=double(13)

#mtry is no of Variables randomly chosen at each split
for(mtry in 1:13)
{
  rf=randomForest(medv ~ . , data = Boston ,
  	subset = train,mtry=mtry,ntree=400)
  oob.err[mtry] = rf$mse[400] #Error of all Trees fitted

  pred<-predict(rf,Boston[-train,]) #Predictions on Test Set for each Tree
  test.err[mtry]= with(Boston[-train,], mean( (medv - pred)^2)) #Mean Squared Test Error

  cat(mtry," ") #printing the output to the console

}

matplot(
	1:mtry , cbind(oob.err,test.err), pch=19 ,
	col=c("red","blue"),type="b",
	ylab="Mean Squared Error",
	xlab="Number of Predictors Considered at each Split")
legend("topright",legend=c("Out of Bag Error","Test Error"),
	pch=19, col=c("red","blue"))


#' @title f-test
#' @description f-test
#' @param sd1 First standard deviation
#' @param sd2 Second standard deviation
#' @param df1 First degrees of freedom
#' @param df2 Second degrees of freedom
#' @param prob Probability
#' @return Test decision
#' @rdname f_test
f_test <- function(sd1, sd2, df1, df2, prob){
  if(sd1 > sd2){
    F.estimated <- sd1^2/sd2^2
    F.quantile <- qf(p = prob, df1 = df1, df2 = df2)
  }else{
    F.estimated <- sd2^2/sd1^2
    F.quantile <- qf(p = prob, df1 = df1, df2 = df2)
  }
  if(F.estimated < F.quantile){
    note <- TRUE
  }else{
    note <- FALSE
  }
  return(list(f_estimated = F.estimated, f_quantile = F.quantile, decision = note))
}

#' @title deform.snet
#' @description Two-epochs deformation analysis based on congruency testing
#' @param snet_1_path Path to the data of the first epoch of the measurements
#' @param snet_2_path Path to the data of the second epoch of the measurements
#' @param sd.apriori Apriori standard deviation
#' @param units Units of the results, Default: 'mm'
#' @param dim_type Dimension type of the network, Default: '1D'
#' @param prob Probability for statistical testing, Default: 0.95
#' @param wdh_model Weightening model for leveling measurements, Default: list("n_dh", "sd_dh", "d_dh", "E")
#' @return dataframe with two columns: "Name" indicating the name of the point and "stable" indicating the stability status of the point (TRUE or FALSE)
#' @details DETAILS
#' @examples
#' \dontrun{
#' if(interactive()){
#'  #EXAMPLE1
#'  }
#' }
#' @seealso
#' @rdname snet.stable
#' @export
#' @importFrom dplyr arrange select case_when
#' @importFrom MASS ginv
deform.snet <- function(snet_1_path, snet_2_path, sd.apriori, units = "mm",  dim_type = "1D", prob = 0.95, wdh_model = list("n_dh", "sd_dh", "d_dh", "E")){
  "%!in%" <- Negate("%in%")
  wdh_model <- wdh_model[[1]]
  units.lookup.table <- c(mm = 1000, cm = 100, m = 1)
  if(length(sd.apriori) == 1){
    sd0_i <- sd.apriori[1]
    sd0_j <- sd.apriori[1]
  }else{
    sd0_i <- sd.apriori[1]
    sd0_j <- sd.apriori[2]
  }
  #=================== Reading snets ===============================
  snet_i <- suppressWarnings(read_surveynet(file = snet_1_path))
  snet_j <- suppressWarnings(read_surveynet(file = snet_2_path))

  #=================== Checking snets ==============================
  if(!identical(snet_i$observations[, c("from", "to")], snet_j$observations[, c("from", "to")])){
    print("Observation plans are not identical in two epochs.")
  }

  used_points_i <- unique(c(snet_i$observations$from, snet_i$observations$to))
  used_points_j <- unique(c(snet_j$observations$from, snet_j$observations$to))

  if(!!any(used_points_i %!in% snet_i[[1]]$Name)){
    stop(paste("There is no coordinates for point", paste(used_points_i[which(used_points_i %!in% snet_i[[1]]$Name)], "in reference epoch"), sep = " "))
  }else{used_points_i <- snet_i[[1]]$Name
  }

  if(!!any(used_points_i %!in% snet_i[[1]]$Name)){
    stop(paste("There is no coordinates for point", paste(used_points_j[which(used_points_j %!in% snet_j[[1]]$Name)]), "in target epoch",  sep = " "))
  }else{used_points_j <- snet_j[[1]]$Name
  }

  if(!identical(used_points_i, used_points_i)){
    print("Two epochs contains different points.")
    if(length(used_points_i) > length(used_points_j)){
      print(paste("Points", used_points_i[which(used_points_i %!in% used_points_j)], "do not exist in the target epoch", sep = " "))
      used_points <- used_points_j
    }else{
      if(length(used_points_i) < length(used_points_j)){
        print(paste("Points", used_points_j$Points$Name[which(used_points_j %!in% used_points_i)], "do not exist in the reference epoch", sep = " "))
        used_points <- used_points_i
      }
      print("Only the results for common points will be processed.")
    }
  }else{
    used_points <- used_points_i
  }

  if(!identical(snet_i$Points$h, snet_j$Points$h)){
    stop(print("Approximate coordinates in two epoches must be the same"))
  }

  if(!identical(snet_i$points$Name[snet_i$points$Point_object], snet_j$points$Name[snet_j$points$Point_object])){
    stop(print("Reference points must be the same"))
  }
  snet_i[[1]] <- snet_i[[1]][match(snet_i[[1]]$Name, used_points), ] %>% dplyr::arrange(Point_object, desc = TRUE)
  snet_j[[1]] <- snet_j[[1]][match(snet_j[[1]]$Name, used_points), ] %>% dplyr::arrange(Point_object, desc = TRUE)
  #===========================================================================

  #=================== Adjustment ============================================
  snet_i_adj <- suppressMessages(adjust.snet(adjust = TRUE, survey.net = snet_i, dim_type = "1D", sd.apriori = sd0_i,  all = TRUE, prob = prob, wdh_model = wdh_model))
  snet_j_adj <- suppressMessages(adjust.snet(adjust = TRUE, survey.net = snet_j, dim_type = "1D", sd.apriori = sd0_j,  all = TRUE, prob = prob, wdh_model = wdh_model))
  if(any(c(snet_i_adj$Summary$`Test decision`, snet_j_adj$Summary$`Test decision`) != "Model is correct")) {
    return(list(snet_1_adj = snet_i_adj[1:3], snet_2_adj = snet_i_adj[1:3]))
    stop("One epoch adjustment failed")
  }
  #============================================================================
  points_i <- snet_i_adj$Points
  points_j <- snet_j_adj$Points

  points_i$Stable <- NA
  points_j$Stable <- NA

  Qx_i <- snet_i_adj$Matrices$Qx
  Qx_j <- snet_j_adj$Matrices$Qx

  #=================== Calculating reference accuracy factor ==================
  s0_i <- snet_i_adj$Summary$`sigma aposteriori`
  s0_j <- snet_j_adj$Summary$`sigma aposteriori`
  f_i <- snet_i_adj$Summary$`Degrees of freedom`
  f_j <- snet_j_adj$Summary$`Degrees of freedom`

  if(f_test(sd1 = s0_i, sd2 = s0_j, df1 = f_i, df2 = f_j, prob = prob)[[3]]){
    s0 <- sqrt((f_i*s0_i^2+f_j*s0_j^2)/(f_i + f_j))
    f0 <- f_i + f_j
  }else{
    if(s0_i > s0_j){
      s0 <- s0_i
      f0 <- f_i
      print("Two epoches are not equally precised! Computation will be continued with the worse reference standard deviation.")
    }else{
      s0 <- s0_j
      f0 <- f_j
      print("Two epoches are not equally precised! Computation will be continued with the worse reference standard deviation.")
    }
  }
  #============================================================================

  #=================== Testing whole network ==================================

  d_all <- (points_j$h - points_i$h)*units.lookup.table[units]

  Qd_all <- Qx_i + Qx_j

  Qd_all_ginv <- MASS::ginv(Qd_all)

  dd_all <- (crossprod(d_all, Qd_all) %*% d_all)

  teta_all_squared <- ((crossprod(d_all, Qd_all_ginv) %*% d_all)/qr(Qd_all)$rank)

  snet_test <- f_test(sd1 = sqrt(teta_all_squared), sd2 = s0, df1 = qr(Qd_all)$rank, df2 = f0, prob = prob)

  if(sum(points_i$Point_object) == 0){
    fix <- "all"
    if(!snet_test[[3]]){
      r_points_ind <- !points_i$Point_object
      names(r_points_ind) <- points_i$Name
      iter <- 0
      m <- sum(r_points_ind)
      while(!snet_test[[3]] & m > 1) {
        iter = iter + 1
        r_ind_matrix <- diag(sum(r_points_ind)) == 1
        teta_r <- rep(NA, sum(r_points_ind))
        for(i in 1:sum(r_points_ind)){
          drb <- d_all[r_points_ind][r_ind_matrix[i, ]]
          drf <- d_all[r_points_ind][!r_ind_matrix[i, ]]

          Qdbb  <- Qd_all_ginv[r_points_ind, r_points_ind][r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdbf  <- Qd_all_ginv[r_points_ind, r_points_ind][r_ind_matrix[i, ], !r_ind_matrix[i, ]]
          Qdfb  <- Qd_all_ginv[r_points_ind, r_points_ind][!r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdff  <- Qd_all_ginv[r_points_ind, r_points_ind][!r_ind_matrix[i, ], !r_ind_matrix[i, ]]

          dsb <- drb + solve(Qdbb) %*% Qdbf %*% drf
          Qsff <- Qdff - Qdfb %*% solve(Qdbb) %*% Qdbf

          dd_b <- (crossprod(dsb, Qdbb) %*% dsb)
          teta_r[i] <- dd_b
        }
        names(teta_r) <- points_i$Name[r_points_ind]
        max_teta_name <- names(teta_r[which(teta_r==max(teta_r))])
        points_i[points_i$Name == max_teta_name, "Stable"] <- FALSE
        points_j[points_j$Name == max_teta_name, "Stable"] <- FALSE

        r_points_ind[which(points_i$Stable == FALSE)] <- FALSE
        names(r_points_ind) <- points_i$Name

        d_rest <- d_all[r_points_ind]

        Qd_rest_ginv <- Qd_all_ginv[r_points_ind, r_points_ind]

        dd_rest <- (crossprod(d_rest, Qd_rest_ginv) %*% d_rest)

        teta_rest_squared <- ((crossprod(d_rest, Qd_rest_ginv) %*% d_rest)/qr(Qd_rest_ginv)$rank)

        snet_test <- f_test(sd1 = sqrt(teta_rest_squared), sd2 = s0, df1 = qr(Qd_rest_ginv)$rank, df2 = f0, prob = prob)
        m <- sum(r_points_ind)
      }
    }
  }else{
    # ================== Testing for reference points ============================

    r_points_names <- snet_i_adj$Points$Name[!snet_i_adj$Points$Point_object]
    o_points_names <- snet_i_adj$Points$Name[snet_i_adj$Points$Point_object]

    r_points_ind <- !points_i$Point_object
    names(r_points_ind) <- points_i$Name

    dr <- d_all[r_points_ind]
    names(dr) <- points_i$Name[r_points_ind]
    do <- d_all[!r_points_ind]
    names(do) <- points_i$Name[!r_points_ind]

    Qdrr <- Qd_all_ginv[r_points_ind, r_points_ind]
    Qdro  <- Qd_all_ginv[r_points_ind, !r_points_ind]
    Qdor  <- Qd_all_ginv[!r_points_ind, r_points_ind]
    Qdoo  <- Qd_all_ginv[!r_points_ind, !r_points_ind]

    dso <- do + solve(Qdoo) %*% Qdor %*% dr
    Qsrr <- Qdrr - Qdro %*% solve(Qdoo) %*% Qdor

    dd_r <- (crossprod(dr, Qsrr) %*% dr) # kvadratna forma

    teta_r_squared <- ((crossprod(dr, Qsrr) %*% dr)/qr(Qsrr)$rank)

    r_test <- f_test(sd1 = sqrt(teta_r_squared), sd2 = s0, df1 = qr(Qsrr)$rank, df2 = f0, prob = prob)

    if(!r_test[[3]]){
      iter <- 0
      m <- sum(r_points_ind)
      while(!r_test[[3]] & m > 1) {
        iter = iter + 1
        r_ind_matrix <- diag(sum(r_points_ind)) == 1
        teta_r <- rep(NA, sum(r_points_ind))
        for(i in 1:sum(r_points_ind)){
          drb <- d_all[r_points_ind][r_ind_matrix[i, ]]
          drf <- d_all[r_points_ind][!r_ind_matrix[i, ]]

          Qdbb <- Qdrr[r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdbf  <- Qdrr[r_ind_matrix[i, ], !r_ind_matrix[i, ]]
          Qdfb  <- Qdrr[!r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdff  <- Qdrr[!r_ind_matrix[i, ], !r_ind_matrix[i, ]]

          dsb <- drb + solve(Qdbb) %*% Qdbf %*% drf
          Qsff <- Qdff - Qdfb %*% solve(Qdbb) %*% Qdbf

          dd_b <- (crossprod(dsb, Qdbb) %*% dsb)
          teta_r[i] <- dd_b
        }
        names(teta_r) <- points_i$Name[r_points_ind]
        max_teta_name <- names(teta_r[which(teta_r==max(teta_r))])
        points_i[points_i$Name == max_teta_name, "Stable"] <- FALSE
        points_j[points_j$Name == max_teta_name, "Stable"] <- FALSE

        r_points_ind <- is.na(!points_i$Point_object & points_i$Stable)
        names(r_points_ind) <- points_i$Name

        dr <- d_all[r_points_ind]
        names(dr) <- points_i$Name[r_points_ind]
        do <- d_all[!r_points_ind]
        names(do) <- points_i$Name[!r_points_ind]

        Qdrr <- Qd_all_ginv[r_points_ind, r_points_ind]
        Qdro  <- Qd_all_ginv[r_points_ind, !r_points_ind]
        Qdor  <- Qd_all_ginv[!r_points_ind, r_points_ind]
        Qdoo  <- Qd_all_ginv[!r_points_ind, !r_points_ind]

        Qsrr <- Qdrr - Qdro %*% solve(Qdoo) %*% Qdor

        teta_r_squared <- ((crossprod(dr, Qsrr) %*% dr)/qr(Qsrr)$rank)

        r_test <- f_test(sd1 = sqrt(teta_r_squared), sd2 = s0, df1 = qr(Qsrr)$rank, df2 = f0, prob = prob)
        m <- sum(r_points_ind)
      }
    }
    #================== Testing for object points ==============================

    points_i$Stable[r_points_ind] <- TRUE
    points_i$Stable[!points_i$Stable] <- NA

    points_j$Stable[r_points_ind] <- TRUE
    points_j$Stable[!points_j$Stable] <- NA

    o_points_ind <- !r_points_ind
    names(o_points_ind) <- points_i$Name

    dso <- do + solve(Qdoo) %*% Qdor %*% dr
    teta_o_squared <- ((crossprod(dso, Qdoo) %*% dso)/qr(Qdoo)$rank)
    o_test <- f_test(sd1 = sqrt(teta_o_squared), sd2 = s0, df1 = qr(Qdoo)$rank, df2 = f0, prob = prob)

    if(!o_test[[3]]){
      iter <- 0
      m <- sum(o_points_ind)
      while(!o_test[[3]] & m > 1) {
        iter = iter + 1
        o_ind_matrix <- diag(sum(is.na(points_i$Stable))) == 1
        teta_o <- rep(NA, sum(is.na(points_i$Stable)))
        dobs <- rep(NA, sum(is.na(points_i$Stable)))
        Qdoo_o <- Qd_all_ginv[o_points_ind, o_points_ind]
        for(i in 1:sum(o_points_ind)){
          drb <- (points_j$h[is.na(points_i$Stable)][o_ind_matrix[i, ]] - points_i$h[is.na(points_i$Stable)][o_ind_matrix[i, ]])*units.lookup.table[units]
          drf <- (points_j$h[is.na(points_i$Stable)][!o_ind_matrix[i, ]] - points_i$h[is.na(points_i$Stable)][!o_ind_matrix[i, ]])*units.lookup.table[units]

          Qdbb  <- Qdoo_o[o_ind_matrix[i, ], o_ind_matrix[i, ]]
          Qdbf  <- Qdoo_o[o_ind_matrix[i, ], !o_ind_matrix[i, ]]
          Qdfb  <- Qdoo_o[!o_ind_matrix[i, ], o_ind_matrix[i, ]]
          Qdff  <- Qdoo_o[!o_ind_matrix[i, ], !o_ind_matrix[i, ]]

          dsb <- drb + solve(Qdbb) %*% Qdbf %*% drf
          Qsff <- Qdff - Qdfb %*% solve(Qdbb) %*% Qdbf

          dd_b <- (crossprod(dsb, Qdbb) %*% dsb)
          teta_o[i] <- dd_b
          dobs[i] <- drb
        }
        names(teta_o) <- points_i$Name[o_points_ind]
        names(dobs) <- points_i$Name[o_points_ind]
        max_teta_name <- names(teta_o[which(teta_o==max(teta_o))])
        max_do <- dobs[which(teta_o == max(teta_o))]
        points_i[points_i$Name == max_teta_name, "Stable"] <- FALSE
        points_j[points_j$Name == max_teta_name, "Stable"] <- FALSE

        o_points_ind <- is.na(points_i$Stable)
        names(o_points_ind) <- points_i$Name

        # Qdrr <-  Qd_all_ginv[o_points_ind, o_points_ind]
        # Qdro  <- Qd_all_ginv[o_points_ind, !o_points_ind]
        # Qdor  <- Qd_all_ginv[!o_points_ind, o_points_ind]
        # Qdoo  <- Qd_all_ginv[!o_points_ind, !o_points_ind]

        Qdrr <-  Qd_all_ginv[(!r_points_ind & o_points_ind), (!r_points_ind & o_points_ind)]
        Qdro  <- Qd_all_ginv[(!r_points_ind & !o_points_ind), (!r_points_ind & o_points_ind)]
        Qdor  <- Qd_all_ginv[(!r_points_ind & o_points_ind), (!r_points_ind & !o_points_ind)]
        Qdoo  <- Qd_all_ginv[(!r_points_ind & !o_points_ind), (!r_points_ind & !o_points_ind)]

        do <- d_all[!r_points_ind & o_points_ind]

        Qsrr <- Qdrr - Qdro %*% solve(Qdoo) %*% Qdor

        teta_o_squared <- ((crossprod(do, Qsrr) %*% do)/qr(Qsrr)$rank)
        o_test <- f_test(sd1 = sqrt(teta_o_squared), sd2 = s0, df1 = qr(Qsrr)$rank, df2 = f0, prob = prob)

        m <- sum(o_points_ind)
        if(!o_test[[3]] & m == 1){
          points_i[o_points_ind, "Stable"] <- FALSE
          points_j[o_points_ind, "Stable"] <- FALSE
        }
      }
    }

  }
  points_i$Stable[is.na(points_i$Stable)] <- TRUE
  points_j$Stable[is.na(points_j$Stable)] <- TRUE

  return(points_i %>% dplyr::select(id, Name, Stable))
}


# establece ruta para leer/escribir
setwd("~/Desktop/sip/data")

# lee datos
d <- read.csv("ptot-edo-2010-2020.csv")
str(d)

# quita total nacional
d <- d[-which(d$edon==33),]

# recalcula cambio %
d$chg <- NULL
d$chg <- d$ptot2020 / d$ptot2010

# población total
sum(d$ptot2020)
# cambio
sum(d$ptot2020) / sum(d$ptot2010)
# subre/sub-crecimeiento
d$sobsub <- round(d$chg - sum(d$ptot2020) / sum(d$ptot2010), 2)
d[order(d$sobsub), c("estado", "sobsub")]

quantile(d$sobsub, probs = c(0,.33,.5,.67,1))

quantile(d$ptot2020, probs = c(0,.33,.5,.67,1))
d$size <- 0
d$size[d$ptot2020 <= 2332000]                         <- 1
d$size[d$ptot2020 >  2332000 & d$ptot2020 <= 3763000] <- 2
d$size[d$ptot2020 >  3763000]                         <- 3
# factor
d$size <- factor(d$size, levels = 1:3, labels = c("ch","med","gde"))
table(d$size)

# ¿cuántas personas cree Ud. que debería representar un diputado federal? = DIVISOR
r1787 <- 33000 # el techo de 1878 (constitución EUA dice r > 30000)
# divisor ideal EEUU hoy (nacional)
r.usa <- round(328200000 / 435)
r.usa

# relación ideal mx 2020
r2020 <- round(sum(d$ptot2020) / 300)
# relación ideal mx previas
r1990 <- round(sum(d$ptot1990) / 300)
r2000 <- round(sum(d$ptot2000) / 300)
r2010 <- round(sum(d$ptot2010) / 300)
r1990
r2000
r2010
r2020

# Si usaramos esto
R <- 100000

# Jeferson:
# (1) Población del estado por divisor = COCIENTE
# (2) Parte entera del conciente = APPORTIONMENT
app <- data.frame(edo = d$edo,
                  jef90 = as.integer(d$ptot1990 / R),
                  jef00 = as.integer(d$ptot2000 / R),
                  jef10 = as.integer(d$ptot2010 / R),
                  jef20 = as.integer(d$ptot2020 / R))
# (3) Mínimo dos por estado (regla Mx, no EEUU)
app$jef90[app$jef90<2] <- 2
app$jef00[app$jef00<2] <- 2
app$jef10[app$jef10<2] <- 2
app$jef20[app$jef20<2] <- 2
app

# tamaño del Congreso resultante, muy grande
colSums(app[,-1])

# pongamos la tercera parte
R  <- 300000
app <- data.frame(edo = d$edo,
                  jef90 = as.integer(d$ptot1990 / R),
                  jef00 = as.integer(d$ptot2000 / R),
                  jef10 = as.integer(d$ptot2010 / R),
                  jef20 = as.integer(d$ptot2020 / R))
# (3) Mínimo dos por estado (regla Mx, no EEUU)
app$jef90[app$jef90<2] <- 2
app$jef00[app$jef00<2] <- 2
app$jef10[app$jef10<2] <- 2
app$jef20[app$jef20<2] <- 2
app
# tamaño del Congreso resultante, muy grande
colSums(app[,-1])

# hamilton compromise
# (1) Fija el tamaño del cuerpo dada la relación de representación
N <- as.integer( sum(d$ptot2020) / R )
N  # 420, no 403, dice Hamilton. Algunas fracciones tendrán q asignarse para llegar al tamaño
# (2) Regla de tres:  N * Pob estatal / Pob total = cociente
Q = N * (d$ptot2020 / sum(d$ptot2020))
entero <-     as.integer(Q)
resto <-  Q - as.integer(Q)
# (3) Mínimo uno por estado
entero[entero<2] <- 2
# Cuántos hay?
faltan <- N - sum(entero) # falta asignar 17
app$ham20 <- entero
sel <- order(-resto)[1:faltan] # índices de los 17 restos mayores
# verifica
resto[sel]
resto[-sel]
# distribuye los diputados restantes
app$ham20[sel] <- app$ham20[sel] + 1
# verifica
sum(app$ham20)

app[,c("edo","jef20","ham20")]
# población creciente
app$dif <- app$ham20 - app$jef20
app$dif.r <- round(app$ham20 / app$jef20,2)
app[order(d$ptot2020),c("edo","jef20","ham20","dif","dif.r")]

# descripción según tamaño del estado
app$size <- d$size
with(app, table(size, dif))
with(app, table(size, dif.r))
with(app, aggregate(dif,   list(size), mean))
with(app, aggregate(dif.r, list(size), mean))

# mejor comparación con cuerpos del mismo tamaño
# jeferson
R  <- sum(d$ptot2020) / 300 # con SMDs de diputados
R  <- sum(d$ptot2020) / 315 # prueba-y-error para que suma de enteros llegue a 300
app <- data.frame(edo = d$edo,
                  jef20 = as.integer(d$ptot2020 / R))
app$jef20[app$jef20<2] <- 2
app
# tamaño del Congreso resultante, muy grande
sum(app[,-1])

# hamilton
N <- 300
Q = N * (d$ptot2020 / sum(d$ptot2020))
entero <-     as.integer(Q)
resto <-  Q - as.integer(Q)
# (3) Mínimo uno por estado
entero[entero<2] <- 2
# Cuántos hay?
faltan <- N - sum(entero) # falta asignar 17
app$ham20 <- entero
sel <- order(-resto)[1:faltan] # índices de los 17 restos mayores
app$ham20[sel] <- app$ham20[sel] + 1
# verifica
sum(app$ham20)

app
# población creciente
app$dif <- app$ham20 - app$jef20
app$dif.r <- round(app$ham20 / app$jef20,2)
app[order(d$ptot2020),]

# descripción según tamaño del estado
app$size <- d$size
with(app, table(size, dif))
with(app, table(size, dif.r))
with(app, aggregate(dif,   list(size), mean))
with(app, aggregate(dif.r, list(size), mean))

# webster
R  <- sum(d$ptot2020) / 300.342 # prueba-y-error para que suma de enteros llegue a 300
app$web20 <- round(d$ptot2020 / R)
app$web20[app$web20<2] <- 2
# tamaño del Congreso resultante, muy grande
sum(app$web)

## # Hill --- aún no jala, verlo en Balinski
## N <- 300
## Q = N * (d$ptot2020 / sum(d$ptot2020))
## entero <-     as.integer(Q)
## geomedia <- sqrt( entero * (entero+1))
## app$hill20 <- entero
## app$hill[Q - geomedia > 0] <- entero[Q - geomedia > 0] + 1
## # (3) Mínimo uno por estado
## app$hill20[app$hill20<2] <- 2
## # Cuántos hay?
## sum(app$hill20)

# diferencias con hamilton app <-
app <- within(app, {
                djef20 <- jef20 - ham20 ;
                dweb20 <- web20 - ham20 ;
                drjef20 <- round(jef20 / ham20, 2);
                drweb20 <- round(web20  / ham20, 2)
})

plot(d$ptot2020, app$djef20, pch = 8)
sel <- which(app$djef20!=0)
text(d$ptot2020[sel], (app$djef20[sel]+.07), labels = app$edo[sel], cex = .6)
# points(d$ptot2020, app$dweb20, col = "red")

# R de cada estado contra la ideal
plot(d$ptot2020, (d$ptot2020 / app$ham20))
abline(h = R)
plot(d$ptot2020, (d$ptot2020 / app$jef20))
abline(h = R)

# Relative Representation Index (Ansolabehere Snyder)
# RRI =  (pob.nal / 300) / (pob.edo / ndip.edo)
app$rri.jef <- round((sum(d$ptot2020) / 300) / (d$ptot2020 / app$jef20), 2);
app$rri.ham <- round((sum(d$ptot2020) / 300) / (d$ptot2020 / app$ham20), 2);
app$rri.web <- round((sum(d$ptot2020) / 300) / (d$ptot2020 / app$web20), 2);

plot(c(.5,1.5), c(.5,1.5), type = "n")
points(app$rri.ham, app$rri.jef)
abline(a = 0, b = 1, lty = 2)

plot(d$ptot2020, app$rri.jef, type = "n", main = "Jefferson")
text(d$ptot2020, app$rri.jef, labels = app$edo, cex = .75)
abline(h = 1)

plot(d$ptot2020, app$rri.ham, type = "n", main = "Hamilton")
text(d$ptot2020, app$rri.ham, labels = app$edo, cex = .75)
abline(h = 1)

app[,c("edo", "rri.ham", "rri.jef")]


suppressPackageStartupMessages(library(float))
set.seed(1234)

tol = 1e-6

cmp = function(qr_x, qr_xs)
{
  test = dbl(qr.R(qr_xs))
  truth = qr.R(qr_x)
  stopifnot(all.equal(test, truth, tol=tol))

  test = dbl(qr.Q(qr_xs))
  truth = qr.Q(qr_x)
  stopifnot(all.equal(test, truth, tol=tol))

  test = dbl(qr.R(qr_xs, complete=TRUE))
  truth = qr.R(qr_x, complete=TRUE)
  stopifnot(all.equal(test, truth, tol=tol))

  test = dbl(qr.Q(qr_xs, complete=TRUE))
  truth = qr.Q(qr_x, complete=TRUE)
  stopifnot(all.equal(test, truth, tol=tol))
}

# m > n
x = matrix(stats::rnorm(30), 10)
xs = fl(x)
qr_x = qr(x, LAPACK=TRUE)
qr_xs = qr(xs)

stopifnot(identical(qr_xs$rank, 3L))
cmp(qr_x, qr_xs)

# NOTE: m < n and rank degenerate cases not well-defined


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

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

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

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 install.packages("MSwM")

 library(MSwM)

 MarkovSwitchData <- read.csv("d:/StocksRegimeSwitching.csv", header = TRUE)

 attach(MarkovSwitchData)

 head(MarkovSwitchData)

 dim(MarkovSwitchData)

 summary(MarkovSwitchData)

 yLogValueStocks <- cbind(LVS)

 head(yLogValueStocks)

 yLogGrowthStocks <- cbind(LGS)

 head(yLogGrowthStocks)

 x <- cbind(LRY, LRC, INT, LRV)

 olsLogValueStocks <- lm(yLogValueStocks~x)

 summary(olsLogValueStocks)

 olsLogGrowthStocks <- lm(yLogGrowthStocks~x)

 summary(olsLogGrowthStocks)

 MarkovSwtchLogValueStocks <- msmFit(olsLogValueStocks, k = 2, sw = rep(TRUE, 6))

 summary(MarkovSwtchLogValueStocks)

 MarkoSwtchLogGrowthStocks <- msmFit(olsLogGrowthStocks, k = 2, sw = rep(TRUE, 6))

 summary(MarkoSwtchLogGrowthStocks)

 par(mar=c(3,3,3,3))

 plotProb(MarkovSwtchLogValueStocks, which=1)

 plotProb(MarkoSwtchLogValueStocks, which=2)

 plotProb(MarkoSwtchLogGrowthStocks, which=1)

 plotProb(MarkoSwtchLogGrowthStocks, which=2)

 par(mar=c(3,3,3,3))

 plotDiag(MarkovSwtchLogValueStocks, regime=1, which=1)

 plotDiag(MarkovSwtchLogValueStocks, regime=1, which=2)

 plotDiag(MarkoSwtchLogGrowthStocks, regime=1, which=1)

 plotDiag(MarkoSwtchLogGrowthStocks, regime=1, which=2)

 plotDiag(MarkoSwtchLogGrowthStocks, regime=1, which=3)

Chapter 08/1Markov Chains - Stocks Regime Switching Model.r


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     02.07.2017
#modificado: 09.12.2019

library("e1071")

#Create testing set by hold out
set.seed(12345)
n <- nrow(iris)
n_test <- floor(n/3)
sampindex <- sample(1:n,size=n_test,replace=FALSE)
testset <- iris[sampindex,]
trainset <- iris[-sampindex,]

#Perform Naive Bayes fit
mod <- naiveBayes(Species ~ .,          #model design
                  trainset,             #training set
                  laplace=1)            #Laplace correction

#Test model
res <- predict(mod,                     #model
               testset)                 #testing set

#Confusion Matrix
conf_mat <- table(testset[,"Species"],res)
conf_mat

#Error rate
err_rt <- 100*(sum(conf_mat) - sum(diag(conf_mat)))/sum(conf_mat)
err_rt


library(generativeart)

# set the paths
IMG_DIR <- "imagesArt/"
IMG_SUBDIR <- "allImages/"
IMG_PATH <- paste0(IMG_DIR, IMG_SUBDIR)

LOGFILE_DIR <- "logfile/"
LOGFILE <- "logfile.csv"
LOGFILE_PATH <- paste0(LOGFILE_DIR, LOGFILE)

# create the directory structure
generativeart::setup_directories(IMG_DIR, IMG_SUBDIR, LOGFILE_DIR)

# include a specific formula, for example:
my_formula <- list(
  x = quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)),
  y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))
)

my_formula1 <- list(
  x = quote(runif(10, 3, 4000)* x_i^22 - (1/x_i)^2),
  y = quote(runif(10,  3,  4000)* y_i^22 - (1/x_i)^2)
)

# call the main function to create five images with a polar coordinate system
generativeart::generate_img(formula = my_formula, nr_of_img = 2, polar = TRUE, filetype = "png", color = "lavender", background_color = "deepskyblue4")


################ Set Up ###################
setwd(choose.dir())
write.csv(growth, file = 'Growth.RichvsPoor.Countries.csv')
rm(list = ls())

rpg <- read.csv('Growth.RichvsPoor.Countries.csv', row.names = 1)

############## Explore Dataset ####################
str(rpg)
summary(rpg)
head(rpg)

############# Linear Regression ###################
#Full fit
lm.rpg    <- lm(Outcome ~ . - intercept , rpg)

#Partialing Out
if (!require('hdm')) install.packages('hdm'); library(hdm)
ry    <- rlasso(Outcome ~ . -intercept - gdpsh465, rpg)$res
rd    <- rlasso(gdpsh465 ~ . -Outcome - intercept, rpg)$res

#regress partialed out Y on partialed out d
part.lm.rpg <- lm(ry ~rd - 1)

########## Load Results into a Table #####################
results       <- matrix(0,2,4)
results[1,]   <- c(summary(lm.rpg)$coef[2,1:2], confint(lm.rpg)[2,])
results[2,]   <- c(summary(part.lm.rpg)$coef[,1:2], confint(part.lm.rpg))

rownames(results) <- c('least-squares', 'partialing-out via lasso')
colnames(results) <- c(colnames(summary(lm.rpg)$coef[,1:2]),colnames(confint(lm.rpg)))

results
rm(est.part)

Case Study 2.3 - Growth of Rich vs Poor Countries.r


data = read.csv(file="C:/Users/shcmpq/OneDrive - BP/Documents/GitHub/algos_practice/montyCarlo/world-happiness-report-2021V2.csv", header=TRUE)

colnames(data)[1] <- gsub('^...','',colnames(data)[1])

data$Regional.indicator = unclass(factor(data$Regional.indicator))

head(data)
pairs(data)

library("corrplot")
Cor = cor(data[,2:7])
corrplot(Cor, type="upper", method="ellipse", tl.pos="d")
corrplot(Cor, type="lower", method="number", col="black",
         add=TRUE, diag=FALSE, tl.pos="n", cl.pos="n")

#data2 = data.frame(data$Logged.GDP.per.capita, data$Freedom.to.make.life.choices, data$Generosity)

#pairs(data2)
#hist(data2$Generosity)

# standardise features to avoid needing to tailor each prior
X = scale(data[,-1], center=TRUE, scale=TRUE)

data_jags = list(generosity = data$Generosity, happiness = X[,'Ladder.score'], popWealth = X[,'Logged.GDP.per.capita'], social = X[,'Social.support'], health = X[,'Healthy.life.expectancy'], popFreedom = X[,'Freedom.to.make.life.choices'])

# use double exponential prior for b coeficients as it prefers numbers close to zero. Sharp spike at 0
ddexp = function(x, mu, tau) {
  0.5*tau*exp(-tau*abs(x-mu))
}

library("rjags")

mod_string = " model {
    for (i in 1:length(generosity)) {
        generosity[i] ~ dnorm(mu[i], prec)
        mu[i] = int + b[1]*happiness[i] + b[2]*popWealth[i] + b[3]*social[i] + b[4]*health[i] + b[5]*popFreedom[i]
    }
    int ~ dnorm(0.0, 1.0/25.0)
    for (j in 1:5){
        b[j] ~  ddexp(0.0, sqrt(2.0))
    }

    prec ~ dgamma(5.0/2.0, 5.0*10.0/2.0)
    sig2 = 1.0 / prec
    sig = sqrt(sig2)

} "

set.seed(72)

# choose to monitor standard dev
params = c("b", "int", "sig")

#inits = function() {
#    inits = list("b"=rnorm(2, 0.0, 100.0), "prec"=rgamma(1,1.0,1.0))
#}

mod = jags.model(textConnection(mod_string), data=data_jags, n.chains=3)

#posterior mean diviance -2*log(likelyhood)
#penalty ~= number of params in model
#lower dic = better fit of model
dic.samples(mod, n.iter=1e3)

# burn in period
update(mod, 1000)

mod_sim = coda.samples(model=mod, variable.names=params, n.iter=5e4)

# stack matrices vertically
mod_csim = do.call(rbind, mod_sim)

### Convergence
plot(mod_sim)
gelman.diag(mod_sim)
autocorr.diag(mod_sim)
effectiveSize(mod_sim)
summary(mod_sim)

dic = dic.samples(mod, n.iter=1e3)

# Model 2 - remove social

mod2_string = " model {
    for (i in 1:length(generosity)) {
        generosity[i] ~ dnorm(mu[i], prec)
        mu[i] = int + b[1]*happiness[i] + b[2]*popWealth[i] + b[3]*health[i] + b[4]*popFreedom[i]
    }
    int ~ dnorm(0.0, 1.0/25.0)
    for (j in 1:4){
        b[j] ~  ddexp(0.0, sqrt(2.0))
    }

    prec ~ dgamma(5.0/2.0, 5.0*10.0/2.0)
    sig2 = 1.0 / prec
    sig = sqrt(sig2)

} "

# choose to monitor standard dev
params = c("b", "int", "sig")

data_jags = list(generosity = data$Generosity, happiness = X[,'Ladder.score'], popWealth = X[,'Logged.GDP.per.capita'], health = X[,'Healthy.life.expectancy'], popFreedom = X[,'Freedom.to.make.life.choices'])

mod2 = jags.model(textConnection(mod2_string), data=data_jags, n.chains=3)

#posterior mean diviance -2*log(likelyhood)
#penalty ~= number of params in model
#lower dic = better fit of model
dic.samples(mod2, n.iter=1e3)

# burn in period
update(mod2, 1000)

mod2_sim = coda.samples(model=mod2, variable.names=params, n.iter=5e4)

# stack matrices vertically
mod2_csim = do.call(rbind, mod2_sim)

### Convergence
gelman.diag(mod2_sim)
autocorr.diag(mod2_sim)
effectiveSize(mod2_sim)
summary(mod2_sim)

dic.samples(mod2, n.iter=1e3)

# Model 3 - remove happiness and health

mod3_string = " model {
    for (i in 1:length(generosity)) {
        generosity[i] ~ dnorm(mu[i], prec)
        mu[i] = int  + b[1]*popWealth[i] + b[2]*popFreedom[i]
    }
    int ~ dnorm(0.0, 1.0/25.0)
    for (j in 1:2){
        b[j] ~  ddexp(0.0, sqrt(2.0))
    }

    prec ~ dgamma(5.0/2.0, 5.0*10.0/2.0)
    sig2 = 1.0 / prec
    sig = sqrt(sig2)

} "

# choose to monitor standard dev
params = c("b", "int", "sig")

#inits = function() {
#    inits = list("b"=rnorm(2, 0.0, 100.0), "prec"=rgamma(1,1.0,1.0))
#}

data_jags = list(generosity = data$Generosity, popWealth = X[,'Logged.GDP.per.capita'], popFreedom = X[,'Freedom.to.make.life.choices'])

mod3 = jags.model(textConnection(mod3_string), data=data_jags, n.chains=3)

# burn in period
update(mod3, 1000)

mod3_sim = coda.samples(model=mod3, variable.names=params, n.iter=5e4)

# stack matrices vertically
mod3_csim = do.call(rbind, mod2_sim)

### Convergence
gelman.diag(mod3_sim)
autocorr.diag(mod3_sim)
effectiveSize(mod3_sim)
summary(mod3_sim)

#posterior mean diviance -2*log(likelyhood)
#penalty ~= number of params in model
#lower dic = better fit of model
dic.samples(mod3, n.iter=1e3)

# prediction checks

pm_coef = colMeans(mod3_csim)

pm_Xb = pm_coef["int"] + X[,c(2,5)] %*% pm_coef[1:2]

head(pm_Xb)

plot(pm_Xb, data$Generosity)

m2error = mean((pm_Xb - data$Generosity)^2)

resid = pm_Xb - data$Generosity

plot(resid)

mean_perc_error = mean((abs(resid)/abs(data$Generosity))*100)


coul <- function(r, qi, qj){
	return ((qi * qj)/(4.0*pi*0.0055264*r))
}

buck <- function(r, A, rho, C){
	return (A*exp(-r/rho) - C/r^6)
}

morse <- function(r, D, gamma, r_star){
	return (D*(exp(-2*gamma*(r-r_star)))-2*exp(-gamma*(r-r_star)))
}

pot <- function(r, qi, qj, A, rho, C, D, gamma, r_star){
	return (coul(r, qi,qj) + buck(r, A, rho, C) + morse(r, D, gamma, r_star))
}

A <- 693.650934
rho <- 0.327022
C <- 0.0

D <- 0.577190
gamma <- 1.650000
r_star <- 2.369000

q_O <- -1.2
q_U <- 2.4

UO_pot <- function(r){
	return(pot(r, q_O, q_U, A, rho, C, D, gamma, r_star))
}

xlim <- c(0, 4)
ylim <- c(-25, 30)

pdf("analytical_plot.pdf", fonts = "Helvetica")
r <- seq(0.5, 4, length.out = 200)
r_coarse <- seq(0.98, 4, length.out = 10)

UO <- UO_pot(r)
UO_coarse <- UO_pot(r_coarse)

plot(r, UO, xlim = xlim, ylim = ylim, type = "l", xlab = NA, ylab = NA)
points(r_coarse, UO_coarse, col = 'red', pch=16)
abline(h=0, lty="dashed")
abline(v=r_coarse, col = "lightblue")
dev.off()

pdf("table_plot.pdf")
plot(r_coarse, UO_coarse, xlim = xlim, ylim = ylim, type = "l", xlab = NA, ylab = NA)
points(r_coarse, UO_coarse, col = 'red', pch=16)
abline(h=0, lty="dashed")
dev.off()


######## Simple Gaussian distribution example.
######## This script will illustrate the effect of (not) including the normalising constant c(a0).
######## It will also show the effect of various approximations to c(a0)

source("Gaussian_data.r")
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

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

## New data
### will draw from the same process for simplicity

unnormalised.model <- stan_model("stan/simple_gaussian_posterior_unnormalised.stan")

gs.data.forposterior <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  delta = delta,
  nu = nu,
  N = N,
  y = y
)

unnorm.posterior.gaussian <- sampling(unnormalised.model, data = gs.data.forposterior)
unnorm.posterior.gaussian
pairs(unnorm.posterior.gaussian, pars = c("a_0", "mu", "sigma_sq"))

### The approximately normalised prior

constant_data <- read.csv("../data/Gaussian_logCA0.csv")
library(mgcv)
fit.gam <- mgcv::gam(lc_a0 ~ s(a0), data = constant_data)

plot(constant_data$a0, predict.gam(fit.gam), type = "l")
points(lc_a0 ~ a0 , constant_data)

approx.normalised.model <- stan_model("stan/simple_gaussian_posterior_normalised_approximate.stan")

Ks <- c(50, 100, 1000, 10000)

get_posterior_K <- function(K){
  pred_a0s <- seq(0, max(constant_data$a0), length.out = K)
  a0_grid <- data.frame(a0 = pred_a0s,
                        lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))
  gs.data.forposterior$pred_grid_x <- a0_grid$a0
  gs.data.forposterior$pred_grid_y <- a0_grid$lc_pred
  approx.norm.posterior.gauss <- sampling(approx.normalised.model,
                                          data = gs.data.forposterior, refresh = 0)
  return(approx.norm.posterior.gauss)
}

system.time(
  all.approximates <- lapply(Ks, get_posterior_K)
)

### Now the normalised prior
normalised.model <- stan_model("stan/simple_gaussian_posterior_normalised.stan")

norm.posterior.gauss <- sampling(normalised.model, data = gs.data.forposterior)
norm.posterior.gauss
pairs(norm.posterior.gauss, pars = c("a_0", "mu", "sigma_sq"))

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

a0.approx.list <- lapply(Ks, function(k){
  i <- match(k, Ks)
  a0 <- extract(all.approximates[[i]], 'a_0')$a_0
  return(data.frame(a0 = a0, normalisation = paste("K=", k, sep = "")))
} )

a0.norm <- extract(norm.posterior.gauss, 'a_0')$a_0

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

library(ggplot2)

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

a0_dist

ggsave("../figures/a0_posterior_Gaussian.pdf", a0_dist, dpi = 300)

a0_dist_norm <- ggplot(subset(a0.dt, normalisation != "unnormalised"),
                       aes(x = normalisation, y = a0,
                           fill = normalisation, colour = normalisation)) +
  geom_boxplot(alpha = .4) +
  ggtitle("Gaussian") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist_norm

ggsave("../figures/a0_posterior_Gaussian_normalisation_comparison.pdf", a0_dist_norm, dpi = 300)

###
unnorm.pars <- as.data.frame(
  cbind(extract(unnorm.posterior.gaussian, 'mu')$mu,
        extract(unnorm.posterior.gaussian, 'sigma_sq')$sigma_sq)
)
names(unnorm.pars) <- c("mu", "sigma_sq")
#

app.norm.pars.list <- lapply(all.approximates, function(x) {
  pars <- as.data.frame(
    cbind(extract(x, 'mu')$mu,
          extract(x, 'sigma_sq')$sigma_sq)
  )
  names(pars) <- c("mu", "sigma_sq")
  return(pars)
})

library(reshape2)
app.norm.pars.df.list <- lapply(seq_along(app.norm.pars.list), function(i) {
  y <- app.norm.pars.list[[i]]
  dt <- melt(y, variable.name = "parameter", value.name = "sample")
  dt$normalisation <- paste("K=", Ks[i] ,sep = "")
  return(dt)
} )

#
norm.pars <- as.data.frame(
  cbind(extract(norm.posterior.gauss, 'mu')$mu,
        extract(norm.posterior.gauss, 'sigma_sq')$sigma_sq)
)
names(norm.pars) <- c("mu", "sigma_sq")

unnorm.dt <- melt(unnorm.pars, variable.name = "parameter", value.name = "sample")
unnorm.dt$normalisation <- "unnormalised"
norm.dt <- melt(norm.pars, variable.name = "parameter", value.name = "sample")
norm.dt$normalisation <- "normalised"
posterior.dt <- rbind(unnorm.dt, norm.dt, do.call(rbind, app.norm.pars.df.list))

posterior.dt$normalisation <- factor(posterior.dt$normalisation,
                                  levels = c("unnormalised", "normalised", paste("K=", Ks, sep = "")) )

###

true.pars <- data.frame(parameter = names(norm.pars), value = c(true.mu, true.sigma^2) )

parameter_posteriors <- ggplot(data = posterior.dt,
                               aes(x = sample, colour = normalisation, fill = normalisation)) +
  geom_density(alpha = .4) +
  scale_x_continuous("") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  facet_wrap(.~parameter,  scales = "free") +
  geom_vline(data = true.pars, aes(xintercept = value), linetype = "dashed") +
  theme_bw(base_size = 20)

parameter_posteriors

ggsave(filename = "../figures/parameter_posterior_Gaussian.pdf", plot = parameter_posteriors, dpi = 300)


#!/usr/bin/env R

# http://stackoverflow.com/questions/3485456/useful-little-functions-in-r

spike_file = 'spikes-103-0.gdf'

voltage_file = 'voltages-104-0.dat'

t_sim = 10

# Gets the frequencies returned by the FFT function
getFFTFreqs = function(Nyq.Freq, data) {
  # Odd number of sample
  if ((length(data) %% 2) == 1) {
    FFTFreqs = c(seq(0, Nyq.Freq, length.out=(length(data)+1)/2),
           seq(-Nyq.Freq, 0, length.out=(length(data)-1)/2))
  }
  else {
    FFTFreqs = c(seq(0, Nyq.Freq, length.out=length(data)/2),
         seq(-Nyq.Freq, 0, length.out=length(data)/2))
  }

  return (FFTFreqs)
}

# FFT plot
# Params:
# x,y -> the data for which we want to plot the FFT
# samplingFreq -> the sampling frequency
# shadeNyq -> if true the region in [0;Nyquist frequency] will be shaded
# showPeriod -> if true the period will be shown on the top
# Returns a list with:
# freq -> the frequencies
# FFT -> the FFT values
# modFFT -> the modulus of the FFT
plotFFT = function(x, y, samplingFreq, shadeNyq=TRUE, showPeriod = TRUE) {
  Nyq.Freq = samplingFreq/2
  FFTFreqs = getFFTFreqs(Nyq.Freq, y)

  FFT = fft(y)
  modFFT = Mod(FFT)
  FFTdata = cbind(FFTFreqs, modFFT)

  plot(FFTdata[1:nrow(FFTdata)/2,], t="l", pch=20, lwd=2, cex=0.8, main="",
      xlab="Frequency (Hz)", ylab="Power")

  if (showPeriod == TRUE) {
    # Period axis on top
    a = axis(3, lty=0, labels=FALSE)
    axis(3, cex.axis=0.6, labels=format(1/a, digits=2), at=a)
  }

  if (shadeNyq == TRUE) {
    # Gray out lower frequencies
    rect(0, 0, 2/max(x), max(FFTdata[,2])*2, col="gray", density=30)
  }

  ret = list("freq"=FFTFreqs, "FFT"=FFT, "modFFT"=modFFT)
  return (ret)
}

bin.ts = function(data, time, bins) {
  times = seq(min(time), max(time), (max(time) - min(time))/bins)
  freq = hist(time, times, plot=FALSE)$counts
  d = data.frame(time=times[-length(times)], freq=freq)
}

spikes = read.csv2(spike_file,
  sep='\t',
  col.names=c('neuron', 'time', 'spike'),
  header=FALSE,
  stringsAsFactors=FALSE
)
spikes$spike = 1
spikes$time = as.numeric(spikes$time)

spikes.binned = bin.ts(spikes$spike, spikes$time, 1000)

par(mfrow=c(2,1))
plotFFT(spikes.binned$time, spikes.binned$freq, 1000/10)

voltages = read.csv2(voltage_file,
  sep='\t',
  col.names=c('neuron', 'time', 'voltage', 'NA'),
  header=FALSE,
  stringsAsFactors=FALSE
)
voltages$time = as.numeric(voltages$time)
voltages$voltage = as.numeric(voltages$voltage)

voltages.binned = bin.ts(voltages$voltage, voltages$time, 1000)

plotFFT(voltages.binned$time, voltages.binned$freq, nrow(voltages.binned)/t_sim)


isLeapYear <- function(year) {
    ifelse(year%%100==0, year%%400==0, year%%4==0)
}

for (y in c(1900, 1994, 1996, 1997, 2000)) {
    print(paste(y, " is ", ifelse(isLeapYear(y), "", "not "), "a leap year.", sep=""))
}


#saving plots
pdf('task4.pdf')

par(mfrow=c(3,2),xpd=FALSE)
N<-1;
set.seed(32)

#loop for the cases of 2,3,4,5,9
for (N in c(2,3,4,5,9)){
#Creating a sinus in R
q <- 1:10000
q <- q*0.0001
y <- sin(2*pi*q)

plot(q,y,type="l",col="firebrick1",xlab="q",xlim=c(-0.1, 1.1), ylim=c(-6.5, 6.5) )

#sampling the points

#libraries used
library(RMThreshold) #necessary functions
library(hydroGOF);
library(Metrics v0.1.2);

x2 = vector(,10);
l<-length(q)
step=l/10
for (i in 1:10){
 	x2[i] <- q[i*step];
}

#creating the noisy signal
q <- x2;
y <- sin(2*pi*q);
noise<-rnorm(length(q),0,1)
noisy.y <- y +noise
points(q,noisy.y,col='deepskyblue4',lwd=1)

#computing the model with lm function for N=2,3,4,5,9
model <- lm(noisy.y ~ poly(q,N))

#printing the coefficient values from regression model
a2Pval <- summary(model)$coefficients[2, 4]
print ("w is the following")
print (a2Pval)

#finding the residual standard error
summary(model)
print("Residual standard error")
print (summary(model))

predicted.intervals <- predict(model,data.frame(x=q),interval='confidence', level=0.95)
#finding RMSE ,actual and predicted
error<-RMSE(y,predicted.intervals[1,])
print(error)

#displaying the fitting curves
predicted.intervals <- predict(model,data.frame(x=q),interval='confidence', level=0.95)
lines(q,predicted.intervals[,1],col='green',lwd=2)
lines(q,predicted.intervals[,2],col='black',lwd=1)
lines(q,predicted.intervals[,3],col='black',lwd=1)

}

dev.off()


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

# ref: http://www.ats.ucla.edu/stat/r/pages/greek_letters.htm
par(mfrow = c(1, 2))
curve(dnorm, from = -3, to = 3, n = 1000, main = "Normal Probability Density Function")
text(-2, 0.3, expression(f(x) == paste(frac(1, sqrt(2 * pi * sigma^2)),
                                       " ", e^{
                                         frac(-(x - mu)^2, 2 * sigma^2)
                                       })), cex = 1.2)
x <- dnorm(seq(-3, 3, 0.001))
plot(seq(-3, 3, 0.001), cumsum(x)/sum(x), type = "l", col = "blue",
     xlab = "x", main = "Normal Cumulative Distribution Function")
text(-1.5, 0.7, expression(phi(x) == paste(frac(1, sqrt(2 * pi)),
     " ", integral(e^(-t^2/2) * dt, -infinity, x))), cex = 1.2)


source("../Gaussian_data.r")

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

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

## New data
### will draw from the same process for simplicity

gs.data.forposterior <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  delta = delta,
  nu = nu,
  N = N,
  y = y,
  a_0 = .4
)

original <- stan_model("../stan/simple_gaussian_prior.stan")
new <- stan_model("../stan/simple_gaussian_prior_v2.stan")

original.mcmc <- sampling(original, data = gs.data.forposterior)
new.mcmc <- sampling(new, data = gs.data.forposterior)

original.mcmc
new.mcmc
get_deriv <- function(x){
  gs.data.forposterior$a_0 <- x
  new.mcmc <- sampling(new, data = gs.data.forposterior, refresh = 0)
  logL <- extract(new.mcmc, 'logL')$logL
  return(mean(logL))
}
get_deriv <- Vectorize(get_deriv)

J <- 15
maxA <- 10
a0s <- c(seq(0.05, 1, length.out = J-3), seq(1.2, maxA, length.out = 3))
system.time(
  ca0.prime <- get_deriv(a0s)
)

plot(a0s, ca0.prime)
plot(a0s, ca0.prime, xlim = c(0, 1))
abline(h = 0, lwd = 2, lty = 2)


crp = function(n, a) {
  restaurant = data.frame(table = 1, customers = 1)
  for (j in seq(n - 1)) {
    restaurant = arrival(restaurant, a)
    }
  restaurant
  }

arrival = function(r, a) {
  p = 1 - a / (sum(r$customers) + a)
  if (rbinom(1, 1, p)) {
    join_table(r, a)
    } else {
    start_table(r)
    }
  }

join_table = function(r, a) {
  probs = r$customers / sum(r$customers)
  table = sample(1:nrow(r), size = 1, prob = probs)
  r[table, 'customers'] = r[table, 'customers'] + 1
  r
  }

start_table = function(r) {
  rbind(r, c(nrow(r) + 1, 1))
  }


stdin <- file("stdin")
open(stdin)

invisible(readLines(stdin, n = 1, warn = FALSE)) # Consumes line to ignore `n`
x <- as.integer(strsplit(trimws(
  readLines(stdin, n = 1, warn = FALSE), which = "both"), " ")[[1]])

close(stdin)

mean_ <- function(x) {
  sum(x) / length(x)
}
cat(mean_(x), "\n")

median_ <- function(x) {
  y <- sort(x)
  if (length(x) %% 2 == 0) {
    return((y[length(x) / 2] + y[(length(x) / 2) + 1]) / 2)
  } else {
    return(y[length(x) / 2])
  }
}
cat(median_(x), "\n")

mode_ <- function(x) {
  u <- sort(unique(x))
  c <- tabulate(match(x, u))
  u[c == max(c)]
}
cat(mode_(x)[1], "\n")


library(mgcv)
library(splines)
data = data.frame(ds1 = rnorm(100),
                   ds2 = rnorm(100))
mod = lm(ds1 ~ ds2, data=data)
summary(mod)
plot(ds1 ~ ds2, data = data, cex = .9)
abline(mod, col="red")

mod <- lm(ds1 ~ bs(ds2, knots = 2), data=data)
summary(mod)
plot(ds1 ~ ds2, data = data, cex = .8)
lines(data$ds2, predict(mod), lwd=2, col='red')

mod <- gam(ds1 ~ s(ds2, bs = "cr", k = 2),
           data = data,
           family = gaussian)
summary(mod)
plot(mod)


=begin
[((<index-ja|URL:index-ja.html>))]
= Algebra::ElementaryDivisor
((*(単因子モジュール)*))

多項式を成分とする行列から単因子を求めるためのモジュールです。
((|MatrixAlgebra|)) クラスにインクルードされます。

== ファイル名:

* ((|elementary-divisor.rb|))

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

なし

== 関連する関数:

--- Algebra::MatrixAlgebra#i2o
    多項式成分の行列を行列係数の多項式に変換します。

--- Algebra::MatrixAlgebra#e_deg
    多項式成分の行列の成分の最大次数を返します。

== クラスメソッド:

--- ::factorize(array)

    単因子の配列 ((|array|)) をそれぞれ因数分解して、Algebra::Factors
    オブジェクトの配列にして返します。

== メソッド:

--- e_diagonalize!
    掃き出し法により単因子の対角行列に変形する。

--- e_diagonalize
    (({dup.e_diagonalize!})) と同じ。

--- elementary_divisor
    単因子の配列を返す。

--- e_inverse
    掃き出し法より、正則行列を求める。
=end


#------------------------------------------------------------------------------
#	 class calculating metrics for regression models.
#
#	This class has several functions calculating metrics of predictive ability
#	of regression models.
#	To obtain the metrics, initialize the object and call
#	\emph{calculate.metrics} method.
#
#	Following metrics are calculated for regression models.
#
#	\describe{
#		\item{Mean squared error (MSE)}{
#			\eqn{mean((prediction - response) ^ 2)}
#		}
#		\item{Root mean squared error (RMSE)}{
#			\eqn{sqrt(mean((prediction - response) ^ 2))}
#		}
#		\item{R squared, \eqn{R ^ 2}}{
#			\eqn{Pearson's product moment correlation coefficient ^ 2}
#
#			Note that this definition of \eqn{R^2} may produce high values
#			for models without predictive ability so that I recommend to use
#			\eqn{Q ^ 2} instead of \eqn{R ^ 2}.
#			See
#			\href{http://www.russpoldrack.org/2012/12/the-perils-of-leave-one-out.html}{
#				this
#			},
#			\href{http://not2hastie.tumblr.com}{this} and
#			\href{https://metarabbit.wordpress.com/2014/03/06/evaluating-regression-with-cross-validation/}{
#				this
#			}.
#		}
#		\item{Spearman's rho}{
#			\code{cor(response, prediction, method = "spearman")}
#		}
#		\item{Kendall's tau}{
#			\code{cor(response, prediction, method = "spearman")}
#		}
#		\item{Q squared, \eqn{Q^2}}{
#			\eqn{
#				1 - \sum((prediction - response) ^ 2)
#				/ \sum((response - mean(response)) ^ 2)
#			}
#		}
#	}
#------------------------------------------------------------------------------
regression.metrics.calculator <- R6::R6Class("regression.metrics.calculator")

#------------------------------------------------------------------------------
#	Calculate mean squared error (MSE).
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.mse",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(mean((fit$prediction - fit$response) ^ 2))
	}
)

#------------------------------------------------------------------------------
#	Calculate root mean squared error (RMSE).
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.rmse",
	function(fit) {
		return(sqrt(private$calc.mse(fit)))
	}
)

#------------------------------------------------------------------------------
#	Calculate R squared.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.r.squared",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(stats::cor(fit$response, fit$prediction) ^ 2)
	}
)

#------------------------------------------------------------------------------
#	Calculate Spearman's rho.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.spearman",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(stats::cor(fit$response, fit$prediction, method = "spearman"))
	}
)

#------------------------------------------------------------------------------
#	Calculate Kendall's tau.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.kendall",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(stats::cor(fit$response, fit$prediction, method = "kendall"))
	}
)

#------------------------------------------------------------------------------
#	Calculate Q squared.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.q.squared",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		press <- sum((fit$prediction - fit$response) ^ 2)
		tss <- sum((fit$response - mean(fit$response)) ^ 2)
		return(1 - press / tss)
	}
)

#------------------------------------------------------------------------------
#	Calculate all metrics.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#
#	Returns:
#		calculated metrics in following format.
#
#			list(
#				matrix(mse, rmse, r.squared, spearman, kendall, q.squared)
#			)
#
#		Because classification.metrics.calculator can returns metrics for
#		different threshold determination method, the format of the result
#		should be a list having matrix.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"public", "calculate.metrics",
	function(fit) {
		metrics <- cbind(
			mse = private$calc.mse(fit),
			rmse = private$calc.rmse(fit),
			r.squared = private$calc.r.squared(fit),
			spearman = private$calc.spearman(fit),
			kendall = private$calc.kendall(fit),
			q.squared = private$calc.q.squared(fit)
		)
		# To have same result format with classification.metrics.calculator,
		# return the matrix of metrics in a list.
		return(list(metrics))
	}
)


# to install sjPlot
# install.packages("devtools")
# devtools::install_github("strengejacke/strengejacke")

setwd("/home/alf/alf_github/matrixcorr_questio")

library(XLConnect)
library(MASS)
library(corrplot)
library(Hmisc)
library(xtable)
library(sjPlot)

#########################################################################################################
# x is a matrix containing the data
# method : correlation method. "pearson"" or "spearman"" is supported
# removeTriangle : remove upper or lower triangle
# results :  if "html" or "latex"
  # the results will be displayed in html or latex format

corstars <-function(x, method=c("pearson", "spearman"), removeTriangle=c("upper", "lower"),
                     result=c("none", "html", "latex")){
    #Compute correlation matrix
    require(Hmisc)
    x <- as.matrix(x)
    correlation_matrix<-rcorr(x, type=method[1])
    R <- correlation_matrix$r # Matrix of correlation coeficients
    p <- correlation_matrix$P # Matrix of p-value

    ## Define notions for significance levels; spacing is important.
    mystars <- ifelse(p < .0001, "****", ifelse(p < .001, "*** ", ifelse(p < .01, "**  ", ifelse(p < .05, "*   ", "    "))))

    ## trunctuate the correlation matrix to two decimal
    R <- format(round(cbind(rep(-1.11, ncol(x)), R), 2))[,-1]

    ## build a new matrix that includes the correlations with their apropriate stars
    Rnew <- matrix(paste(R, mystars, sep=""), ncol=ncol(x))
    diag(Rnew) <- paste(diag(R), " ", sep="")
    rownames(Rnew) <- colnames(x)
    colnames(Rnew) <- paste(colnames(x), "", sep="")

    ## remove upper triangle of correlation matrix
    if(removeTriangle[1]=="upper"){
      Rnew <- as.matrix(Rnew)
      Rnew[upper.tri(Rnew, diag = TRUE)] <- ""
      Rnew <- as.data.frame(Rnew)
    }

    ## remove lower triangle of correlation matrix
    else if(removeTriangle[1]=="lower"){
      Rnew <- as.matrix(Rnew)
      Rnew[lower.tri(Rnew, diag = TRUE)] <- ""
      Rnew <- as.data.frame(Rnew)
    }

    ## remove last column and return the correlation matrix
    Rnew <- cbind(Rnew[1:length(Rnew)-1])
    if (result[1]=="none") return(Rnew)
    else{
      if(result[1]=="html") print(xtable(Rnew), type="html")
      else print(xtable(Rnew), type="latex")
    }
}
#########################################################################################################

wb = loadWorkbook("mat_zab_new.xlsx")
df = readWorksheet(wb, sheet = "Foglio1")
df$ID=NULL
saveRDS(df,"mat_zab2.rds")
#########################################################################################################

mat_zab2=readRDS("mat_zab2.rds")

last_mat_zab=mat_zab2

###########################################################################################################àààà

corstars(mat_zab2,"spearman","upper","none")
corstars(last_mat_zab,"pearson","upper","none")
capture.output(corstars(last_mat_zab,"spearman","upper","latex"), file = "matcorr_last_spear.tex")
capture.output(corstars(last_mat_zab,"spearman","upper","html"), file = "matcorr_last_spear.html")

###########################################################################################################àààà

# modello totale

tot=glm(SCORE_VG~.,data=last_mat_zab)
summary(tot)
sjt.glm(tot,show.aic = TRUE, show.family = TRUE, show.r2 = TRUE,file="tot_last.html")
capture.output(xtable(tot), file = "tot_last.tex")

mod1_zab=tot=glm(Q31~Q29+SCORE_VG+Q33.N+Q41N,data=last_mat_zab)
summary(mod1_zab)
sjt.glm(mod1_zab,show.aic = TRUE, show.family = TRUE, show.r2 = TRUE,file="mod1_zab.html")
capture.output(xtable(mod1_zab), file = "mod1_zab.tex")

mod2_zab=tot=glm(Q32~Q29+SCORE_VG+Q33.N+Q41N,data=last_mat_zab)
summary(mod2_zab)
sjt.glm(mod2_zab,show.aic = TRUE, show.family = TRUE, show.r2 = TRUE,file="mod2_zab.html")
capture.output(xtable(mod2_zab), file = "mod2_zab.tex")

######################################################################################################
# [1] http://www.sthda.com/english/wiki/elegant-correlation-table-using-xtable-r-package


Seatbelts <- data.frame(Seatbelts)
str(Seatbelts)
head(Seatbelts,n=10)
summary(Seatbelts)

BeforeLaw <-subset(Seatbelts,law ==0)
AfterLaw <- subset(Seatbelts,law!=0)

summary(BeforeLaw)
summary(AfterLaw)

library(glmnet)

x <- model.matrix(DriversKilled~., BeforeLaw)[,-c(1,8)]
y <- BeforeLaw$DriversKilled

LassoMod <- glmnet(x, y, alpha=1, nlambda=100,
                   lambda.min.ratio=0.0001)

plot(LassoMod,xvar="norm",label=TRUE)

CvLassoMod <- cv.glmnet(x, y, alpha=1, nlambda=100,
                        lambda.min.ratio=0.0001)

plot(CvLassoMod)

best.lambda <- CvLassoMod$lambda.min
best.lambda

coef(CvLassoMod, s = "lambda.min")