## The web link for this lesson
## https://courses.edx.org/courses/HarvardX/PH525.4x/1T2015/courseware/92dbe89dc80c4fc084cad3f00b0381f7/494a3c869b7d4d9facbc92c1c8ded6c6/

download.file("http://bowtie-bio.sourceforge.net/recount/ExpressionSets/bottomly_eset.RData","bottomly_eset.RData")
load("bottomly_eset.RData")
library("Biobase")
pData(bottomly.eset)

# raw counts matrix
head(exprs(bottomly.eset))

total<- nrow(exprs(bottomly.eset))

ratios<- numeric()
for (i in 1:ncol(exprs(bottomly.eset))) {
        zeros<- sum(exprs(bottomly.eset)[,i] == 0)
        ratio<- zeros/total
        ratios<- c(ratios, ratio)
}

g<- as.factor(pData(bottomly.eset)$experiment.number)

library(ggplot2)
d<- data.frame(ratios=ratios, group=g)
ggplot(d) + geom_boxplot(aes(x=group, y=ratios))

## different batches have differnt proportion of 0s for the counts

## make a multidimensional scaling plot
##  However, when computing distances we prefer
# to have measures with similar variability across samples.
## Because this is RNAseq data, the variance depends on the mean:
library(genefilter)
A<- rowMeans(exprs(bottomly.eset))
SD<- rowSds(exprs(bottomly.eset))
plot(A,SD)

## log2 transformation to stablize the variance
y<- log2( exprs( bottomly.eset )+0.5)

library(devtools)
install_github("rafalib","ririzarr")
library(rafalib)
mypar(2,1)
hist(y[,1],nc=100)
hist(y[y[,1]>0,1],nc=100)
abline(v=3)

## use counts bigger than 8
y<- exprs( bottomly.eset )
ind<- which(apply( y>=8, 1, all))
y<- log2( y[ind,] )

## make a multidimensional scaling plot

s<- svd(y)
U<- s$u  ## orthogonal matrix  UtU = I
V<- s$v  ## orthogonal matrix
D<- diag(s$d)  # diagnonal matrix

library(rafalib)
mypar2(1,1)
plot(s$d)

Yhat<- U %*% D %*% t(V)
resid<- Y - Yhat
boxplot(resid, ylim = c(-2,2), range=0)

##### normalizing NGS count data for biased GC content, this is just to demonstrate
### that GC bias can affect counts, for real data analysis, GC bias correction methods
### for example:
### EDAseq bioconductor http://www.ncbi.nlm.nih.gov/pubmed/22177264

# Systematic bias is important to keep in mind, especially in experiments with many batches. Comparisons across batches are complicated by technical biases, and it is essential that conditions of interest (treatment vs untreated) be balanced across batches, or else the experiment will uncover a mix of biological differences and systematic bias, with no hope to disentangle the two. This issue comes up over and over again in genomic studies, since the beginning of microarray data and continuing to the present day, with massive sequencing-based genomic data sets.

# The ReCount project provides summaries of a number of RNA-seq experiments as ExpressionSet objects, so that labs around the world do not have to perform alignment just to "re-count" the number of reads which fall in genes. If you use data from this project make sure to cite the authors! Download the ExpressionSet for the Bottomly experiment, here. Load this object into R:

library(Biobase)
load("bottomly_eset.RData")
bottomly.eset
head(exprs(bottomly.eset))

# Examine the histogram of sample-sample correlations of log counts:

hist(cor(log(exprs(bottomly.eset) + 1)))

#There are a number of reasons for such high correlations:

#Biological correlation: genes are expressed similarly across organisms
# Systematic bias: technical bias affects the same genes similarly (for example, if the bias is due to the sequence of the gene, then this could be common across experiments)
# The presence of many zeros, which anchor the cloud of log counts at (0,0)
#Remove some of the rows with many zeros, and plot the histogram of correlations again:

mat = exprs(bottomly.eset)
rs = rowSums(mat)
hist(cor(log(mat[ rs > 10, ] + 1)))

#Subset and rename the ExpressionSet to remove the genes which have 2 or fewer reads across all samples:

e = bottomly.eset[ rowSums(exprs(bottomly.eset)) > 2, ]
dim(e)

# We now have 12971 genes and 21 samples. The genes are annotated with ENSEMBL IDs,
# stored as rownames (and in fData(e)). The quickest way for us to check the GC content
# of each gene is to use the precomputed TxDb for mouse in Bioconductor. If we were doing
# this analysis not just for quick check, we should load the ENSEMBL genes from the ENSEMBL
# GTF file and use these for computing GC.

biocLite("TxDb.Mmusculus.UCSC.mm9.knownGene")
biocLite("BSgenome.Mmusculus.UCSC.mm9")
biocLite("org.Mm.eg.db")

library("TxDb.Mmusculus.UCSC.mm9.knownGene")
library("BSgenome.Mmusculus.UCSC.mm9")
library("org.Mm.eg.db")

# Now we will connect the ENSEMBL IDs to Entrez IDs, and then get the sequence for the exons per gene.
## because in the TxDb.Mmusculus.UCSC.mm9.knownGene database, genes are in ENTREZID.

res = select(org.Mm.eg.db, keys=rownames(e), keytype="ENSEMBL", columns="ENTREZID")

#Note there are 1 to many mappings, which will we ignore for this quick analysis. Now add a column to the ExpressionSet, by getting the first match of the ENTREZ IDs to our ENSEMBL IDs.

fData(e)$ENTREZ = res$ENTREZID[ match(rownames(e), res$ENSEMBL) ]

#There are some NA's for those ENSEMBL IDs missing matches, which we will just remove from analysis:

sum(is.na(fData(e)$ENTREZ))
e = e[ !is.na(fData(e)$ENTREZ) , ]

#Now it's only two steps to get the GC content: get the genes, and get the sequence for the genes. First we get the exons for each gene:

txdb = TxDb.Mmusculus.UCSC.mm9.knownGene
grl = exonsBy(txdb, by="gene")

#We need to subset the ExpressionSet again to only those genes for which we have ranges:

e = e[ fData(e)$ENTREZ %in% names(grl), ]

#Now put the exon GRangesList in the order of the counts ExpressionSet and reduce the exons GRangesList.
## The reduce() call is necessary so that we don't overcount any overlapping exon sequence.

reduced.exons = reduce(grl[ fData(e)$ENTREZ ])

# Get the sequence for the reduced exons using getSeq. Note that the returned object is a
# DNAStringSetList. For each gene, we have a DNAStringSet of the reduced exon sequence.
# By calling DNAStringSet(lapply(x, unlist)) on the DNAStringSetList, 'x', we get a DNAStringSet
# for each gene with the joined reduced exon sequence. Note that this unlisting does take a few minutes to perform though.

#What is the GC-content (a ratio, answer between 0 and 1) for the first gene in reduced.exons?
# Hint: letterFrequency

?getSeq
mm9_genome<- BSgenome.Mmusculus.UCSC.mm9

exonSeq<- getSeq(mm9_genome, reduced.exons)
exonSeq_unlist<- DNAStringSet(lapply(exonSeq, unlist))
#G/C content for the first gene

sum(letterFrequency(x=exonSeq_unlist[1], letters=c("C","G"), as.prob=T))

gc<- apply(letterFrequency(x=exonSeq_unlist, letters=c("C","G"), as.prob=T), 1, sum)

# Plot the log counts over the GC content for one sample:

plot( log(exprs(e)[,1]+1) ~ gc)

# It might be easier to see a dependence with boxplots:

boxplot( log(exprs(e)[,1]+1) ~ cut(gc, 20))

# We can calculate the median log count for each bin of GC content for a single sample:

sapply(split(log(exprs(e)[,1]+1), cut(gc, 20)), median)

# We can perform this calculation across all samples as well:

gc.depend = sapply(1:ncol(e), function(i) sapply(split(log(exprs(e)[,i]+1), cut(gc, 20)), median))

# Plot the GC dependence and color the lines by batch identifier:

plot(gc.depend[,1], type="n", ylim=c(0,6))
batch = factor(e$experiment.number)
for (i in 1:ncol(e)) lines(gc.depend[,i], col=batch[i])
legend("bottom", levels(batch), col=1:3, lty=1)


#!/usr/bin/Rscript

# Daniel J. Parente, Ph.D.
# Swint-Kruse Laboratory
# Physician Scientist Training Program
# University of Kansas Medical Center

# Calculates the Spearman R^2 matrix of any number of variables
# and displays on the command line

args <- commandArgs(trailingOnly = TRUE)
x = read.table(args[1], head=TRUE, sep="\t");
res = cor(x,method="spearman", use="pairwise.complete.obs")^2;

res


### Name:
# Anthony Grant-Cook

# Date: 13 December 2021

# Final project code

rm(list = ls()) # remove all variables in memory
graphics.off() # clear out all plots from previous work.
cat("\014") # clear the console

# add your libraries here

library(tidyverse)

# install.packages("psych")
library(psych)

library(tibble)

# add your code here. Be sure to leave your data file(s) in the data/ directory of this repository.

# Section 01: ANN & KNN analysis on smaller data set

# install package

install.packages("neuralnet")

# Libraries

require(neuralnet)

# Neural Network analysis
# creating a data set with variables that contain non-categorical numerical values.
# TKS is a variable which stands for Technical Knowledge Score which ranges from 1-100.
# CSS is a variable which stands for Communication Skill Score which ranges from 1-100 as well.
# The context of this data set is based around if the student is placed or not place depending on how well the student's score are for both variables.
# `1` means that the student is placed while `0` means that the student is not placed.

# I utlized information about neural networks and how they can be implemented using this website: https://www.datacamp.com/community/tutorials/neural-network-models-r

probtopredict <- function(g){
  TKS=c(20,10,30,20,80,30)
  CSS=c(90,20,40,50,50,80)
  Placed=c(1,0,0,0,1,1)

  # combination of columns into single data set

  df=data.frame(TKS,CSS,Placed)

  summary(df)
  # fitting the neural network

  ptm <- proc.time()

  nn=neuralnet(Placed~TKS+CSS,data=df, hidden=3,act.fct = "logistic",
               linear.output = FALSE)

  # plot the neural network

  plot(nn)

  # Create test data set using technical knowledge score and communication skills score

  TKS=c(30,40,85)
  CSS=c(85,50,40)

  # Predict the result

  test=data.frame(TKS,CSS)
  Predict=compute(nn,test)
  Predict$net.result

  # Convert prediction to probabilities. Convert probabilities into binary classes.

  prob <- Predict$net.result
  pred_time <- list(a = ifelse(prob>0.5, 1, 0), b = proc.time() - ptm)
  return(pred_time)
}

probtopredict(g)

# Calculate the average error upon 8 iterations of code.
# I made sure to record data after every iteration.

error_sum <- sum(0.749999, 0.000832, 0.006433, 0.002052, 0.002546, 0.750049, 0.75, 0.003247)
error_avg <- error_sum / 8
error_avg

# Calculate the average of time (elapsed) upon 8 iterations.
# I made sure to record the data found
time_sum <- sum(.001, 0, 0, .001, 0, .004, 0, .001)
time_avg <- time_sum / 8
time_avg # time average = 0.000875

error <- c(0.749999, 0.000832, 0.006433, 0.002052, 0.002546, 0.750049, 0.75, 0.003247)

# Calculate the variance and standard deviation of the steps

var_error <- var(error)
var_error # variance = 0.1494668
stdev_error <-  sqrt(var(error))
stdev_error # standard deviation = 0.3866094

steps <- c(13, 105, 124, 127, 107, 3, 10, 113)

# Correlation analysis

plot(x = error, y = steps)
cor(error, steps) # Here we have a very strong negative correlation

# Calculate the average amount of steps taken.
sum_steps <- sum(steps)
avg_steps <- sum(steps) / 2
avg_steps # 306 Step functions on average.

# Calculate the variance and standard deviation of the steps
var_steps <- var(steps)
var_steps # Variance = 3188.75 (This is a very high variance)
stdev_steps <- sqrt(var(steps))
stdev_steps # Standard deviation = 56.46902 (The standard deviation is very high thus extremely spread out)

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

# KNN analysis

# Clear data
rm(list = ls()) # remove all variables in memory
graphics.off() # clear out all plots from previous work.
cat("\014") # clear the console

# Load Library
library(tidyverse)
library(gmodels)

install.packages("class")
library(class)

# For this analysis, I am using a segment of the iris data set that is provided natively in R.
# However, to ensure that the efficiency is un-biased (meaning that there is more data utilized), I will only use the same amount of rows as
# the data set that I had initially created.

# It should be noted that I followed a tutorial and gained some understanding on how KNN algorithms work using: https://www.datacamp.com/community/tutorials/machine-learning-in-r#six

# Correlation of iris species with length and width. This is an example we did in class

View(iris)
summary(iris)
ggplot(data = iris) + geom_point(mapping = aes(x = Sepal.Length, y = Sepal.Width,color = Species ))
cor(iris$Petal.Length, iris$Petal.Width)

# Here we see there is a high correlation.

# Next, we must wrangle the data in order to match the same number of rows and columns as the initial data set.

setosa_ <- filter(iris, Species == "setosa")
setosa_ <- head(setosa_,2)
setosa_

versicolor_ <- filter(iris, Species == "versicolor")
versicolor_ <- head(versicolor_, 2)
versicolor_

virginica_ <- filter(iris, Species == "virginica")
virginica_ <- head(virginica_, 2)
virginica_

iris_df <- data.frame(setosa_, versicolor_, virginica_)
iris_df
summary(iris_df)

# Next we normalize the function. I will time this as it is part of the KNN Machine Learning Process.

normalize <- function(x) {
  num <- x - min(x)
  denom <- max(x) - min(x)
  return (num/denom)
}

iris_norm <- as.data.frame(lapply(iris_df[1:4], normalize))
summary(iris_norm)

# Generate random seed

set.seed(1234)

# Take sample of rows to get an equal amount of each species
ind <- sample(2, nrow(iris_df), replace=TRUE, prob=c(0.67, 0.33))

# Split into Training & Testing

# Compose training set
iris.training <- iris_df[ind==1, 1:4]

# Inspect training set
head(iris.training)

# Compose test set
iris.test <- iris_df[ind==2, 1:4]

# Inspect test set
head(iris.test)

iris.trainLabels <- iris_df[ind==1,5]
print(iris.trainLabels)

iris.testLabels <- iris[ind==2, 5]
print(iris.testLabels)

# building the model and timing the knn algorithm.
# It should be noted that I am not trying to figure out the efficiency of KNN itself.
# I will use a function to encapsulate the KNN model so that I am able to calculate the time that it takes.

KNN <- function(g){
  ptm <- proc.time()
  iris_pred <- knn(train = iris.training, test = iris.test, cl = iris.trainLabels, k=2)
  pred_time <- list(a = iris_pred, b = proc.time() - ptm)
  return(pred_time)
}

# Rerun the function for 8 iterations.
# To do this, we can use the purrr library and call the method `rerun`

library(purrr)
n <- 8
rerun(8, KNN(g))

elapsed_time_sum <- sum(0.001, 0, 0, 0.001, 0, 0, 0, 0)
elapsed_time_avg <- elapsed_time_sum / 8
elapsed_time_avg # The elapsed time average is equal to 0.00025

# (Did you remember to add your name to this script?)


# create a 2-times-2 matrix
mat <- matrix(1:4, 2, 2)

# matrix with scalar
mat + 2
mat * 2
mat ^ 2

# matrix with matrix
mat + mat
mat * mat
mat ^ mat


=begin
  # sample-algebraicfield01.rb

  require "algebra"

  Px = Polynomial(Rational, "x")
  x = Px.var
  F = ResidueClassRing(Px, x**2 + x + 1)
  x = F[x]
  p( (x + 1)**100 )
      #=> -x - 1
  p( (x-1)** 3 / (x**2 - 1) )
      #=> -3x - 3

  G = Polynomial(F, "y")
  y = G.var
  p( (x + y + 1)** 7 )
      #=> y^7 + (7x + 7)y^6 + 8xy^5 + 4y^4 + (4x + 4)y^3 + 5xy^2 + 7y + x + 1

  H = ResidueClassRing(G, y**5 + x*y + 1)
  y = H[y]
  p( 1/(x + y + 1)**7 )
    #=> (1798/3x + 1825/9)y^4 + (-74x + 5176/9)y^3 +
    #     (-6886/9x - 5917/9)y^2 + (1826/3x - 3101/9)y + 2146/9x + 4702/9
((<_|CONTENTS>))
=end


# Dichotomizing variables

#This function is used for dichotomizing numeric vectors into "0" and "1", based on user provided breaking points.

#By default, values equal or above the breaking point will be transformed to "1". Values below the breaking point will be transformed to "0".
#If greater.or.equal = FALSE, values equal or below the breaking point will be transformed to "1". Values above the breaking point will be transformed to "0".

#Missing values will always be considered as NA.

dichotomize <- function(trait,breaking.point,greater.or.equal=TRUE){

  n <- length(trait)
  results<- rep(NA,n)

  if(greater.or.equal==TRUE){
    for(a in 1:n){
      if (is.na(trait[a]==TRUE)){
        results[a]<-NA
      }else{
        if (trait[a]>=breaking.point){
          results[a]<- 1}
        if(trait[a]<breaking.point){
          results[a]<- 0
        }
      }
    }
  }else{
    for(a in 1:n){
      if (is.na(trait[a]==TRUE)){
        results[a]<-NA
      }else{
        if (trait[a]<=breaking.point){
          results[a]<- 1}
        if(trait[a]>breaking.point){
          results[a]<- 0
        }
      }
    }

  }
  return(results)
}

# #example 1 - dichomotize car speed above or equal to 13.
# dichotomize(cars$speed,13)
#
# #example 2 - dichomotize car speed below or equal to 13.
# dichotomize(cars$speed,13, greater.or.equal = FALSE)


sparrow <- read.table('sparrow.txt',as.is=T,header=T)

# create new variable lhumerus with the log of the humerus
sparrow$lhumerus <- log(sparrow$humerus)

# traditional equal variance t-test
t.test(sparrow$humerus[sparrow$fate=='died'],
       sparrow$humerus[sparrow$fate=='alive'],
       var.equal=T)

# formula interface to same test, explicitly indicating a factor
t.test(humerus~as.factor(fate), data=sparrow, var.equal=T)

# if omit var.equal, get Welch t-test (discussed next week)

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


asymp <-function(v=0.0, min=-10, max=+10)
{
  r = max - min;
  return (min + r * (pi/2 + atan(v)) / pi)
}

vtp2pol <- function(scale=0.0, resonance=0.0, shift=0.0, fbfact=0.0, rpfact=0.0)
{
  f = exp(scale/50) * 1000.0 * c(1,3,5,7,9,11,13,15) / 2
  b = exp(resonance/50) * 50.0 + 20.0 * 1:8

  for (j in 1:8) {
	if (j > 1)
	  minv = 50.0 + (f[j] + f[j-1]) / 2.0
	else
	  minv = 50.0
	if (j < 8)
	  maxv = (f[j+1] + f[j]) / 2.0 - 50.0
	else
	  maxv = f[j] + 450.0 * exp(scale/50)
	if (j%%2) {  # if j is odd positive values decrease freq
	  v = asymp(fbfact*.0325, maxv, minv)
	} else {  # if j is even positive values increase freq
	  v = asymp(fbfact*.0325, minv, maxv)
	}
	f[j] = v
  }

  if (rpfact < 0.0) {
	minv = f[1] + 50.0
	maxv = f[2] + (f[2] - minv)
	f[2] = asymp(rpfact*.0325, minv, maxv)
	minv = f[2] + 50.0
	maxv = f[3] + (f[3] - minv)
	f[3] = asymp(rpfact*.0325, minv, maxv)
  } else {
	maxv = f[4] - 50.0
	minv = f[3] - (maxv - f[3])
	f[3] = asymp(rpfact*.0325, minv, maxv)
	maxv = f[3] - 50.0
	minv = f[2] - (maxv - f[2])
	f[2] = asymp(rpfact*.0325, minv, maxv)
  }

  mid = exp(scale/50) * 500.0
  minv = 50.0 - f[1]
  maxv = -minv
  v = asymp(shift*0.325, minv, maxv)
  cat("minv=",minv," maxv=",maxv," v=",v,"\n")
  f = f + v

  rtn <- data.frame(f, b)
  return(rtn)
}

vtSpect <- function(vt)
{
    s=rep(1,101);
	for (i in 1:length(vt$f)) {
	  s = s * formant(vt$f[i], vt$b[i], 100, 8000)
    }
	s = s * hpc2(8, seq(0, 8000, 8000/100), 500)
    return(s)
}


dft <- function(timeScopeList, pointCount) {
    realPointCount <- length(timeScopeList)
    freqScopeList <- c()

    for(k in 1:pointCount) {
        sumCache <- 0
        for(n in 1:pointCount) {
            if (n>realPointCount) {
                break
            }

            sumCache <- sumCache + timeScopeList[n] * exp(-1i * 2 * pi * (k - 1) * (n - 1) / pointCount)
        }

        freqScopeList <- append(freqScopeList, sumCache)
    }

    return(freqScopeList)
}

print(dft(c(1, 2, 1, 2), 4))


# allocativ 3001.2021.0002

## Spatial Step 1: Import and Clean Data
sp1 = 'Spatial Step 1: Import and Clean Data'

### Import and Join Labels (W) with Predictors (X) and Outcomes (Y)
df_W = read.csv('_data/FIPS_ZCTA.csv', stringsAsFactors = FALSE) # Import dataset from _data folder
df_X1 = dbGetQuery(con_1, 'SELECT * FROM CDC_PLACES_2019_ZCTA') # Select first 6 lines from table with PostgreSQL query
df_X2 = dbGetQuery(con_1, 'SELECT * FROM CENSUS_ACS_2019_ZCTA') # Select first 6 lines from table with PostgreSQL query
df_X = merge(df_X1, df_X2, by = 'ZCTA', how = 'inner') # Merge data frame into data slot in SpatialDataFrame
df_Y = read.csv(paste('_data/', DV_file, '.csv', sep = ''), stringsAsFactors = FALSE) # Import dataset from _data folder
df_Y$D1_23 <- NULL
df_WX = merge(df_W, df_X, by = 'ZCTA', how = 'inner') # Merge data frame into data slot in SpatialDataFrame
df_WXY = merge(df_WX, df_Y, by.x = 'ZCTA', all.x = TRUE) # Merge data frame into data slot in SpatialDataFrame
head(df_WXY) # Verify

### Join with Shapes (Z)
sdf_Z = readOGR(dsn = '_shape/CENSUS_TIGER_2018_ZCTA', layer = 'cb_2018_us_zcta510_500k') # Import shape file with rgdal package
sdf_Z$ZCTA = as.character(sdf_Z$GEOID10) # Convert numeric to character
sdf_Z$ZCTA = paste('ZCTA', sdf_Z$ZCTA, sep = '') # Add character string to each value in column
library(sp) # Reimport sp library for merge() function
sdf_WXYZ = merge(sdf_Z, df_WXY, by = 'ZCTA') # Merge data frame into data slot in SpatialDataFrame
sdf_WXYZ = sdf_WXYZ[which(sdf_WXYZ$ST == ST & sdf_WXYZ$population >= 0), ]
head(sdf_WXYZ) # Verify
sdf_WXYZ # Show SpatialDataFrame

### Export to Summary File
sink(file = 'summary.txt', append = TRUE, type = 'output')
cat(c(sp1, '\n\n'), file = 'summary.txt', append = TRUE)
cat(c('Selected States: ', states, '\n'), file = 'summary.txt', append = TRUE)
cat(c('Zip Code Observations: ', nrow(df_WXY), '\n\n'), file = 'summary.txt', append = TRUE)
print(sdf_WXYZ)
cat(c('\n'), file = 'summary.txt', append = TRUE)
cat(c('####################', '\n\n'), file = 'summary.txt', append = TRUE)
sink()

## Spatial Step 2: Create Spatially Adjusted Outcomes
sp2 = 'Spatial Step 2: Create Spatially Adjusted Outcomes'

### Tidy Counts
spm0 = 'Observed counts from Raw Data'
spr0 = 'count'
sdf_WXYZ$count <- sdf_WXYZ$mhlth_count
sdf_WXYZ$population[!is.finite(sdf_WXYZ$population)] <- 0
sdf_WXYZ$count[!is.finite(sdf_WXYZ$count) | sdf_WXYZ$population == 0] <- 0
summary(sdf_WXYZ$count) # verify

### Calculate Crude Rates
spm1 = 'Observed counts per 1000 residents from American Community Survey'
spr1 = 'crude'
sdf_WXYZ$crude =  sdf_WXYZ$count / sdf_WXYZ$population * 1000 # Calculate countd counts from rates
sdf_WXYZ$crude[!is.finite(sdf_WXYZ$crude) | sdf_WXYZ$population == 0] <- 0
sdf_WXYZ$crude = round(sdf_WXYZ$crude, 0)
summary(sdf_WXYZ$crude) # verify

### Log transform crude rates
spm2 = 'Transformed crude rates'
spr2 = 'log'
sdf_WXYZ$log = log(sdf_WXYZ$crude)
sdf_WXYZ$log[!is.finite(sdf_WXYZ$log)| sdf_WXYZ$population == 0] <- 0
summary(sdf_WXYZ$log) # Verify

### Calculate Standardized Rates
spm3 = 'Ratio of observed counts to expected counts based on global population rate'
spr3 = 'SMR'
US_rate = sum(sdf_WXYZ$count)/sum(sdf_WXYZ$population) # Calculate rate across US
sdf_WXYZ$expected = US_rate * sdf_WXYZ$population # Calculate expected rate
sdf_WXYZ$SMR = sdf_WXYZ$count / sdf_WXYZ$expected # Standardized mortality ratio (actual/expected)
sdf_WXYZ$SMR[!is.finite(sdf_WXYZ$SMR) | sdf_WXYZ$population == 0] <- NULL
summary(sdf_WXYZ$SMR) # verify

### Binary transformed standardized rates
spm4 = 'Binary variable representing SMR above 1'
spr4 = 'binary'
sdf_WXYZ$binary <- 0
sdf_WXYZ$binary[sdf_WXYZ$population > 0 & sdf_WXYZ$SMR > 1] <- 1
sdf_WXYZ$binary[sdf_WXYZ$population > 0 & sdf_WXYZ$SMR < 1] <- 0
sdf_WXYZ$binary[sdf_WXYZ$population == 0] <- NA
summary(sdf_WXYZ$binary) # verify

### Local Empirical Bayes Smoothing
spm5 = 'Local Empirical Bayes smoothed observed counts'
spr5 = 'bayes'
queen_N = poly2nb(sdf_WXYZ, queen = TRUE)# Queen's neighbors
bayes_local = EBlocal(sdf_WXYZ$count, sdf_WXYZ$population+1, queen_N) # Local Empirical Bayes smooothing, add 1 to population to remvoe zeros
sdf_WXYZ$bayes = bayes_local$est # Save as new column
sdf_WXYZ$bayes[!is.finite(sdf_WXYZ$bayes) | sdf_WXYZ$population == 0] <- 0
summary(sdf_WXYZ$bayes) # verify

### Standard Scaled bayes rate
spm6 = 'Standard Scaled bayes rate'
spr6 = 'scale'
sdf_WXYZ$scale = predict(boxcox(sdf_WXYZ$bayes, standardize = TRUE))
sdf_WXYZ$scale[!is.finite(sdf_WXYZ$scale)] <- 0
summary(sdf_WXYZ$scale) # Verify

### Verify
rates = c(spr0, spr1, spr2, spr3, spr4, spr5, spr6) # Save rates as object
summary(sdf_WXYZ[rates]) # Descriptive statistics on rates
dim(sdf_WXYZ[rates]) # Observations and variables
head(sdf_WXYZ[rates]) # Verify

### Export to Summary File
sink(file = 'summary.txt', append = TRUE, type = 'output')
cat(c(sp2, '\n\n'), file = 'summary.txt', append = TRUE)
summary(sdf_WXYZ[rates])
cat(c('\n'), file = 'summary.txt', append = TRUE)
cat(c(spr0, '=', spm0, '\n'), file = 'summary.txt', append = TRUE)
cat(c(spr1, '=', spm1, '\n'), file = 'summary.txt', append = TRUE)
cat(c(spr2, '=', spm2, '\n'), file = 'summary.txt', append = TRUE)
cat(c(spr3, '=', spm3, '\n'), file = 'summary.txt', append = TRUE)
cat(c(spr4, '=', spm4, '\n\n'), file = 'summary.txt', append = TRUE)
cat(c(spr5, '=', spm5, '\n\n'), file = 'summary.txt', append = TRUE)
cat(c(spr6, '=', spm6, '\n\n'), file = 'summary.txt', append = TRUE)
cat(c('####################', '\n\n'), file = 'summary.txt', append = TRUE)
sink()

## Spatial Step 3: Test for Spatial Autocorrelation
sp3 = 'Spatial Step 3: Test for Spatial Autocorrelation'

### Moran's Test I for Spatial Autocorrelation
spm5 = 'Morans I and LISA weights using Queens Neighbors and Local Empirical Bayes smoothed counts'
spa1 = 'LISA'
queen_W = nb2listw(queen_N, zero.policy = TRUE) # Weight matrix based on neighbors
Y <- sdf_WXYZ$bayes
Y[is.na(Y)] <- 0 # Remove NA
moran_test = moran.test(Y, queen_W, zero.policy = TRUE)
LISA = localmoran(Y, queen_W) # local moran test using queen's neighbors
colnames(LISA)[5] <- 'P'
colnames(LISA) <- paste('LISA_', colnames(LISA), sep = '') # Change column names to P
LISA[is.na(LISA)] <- 0 # Remove NA
sdf_WXYZ = cbind(sdf_WXYZ, LISA)
sdf_WXYZ$LISA <- 0 # create a new variable identifying the moran plot quadrant (dismissing the non-siginificant ones)
sdf_WXYZ$m.crude = sdf_WXYZ$crude - mean(sdf_WXYZ$crude) # center the variables around its mean
sdf_WXYZ$m.LISA_Ii = sdf_WXYZ$LISA_Ii - mean(sdf_WXYZ$LISA_Ii) # center the variables around its mean
sdf_WXYZ$LISA[sdf_WXYZ$m.crude < 0 & sdf_WXYZ$m.LISA_Ii < 0] <- -1
sdf_WXYZ$LISA[sdf_WXYZ$m.crude < 0 & sdf_WXYZ$m.LISA_Ii > 0] <- 0
sdf_WXYZ$LISA[sdf_WXYZ$m.crude > 0 & sdf_WXYZ$m.LISA_Ii < 0] <- 0
sdf_WXYZ$LISA[sdf_WXYZ$m.crude > 0 & sdf_WXYZ$m.LISA_Ii > 0] <- 1
sdf_WXYZ$LISA[sdf_WXYZ$LISA_P > 0.05] <- 0 # non-significant
summary(sdf_WXYZ$LISA) # verify

### Geographic Weighted Regression
spm6 = 'Geographic weighted regression'
spa2 = 'GWR'
Y = 'crude'

### Adjust for local health status
spi1 = 'health'
X = names(subset(df_X1, select = -c(ZCTA)))
F = as.formula(paste(Y, ' ~ ', paste(X, collapse = ' + '), sep = ''))
D = sdf_WXYZ@data[c(X, Y)]
for(i in 1:ncol(D)) {D[ , i][is.na(D[ , i])] <- median(D[ , i], na.rm = TRUE)} # Replace missing values with column medians
head(D)

#### Get variance weights from PCA, importance weights from RandomForest
pca = prcomp(D[X], scale = TRUE, rank. = 1) # PCA from tidyverse, `scale = TRUE` standard scale features, `tol = 0.1` threshold percent of highest variance to keep components
df_pca = rownames_to_column(data.frame(abs(pca$rotation)))
df_pca = df_pca[which(df_pca$PC1 > quantile(df_pca$PC1, 0.5)[[1]]), ]
colnames(df_pca) <- c('feature', 'variance')
rf = randomForest(formula = F, data = D, ntree = 1000, importance = TRUE)
df_rf = rownames_to_column(as.data.frame(importance(rf)))
df_rf[,2] = df_rf[,2] / 100
df_rf = df_rf[,-3]
colnames(df_rf) <- c('feature', 'importance') # Change column names to easily readible
df_fp = merge(df_rf, df_pca, by = 'feature')
df_fp$weight = df_fp[,2] * df_fp[,3]
df_health = df_fp
head(df_fp)

#### Create Index
df_X$health = rowSums(df_X[df_fp$feature] * df_fp$weight)
df_X3 = df_X[c('ZCTA', 'health')]
sdf_WXYZ = merge(sdf_WXYZ, df_X3, by = 'ZCTA') # Merge data frame into data slot in SpatialDataFrame
sdf_WXYZ$health[!is.finite(sdf_WXYZ$health)] <- median(sdf_WXYZ$health, na.rm = TRUE)
summary(sdf_WXYZ$health) # Verify
head(sdf_WXYZ)

### Adjust for local social factors
spi2 = 'social'
X = names(subset(df_X2, select = -c(ZCTA)))
F = as.formula(paste(Y, ' ~ ', paste(X, collapse = ' + '), sep = ''))
D = sdf_WXYZ@data[c(X, Y)]
for(i in 1:ncol(D)) {D[ , i][is.na(D[ , i])] <- median(D[ , i], na.rm = TRUE)} # Replace missing values with column medians
head(D)

#### Get variance weights from PCA, importance weights from RandomForest
pca = prcomp(D[X], scale = TRUE, rank. = 1) # PCA from tidyverse, `scale = TRUE` standard scale features, `tol = 0.1` threshold percent of highest variance to keep components
df_pca = rownames_to_column(data.frame(abs(pca$rotation)))
df_pca = df_pca[which(df_pca$PC1 > quantile(df_pca$PC1, 0.5)[[1]]), ]
colnames(df_pca) <- c('feature', 'variance')
rf = randomForest(formula = F, data = D, ntree = 1000, importance = TRUE)
df_rf = rownames_to_column(as.data.frame(importance(rf)))
df_rf[,2] = df_rf[,2] / 100
df_rf = df_rf[,-3]
colnames(df_rf) <- c('feature', 'importance') # Change column names to easily readible
df_fp = merge(df_rf, df_pca, by = 'feature')
df_fp$weight = df_fp[,2] * df_fp[,3]
df_social = df_fp
head(df_fp)

#### Create index
df_X$social = rowSums(df_X[df_fp$feature] * df_fp$weight)
df_X3 = df_X[c('ZCTA', 'social')]
sdf_WXYZ = merge(sdf_WXYZ, df_X3, by = 'ZCTA') # Merge data frame into data slot in SpatialDataFrame
sdf_WXYZ$social[!is.finite(sdf_WXYZ$social)] <- median(sdf_WXYZ$social, na.rm = TRUE)
summary(sdf_WXYZ$social) # Verify
head(sdf_WXYZ)

#### Get Bandwidth and GWR weights
RP = coordinates(gCentroid(sdf_WXYZ, byid = T, id = sdf_WXYZ$ZCTA))
DM1 = gw.dist(dp.locat = RP) # Compute the distances between the centroid points of polygons
fixed = sqrt(mean(aggregate(as.numeric(sdf_WXYZ$ALAND10), by = list(FIPS = sdf_WXYZ$FIPS), FUN = sum)$x)*3)
GWR = gwr.basic(bayes ~ 0 + social + health, data = sdf_WXYZ, kernel = "gaussian", regression.points = RP, bw = fixed, longlat = T, dMat = DM1) # Fit a GWR to the ceontroids of election divisions using the optimal N with a "Gaussian" kernel.
sdf_WXYZ$GWR <- -1*(log(abs(GWR$SDF$health - median(GWR$SDF$health)))) # Save weighhted coefficients as new column
sdf_WXYZ$GWR[!is.finite(sdf_WXYZ$GWR)] <- 0
summary(sdf_WXYZ$GWR) # Verify

### Calculate County wide crude, SMR, and bayes
df_Y2 = aggregate(sdf_WXYZ$population, by = list(FIPS = sdf_WXYZ$FIPS), FUN = ineq)
colnames(df_Y2) <- c('FIPS', 'population')
df_Y2$count = aggregate(sdf_WXYZ$count, by = list(FIPS = sdf_WXYZ$FIPS), FUN = sum)$x
df_Y2$count[!is.finite(df_Y2$count)] <- 0
df_Y2$crude = df_Y2$count / df_Y2$population
df_Y2$crude[!is.finite(df_Y2$crude)] <- 0
df_Y2$SMR = aggregate(sdf_WXYZ$SMR, by = list(FIPS = sdf_WXYZ$FIPS), FUN = mean)$x
df_Y2$SMR[!is.finite(df_Y2$SMR)] <- 0
df_Y2$bayes = aggregate(sdf_WXYZ$bayes, by = list(FIPS = sdf_WXYZ$FIPS), FUN = mean)$x
df_Y2$bayes[!is.finite(df_Y2$bayes)] <- 0

### Calculate County specific GINI, LISA, and GWR
spm7 = 'Gini index of crude hospitalization rate among zip codes within counties'
spa3 = 'gini'
df_Y2$gini = aggregate(sdf_WXYZ$crude, by = list(FIPS = sdf_WXYZ$FIPS), FUN = ineq)$x
df_Y2$gini[!is.finite(df_Y2$gini)] <- 0
df_Y2$LISA = aggregate(sdf_WXYZ$LISA, by = list(FIPS = sdf_WXYZ$FIPS), FUN = mean)$x
df_Y2$LISA[!is.finite(df_Y2$LISA)] <- 0
df_Y2$GWR = aggregate(sdf_WXYZ$GWR, by = list(FIPS = sdf_WXYZ$FIPS), FUN = mean)$x
df_Y2$GWR[!is.finite(df_Y2$GWR)] <- 0
head(df_Y2)

### Verify
auto = c(spr1, spr3, spr5, spa1, spa2, spa3) # Save rates as object
summary(df_Y2[auto]) # Descriptive statistics on rates
dim(df_Y2[auto]) # Observations and variables
head(df_Y2[auto]) # Verify

### Export Spatial Outcomes by Zip Code
ZCTA = c(spr0, spr1, spr2, spr3, spr4, spr5, spr6, spi1, spi2, 'ZCTA') # Save rates as object
df_Y_ZCTA = sdf_WXYZ[ZCTA] # Save
write.csv(df_Y_ZCTA, paste('_data/_spatial_ZCTA.csv', sep = ''), row.names = FALSE) # Clean in excel and select variable

### Export Spatial Outcomes by County
FIPS = c(spr1, spr3, spr5, spa1, spa2, spa3, 'FIPS') # Save rates as object
df_Y_FIPS = df_Y2[FIPS] # Save
write.csv(df_Y_FIPS, paste('_data/_spatial_FIPS.csv', sep = ''), row.names = FALSE) # Clean in excel and select variable

### Export to Summary File
sink(file = 'summary.txt', append = TRUE, type = 'output')
cat(c(sp3, '\n\n'), file = 'summary.txt', append = TRUE)
cat(c(spm5, ' (Null = No Autocorrelation)'), file = 'summary.txt', append = TRUE)
print(moran_test)
cat(c('\n'), file = 'summary.txt', append = TRUE)
cat(c(spm6, '\n\n'), file = 'summary.txt', append = TRUE)
cat('Create composite indices from health variables\n'), file = 'summary.txt', append = TRUE)
head(df_health)
cat(c('\n'), file = 'summary.txt', append = TRUE)
print(cor.test(sdf_WXYZ$crude, sdf_WXYZ$health, method = 'spearman'))
cat(c('\n'), file = 'summary.txt', append = TRUE)
cat('Create composite indices from social variables\n', file = 'summary.txt', append = TRUE)
head(df_social)
cat(c('\n'), file = 'summary.txt', append = TRUE)
print(cor.test(sdf_WXYZ$crude, sdf_WXYZ$social, method = 'spearman'))
cat(c('\n'), file = 'summary.txt', append = TRUE)
print(GWR)
cat(c('\n'), file = 'summary.txt', append = TRUE)
summary(df_Y2[auto])
cat(c('\n'), file = 'summary.txt', append = TRUE)
cat('crude = crude rate per popualtion by County\n', file = 'summary.txt', append = TRUE)
cat('SMR = Mean zip code SMR by County\n', file = 'summary.txt', append = TRUE)
cat('bayes = Mean zip code bayes by County\n', file = 'summary.txt', append = TRUE)
cat(c(spa1, '=', spm5, '\n'), file = 'summary.txt', append = TRUE)
cat(c(spa2, '=', 'Weighted Coefficients of health index using ', spm6, '\n'), file = 'summary.txt', append = TRUE)
cat(c(spa3, '=', spm7, '\n\n'), file = 'summary.txt', append = TRUE)
cat(c('####################', '\n\n'), file = 'summary.txt', append = TRUE)
sink()


# Databricks notebook source
# MAGIC %md
# MAGIC # Decision Trees
# MAGIC ### Not focused on best way to perform modelling using Decision Trees or Random Forest
# MAGIC #### Instead focus on intro and getting you started and using Decision Trees & Random Forest

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

# MAGIC %md
# MAGIC ## Who has used modelling in the past?
# MAGIC ### Slack Poll

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

library("caret")
library("tidyverse")
data(diamonds)
model <- lm(price ~ ., diamonds)
p <- predict(model, diamonds)

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

head(diamonds)

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

summary(model)

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

summary(p)

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

# MAGIC %md
# MAGIC ## Decision Trees
# MAGIC * Tree-based models
# MAGIC  - Non-parametric algorithms
# MAGIC  - Partitioning the feature space into a number of smaller (non-overlapping) regions with similar response values using a set of splitting rules.
# MAGIC * Predictions are obtained by fitting a simpler model (e.g., a constant like the average response value) in each region.
# MAGIC * Such divide-and-conquer methods can produce simple rules that are easy to interpret and visualize with tree diagrams.

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

# MAGIC %md
# MAGIC - One methodology for constructing Decision Trees is CART the classification and regression tree (CART) algorithm
# MAGIC   - Partition training data into homogeneous subgroups (nodes)
# MAGIC and then fits a simple constant in each node
# MAGIC - Nodes are formed recursively using binary partitions formed by asking simple yes-or-no questions about each feature (e.g., is age < 18?).
# MAGIC  - This is done a number of times until a suitable stopping criteria is satisfied (e.g., a maximum depth of the tree is reached).
# MAGIC - Then the model predicts the output based on
# MAGIC  - (1) the average response values for all observations that fall in that subgroup (regression problem), or
# MAGIC  - (2) the class that has majority representation (classification problem).

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

# MAGIC %md
# MAGIC
# MAGIC ### Example of Decision Tree
# MAGIC
# MAGIC ![DCT1.jpg](https://cdn-images-1.medium.com/max/824/0*J2l5dvJ2jqRwGDfG.png)

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

# MAGIC %md
# MAGIC
# MAGIC ![DCT2.jpg](https://cdn-images-1.medium.com/max/688/0*pb-1ufHK-OmR8k7r.png)

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

library(rpart)
model <- rpart(Species ~., data = iris)
par(xpd = NA) # otherwise on some devices the text is clipped
plot(model)
text(model, digits = 3)

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

dim(iris)

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

print(model, digits = 2)

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

# MAGIC %md
# MAGIC ## Decision Trees: Partitioning
# MAGIC
# MAGIC - CART uses binary recursive partitioning (it’s recursive because each split or rule depends on the splits above it).
# MAGIC - The objective at each node is to find the “best” feature to partition the remaining data into one of two regions (R1 and R2) such that the overall error between the actual response (yi) and the predicted constant (ci) is minimized.
# MAGIC - Having found the best feature/split combination, the data are partitioned into two regions and the splitting process is repeated on each of the two regions (hence the name binary recursive partitioning).

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

# MAGIC %md
# MAGIC ### Decision Trees: Deep
# MAGIC - Early stopping
# MAGIC   - Restrict the tree depth to a certain level or
# MAGIC  - Restrict the mini number of observations allowed in any terminal node
# MAGIC - Pruning
# MAGIC   - grow a very large, complex tree and then prune it back to find an optimal subtree

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

# Load the data and remove NAs
data("PimaIndiansDiabetes2", package = "mlbench")
PimaIndiansDiabetes2 <- na.omit(PimaIndiansDiabetes2)
# Inspect the data
sample_n(PimaIndiansDiabetes2, 3)
#https://rdrr.io/cran/mlbench/man/PimaIndiansDiabetes.html

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

# Split the data into training and test set
set.seed(123)
training.samples <- PimaIndiansDiabetes2$diabetes %>%
  createDataPartition(p = 0.8, list = FALSE)
train.data  <- PimaIndiansDiabetes2[training.samples, ]
test.data <- PimaIndiansDiabetes2[-training.samples, ]

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

# Build the model
set.seed(123)
model1 <- rpart(diabetes ~., data = train.data, method = "class")
# Plot the trees
par(xpd = NA) # Avoid clipping the text in some device
plot(model1)
text(model1, digits = 3)

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

# Make predictions on the test data
predicted.classes <- model1 %>%
  predict(test.data, type = "class")
head(predicted.classes)

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

# Compute model accuracy rate on test data
mean(predicted.classes == test.data$diabetes)

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

# MAGIC %md
# MAGIC #### Pruning the tree

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

?train

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

# Fit the model on the training set
set.seed(123)
model2 <- train(
  diabetes ~., data = train.data, method = "rpart",
  trControl = trainControl("cv", number = 10),
  tuneLength = 10
  )
# Plot model accuracy vs different values of
# cp (complexity parameter)
plot(model2)

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

# Print the best tuning parameter cp that
# maximizes the model accuracy
model2$bestTune

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

# Plot the final tree model
par(xpd = NA) # Avoid clipping the text in some device
plot(model2$finalModel)
text(model2$finalModel,  digits = 3)

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

# Decision rules in the model
model2$finalModel

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

# Make predictions on the test data
predicted.classes <- model2 %>% predict(test.data)
# Compute model accuracy rate on test data
mean(predicted.classes == test.data$diabetes)

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

# MAGIC %md
# MAGIC ## Take aways:
# MAGIC - Simple and easy to implement (no preprocessing required and categorical variables handled, handle missing values)
# MAGIC - Not great on predictive accuracy
# MAGIC - Deep trees have high variance / Shallow Trees bias.
# MAGIC
# MAGIC ## More technical:
# MAGIC - A problem with decision trees like CART is that they are greedy.
# MAGIC - Even with Bagging, the decision trees can have a lot of structural similarities and in turn have high correlation in their predictions.

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

# MAGIC %md
# MAGIC ## Another way to think about Decision Trees
# MAGIC - Great advantage of decision trees: make a complex decision simpler by breaking it down into smaller, simpler decisions using a divide-and-conquer strategy.
# MAGIC - Identify a set of if-else conditions that split the data according to the value of the features.

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

# MAGIC %md
# MAGIC # Before jumping to the next section, let's try out few examples


#BASIC GRAPHS

install.packages("vcd")
names(Arthritis)

#SIMPLE VERTICAL AND HORIZONTAL BAR CHARTS
library(vcd)
counts<-table(Arthritis$Improved)
counts
barplot(counts, main ="Simple Bar Plot", xlab="Improvement", ylab="Frequency")
barplot(counts, main="Horizontal Bar Plot", xlab="Frequency", ylab="Improvement", horiz=TRUE)

#STACKED AND GROUPED BAR PLOTS
library(vcd)
counts<-table(Arthritis$Improved, Arthritis$Treatment)
counts
barplot(counts, main="Stacked Bar Plot", xlab="Treatment", ylab="Frequency", col=c("red", "yellow", "green"), legend=rownames(counts))
barplot(counts, main="Grouped Bar Plot", xlab="Treatment", ylab="Frequency", col=c("red", "yellow", "green"), legend=rownames(counts), beside=TRUE)

#SPINOGRAM
#Stacked bar plot rescaled height =1
#Larger % of patients w/ marked improvement in Treated condition quite evident in comparison to Placebo
library(vcd)
attach(Arthritis)
counts <- table(Treatment, Improved)
spine(counts, main="Spinogram Example")
detach(Arthritis)


 DTRSEN Example Program Results

 Matrix A computed from Q*T*Q^T
          1       2       3       4
 1   0.3500  0.4500 -0.1400 -0.1700
 2   0.0900  0.0700 -0.5399  0.3500
 3  -0.4400 -0.3300 -0.0300  0.1700
 4   0.2500 -0.3200 -0.1300  0.1100

 Condition number estimate of the selected cluster of eigenvalues =   1.75E+00

 Condition number estimate of the specified invariant subspace    =   3.22E+00


CV.class <- function(obj, data, folds=as.list(1:obj$N)){
  require(MASS)
  require(mixlm)
  nfolds <- length(folds)
  n <- obj$N
  pred <- rep(0, n)
  for(i in 1:nfolds){
    mod <- update(obj, subset=-folds[[i]])
    pred[folds[[i]]] <- predict(mod, newdata=data[folds[[i]],,drop=FALSE])$class
  }
  res <- list()
  attach(data)
  res$true <- eval(attr(formula(obj),"variables"))[[1]]
  pred <- factor(pred, labels=levels(res$true))
  detach(data)
  res$predicted <- pred
  confusion(res$true,res$predicted)
  return(res)
}

Kfold <- function(n, K, random=TRUE){
  ord <- 1:n
  if(random) ord <- sample(n,n,replace=FALSE)
  foldmat <- matrix(ord, nrow=K)
  folds <- list()
  for(i in 1:K){
    folds[[i]] <- foldmat[i,]
  }
  return(folds)
}


data_file = "winequality/winequality-white.csv"

wine <- read.csv( data_file, sep=';', header = TRUE )

numel = length( as.matrix( wine )) / length( wine )

pcx <- prcomp( wine, scale = TRUE )
biplot( pcx, xlabs = rep( '.', numel ))

# another window
dev.new()

bar_colors = c( 'red', 'red', rep( 'gray', 10 ))
plot( pcx, col = bar_colors )


library(FactoMineR)
library(factoextra)
library('dendextend')

setwd('/home/belu/VS Workplace/licentiate-thesis-repo/notebooks/R-scripts/')

amines <- read.csv('amines_clusterization/amines_fchem_properties.csv', header=TRUE)

distance.dice <- read.csv('amines_clusterization/similarity_tanimoto.csv', header=TRUE)

#res.pca <- PCA(amines, ncp = 3, graph = FALSE)

hc1 <- hclust(dist(amines, method = 'canberra'), method='centroid')
hc2 <- hclust(dist(distance.dice, method = 'canberra'), method='centroid')

dend1 <- as.dendrogram(hc1)
dend2 <- as.dendrogram(hc2)

cutree(dend1, h = 150)

#dend_diff(dend1, dend2)

dl <- dendlist(dend1, dend2)
tanglegram(dl, sort = TRUE, common_subtrees_color_lines = FALSE, highlight_distinct_edges  = FALSE, highlight_branches_lwd = FALSE)

#res.hcpc <- HCPC(res.pca, graph = TRUE)

#fviz_cluster(res.hcpc, geom = "point", main = "")

#plot(res.hcpc, choice = "3D.map")


```{r echo= FALSE,message=TRUE}

require("igraph",quietly = T)
require("networkD3",quietly = T)
require("d3heatmap")
require("plotly")
require("ggplot2")
# require("fields")

setwd("~/git/ExploratoryGraph/Code/Functions/")

graph <- read.graph("../DataIngest/p.pacificus_neural.synaptic_1.graphml",format = "graphml")

graph<- as.undirected(graph, mode="collapse")

#Let's compute the adjacency and convert it to a boolean matrix

adjacency<- get.adjacency(graph,type = "both",attr = NULL,sparse = T, edges = F)
A = adjacency>0

#Compute the degree
degreeGraph<- rowSums(as.matrix(A))
orderByDegree<- order(degreeGraph,decreasing = T)

#put a common prior Beta(alpha, beta)
alpha <- 0.5
beta <- 0.5

post_alpha<-  A + alpha
post_beta<- 1- A + alpha
post_A_mean<- post_alpha/(post_alpha+post_beta)

#plot
sortedA<- post_A_mean[orderByDegree,orderByDegree]

d3heatmap(as.matrix(sortedA), scale = "none", colors = ("Blues"))


#' @title calcHMWettedSA
#'
#' @description Calculate hull wetted surface area (\code{wettedSA}) (m^2)
#' using the Holtrop & Mennen method.
#'
#'@param lwl Waterline length (vector of numericals, m) (see
#'\code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param actualDraft Actual draft (vector of numericals, m)
#'@param Cm Midship section coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCm}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCbw}})
#'@param Cwp Water plane area coefficient (vector of numericals, see
#'\code{\link{calcCwp}})
#'@param Abt Traverse bulb area (vector of numericals, m^2) (see
#'\code{\link{calcAbt}})
#'
#'@details
#'Actual draft is typically obtained from sources such as AIS messages or ship
#'records.
#'
#' @return \code{wettedSA} (vector of numericals, m^2)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCm}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcCwp}}
#'\item \code{\link{calcAbt}}}
#'
#' @family Holtrop-Mennen Calculations
#'
#' @examples
#'calcHMWettedSA(218.75,12.48,32.25,0.99,0.81,0.91,32.02)
#'
#' @export

calcHMWettedSA<- function(lwl,actualDraft,breadth,Cm,Cbw,Cwp,Abt){

wettedSA<-lwl*(2*actualDraft+breadth)*(Cm^0.5)*
    (0.453+0.4425*Cbw-0.2862*Cm-0.003467*(breadth/actualDraft)+
       0.3696*Cwp)+2.38*(Abt/Cbw)

    return(wettedSA)
}


#------------------------------------------------------------------------------
# annualhydrographs.r
#
# General purpose script which plots the historical flow distribution and
# overlays a few random hydrographs in ggplot2. Shows the use of the
# geom_ribbon function to shade portions of a graph.
#
# challenge: modify the script to read in the annual maximum daily series
# and plot the hydrographs with the top 3 annual maximum daily flows (or minimum)
# (hint: use hy_annual_stats() to pull the annual maximum series!)
#
# D.Hutchinson 2020-04-28
#-------------------------------------------------------------------------------

# required libraries
library(dplyr)
library(ggplot2)
library(lubridate)
library(tidyhydat)

# script parameters
wsc_id <- "08MF005"

# pull the station metadata
stn_info <- hy_stations(station_number = wsc_id)

# get historical daily flow series
dly_flow <- hy_daily_flows(station_number = wsc_id)

# add a columns for Year, day of year (DOY)
dly_flow <- dly_flow %>%
            mutate(YEAR = year(Date), DOY = yday(Date))

# now compute historical quantiles (interdecile, interquartile, median)
pctiles <- c(0.10, 0.25,0.50,0.75,0.90)
dly_stats <- dly_flow %>%
             select(STATION_NUMBER, DOY, Value) %>%
             group_by(STATION_NUMBER, DOY) %>%
             do(
               data.frame(
                 t(quantile(.$Value, probs = pctiles, na.rm = TRUE))
             ))

# filter the last 5 years of hydrographs
max_year <- max(dly_flow$YEAR)
select_years <- dly_flow %>% filter(YEAR >= max_year - 5) %>%
                mutate(YEAR = as.factor(YEAR))

# now plot the results
ggplot(dly_stats) +
  geom_ribbon(aes(x = DOY, ymin = X10., ymax = X90.), fill = "light grey", alpha = 0.2) +
  geom_ribbon(aes(x = DOY, ymin = X25., ymax = X75.), fill = "dark grey", alpha = 0.2) +
  geom_line(aes(x = DOY, y = X50.), lty = 2, colour = "blue") +
  geom_line(data = select_years, aes(x = DOY, y = Value, colour = YEAR)) +
  labs(
    title = sprintf("%s [%s]", stn_info$STATION_NAME[1], wsc_id),
    x = "Day of year",
    y = "Discharge"
  ) +
  theme_bw()

# End script


BNP_DIR = "/Users/jtobin/projects/bnp"
SBP_SRC = paste(BNP_DIR, "stick-breaking-process/src/sbp.r", sep = "/")

source(SBP_SRC)

# ex: gaussian base measure
#
# > dp(10, 1, function() { rnorm(1) })
dp = function(n, a, h) {
  p = sbp(n - 1, a)
  g = replicate(length(p), h())
  list(p, g)
  }


#Notes can be found at the link below
#https://nbviewer.jupyter.org/github/corybaird/PLCY_Code_2020_winter/blob/main/Code_sessions/Session_2/Session_2_Notes.ipynb

# A.1 Import libraries¶

## Step 1
#install.packages('dplyr')
#install.packages('ggplot2')

#A.2 Import data¶

# Step 2
library(ggplot2)
library(dplyr)

mtcars = as_tibble(mtcars)
mtcars %>% head(2)

# 1. OLS regression
# 1.1 OLS: Built-in package lm
# 1.1.1 Regression summary¶

linear_reg = lm(mpg ~ wt, data=mtcars)

print(summary(linear_reg))

# 1.1.1.1 Accessing coefficients from summary

linear_reg_summary = summary(linear_reg)

linear_reg_summary$coefficients

# F-stat
print('F-stat')
linear_reg_summary$fstatistic

# R-sq
print(paste('R-sq:', linear_reg_summary$r.squared, sep=' '))

# 1.1.1.2 Accessing specific coefficients¶

#linear_reg_summary$coefficients["wt","Std. Error"] #Std. errors

#linear_reg_summary$coefficients["wt","t value"] #T-value

beta1_lm = linear_reg_summary$coefficients["wt","Estimate"] #Beta

beta1_lm

# 1.1.2 Residuals¶

#linear_reg$fitted.values #Yhat
#linear_reg$coefficients #coefficients
#linear_reg$residuals #Residuals

df_model = mtcars  %>% select(wt,mpg)

df_model = df_model  %>%
rename('y' = mpg) %>%
mutate(residu = linear_reg$residuals,
       predicted_y = linear_reg$fitted.values)

df_model %>% head(5)

# 1.1.2.1 Plot regression residuals¶

#predicted_y == yhat
df_model  %>% ggplot(aes(y, predicted_y))+ geom_point()

# 1.2 OLS: Using matrix algebra¶
# 1.2.1 Create matrices for X and Y values¶

X = as.matrix(mtcars %>% select(wt))
X = cbind(X,rep(1,length(X))) #Add constant/intercept
colnames(X)[2] <- "Intercept" #Name intercept
Y = as.matrix(mtcars %>% select(mpg))

# Method 1: SOLVE OLS USING Linear algebra
A = solve(t(X)%*%X)
bhat_hand = A  %*% t(X) %*% Y
print(bhat_hand)

# Method 2: SOlVE OLS using cov--Note only works for Single linear regression
cov(Y, X)['mpg','wt']/var(X)['wt','wt']

# 2. Regression diagnostics¶

#Step 1
#install.packages('lmtest')

#Step 2
library(lmtest)

# 2.1 Breusch pagan: test for heteroskedasticity¶

linear_reg = lm(mpg ~ wt, data=mtcars)
bptest(linear_reg)

### 2.1.1 Create function to check the above test
diagnostics <- function(regression) {
    bp_res = bptest(linear_reg)$p.value
    if (bp_res<.1){
        print(paste("P-value", round(bp_res,3)))
        print("Reject null. Thus there is evidence of heteroskedasticity")
    }
    else{
        print(paste("P-value", round(bp_res,3)))
        print("Cannot reject null. No evidence of heteroskedasticity")
    }
}

diagnostics(linear_reg)

# 2.2 DW test: test for serial correlation¶

dwtest(linear_reg)

# 2.3 Functional misspecification¶
resettest(linear_reg)

# 2.4 Introduction to functions¶
# 2.4.1 Function: square numbers¶

square = function(a){
  solution = a^2
  return (solution)
}
square(4)

# 2.4.2 Function: add two numbers¶

add_numbers = function(a,b){
    solution = (a^2)+b
    return (solution)
}

add_numbers(2,3)

# 2.4.3 Function: using if and else¶

number_test = function(a,b,c) {
    print('You can print anything you want inside functions')
    solution1 = a+b
    solution = solution1-c
    print(paste("The solution is:", solution))
    if (solution>100){
        print('Big numbers are lame')
    }
    else{
        print('Small numbers are cool')
    }
}

number_test(1,2,5)

# 2.4.4 Function: BP, DW and RESET Test¶

diagnostics = function(regression) {
    #BP-test
    print('-------')
    print('BP-Test')
    bp_res = bptest(linear_reg)$p.value
    if (bp_res<.1){
        print(paste("P-value", round(bp_res,3)))
        print("Reject null. Thus there is evidence of heteroskedasticity")
    }
    else{
        print(paste("P-value", round(bp_res,3)))
        print("Cannot reject null. No evidence of heteroskedasticity")
    }
    #DW-test
    print('-------')
    print('DW-Test')
    dw_res = dwtest(linear_reg)$p.value
    if (dw_res<.1){
        print(paste("P-value", round(dw_res,3)))
        print("Reject null. Thus there is evidence of serial correlation")
    }
    else{
        print(paste("P-value", round(bp_res,3)))
        print("Cannot reject null. No evidence of serial correlation")
    }
    #Ramsey Reset test
    print('-------')
    print('Rest-Test')
    ram_res = resettest(linear_reg)$p.value
    if (ram_res<.1){
        print(paste("P-value", round(ram_res,3)))
        print("Reject null. Thus there is evidence of misspecification")
    }
    else{
        print(paste("P-value", round(ram_res,3)))
        print("Cannot reject null. No evidence of  misspecification")
    }
}

diagnostics(linear_reg)

# 3. Other regression models
# 3.1 Robust S.E. regression

library(MASS)

summary(rlm(mpg ~ wt, mtcars))

# 3.2 Fixed effects¶

library(plm)

data("Grunfeld", package="plm")
Grunfeld  %>% head(3)

# 3.2.1 Fixed effects: Individual fixed effects¶

grun.fe <- plm(inv~value+capital, index=c('firm','year'), data = Grunfeld, model = "within")
summary(grun.fe)$coefficients

# 3.2.2 Fixed effects: Individual AND time fixed effects¶

#Method 1: factor(year)
grun.fe <- plm(inv~value+capital+factor(year), index=c('firm','year'), data = Grunfeld, model = "within")

#Method 2: effect='twoways'
grun.fe <- plm(inv~value+capital, index=c('firm','year'), data = Grunfeld, model = "within", effect='twoways')
summary(grun.fe)$coefficients

# 3.3 Standard errors
# 3.3.1 Baseline standard error¶

summary(grun.fe)$coefficients

# 3.3.2 Clustered standard error¶

coeftest(grun.fe, vcovHC(grun.fe, type = 'HC0', cluster = c('group','time')))

# 3.4 Random effects¶

grun.re <- plm(inv~value+capital,index=c('firm','year'), data = Grunfeld, model = "random")
summary(grun.re)$coefficients

# 3.4.1 Robust standard errors¶

coeftest(grun.re, vcovHC(grun.re, type = 'HC0', cluster = c('group','time')))

# 3.5 Logistic regression¶

mtcars %>% head(2)

summary(glm(am~ cyl+disp+drat+mpg, family='binomial', mtcars))

# 4. Machine Learning: Supervised learning¶

# Step 1
#install.packages('caret')

# Step 2
library(caret)

data(Sacramento)
house_df = Sacramento %>% as_tibble()
house_df  = house_df %>% mutate(ID = row_number())
house_df %>% head(3)

# 4.1.1. Baseline regression¶

model = lm(price ~ beds+baths+sqft, data=house_df)

# 4.1.1.1 Evaluate model by calculating RMSE¶

rmse = function(acutal, predicted){
    error = predicted - acutal
    rmse = sqrt(mean(error^2))
    return(rmse)
}

# 4.1.1.2 Actual data=price , Predicted data=fitted.values¶

rmse(house_df$price, model$fitted.values)

# 4.1.2 Train-test regression¶

set.seed(42)

train = house_df  %>% sample_frac(.8)
train %>% head(2)

test = house_df[-train$ID,]
test %>% head(2)

model = lm(price ~ beds+baths+sqft, data=train)

p = predict(model, test)

rmse(p, test$price)

# 4.2 Cross validation¶

model <- train(
  price ~ beds+baths+sqft,
    data=house_df,
  method = "lm",
  trControl = trainControl(
    method = "cv",
    number = 10,
    verboseIter = FALSE
  )
)
model


sigmoid = function( x ) {
	z <- 1 / ( 1 + exp( -x ))
}


WORLD <- read.csv('WORLD.CSV')
str(WORLD)
plot(WORLD)

WORLD_CLEAN <- na.omit(WORLD[, 3:15])
str(WORLD_CLEAN)
plot(WORLD_CLEAN)

WORLD_COR <- cor(WORLD_CLEAN)
WORLD_COR
library(corrplot)
corrplot(WORLD_COR)
corrplot(WORLD_COR, method = 'number')
corrplot(WORLD_COR, method = 'ellipse')
# +0.96: EDUC / GNPCAP
# -0.96: LIFEEXP / BABYMORT


library(neuralnet)
library(caret)
library(grDevices)
library(leaps)
library(relaimpo)
library(corrplot)
library(car)
library(DAAG)
# Alters the way numbers are outputted
options(scipen = 999,digits = 3)
library(nnet)
library(NeuralNetTools)
library(plyr)
library(ggvis) #Data visulization
library(psych) #Scatterplot matrix
library(knitr)

# Read the data
concrete <- read.csv(file.choose())
View(concrete)
class(concrete)

knitr::kable(head(concrete), caption = "Partial Table Preview")

str(concrete)

normalize <- function(x){
  return ((x - min(x))/(max(x) - min(x) ))
}

concrete_norm <- as.data.frame(lapply(concrete, normalize))

#training set
concrete_train <- concrete_norm[1:773, ]

#test set
concrete_test <- concrete_norm[774:1030, ]

#Build a neural network with one hidden layer
concrete_model <- neuralnet(strength ~ cement + slag + ash + water + superplastic + coarseagg + fineagg + age , data = concrete_train, hidden = 1)

plot(concrete_model)

#building the predictor, exclude the target variable column
model_results <- compute(concrete_model, concrete_test[1:8])

#store the net.results column
predicted_strength <- model_results$net.result

cor(predicted_strength, concrete_test$strength)

#building the new model
concrete_model2 <- neuralnet(strength ~ cement + slag + ash + water + superplastic + coarseagg + fineagg + age, data = concrete_train, hidden = 5 )

#nuilding the new predictor
model_results2 <- compute(concrete_model2, concrete_test[1:8])

#storing the results
predicted_strength2 <- model_results2$net.result

cor(predicted_strength2, concrete_test$strength)


### AR test and its corresponding power and sample size functions

AR.test=function(ivmodel, beta0=0, alpha=0.05){
  Yadj = ivmodel$Yadj; Dadj = ivmodel$Dadj; Zadj = ivmodel$Zadj;
  n=ivmodel$n;  k=ivmodel$p;  l=ivmodel$L

  if(ncol(Yadj)>1){
    print("The outcome variable should be in one dimension!")
	return(NULL)
  }
  if(ncol(Dadj)>1){
    print("The treatment variable should be in one dimension!")
	return(NULL)
  }
  if(l+k>=n){
    print("Too many IVs, AR can't handle!")
    return(NULL)
  }

### test
  temp=Yadj-beta0*Dadj
  Fstat=c(sum(qr.fitted(ivmodel$ZadjQR, temp)^2))/c(sum(temp^2)-sum(qr.fitted(ivmodel$ZadjQR, temp)^2))*(n-k-l)/l
  p.value=1-pf(Fstat, df1=l, df2=n-k-l)

### confidence interval
  cval=qf(1-alpha, df1=l, df2=n-k-l)*l/(n-k-l)
  coef.beta0sq=cval*sum(Dadj^2)-(cval+1)*sum(qr.fitted(ivmodel$ZadjQR, Dadj)^2)
  coef.beta0=-2*cval*sum(Dadj*Yadj)+2*(cval+1)*sum(Dadj*qr.fitted(ivmodel$ZadjQR, Yadj))
  coef.constant=cval*sum(Yadj^2)-(cval+1)*sum(qr.fitted(ivmodel$ZadjQR, Yadj)^2)
  Delta=coef.beta0^2-4*coef.constant*coef.beta0sq

  ci=matrix(NA, ncol=2)
  colnames(ci)<-c("lower", "upper")

  if(coef.beta0sq==0){
    if(coef.beta0>0){
      info=c("[",-coef.constant/coef.beta0,",Infinity)")
      ci[1,]=c(-coef.constant/coef.beta0, Inf)
    }
    if(coef.beta0<0){
      info=c("(-Infinity,",-coef.constant/coef.beta0,"]");
      ci[1,]=c(-Inf, -coef.constant/coef.beta0)
    }
    if(coef.beta0==0){
      if(coef.constant>=0){
        info="Whole Real Line"
        ci[1,]=c(-Inf, Inf)
      }
      if(coef.constant<0){
        info="Empty Set"
      }
    }
  }

  if(coef.beta0sq!=0){
    if(Delta<=0){
      if(coef.beta0sq>0){
        info="Whole Real Line"
        ci[1,]=c(-Inf, Inf)
      }
      if(coef.beta0sq<0){
        info="Empty Set"
      }
    }
    if(Delta>0){
      # Roots of quadratic equation
      root1=(-coef.beta0+sqrt(Delta))/(2*coef.beta0sq)
      root2=(-coef.beta0-sqrt(Delta))/(2*coef.beta0sq)
      upper.root=max(root1,root2)
      lower.root=min(root1,root2)
      if(coef.beta0sq<0){
        info=paste("[",lower.root,", ",upper.root,"]",sep="")
        ci[1, ]=c(lower.root, upper.root)
      }
      if(coef.beta0sq>0){
        info= paste("(-Infinity,",lower.root,"] union [",upper.root,",Infinity)")
        ci[1, ]=c(-Inf, lower.root)
        ci<-rbind(ci, c(upper.root, Inf))
      }
    }
  }

  return(list(Fstat=Fstat, df=c(l, n-k-l), p.value=p.value,
              ci.info=info, ci=ci))
}

AR.power=function(n, k, l, beta, gamma, Zadj_sq,
                  sigmau, sigmav, rho, alpha=0.05){
  if(length(gamma)!=ncol(as.matrix(Zadj_sq))|length(gamma)!=nrow(as.matrix(Zadj_sq))){
	print("The dimension of Zadj_sq doesn't match gamma")
	stop()
  }
  ncp=beta^2*n*c(t(as.matrix(gamma))%*%as.matrix(Zadj_sq)%*%as.matrix(gamma))/
	    (sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)

  temp = qf(1-alpha, df1=l, df2=n-k-l)
  power = 1-pf(temp, df1=l, df2=n-k-l, ncp=ncp)

  return(power)
}

AR.size=function(power, k, l, beta, gamma, Zadj_sq,
                 sigmau, sigmav, rho, alpha=0.05){
  if(length(gamma)!=ncol(as.matrix(Zadj_sq))|length(gamma)!=nrow(as.matrix(Zadj_sq))){
    print("The dimension of Zadj_sq doesn't match gamma")
	stop()
  }
  ncp=beta^2*c(t(as.matrix(gamma))%*%as.matrix(Zadj_sq)%*%as.matrix(gamma))/
	  (sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)

  oldn<-k+l+1
  state<-1
  while(state){
    temp = qf(1-alpha, df1=l, df2=oldn-k-l)
    temppower = 1-pf(temp, df1=l, df2=oldn-k-l, ncp=ncp*oldn)
    if(temppower < power){
	  oldn <- oldn*2
	}else{
	  state <- 0
	}
  }

  lower <- oldn%/%2
  upper <- oldn
  while((upper-lower)>2){
    new <- (upper+lower)%/%2
    temp = qf(1-alpha, df1=l, df2=oldn-k-l)
    temppower = 1-pf(temp, df1=l, df2=oldn-k-l, ncp=ncp*new)
    if(temppower < power){
	  lower <- new
	}else{
	  upper <- new
	}
  }

  return(upper)
}


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 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.
 install.packages("rnn")
 library(rnn)

 set.seed(10)

 f <- 5

 w <- 2*pi*f

 t <- seq(0.005,2,by=0.005)

 x <- sin(t*w) + rnorm(200, 0, 0.25)

 y <- cos(t*w)

 X <- matrix(x, nrow = 40)

 Y <- matrix(y, nrow = 40)

 plot(as.vector(X), col='blue', type='l', ylab = "x-matrix, y-matrix", main = "Noisy waves")

 lines(as.vector(Y), col = "red")

 X <- (X - min(X)) / (max(X) - min(X))

 X

 Y <- (Y - min(Y)) / (max(Y) - min(Y))

 Y

 X <- t(X)

 Y <- t(Y)

 train <- 1:8

 test <- 9:10

 model <- trainr(Y = Y[train,],
                  X = X[train,],
                  learningrate = 0.05,
                  hidden_dim = 16,
                  numepochs = 1500)

 Y_predicted <- predictr(model, X)

 plot(as.vector(t(Y)), col = 'red', type = 'l', main = "Actual values vs Predicted values", ylab = "Y, Y-predicted")

 lines(as.vector(t(Y_predicted)), type = 'l', col = 'blue')

 plot(as.vector(t(Y[test,])), col = 'red', type='l', main = "Actual vs predicted: testing set", ylab = "Y,Y-predicted")

 lines(as.vector(t(Y_predicted[test,])), type = 'l', col = 'blue')

Chapter 11/1Recurrent Neural Networks - Predicting periodic signal.r


# DATA
# Return the list of all instralled data packages
> data()

# Set folder
> setwd('BootcampWithR/MoneyBall')

# Info about R
> R.version

# dplyr command
# Select only columns x and y
> dplyr::select(df2, c(x, y))

# Remove columns x and y
> dplyr::select(df2, -c(x, y))

# Clear R environment
> ls()
# [1] "covidSource"       "covidSourceVeneto" "dataframe"
# [4] "date21"            "date22"            "date23"
# [7] "last"              "s"                 "x"

> rm(list = ls())

## ggplot2
# Update the default plot dimensions to 12 x 6.
> options(repr.plot.width = 12, repr.plot.height = 6)

# Define a custom theme updating background and labels
> theme_custom <- function(base_size, ...){
    ggplot2::theme_gray(base_size = base_size, ...) +
    ggplot2::theme(
        plot.title = element_text(face = 'bold'),
        plot.subtitle = element_text(color = '#333333'),
        panel.background = element_rect(fill = "#EBF4F7"),
        strip.background = element_rect(fill = "#33AACC"),
        legend.position = "bottom"
    )
}

> ggplot2::theme_set(theme_custom(base_size = 20))
> ggplot2::update_geom_defaults("line", list(size = 1.5))

# #### RANDOMIZATION #####
# Generates a vector of random normal variables with n
> rnorm(3)
> rnorm(10, mean=50, sd=.1)

# Reproduce same set of random numbers (needs to be called before rnorm())
> set.seed(100)
> rnorm(50)

# Generates


numi <- function(s) {
  strsplit(gsub("[^,0123456789]", "", s), ",")[[1]]
}
cat(sapply(lapply(readLines(tail(commandArgs(), n=1)), numi), function(s) {
  t <- as.integer(s)
  ifelse(t[1] + t[2] + t[3] == 0, 0,
         ((t[1] * 3 + t[2] * 4 + t[3] * 5) * t[4]) %/% (t[1] + t[2] + t[3]))
}), sep="\n")


### Loading libraries

library("tree")
library("randomForest")
library("pander")
library("rpart")

### Data Input
data <- as.data.frame(read.csv("0806alldata.csv", header = TRUE))
attach(data)
group1 <- data[,c("x", "y", "type",
                  "ec", "elv",
                  "ph", "hard",
                  "tds", "temp",
                  "eh", "cumrain",
                  "lag1")]

group2 <- data[,c("x", "y", "type",
                  "ec", "elv",
                  "aq", "Ca", "Mg",
                  "Fe", "Mn", "K",
                  "Na", "cumrain",
                  "lag1")]

group3 <- data[,c("x", "y", "type",
                  "ec", "elv",
                  "aq", "CO3",
                  "HCO3",
                  "CO2", "Cl",
                  "SO4", "NO2",
                  "NO3", "SiO2",
                  "cumrain",
                  "lag1")]

Formula1 <- ec ~ x + y + elv +
                  ph + hard + tds +
                  temp + eh + cumrain +
                  lag1

Formula2 <- ec ~ Ca + Mg + Fe +
                  Mn + K + Na +
                  cumrain + lag1

Formula3 <- ec ~ CO3 + HCO3 + CO2 +
                  Cl + SO4 + NO2 +
                  NO3 + SiO2 + cumrain +
                  lag1

#### Tree package ####
### Fit Regression Tree
## Fit tree model
treeModel1 <- tree(Formula1, data = group1)
treeModel2 <- tree(Formula2, data = group2)
treeModel3 <- tree(Formula3, data = group3)

## Evaluate tree
summary(treeModel1)
summary(treeModel2)
summary(treeModel3)

deviance(treeModel1, detail = F)
deviance(treeModel2, detail = F)
deviance(treeModel3, detail = F)

plot(treeModel1)
text(treeModel1, cex = 0.5)

plot(treeModel2)
text(treeModel2, cex = 0.5)

plot(treeModel3)
text(treeModel3, cex = 0.5)

## Cross validate the model (where to stop prunning)
cvTree1 <- cv.tree(treeModel1, FUN = prune.tree)
cvTree2 <- cv.tree(treeModel2, FUN = prune.tree)
cvTree3 <- cv.tree(treeModel3, FUN = prune.tree)

plot.new()
par(mfrow=c(1,3))
mtext("Cross validation plots")
plot(cvTree1$size, cvTree1$dev,
     type = "l",
     col = "red",
     main = "Group 1")
plot(cvTree2$size, cvTree2$dev,
     type = "l",
     col = "green",
     main = "Group 2")
plot(cvTree3$size, cvTree3$dev,
     type = "l",
     col = "blue",
     main = "Group 3")

## Use optimum number of nodes to prune the tree
treePrune1 <- prune.tree(treeModel1, best=2)
treePrune2 <- prune.tree(treeModel2, best=5)
treePrune3 <- prune.tree(treeModel3, best=10)

## Summary
summary(treePrune1)
summary(treePrune2)
summary(treePrune3)

## Plot pruned tree
plot.new()
par(mfrow=c(1,3))
plot(treePrune1)
text(treePrune1, cex = 0.8)
plot(treePrune2)
text(treePrune2, cex = 0.8)
plot(treePrune3)
text(treePrune3, cex = 0.8)

plot.new()
par(mfrow=c(1,3))
plot(prune.tree(treeModel1), order = c("decreasing"))
plot(prune.tree(treeModel2), order = c("decreasing"))
plot(prune.tree(treeModel3), order = c("decreasing"))

#### rpart package ####
## Make model
rpModel1 <- rpart(Formula1,
                  method = "class",
                  data = group1)
rpModel2 <- rpart(Formula2,
                  method = "class",
                  data = group1)
rpModel3 <- rpart(Formula3,
                  method = "class",
                  data = group1)

## Plot model
pander(printcp(rpModel1))
pander(printcp(rpModel2))
pander(printcp(rpModel3))

## Crossval model
plot.new()
par(mfrow=c(1,3))
plotcp(rpModel1,
       main = "Group1")
plotcp(rpModel2,
       main = "Group2")
plotcp(rpModel2,
       main = "Group3")

## Summary
summary(rpModel1)
summary(rpModel2)
summary(rpModel3)

## plot tree
plot(rpModel1,
     uniform=TRUE,
     main="Class tree group1")
text(rpModel1,
     use.n=TRUE,
     all=TRUE,
     cex=.8)
plot(rpModel2,
     uniform=TRUE,
     main="Class tree group2")
text(rpModel2,
     use.n=TRUE,
     all=TRUE,
     cex=.8)
plot(rpModel3,
     uniform=TRUE,
     main="Class tree group3")
text(rpModel3,
     use.n=TRUE,
     all=TRUE,
     cex=.8)

#### evtree package ####
library("evtree")
evModel1 <- evtree(Formula1, data = group1)
plot(evModel1)
table(predict(evModel1), group1$ec)

evModel2 <- evtree(Formula2, data = group2)
plot(evModel2)
table(predict(evModel2), group2$ec)

evModel3 <- evtree(Formula3, data = group3)
plot(evModel3)
table(predict(evModel3), group3$ec)

#### RandomForest package ####
## Fit a RF model
# Impute missing values with mean
sum(!is.na(data))
group1Imp <- rfImpute(ec ~ ., data = group1)
rfModel1 <- randomForest(Formula1, data = group1Imp,
                              ntree = 500,
                              mtry = 2,
                              importance = TRUE,
                              do.trace = 100,
                              proximity=TRUE)

rfModel2 <- randomForest(Formula2,
                              data = group2,
                              ntree = 500,
                              mtry = 2,
                              importance = TRUE,
                              do.trace = 100,
                              proximity=TRUE)

rfModel3 <- randomForest(Formula3,
                              data = group3,
                              ntree = 500,
                              mtry = 2,
                              importance = TRUE,
                              do.trace = 100,
                              proximity=TRUE)

## Evaluate RF model
print(rfModel1)
print(rfModel2)
print(rfModel3)

plot.new()
par(mfrow=c(1,3))
plot(rfModel1)
plot(rfModel2)
plot(rfModel3)

pander(round(importance(rfModel1), 3))
pander(round(importance(rfModel2), 3))
pander(round(importance(rfModel3), 3))

varImpPlot(rfModel1)
varImpPlot(rfModel2)
varImpPlot(rfModel3)


#  James Rekow

#  currently equivalent to identifySubgroupsVer1 (using gap statistic of Tibshirani et al. to determine
#  number of clusters, and kmeans to partition into clusters. Other methods didn't improve performance)
#  Partition Into Universal Subgroups (PIUS algorithm)

pias = function(abdList, rollRange = 0.025, numClust = NULL){

  #  ARGS: rollRange - the maximum difference in overlap between two DOC points for which the two points
  #                    are still considered close enough that they are included in each others local
  #                    dissimilarity profiles (e.g. in computing rolling mean, etc.)
  #
  #  RETURNS: subgroupsGuess - vector of indices grouping input samples by subgroup. e.g. subgroupIxVec =
  #                            c(1, 1, 1, 2, 2) would indicate that samples 1:3 are in a subgroup together,
  #                            and samples 4 and 5 are in a separate subgroup together

  source("computeInfoWeightMat.r")
  source("identifyNumSubgroups.r")

  ##  STEP 1: matrix of info weights
  ##  METHOD: linear residual based on rolling midpoint (mean of min, max) of dissimilarity values,
  ##          not normalized

  #  compute matrix of info weights
  infoMat = computeInfoWeightMat(abdList = abdList, rollRange = rollRange)

  ##  STEP 2: compute the number of universal subgroups present in cohort
  ##  METHOD: gap statistic of Tibshirani et al.

  #  use identify numsubgroups to identify correct number of subgroups, if an expected number of clusters
  #  isn't provided
  if(is.null(numClust)){
    numClust = identifyNumSubgroups(infoMat = infoMat)
  } #  end if

  ##  STEP 3:  partition samples into subgroups with universal dynamics
  ##  METHOD:  use the number of clusters computed in Step 2 an the matrix of info weights computed in
  ##           Step 1 as the data

  #  use kmeans to identify subgroups of samples, putting them into numClust clusters
  subgroupsGuess = kmeans(x = infoMat, centers = numClust, iter.max = 1000, nstart = 100)$cluster

  return(subgroupsGuess)

} #  end pias function


## 目前TSA包已经被删除的归档, 安装指南:　https://blog.csdn.net/sheneddie/article/details/106598601
library(TSA)
library( forecast)
Data=read.csv("Data.csv")
eacf(diff(log(Data$purchase)),15,28)
eacf(log(Data$redeem),15,28)
eacf(diff(log(Data$redeem)),15,28)

auto.arima(log(Data$redeem))
auto.arima(log(Data$purchase))


# Load necessary libraries

# Pull Maddison data into dataframe
mad <- read.csv("~/Dropbox/project/studyguide/data/maddison2010.csv", header=TRUE)

mad <- mad[which(mad$year>1819),] # only 1820 and later

mad$lndenmark <- round(log(mad$denmark),digits=2)
mad$lnfrance <- round(log(mad$france),digits=2)
mad$lnusa <- round(log(mad$usa),digits=2)
mad$lnenglandgbuk <- round(log(mad$englandgbuk),digits=2)
mad$lnhollandnetherlands <- round(log(mad$hollandnetherlands),digits=2)

fig <- plot_ly(mad, x = ~year)
fig <- fig %>% add_trace(y = ~lnfrance, name = 'France', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnusa, name = 'USA', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnhollandnetherlands, name = 'Holland/Netherlands', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnenglandgbuk, name = 'England/UK', type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita in the long run', x=0),
              xaxis = list(title = 'Year', tick0=1820, dtick=20),
              yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
              hovermode="x unified")
api_create(fig, filename = "mad-stable-lngdppc")

# Pull Maddison data into dataframe
mad <- read.csv("~/Dropbox/project/studyguide/data/maddison_world.csv", header=TRUE)

fig <- plot_ly(mad, x = ~ln_pop, y = ~ln_gdppc, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of GDP p.c. and population', x=0),
              xaxis = list(title = 'Log global population'),
              yaxis = list(title = 'Log global GDP per capita')
              )
api_create(fig, filename = "mad-global-lngdppc-pop")


suppressPackageStartupMessages(library(float))
set.seed(1234)
tol = 1e-6

same = function(test, truth) stopifnot(all.equal(test, truth, tol=tol))

x1 = matrix(stats::rnorm(30), 10)
x2 = matrix(stats::rnorm(30), 10)
x3 = matrix(1:30, 10)

s1 = fl(x1)
s2 = fl(x2)

### Addition
test = dbl(s1 + s2)
truth = x1 + x2
same(test, truth)
test = s1 + x2
same(test, truth)
test = x2 + s1
same(test, truth)

test = dbl(s1 + x3)
truth = x1 + x3
same(test, truth)
test = dbl(x3 + s1)
same(test, truth)

test = dbl(s1 + 1L)
truth = x1 + 1
same(test, truth)
test = s1 + 1.0
same(test, truth)

### Multiplication
test = dbl(s1 * s2)
truth = x1 * x2
same(test, truth)
test = s1 * x2
same(test, truth)
test = x2 * s1
same(test, truth)

test = dbl(s1 * x3)
truth = x1 * x3
same(test, truth)
test = dbl(x3 * s1)
same(test, truth)

test = dbl(s1 * 1L)
truth = x1 * 1L
same(test, truth)
test = s1 * 1.0
same(test, truth)

### Subtraction
test = dbl(s1 - s2)
truth = x1 - x2
same(test, truth)
test = s1 - x2
same(test, truth)

truth = x2 - x1
test = x2 - s1
same(test, truth)

test = dbl(s1 - x3)
truth = x1 - x3
same(test, truth)

truth = x3 - x1
test = dbl(x3 - s1)
same(test, truth)

test = dbl(s1 - 1L)
truth = x1 - 1L
same(test, truth)
test = s1 - 1.0
same(test, truth)

### Division
test = dbl(s1 / s2)
truth = x1 / x2
same(test, truth)
test = s1 / x2
same(test, truth)

truth = x2 / x1
test = x2 / s1
same(test, truth)

test = dbl(s1 / x3)
truth = x1 / x3
same(test, truth)

truth = x3 / x1
test = dbl(x3 / s1)
same(test, truth)

test = dbl(s1 / 1L)
truth = x1 / 1L
same(test, truth)
test = s1 / 1.0
same(test, truth)

### Power
test = dbl(s1 ^ s2)
truth = x1 ^ x2
same(test, truth)
test = s1 ^ x2
same(test, truth)

truth = x2 ^ x1
test = x2 ^ s1
same(test, truth)

test = dbl(s1 ^ x3)
truth = x1 ^ x3
same(test, truth)

truth = x3 ^ x1
test = dbl(x3 ^ s1)
same(test, truth)

test = dbl(s1 ^ 1L)
truth = x1 ^ 1L
same(test, truth)
test = s1 ^ 1.0
same(test, truth)


#'## Compute CIs for prediction ratios
#'### Functions for computing Ratio CIs
FiellerRatioCI <- function(a, b, V, t)
{
  theta <- a/b
  g <- (t^2)*V[2,2]/b^2
  se <- sqrt(V[1,1] - 2*theta*V[1,2] + theta^2 * V[2,2] - g*(V[1,1]-V[1,2]^2/V[2,2]))
  LCL <- (1/(1-g))*(theta- g*V[1,2]/V[2,2] - t/b * se)
  UCL <- (1/(1-g))*(theta- g*V[1,2]/V[2,2] + t/b * se)
  if (!is.na(UCL) & !is.na(LCL) & UCL < LCL) {
    UCL <- NA; LCL <- NA
  }
  return(list(pred.ratio=theta, upper.Confidence.limit = UCL, lower.Confidence.limit = LCL))
}

makeContrastMatrix <- function(preds, indx, pairs.factor, first.level, second.level)
{
  X <- model.matrix(~ Combinations-1, data = preds)
  ## Form the contrast matrix
  #Determine the columns of X for each contrast
  colsets <- split(colnames(X), preds[indx], lex.order = TRUE)
  prediv <- split(preds, preds[indx], lex.order = TRUE)
  locns <- lapply(colsets,
                  function(x, cols = colnames(X))
                  { pair <-  na.omit(match(x, cols)); names(pair) <- x; return(pair) })
  contr <- mapply(function(pred, cols, pairs.factor, first.level, second.level)
  {
    names(cols) <- gsub("Combinations", "", names(cols), fixed = TRUE)
    #    k1 <- (1:length(cols))[grepl(first.level, names(cols), fixed = TRUE)]
    #    k2 <- (1:length(cols))[grepl(second.level, names(cols), fixed = TRUE)]
    k1 <- (1:length(cols))[pred[pairs.factor] == first.level]
    k2 <- (1:length(cols))[pred[pairs.factor] == second.level]

    if (any(c(length(k1),length(k2)) == 0)) #no contrast
      cols <- NA
    else
    {
      if (length(k1) != 1)
        stop("There is more than one observation with the level ", first.level, " in combination ", names(cols))
      else
      {
        if (length(k2) != 1)
          stop("There is more than one observation with the level ", second.level, " in combination ", names(cols))
        else
        {
          cols[1:length(cols)] <- 0
          cols[k1] <- 1
          cols[k2] <- -1
        }
      }
    }
    return(cols)
  }, prediv, locns, MoreArgs = list(pairs.factor = pairs.factor,
                                   first.level = first.level, second.level = second.level),
  SIMPLIFY = FALSE)

  #Substitute the contrast in one column and NA in the other for each contrast
  for (k in 1:length(locns))
  {
    for (j in 1:length(locns[[k]]))
    {
      X[locns[[k]][j], locns[[k]][1]] <- contr[[k]][j]
      if (j != 1)
        X[locns[[k]][j], locns[[k]][j]] <- 0
    }
  }

  #Form contrast matrix
  X <- X[, unlist(locns)[order(unlist(locns))]]
  which.cols <- unlist(lapply(1:ncol(X),
                              function(k)
                              {
                                if   (any(is.na(as.vector(X[,k])))) retain <- FALSE
                                else retain <- !all(X[,k] == 0)
                              }))
  L <- t(X[, which.cols])

  rownames(L) <- gsub(paste0("Combinations"), "", rownames(L), fixed = TRUE)
  lev <- levels(preds[[pairs.factor]])[1]
  rownames(L) <- gsub(paste0(",",lev), "", rownames(L), fixed = TRUE)
  rownames(L) <- gsub(paste0(lev,","), "", rownames(L), fixed = TRUE)
  return(L)
}

ratioTransform.alldiffs <- function(alldiffs.obj, ratio.factor,
                                    numerator.levels, denominator.levels,
                                    method = "Fieller", alpha = 0.05,
                                    response = NULL, response.title = NULL,
                                    tables = "predictions",
                                    ...)
{
  #Check that a valid object of class alldiffs
  validalldifs <- validAlldiffs(alldiffs.obj)
  if (is.character(validalldifs))
    stop(validalldifs)
  alldiffs.obj <- renameDiffsAttr(alldiffs.obj)

  meth.options <- c("Fieller")
  method.opt <- meth.options[check.arg.values(method, meth.options)]
  options <- c("none", "predictions", "backtransforms", "vcov",
               "differences", "p.differences", "sed", "LSD", "all")
  opt <- options[unlist(lapply(tables, check.arg.values, options=options))]

  #Get a t-value (use z if no tdf attribute)
  tdf <- attr(alldiffs.obj, which = "tdf")
  if (!is.null(tdf))
  {
    t <- qt(1 - alpha/2, df = tdf)
  } else
    t <- qnorm(1 - alpha/2)

  if (is.null(response))
    response <- attr(alldiffs.obj, which = "response")
  if (is.null(response.title))
    response.title <- attr(alldiffs.obj, which = "response.title")
  classify <- attr(alldiffs.obj, which = "classify")

  facs <- fac.getinTerm(classify, rmfunction = TRUE)
  alldiffs.obj <- renewClassify(alldiffs.obj, newclassify = classify) #make sure in standard order
  tmp <- alldiffs.obj$predictions
  tmp$Combinations <- dae::fac.combine(as.list(tmp[facs]), combine.levels = TRUE, sep = ",")
  if (length(ratio.factor) != 1 | !(ratio.factor %in% facs))
    stop("ratio factor must specify a single factor that is in the classify attribute of the alldiffs object")
  if (!all(c(numerator.levels, denominator.levels) %in% levels(tmp[[ratio.factor]])))
    stop("Not all numerator.levels and denominator.levels are levels in ", ratio.factor, " in the alldiffs object")
  sortFactor <- attr(alldiffs.obj, which = "sortFactor")

  indx <- setdiff(facs, ratio.factor)

  # if (length(indx) == 1)
  # {
  #   ratios.dat <- as.data.frame(ratios.dat, row.names = NULL)
  #   names(ratios.dat)[1] <- indx
  # }
  tmp <- split(tmp, tmp[indx], sep = ",", lex.order = TRUE)
  Ratios <- lapply(denominator.levels, function(denom.lev,tmp, t)
  {
    lapply(numerator.levels, function(num.lev, denom.lev, tmp, t)
    {

      if (!(num.lev %in% alldiffs.obj$predictions[[ratio.factor]]) ||
          !(denom.lev %in% alldiffs.obj$predictions[[ratio.factor]]) ||
          num.lev == denom.lev)
        ratioCIs <-NULL
      else
      {
        ratioCIs <- do.call(rbind, lapply(tmp, function(preds, num.lev, denom.lev, V, t)
        {
          indx.vals <- (lapply(preds[indx], function(x) as.character(x)[1])) #current levels of indx factors
          ratio.pair <- c(indx.vals, rep(NA,3))
          names(ratio.pair) <- c(indx, "pred.ratio", "upper.Confidence.limit", "lower.Confidence.limit")
          if (all(c(num.lev, denom.lev) %in% preds[[ratio.factor]]))
          {
            a <- preds[preds[ratio.factor] == num.lev, "predicted.value"]
            b <- preds[preds[ratio.factor] == denom.lev, "predicted.value"]
            labs <- preds$Combinations
            posns <- unlist(lapply(c(num.lev,denom.lev), grep, x =labs, fixed = TRUE))
            lab <- labs[posns]
            Vpair <- V[lab,lab]
            ratio.pair <- as.data.frame(c(indx.vals, (FiellerRatioCI(a, b, Vpair, t = t))))
          }
          return(ratio.pair)
        }, V = alldiffs.obj$vcov, num.lev = num.lev, denom.lev = denom.lev, t = t))

        rownames(ratioCIs) <- NULL
        names(ratioCIs)[match("pred.ratio", names(ratioCIs))] <- "predicted.value"
        ratioCIs$standard.error <- NA
        ratioCIs$est.status <- "Estimable"
        ratio.names <- names(ratioCIs)
        n <- match("standard.error", ratio.names)
        k <- match("upper.Confidence.limit", ratio.names)
        if (n-k+1 != 3)
          stop("Standard.error and confidence limits not together in ratios data frame")
        ratio.names[k:n] <- c("standard.error", "upper.Confidence.limit", "lower.Confidence.limit")
        ratioCIs <- ratioCIs[ratio.names]
        ratioCIs[indx] <-  lapply(indx,
                                  function(fac) new.fac <- factor(ratioCIs[[fac]],
                                                                  levels = levels(alldiffs.obj$predictions[[fac]])))
        ratioCIs <- as.predictions.frame(ratioCIs)
        class(ratioCIs) <- c("predictions.frame", "data.frame")
        attr(ratioCIs, which = "response") <- response
        attr(ratioCIs, which = "response.title") <- response.title

        #sort the predictions.frame, if it was previously sorted
        if (!is.null(sortFactor))
        {
          if (sortFactor != ratio.factor)
            ratioCIs <- sort(ratioCIs, sortFactor = sortFactor, classify = paste(indx, collapse = ":"),
                             sortOrder = attr(alldiffs.obj, which = "sortOrder"))
        }
      }
      return(ratioCIs)
    }, tmp = tmp, denom.lev = denom.lev, t = t)
  }, tmp = tmp, t = t)
  Ratios <- unlist(Ratios, recursive = FALSE)
  nams <- outer(numerator.levels, denominator.levels, paste, sep = ",")
  names(Ratios) <- nams

  if ("predictions" == opt)
  {
    cat("\n\n#### Table(s) of ratio predictions and confidence limits for ", response, "\n\n")
    print(Ratios)
  }
  invisible(Ratios)
}

pairdiffsTransform.alldiffs <- function(alldiffs.obj, pairs.factor, first.levels, second.levels,
                                        Vmatrix = FALSE,
                                        error.intervals = "Confidence",
                                        avsed.tolerance = 0.25, accuracy.threshold = NA,
                                        LSDtype = "overall", LSDsupplied = NULL, LSDby = NULL,
                                        LSDstatistic = "mean", LSDaccuracy = "maxAbsDeviation",
                                        response = NULL, response.title = NULL, tables = "all",
                                        pairwise = TRUE, alpha = 0.05, ...)
{
  #Check for deprecated argument meanLSD.type and warn
  tempcall <- list(...)
  if (length(tempcall))
    if ("meanLSD.type" %in% names(tempcall))
      stop("meanLSD.type has been deprecated - use LSDtype")

  #Check that a valid object of class alldiffs
  validalldifs <- validAlldiffs(alldiffs.obj)
  if (is.character(validalldifs))
    stop(validalldifs)
  alldiffs.obj <- renameDiffsAttr(alldiffs.obj)
  attr(alldiffs.obj, which = "alpha") <- alpha

  #get transform attributes from backtransforms
  transform.power = 1; offset <- 0; scale <- 1
  if (!is.null(alldiffs.obj$backtransforms))
  {
    transform.power = attr(alldiffs.obj$backtransforms, which = "transform.power")
    offset = attr(alldiffs.obj$backtransforms, which = "offset")
    scale = attr(alldiffs.obj$backtransforms, which = "scale")
  }

  sortFactor <- attr(alldiffs.obj, which = "sortFactor")

  int.options <- c("none", "Confidence", "StandardError", "halfLeastSignificant")
  int.opt <- int.options[check.arg.values(error.intervals, int.options)]
  options <- c("none", "predictions", "backtransforms", "vcov",
               "differences", "p.differences", "sed", "LSD", "all")
  opt <- options[unlist(lapply(tables, check.arg.values, options=options))]
  #Get a t-value (use z if no tdf attribute)
  tdf <- attr(alldiffs.obj, which = "tdf")
  if (!is.null(tdf))
  {
    t <- qt(1 - alpha/2, df = tdf)
  } else
    t <- qnorm(1 - alpha/2)

  if (is.null(response))
    response <- attr(alldiffs.obj, which = "response")
  if (is.null(response.title))
    response.title <- attr(alldiffs.obj, which = "response.title")
  classify <- attr(alldiffs.obj, which = "classify")
  facs <- fac.getinTerm(classify, rmfunction = TRUE)
  alldiffs.obj <- renewClassify(alldiffs.obj, newclassify = classify) #make sure in standard order
  tmp <- alldiffs.obj$predictions
  tmp$Combinations <- dae::fac.combine(as.list(tmp[facs]), combine.levels = TRUE, sep = ",")
  if (length(pairs.factor) != 1 | !(pairs.factor %in% facs))
    stop("pairs factor must specify a single factor that is in the classify attribute of the alldiffs object")
  if (!all(c(first.levels, second.levels) %in% levels(tmp[[pairs.factor]])))
    stop("Not all first.levels and second.levels are levels in ", pairs.factor, " in the all diffs object")

  indx <- setdiff(facs, pairs.factor)

  Diffs <- lapply(second.levels, function(second.lev,tmp)
  {
    lapply(first.levels, function(first.lev, second.lev, tmp)
    {

      if (!(first.lev %in% alldiffs.obj$predictions[[pairs.factor]]) ||
          !(second.lev %in% alldiffs.obj$predictions[[pairs.factor]]))
        diffs <-NULL
      else
      {
        L <- makeContrastMatrix(tmp, indx = indx, pairs.factor = pairs.factor, first.lev, second.lev)

        #form the factors indexing the pair-difference predictions
        new.facs <- lapply(indx, function(fac, data)
        {
          levels(tmp[[fac]])
        }, data = tmp)
        names(new.facs) <- indx
        if (length(indx) == 1)
        {
          pairs.dat <- as.data.frame(rownames(L), stringsAsFactors = FALSE)
          names(pairs.dat) <- indx
          pairs.dat[indx] <- factor(pairs.dat[[indx]], levels = rownames(L))
        }
        else
          pairs.dat <- dae::fac.uncombine(rownames(L), new.factors = new.facs, sep = ",")

        #Calculate the differences for the current pair
        diffs <- linTransform(alldiffs.obj, classify = classify,
                              linear.transformation = L, Vmatrix = Vmatrix,
                              error.intervals = "Confidence",
                              avsed.tolerance = avsed.tolerance, accuracy.threshold = accuracy.threshold,
                              response = response, response.title = response.title,
                              pairwise = pairwise, alpha = alpha,
                              tables = "none", ...)
        diffs$predictions <- cbind(pairs.dat, diffs$predictions)
        diffs$predictions <- diffs$predictions[, -match("Combination", names(diffs$predictions))]
        diffs <- renewClassify(diffs, newclassify = paste(indx, collapse = ":"))
        diffs <- redoErrorIntervals(diffs,  error.intervals = int.opt, alpha = alpha,
                                    avsed.tolerance = avsed.tolerance, accuracy.threshold = accuracy.threshold,
                                    LSDtype = LSDtype, LSDby = LSDby, LSDsupplied = LSDsupplied,
                                    LSDstatistic = LSDstatistic, LSDaccuracy = LSDaccuracy)
        # if (!is.null(diffs$backtransforms))
        # {
        #   diffs$backtransforms <- cbind(pairs.dat, diffs$backtransforms)
        #   diffs$backtransforms <- diffs$backtransforms[, -match("Combination", names(diffs$backtransforms))]
        #   #Find missing attributes in new alldiffs.obj and add them back in
        #   newattr <- attributes(diffs$backtransforms)
        #   back.attr <- attributes(alldiffs.obj$backtransforms)
        #   back.attr <- back.attr[names(back.attr)[!(names(back.attr) %in% names(newattr))]]
        #   if (length(back.attr) > 0)
        #   {
        #     newattr <- c(newattr,back.attr)
        #     attributes(diffs$backtransforms) <- newattr
        #   }
        # }

        #sort the alldiffs if it was previously sorted
        if (!is.null(sortFactor))
        {
          if (sortFactor != pairs.factor)
            diffs <- sort(diffs, sortFactor = sortFactor,
                             sortOrder = attr(diffs, which = "sortOrder"))
        }

        if (opt != "none")
          print(diffs, which = opt)
        return(diffs)
      }
    }, tmp = tmp, second.lev = second.lev)
  }, tmp = tmp)
  Diffs <- unlist(Diffs, recursive = FALSE)
  nams <- outer(first.levels, second.levels, paste, sep = ",")
  names(Diffs) <- nams
  invisible(Diffs)
}


library(MASS)
library(mvtnorm)
library(flexmix)

data(ability.cov)
X <- mvrnorm(100, rep(0,6), ability.cov$cov)

f3 <-    factanal(X, factors=3)
R3 <- f3$loadings %*% t(f3$loadings)
diag(R3) <- rep(1,6)

f2 <-    factanal(X, factors=2)
R2 <- f2$loadings %*% t(f2$loadings)
diag(R2) <- rep(1,6)

f1 <-    factanal(X, factors=1)
R1 <- f1$loadings %*% t(f1$loadings)
diag(R1) <- rep(1,6)

KLdiv(cbind(dmvnorm(scale(X), rep(0,6), R1), dmvnorm(scale(X), rep(0,6), R2), dmvnorm(scale(X), rep(0,6), R3)  ) )


input = mtcars[c("am","cyl","hp","wt")]
model=glm(am~cyl+hp+wt,data=input)
x=summary(model)
print(x)
a=data.frame(cyl=10,hp=10,wt=10)
y=round(predict(model,a))
print(y)


#' cma
#'
#' Implementation of the coordinate mapping algorithm.
#'
#' @details
#' The method is threaded via OpenMP. This requires \code{nthreads*n} doubles of
#' additional storage.  If \code{n} is very large relative to \code{m}, this
#' could be very costly; in this case, try using a smaller number of threads by
#' setting the environment variable \code{OMP_NUM_THREADS}.
#'
#' @param x
#' Input data, preferably as a matrix, or optionally as anything coercible to
#' a matrix.
#' @param k
#' The number of coordinates you want mapped.
#'
#' @return
#' An \code{m}x\code{k} matrix.
#'
#' @examples
#' \dontrun{
#' library(fastmap)
#'
#' x = matrix(1:30, 10)
#' cma(x)
#' }
#'
#' @references
#' Ostrouchov, G., 2009. A Matrix Computation View of FastMap and RobustMap
#' Dimension Reduction Algorithms. SIAM Journal on Matrix Analysis and
#' Applications, 31(3), pp.1351-1360.
#'
#' @export
cma = function(x, k=1)
{
  if (!is.matrix(x))
    x = as.matrix(x)

  if (!is.double(x))
    storage.mode(x) = "double"

  .Call(R_cma, x, as.integer(k))
}


#dic with beta regression comparison.
#clear environment, load packages.
rm(list=ls())
library(runjags)

#### generate pseudo data. ####
#2 informative covariates, an informative intercept, 1 uninformative covariate.
set.seed(1234)
n.obs <- 200
x1 <- runif(n.obs,20,40)
#x2 <- runif(n.obs, 2, 4)
x3 <- runif(n.obs,0,300)
#x4 <- runif(n.obs,100,110)
intercept <- rep(1, n.obs)
#y1 <- x1*5 + x2*3 + 5 + rnorm(n.obs)
y1 <- x1*5 + 5 + rnorm(n.obs)
y2 <- rep(10, length(y1))
y <- as.matrix(data.frame(y1,y2))
y <- y / rowSums(y)
#x <- as.matrix(data.frame(intercept,x1,x2,x3))
x <- as.matrix(data.frame(intercept,x1,x3))
#specify jags reps throughout.
n.adapt  <- 500
n.burnin <- 1000
n.sample <- 1000

#### Specify a simple beta model. ####
jags.model <- "
model{
  #priors
  for (i in 1:N.preds) {
    m[i] ~ dnorm(0, 1.0E-3)
  }
  tau ~ dgamma(.1,.1)

  #beta part
  for (i in 1:N){
  y[i] ~ dbeta(p[i], q[i])
  p[i] <- mu[i] * tau
  q[i] <- (1 - mu[i]) * tau
  logit(mu[i]) <- inprod(x[i,],m)
  }
} #end mode loop.
"
#### Specify fixed model. No parameter priors because parameters are fixed. ####
fix.model <- "
model{
  #beta part
  for (i in 1:N){
  y[i] ~ dbeta(p[i], q[i])
  p[i] <- mu[i] * tau
  q[i] <- (1 - mu[i]) * tau
  logit(mu[i]) <- inprod(x[i,],m)
  }
} #end model loop
"

#### Fit JAGS model, get dic. ####
jags.data <- list(y=y[,1],x=x,N.preds = ncol(x), N = nrow(y))
jags.out <- run.jags(model = jags.model, data = jags.data, adapt=n.adapt,burnin=n.burnin,sample=n.sample,n.chains=3, monitor = c('m','tau','deviance'))
jags.sum <- summary(jags.out)
jags.dev <- jags.sum[grep('deviance', rownames(jags.sum)),][4]
jags.m   <- jags.sum[grep('m'       , rownames(jags.sum)),][,4]
jags.tau <- jags.sum[grep('tau'     , rownames(jags.sum)),][4]
#get pD with fix.model.
pD.data <- list(y=y[,1],x=x,N.preds = ncol(x), N = length(y[,1]), tau = jags.tau, m = jags.m)
pD.model <- run.jags(model = fix.model, data = pD.data, adapt=100,burnin=100,sample=100,n.chains=3, monitor = c('deviance'))
pD.sum   <- summary(pD.model)
pD       <- pD.sum[3]
dic      <- 2*jags.dev - pD
dic2     <- extract(jags.out, 'dic')
#### leave one predictor out at a time, calculate dic. ####
jags.compare.dic   <- list()
jags.compare.dic2  <- list()
jags.summary.out   <- list()
for(i in 2:ncol(x)){
  new.x <- x[,-i]
  jd <- list(y=y[,1],x=new.x,N.preds = ncol(new.x), N = length(y[,1]))
  jags.out <- run.jags(model = jags.model, data = jd, adapt=n.adapt,burnin=n.burnin,sample=n.sample,n.chains=3, monitor = c('m','tau','deviance'))
  jags.sum <- summary(jags.out)
  jags.dev <- jags.sum[grep('deviance', rownames(jags.sum)),][ 4]
  jags.m   <- jags.sum[grep('m'       , rownames(jags.sum)),][,4]
  jags.tau <- jags.sum[grep('tau'     , rownames(jags.sum)),][ 4]
  #get pD with fix model.
  pD.data <- list(y=y[,1],x=new.x,N = length(y[,1]), tau = jags.tau, m = jags.m)
  pD.model <- run.jags(model = fix.model, data = pD.data, adapt=100,burnin=100,sample=100,n.chains=3, monitor = c('deviance'))
  pD.sum   <- summary(pD.model)
  pD       <- pD.sum[3]
  jags.compare.dic [[i-1]] <- 2*jags.dev - pD
  jags.compare.dic2[[i-1]] <- extract(jags.out, 'dic')
  jags.summary.out [[i-1]] <- jags.sum
}
jags.compare.dic <- unlist(jags.compare.dic)
names(jags.compare.dic) <- colnames(x[,2:ncol(x)])

#### which model improves DIC the most? ####
#two metrics are in line. Both strongly discourage dropping x1 (good).
#both mildly encourage (1-3 points of support) dropping x3 (uninformative predictor).
dic
jags.compare.dic
dic2
jags.compare.dic2