<<<<<<< HEAD
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Neville Subproject: Using Random Forestes, Factor Analysis, and Logistic regression to Screen Variables for Imapcts on Public Health
## National Health and Nutrition Examination Survey: The R Project for Statistical Computing Script by DrewC!
# Detecting Prediabetes in those under 65

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code
library(skimr) # Library used for easy summary of data

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_nhanes = read.csv("_data/nhanes_1516_noRX_stage.csv") # Import dataset from _data folder

## Verify
dim(df_nhanes)

### Step 2: Prepare Data for Classificaiton

## Subset for outcome of interest
df_nhanes$outcome <- 0 # Add new outcome column and set value to 0
df_nhanes$outcome[df_nhanes$LBXGH >= 5.7 & df_nhanes$LBXGH < 6.4 ] <- 1 # Create new column based on conditions
df_nh = subset(df_nhanes, select = -c(SEQN, LBXGH, DIQ010))

## Resolve missing data
df_nev = df_nh[, -which(colSums(is.na(df_nh)) > 3646)] # Remove variables with high missing values
df_nev = subset(df_nev, select = -c(AUATYMTL, SLQ300, SLQ310, AUATYMTR)) # Remove variables with factor value types
df_nev = na.omit(df_nev) # Omit rows with NA from Data Frame
df_nev = df_nev[which(df_nev$RIDAGEYR < 65), ]

## Verify
dim(df_nev)
colnames(df_nev)

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_nev, outcome == 1) # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
df_fa = na.omit(df_fa)
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
cor_fa = cor(df_fa)
cor_fa[!is.finite(cor_fa)] <- 0
model_scree = fa.parallel(cor_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Scree Test Output to File
result = model_scree # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
write("Eigenvalues from Scree Test",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

## Idenitfy Loadings
factors = fa(r = cor_fa, nfactors = 10)
df_load = as.data.frame(unclass(factors$loadings))
df_ld = df_load[, which(apply(df_load, 2, max) > 0.5)] # Remove variables with high missing values
colnames(df_ld)

df_ld$factor1[df_ld$MR1 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor2[df_ld$MR2 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor3[df_ld$MR3 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor4[df_ld$MR4 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor5[df_ld$MR5 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor6[df_ld$MR6 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor7[df_ld$MR7 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor8[df_ld$MR8 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor9[df_ld$MR9 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor10[df_ld$MR10 > 0.5] <- 1 # Create new column based on conditions
df_ld = subset(df_ld, select = -c(MR1, MR2, MR3, MR4, MR5, MR6, MR7, MR8, MR9, MR10))

df_f1 = subset(df_ld, factor1 == 1) # Subset for outcome of interest
df_f1 = df_f1["factor1"]
df_f2 = subset(df_ld, factor2 == 1) # Subset for outcome of interest
df_f2 = df_f2["factor2"]
df_f3 = subset(df_ld, factor3 == 1) # Subset for outcome of
df_f3 = df_f3["factor3"]
df_f4 = subset(df_ld, factor4 == 1) # Subset for outcome of interest
df_f4 = df_f4["factor4"]
df_f5 = subset(df_ld, factor5 == 1) # Subset for outcome of interest
df_f5 = df_f5["factor5"]
df_f6 = subset(df_ld, factor6 == 1) # Subset for outcome of interest
df_f6 = df_f6["factor6"]
df_f7 = subset(df_ld, factor7 == 1) # Subset for outcome of interest
df_f7 = df_f7["factor7"]
df_f8 = subset(df_ld, factor8 == 1) # Subset for outcome of interest
df_f8 = df_f8["factor8"]
df_f9 = subset(df_ld, factor9 == 1) # Subset for outcome of interest
df_f9 = df_f9["factor9"]
df_f10 = subset(df_ld, factor10 == 1) # Subset for outcome of interest
df_f10 = df_f10["factor10"]

## Write Scree Test Output to File
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Factor Loadings",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(df_f1, file = file, append = TRUE) # write summary to file
capture.output(df_f2, file = file, append = TRUE) # write summary to file
capture.output(df_f3, file = file, append = TRUE) # write summary to file
capture.output(df_f4, file = file, append = TRUE) # write summary to file
capture.output(df_f5, file = file, append = TRUE) # write summary to file
capture.output(df_f6, file = file, append = TRUE) # write summary to file
capture.output(df_f7, file = file, append = TRUE) # write summary to file
capture.output(df_f8, file = file, append = TRUE) # write summary to file
capture.output(df_f9, file = file, append = TRUE) # write summary to file
capture.output(df_f10, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
df_rf = df_nev
forest = randomForest(formula = outcome ~ ., data = df_rf, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).

## Create Importance Variable Lists
df_rank = arrange(df_forest, desc(Gini)) # Descend by variable in data frame
df_rank = df_rank[which(df_rank$Gini > 0 & df_rank$MSE > 0), ]
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

### Summary Statistics of Model Variables
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Summary of Model Variables", file) # Insert title
write(" ", file) # Insert space below result
write("OHX19TC", file) # Insert space below title
capture.output(summary(df_nev$OHX19TC), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMDAVSAD", file) # Insert space below title
capture.output(summary(df_nev$BMDAVSAD), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INDFMMPI", file) # Insert space below title
capture.output(summary(df_nev$INDFMMPI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INQ080", file) # Insert space below title
capture.output(summary(df_nev$INQ080), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMXLEG", file) # Insert space below title
capture.output(summary(df_nev$BMXLEG), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXWBCSI", file) # Insert space below title
capture.output(summary(df_nev$LBXWBCSI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXRDW", file) # Insert space below title
capture.output(summary(df_nev$LBXRDW), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BPXDI3", file) # Insert space below title
capture.output(summary(df_nev$BPXDI3), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBDRFO", file) # Insert space below title
capture.output(summary(df_nev$LBDRFO), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 5: Liner Regression to Determine Direction of Impact

model_logistic <- glm(outcome~ OHX19TC + BMDAVSAD + INDFMMPI + INQ080 + BMXLEG + LBXWBCSI + LBXRDW + BPXDI3 + LBDRFO, data = df_nev)
summary(model_logistic)

## Write Model Output to File
result = summary(model_logistic) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write(" ", file) # Insert space below title
write("First Logistic Regression for Variable Direction",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Create Dichotomous Variables Based on 3rd Quartile

## Create New Variables
df_nh$V1 <- 0 # Add new outcome column and set value to 0
df_nh$V2 <- 0 # Add new outcome column and set value to 0
df_nh$V3 <- 0 # Add new outcome column and set value to 0
df_nh$V4 <- 0 # Add new outcome column and set value to 0
df_nh$V5 <- 0 # Add new outcome column and set value to 0
df_nh$V1[df_nh$OHX01TC == 4 | df_nh$OHX02TC == 4 | df_nh$OHX03TC == 4 | df_nh$OHX04TC == 4 | df_nh$OHX05TC == 4 | df_nh$OHX06TC == 4 | df_nh$OHX07TC == 4 | df_nh$OHX08TC == 4 | df_nh$OHX09TC == 4 | df_nh$OHX10TC == 4 | df_nh$OHX11TC == 4 | df_nh$OHX12TC == 4 | df_nh$OHX13TC == 4 | df_nh$OHX14TC == 4 | df_nh$OHX15TC == 4 | df_nh$OHX16TC == 4 | df_nh$OHX17TC == 4 | df_nh$OHX18TC == 4 | df_nh$OHX19TC == 4 | df_nh$OHX20TC == 4 | df_nh$OHX21TC == 4 | df_nh$OHX22TC == 4 | df_nh$OHX23TC == 4 | df_nh$OHX24TC == 4 | df_nh$OHX25TC == 4 | df_nh$OHX26TC == 4 | df_nh$OHX27TC == 4 | df_nh$OHX28TC == 4 | df_nh$OHX29TC == 4 | df_nh$OHX30TC == 4 | df_nh$OHX31TC == 4 | df_nh$OHX32TC == 4] <- 1 # Create new column based on conditions
df_nh$V2[df_nh$BMDAVSAD > 25.1] <- 1 # Create new column based on conditions
df_nh$V3[df_nh$INDFMMPI > 5] <- 1 # Create new column based on conditions
df_nh$V4[df_nh$INQ080 == 1] <- 1 # Create new column based on conditions
df_nh$V5[df_nh$BMXLEG < 41.58] <- 1 # Create new column based on conditions

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, V1, V2, V3, V4, V5)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

### Step 6: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_lon), size = floor(.50*nrow(df_lon)), replace = F) # Create training and testing dataset with 50% split
train = df_lon[sample, ] # Susbset data frame by sample
test = df_lon[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome~ V1 + V2 + V3 + V4 + V5, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_logistic)) # Save result df to variable
result2 = print(summary(model_back)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Training Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Stepwise Backwards Selection", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 7: Create Score and Verify

# Create new column based on conditions
test$score <- 0 # Add new outcome column and set value to 0
test$score = (20*test$V2) + (15*test$V4) + (10*test$V5)

## Final Model and AUC Score
model_score = glm(outcome~ score, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_score$y, model_score$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Risk Score Validation", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

=======
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Neville Subproject: Using Random Forestes, Factor Analysis, and Logistic regression to Screen Variables for Imapcts on Public Health
## National Health and Nutrition Examination Survey: The R Project for Statistical Computing Script by DrewC!
# Detecting Prediabetes in those under 65

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code
library(skimr) # Library used for easy summary of data

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_nhanes = read.csv("_data/nhanes_1516_noRX_stage.csv") # Import dataset from _data folder

## Verify
dim(df_nhanes)

### Step 2: Prepare Data for Classificaiton

## Subset for outcome of interest
df_nhanes$outcome <- 0 # Add new outcome column and set value to 0
df_nhanes$outcome[df_nhanes$LBXGH >= 5.7 & df_nhanes$LBXGH < 6.4 ] <- 1 # Create new column based on conditions
df_nh = subset(df_nhanes, select = -c(SEQN, LBXGH, DIQ010))

## Resolve missing data
df_nev = df_nh[, -which(colSums(is.na(df_nh)) > 3646)] # Remove variables with high missing values
df_nev = subset(df_nev, select = -c(AUATYMTL, SLQ300, SLQ310, AUATYMTR)) # Remove variables with factor value types
df_nev = na.omit(df_nev) # Omit rows with NA from Data Frame
df_nev = df_nev[which(df_nev$RIDAGEYR < 65), ]

## Verify
dim(df_nev)
colnames(df_nev)

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_nev, outcome == 1) # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
df_fa = na.omit(df_fa)
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
cor_fa = cor(df_fa)
cor_fa[!is.finite(cor_fa)] <- 0
model_scree = fa.parallel(cor_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Scree Test Output to File
result = model_scree # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
write("Eigenvalues from Scree Test",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

## Idenitfy Loadings
factors = fa(r = cor_fa, nfactors = 10)
df_load = as.data.frame(unclass(factors$loadings))
df_ld = df_load[, which(apply(df_load, 2, max) > 0.5)] # Remove variables with high missing values
colnames(df_ld)

df_ld$factor1[df_ld$MR1 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor2[df_ld$MR2 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor3[df_ld$MR3 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor4[df_ld$MR4 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor5[df_ld$MR5 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor6[df_ld$MR6 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor7[df_ld$MR7 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor8[df_ld$MR8 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor9[df_ld$MR9 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor10[df_ld$MR10 > 0.5] <- 1 # Create new column based on conditions
df_ld = subset(df_ld, select = -c(MR1, MR2, MR3, MR4, MR5, MR6, MR7, MR8, MR9, MR10))

df_f1 = subset(df_ld, factor1 == 1) # Subset for outcome of interest
df_f1 = df_f1["factor1"]
df_f2 = subset(df_ld, factor2 == 1) # Subset for outcome of interest
df_f2 = df_f2["factor2"]
df_f3 = subset(df_ld, factor3 == 1) # Subset for outcome of
df_f3 = df_f3["factor3"]
df_f4 = subset(df_ld, factor4 == 1) # Subset for outcome of interest
df_f4 = df_f4["factor4"]
df_f5 = subset(df_ld, factor5 == 1) # Subset for outcome of interest
df_f5 = df_f5["factor5"]
df_f6 = subset(df_ld, factor6 == 1) # Subset for outcome of interest
df_f6 = df_f6["factor6"]
df_f7 = subset(df_ld, factor7 == 1) # Subset for outcome of interest
df_f7 = df_f7["factor7"]
df_f8 = subset(df_ld, factor8 == 1) # Subset for outcome of interest
df_f8 = df_f8["factor8"]
df_f9 = subset(df_ld, factor9 == 1) # Subset for outcome of interest
df_f9 = df_f9["factor9"]
df_f10 = subset(df_ld, factor10 == 1) # Subset for outcome of interest
df_f10 = df_f10["factor10"]

## Write Scree Test Output to File
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Factor Loadings",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(df_f1, file = file, append = TRUE) # write summary to file
capture.output(df_f2, file = file, append = TRUE) # write summary to file
capture.output(df_f3, file = file, append = TRUE) # write summary to file
capture.output(df_f4, file = file, append = TRUE) # write summary to file
capture.output(df_f5, file = file, append = TRUE) # write summary to file
capture.output(df_f6, file = file, append = TRUE) # write summary to file
capture.output(df_f7, file = file, append = TRUE) # write summary to file
capture.output(df_f8, file = file, append = TRUE) # write summary to file
capture.output(df_f9, file = file, append = TRUE) # write summary to file
capture.output(df_f10, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
df_rf = df_nev
forest = randomForest(formula = outcome ~ ., data = df_rf, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).

## Create Importance Variable Lists
df_rank = arrange(df_forest, desc(Gini)) # Descend by variable in data frame
df_rank = df_rank[which(df_rank$Gini > 0 & df_rank$MSE > 0), ]
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

### Summary Statistics of Model Variables
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Summary of Model Variables", file) # Insert title
write(" ", file) # Insert space below result
write("OHX19TC", file) # Insert space below title
capture.output(summary(df_nev$OHX19TC), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMDAVSAD", file) # Insert space below title
capture.output(summary(df_nev$BMDAVSAD), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INDFMMPI", file) # Insert space below title
capture.output(summary(df_nev$INDFMMPI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("INQ080", file) # Insert space below title
capture.output(summary(df_nev$INQ080), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMXLEG", file) # Insert space below title
capture.output(summary(df_nev$BMXLEG), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXWBCSI", file) # Insert space below title
capture.output(summary(df_nev$LBXWBCSI), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBXRDW", file) # Insert space below title
capture.output(summary(df_nev$LBXRDW), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BPXDI3", file) # Insert space below title
capture.output(summary(df_nev$BPXDI3), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("LBDRFO", file) # Insert space below title
capture.output(summary(df_nev$LBDRFO), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 5: Liner Regression to Determine Direction of Impact

model_logistic <- glm(outcome~ OHX19TC + BMDAVSAD + INDFMMPI + INQ080 + BMXLEG + LBXWBCSI + LBXRDW + BPXDI3 + LBDRFO, data = df_nev)
summary(model_logistic)

## Write Model Output to File
result = summary(model_logistic) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write(" ", file) # Insert space below title
write("First Logistic Regression for Variable Direction",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Create Dichotomous Variables Based on 3rd Quartile

## Create New Variables
df_nh$V1 <- 0 # Add new outcome column and set value to 0
df_nh$V2 <- 0 # Add new outcome column and set value to 0
df_nh$V3 <- 0 # Add new outcome column and set value to 0
df_nh$V4 <- 0 # Add new outcome column and set value to 0
df_nh$V5 <- 0 # Add new outcome column and set value to 0
df_nh$V1[df_nh$OHX01TC == 4 | df_nh$OHX02TC == 4 | df_nh$OHX03TC == 4 | df_nh$OHX04TC == 4 | df_nh$OHX05TC == 4 | df_nh$OHX06TC == 4 | df_nh$OHX07TC == 4 | df_nh$OHX08TC == 4 | df_nh$OHX09TC == 4 | df_nh$OHX10TC == 4 | df_nh$OHX11TC == 4 | df_nh$OHX12TC == 4 | df_nh$OHX13TC == 4 | df_nh$OHX14TC == 4 | df_nh$OHX15TC == 4 | df_nh$OHX16TC == 4 | df_nh$OHX17TC == 4 | df_nh$OHX18TC == 4 | df_nh$OHX19TC == 4 | df_nh$OHX20TC == 4 | df_nh$OHX21TC == 4 | df_nh$OHX22TC == 4 | df_nh$OHX23TC == 4 | df_nh$OHX24TC == 4 | df_nh$OHX25TC == 4 | df_nh$OHX26TC == 4 | df_nh$OHX27TC == 4 | df_nh$OHX28TC == 4 | df_nh$OHX29TC == 4 | df_nh$OHX30TC == 4 | df_nh$OHX31TC == 4 | df_nh$OHX32TC == 4] <- 1 # Create new column based on conditions
df_nh$V2[df_nh$BMDAVSAD > 25.1] <- 1 # Create new column based on conditions
df_nh$V3[df_nh$INDFMMPI > 5] <- 1 # Create new column based on conditions
df_nh$V4[df_nh$INQ080 == 1] <- 1 # Create new column based on conditions
df_nh$V5[df_nh$BMXLEG < 41.58] <- 1 # Create new column based on conditions

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, V1, V2, V3, V4, V5)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

### Step 6: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_lon), size = floor(.50*nrow(df_lon)), replace = F) # Create training and testing dataset with 50% split
train = df_lon[sample, ] # Susbset data frame by sample
test = df_lon[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome~ V1 + V2 + V3 + V4 + V5, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_logistic)) # Save result df to variable
result2 = print(summary(model_back)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Training Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Stepwise Backwards Selection", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 7: Create Score and Verify

# Create new column based on conditions
test$score <- 0 # Add new outcome column and set value to 0
test$score = (20*test$V2) + (15*test$V4) + (10*test$V5)

## Final Model and AUC Score
model_score = glm(outcome~ score, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_score$y, model_score$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_under_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Risk Score Validation", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

>>>>>>> 321eaea894d29a3f212ee3e111b86695f46cf6db


#' @title pvalue.rsquare
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
	pvalue.rsquare = function( M ) {
		# R^2 = SSDmodel/(SSDmodel+SSDres)
		# F = DFres/DFmodel*SSDmodel/SSDres
	  # 1/R^2 = 1 + 1/F*DFmodel/DFres
		# or,
		# F = 1/(1/R^2 - 1)*DFres/DFmodel = R^2/(1-R^2)*DFres/DFmodel
			#
		# Actually, R^2 itself has a beta distribution and you could use pbeta
		# directly, but then you'd need to figure out (or recall) what the
		# relation between the DF and the shape parameters of the beta
		# distribution are. By my reckoning, this should do it:
		# pbeta(Rsq, 1/2, (N-2)/2, lower.tail=FALSE)
		#
		# Residual standard error: 1.143 on 8 degrees of freedom
		# Multiple R-Squared: 0.0004207, Adjusted R-squared: -0.1245
		# F-statistic: 0.003367 on 1 and 8 DF, p-value: 0.9552
		# pbeta(0.0004207, 1/2, 8/2, lower=F)
		# >[1] 0.9551511

		dfres = df.residual(M)
		dfmod = sum( df.terms(M))
		rsq = summary(M)$r.squared
		Fval = 1/(1/ rsq - 1)*dfres/dfmod

		out = list(
			rsquare=rsq,
			dfmod = dfmod,
			dfres = dfres,
			Fval = Fval,
			pvalF = pf(Fval, sum( df.terms(M)) , df.residual(M), lower.tail=FALSE),
			pvalB = pbeta( rsq, dfmod/2, dfres/2,  lower.tail=FALSE )
		)
		return (out)

	}


DS <-function(train_X,train_Y){
  n_row <- nrow(train_X)
  Region <- function(s_rm,s_lstat){
    # Variables for finding our RSS for lstat and rm
    sum_lessthan_rm <-0
    sum_grtrthan_rm <-0
    sum_lessthan_lstat <-0
    sum_grtrthan_lstat <-0

    n_lessthan_rm <-0
    n_grtrthan_rm <-0
    n_lessthan_lstat <-0
    n_grtrthan_lstat <-0

    mean_Y_lessthan_rm <-0
    mean_Y_grtrthan_rm <-0
    mean_Y_lessthan_lstat <-0
    mean_Y_grtrthan_lstat <-0

    sum_grtrthan_sqr_rm <-0
    sum_lessthan_sqr_rm <-0
    sum_grtrthan_sqr_lstat <-0
    sum_lessthan_sqr_lstat <-0

    # Getting Regions for all S
    for(i in 1:n_row){
      if(train_X$rm[i] < s_rm){
        sum_lessthan_rm = sum_lessthan_rm + train_Y[i]
        n_lessthan_rm = n_lessthan_rm + 1
      }
      else{
        sum_grtrthan_rm = sum_grtrthan_rm + train_Y[i]
        n_grtrthan_rm = n_grtrthan_rm + 1
      }
      if(train_X$lstat[i] < s_lstat){
        sum_lessthan_lstat = sum_lessthan_lstat + train_Y[i]
        n_lessthan_lstat = n_lessthan_lstat + 1
      }
      else{
        sum_grtrthan_lstat = sum_grtrthan_lstat + train_Y[i]
        n_grtrthan_lstat = n_grtrthan_lstat + 1
      }
    }
    mean_Y_lessthan_rm = sum_lessthan_rm/n_lessthan_rm
    mean_Y_grtrthan_rm = sum_grtrthan_rm/n_grtrthan_rm
    mean_Y_lessthan_lstat = sum_lessthan_rm/n_lessthan_lstat
    mean_Y_grtrthan_lstat = sum_grtrthan_rm/n_grtrthan_lstat

    for(i in 1:n_row){
      if(train_X$rm[i] <s_rm){
        sum_lessthan_sqr_rm <- sum_lessthan_sqr_rm + (train_Y[i] - mean_Y_lessthan_rm)^2
      }
      else{
        sum_grtrthan_sqr_rm <- sum_grtrthan_sqr_rm + (train_Y[i] - mean_Y_grtrthan_rm)^2
      }
      if(train_X$lstat[i] <s_lstat){
        sum_lessthan_sqr_lstat <- sum_lessthan_sqr_lstat + (train_Y[i] - mean_Y_lessthan_lstat)^2
      }
      else{
        sum_grtrthan_sqr_lstat <- sum_grtrthan_sqr_lstat + (train_Y[i] - mean_Y_grtrthan_lstat)^2
      }
    }
    RSS_lstat <- sum_grtrthan_sqr_lstat+sum_lessthan_sqr_lstat
    RSS_rm <- sum_grtrthan_sqr_rm+sum_lessthan_sqr_rm
    return(c(RSS_lstat,RSS_rm))
  }

  Rss_arr_rm <- matrix(nrow = n_row,ncol=1,byrow= TRUE)
  Rss_arr_lstat <- matrix(nrow = n_row,ncol=1,byrow= TRUE)
  for(i in 1:n_row){
    srm <- train_X$rm[i]
    slstat <- train_X$lstat[i]
    output <- Region(srm,slstat)
    #print(output)
    Rss_arr_rm[i] <- output[1]
    Rss_arr_lstat[i] <- output[2]
  }
  returnArray = c()
  sumlessthan <- numlessthan <-numgreaterthan<-sumgreaterthan<-meanYlessthan<-meanYgreatethan <- 0
  if(min(Rss_arr_lstat[1,]) > min(Rss_arr_rm[1,])){
    s_id = which.min(Rss_arr_rm)
    S <- train_X$rm[s_id]
    #caclulating regions R
    for(i in 1:n_row){
      #computing in each possible s
      if (train_X$rm[i] < S)
      {
        sumlessthan = sumlessthan+ train_Y[i]
        numlessthan =numlessthan+1
      }
      else{
        sumgreaterthan = sumgreaterthan+ train_Y[i]
        numgreaterthan = numgreaterthan+1
      }

    }
    meanYlessthan <- sumlessthan/numlessthan
    meanYgreatethan <- sumgreaterthan/numgreaterthan
    returnArray =c("rm",S,meanYlessthan,meanYgreatethan)
    return(returnArray)
  }
  else{
    sIndex =which.min(Rss_arr_lstat)
    S<- train_X$lstat[sIndex]
    #caclulating regions R
    for(i in 1:253){
      #computing in each possible s
      if (train_X$lstat[i] < S)
      {
        sumlessthan = sumlessthan+ train_Y[i]
        numlessthan =numlessthan+1
      }
      if(train_X$lstat[i] >S){
        sumgreaterthan = sumgreaterthan+ train_Y[i]
        numgreaterthan = numgreaterthan+1
      }

    }
    meanYlessthan <- sumlessthan/numlessthan
    meanYgreatethan <- sumgreaterthan/numgreaterthan
    returnArray= c("lstat",S,meanYlessthan,meanYgreatethan)
    return(returnArray)

  }
}

library(MASS)
data("Boston")
set.seed(0911)
n_row = nrow(Boston)
dt <- sample(1:n_row,n_row/2)
train <- Boston[dt,]
test <- Boston[-dt,]
train_Y <- train$medv;

dec_stmp = DS(train,train_Y)
y_hat = matrix(nrow=1, ncol=nrow(test))

test_sum_less_sqr <-0
test_sum_grtr_sqr <-0
if(dec_stmp[1]=="lstat"){
  for(i in 1:nrow(test)){
    if(test$lstat[i] <as.numeric(dec_stmp[2])){
      y_hat[i]=as.numeric(dec_stmp[3])
      test_sum_less_sqr = test_sum_less_sqr + (test$medv[i] - as.numeric(dec_stmp[3]))^2
    }
    else{
      y_hat[i]=as.numeric(dec_stmp[4])
      test_sum_grtr_sqr = test_sum_grtr_sqr + (test$medv[i] - as.numeric(dec_stmp[4]))^2
    }
  }
}
if(dec_stmp[1]=="rm"){
  for(i in 1:nrow(test)){
    if(test$rm[i] <as.numeric(dec_stmp[2])){
      y_hat[i]=as.numeric(dec_stmp[3])
      test_sum_less_sqr = test_sum_less_sqr + (test$medv[i] - as.numeric(dec_stmp[3]))^2
    }
    else{
      y_hat[i]=as.numeric(dec_stmp[4])
      test_sum_grtr_sqr = test_sum_grtr_sqr + (test$medv[i] - as.numeric(dec_stmp[4]))^2
    }
  }
}

test_mse <- (test_sum_grtr_sqr + test_sum_less_sqr)/nrow(test)
print(test_mse)

BDS <- function(B){
  DS_B<-matrix(nrow=B,ncol=4,byrow=TRUE)
  f_hat<-matrix(nrow=B,ncol=nrow(train),byrow=TRUE)
  for(i in 1:B){
    DS_B[i,]<-DS(train,train_Y)
    for(j in 1:nrow(train)){
      if(DS_B[i,1]=="lstat"){
        lstat_S <-as.numeric(DS_B[i,2])
        lstat_avg_less <-as.numeric(DS_B[i,3])
        lstat_avg_grtr <- as.numeric(DS_B[i,4])
        if(train$lstat[j] < lstat_S){
          f_hat[i,j] <- lstat_avg_less

        }else{
          f_hat[i,j] <- lstat_avg_grtr
        }

      }
      else if(DS_B[i,1]=="rm"){
        rm_S <- as.numeric(DS_B[i,2])
        rm_avg_less <-as.numeric(DS_B[i,3])
        rm_avg_grtr <- as.numeric(DS_B[i,4])
        if(train$rm[j] < rm_S){
          f_hat[i,j] <- rm_avg_less

        }else{
          f_hat[i,j] <- rm_avg_grtr
        }

      }
      ###
      train_Y[j] <- train_Y[j]-0.01*f_hat[i,j]

    }
  }
  #MSE
  sqrDiff <- 0
  for(i in 1:nrow(test)){
    predictionRule = sum(0.01*f_hat[,i])
    #print(phat[,i])
    sqrDiff <- sqrDiff+(test$medv[i]- (predictionRule))^2
  }
  print(c("test MSE:" ,sqrDiff/(nrow(test))))
  return(sqrDiff/(nrow(test)))
}

bds_1000=BDS(1000)


# Simple linear regression for machine learning.
#
# This file demonstrate knowledge of linear regression. By using
# conventional libraries.The idea of linear regression is to take continuous
# data and find the best fit of it to a line.
#
# Simple linear regression just refers to the fact that the features only
# includes one column. So the label is composed by just one variable and one
# constant.

# Importing the data set
dataset = read.csv('Salary_Data.csv')

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
set.seed(123) # choose random number, only same number for debugging
split = sample.split(dataset$Salary, SplitRatio = 2/3)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Fitting the Training set with Simple Linear regression model.
# Salary is propotional to YearsExperience and model built on training_set
regressor = lm(formula = Salary ~ YearsExperience, data = training_set)

# Predicting the Test set results
label_pred = predict(regressor, newdata = test_set)

# Visualising the regression line and training set
# install.packages("ggplot2")
# library(ggplot2)
ggplot() +
  geom_point(aes(x=training_set$YearsExperience, y=training_set$Salary),
             colour = 'red') +
  geom_line(aes(x=training_set$YearsExperience, y=predict(regressor, newdata = training_set)),
            colour = 'blue') +
  ggtitle('Experience vs Salary (Training set)') +
  xlab('Years of experience') +
  ylab('Salary')

# Visualising the regression line and test set
ggplot() +
  geom_point(aes(x=test_set$YearsExperience, y=test_set$Salary),
             colour = 'red') +
  geom_line(aes(x=training_set$YearsExperience, y=predict(regressor, newdata = test_set)),
            colour = 'blue') +
  ggtitle('Experience vs Salary (test set)') +
  xlab('Years of experience') +
  ylab('Salary')


# Chapter 6 Lab 1: Subset Selection Methods

# This code is quoted from
# http://faculty.marshall.usc.edu/gareth-james/ISL/code.html

# Best Subset Selection

library(ISLR)
fix(Hitters)
names(Hitters)
dim(Hitters)
sum(is.na(Hitters$Salary))
Hitters=na.omit(Hitters)
dim(Hitters)
sum(is.na(Hitters))
library(leaps)
regfit.full=regsubsets(Salary~.,Hitters)
summary(regfit.full)
regfit.full=regsubsets(Salary~.,data=Hitters,nvmax=19)
reg.summary=summary(regfit.full)
names(reg.summary)
reg.summary$rsq
par(mfrow=c(2,2))
plot(reg.summary$rss,xlab="Number of Variables",ylab="RSS",type="l")
plot(reg.summary$adjr2,xlab="Number of Variables",ylab="Adjusted RSq",type="l")
which.max(reg.summary$adjr2)
points(11,reg.summary$adjr2[11], col="red",cex=2,pch=20)
plot(reg.summary$cp,xlab="Number of Variables",ylab="Cp",type='l')
which.min(reg.summary$cp)
points(10,reg.summary$cp[10],col="red",cex=2,pch=20)
which.min(reg.summary$bic)
plot(reg.summary$bic,xlab="Number of Variables",ylab="BIC",type='l')
points(6,reg.summary$bic[6],col="red",cex=2,pch=20)
plot(regfit.full,scale="r2")
plot(regfit.full,scale="adjr2")
plot(regfit.full,scale="Cp")
plot(regfit.full,scale="bic")
coef(regfit.full,6)

# Forward and Backward Stepwise Selection

regfit.fwd=regsubsets(Salary~.,data=Hitters,nvmax=19,method="forward")
summary(regfit.fwd)
regfit.bwd=regsubsets(Salary~.,data=Hitters,nvmax=19,method="backward")
summary(regfit.bwd)
coef(regfit.full,7)
coef(regfit.fwd,7)
coef(regfit.bwd,7)

# Choosing Among Models

set.seed(1)
train=sample(c(TRUE,FALSE), nrow(Hitters),rep=TRUE)
test=(!train)
regfit.best=regsubsets(Salary~.,data=Hitters[train,],nvmax=19)
test.mat=model.matrix(Salary~.,data=Hitters[test,])
val.errors=rep(NA,19)
for(i in 1:19){
   coefi=coef(regfit.best,id=i)
   pred=test.mat[,names(coefi)]%*%coefi
   val.errors[i]=mean((Hitters$Salary[test]-pred)^2)
}
val.errors
which.min(val.errors)
coef(regfit.best,10)
predict.regsubsets=function(object,newdata,id,...){
  form=as.formula(object$call[[2]])
  mat=model.matrix(form,newdata)
  coefi=coef(object,id=id)
  xvars=names(coefi)
  mat[,xvars]%*%coefi
  }
regfit.best=regsubsets(Salary~.,data=Hitters,nvmax=19)
coef(regfit.best,10)
k=10
set.seed(1)
folds=sample(1:k,nrow(Hitters),replace=TRUE)
cv.errors=matrix(NA,k,19, dimnames=list(NULL, paste(1:19)))
for(j in 1:k){
  best.fit=regsubsets(Salary~.,data=Hitters[folds!=j,],nvmax=19)
  for(i in 1:19){
    pred=predict(best.fit,Hitters[folds==j,],id=i)
    cv.errors[j,i]=mean( (Hitters$Salary[folds==j]-pred)^2)
    }
  }
mean.cv.errors=apply(cv.errors,2,mean)
mean.cv.errors
par(mfrow=c(1,1))
plot(mean.cv.errors,type='b')
reg.best=regsubsets(Salary~.,data=Hitters, nvmax=19)
coef(reg.best,11)

# Chapter 6 Lab 2: Ridge Regression and the Lasso

x=model.matrix(Salary~.,Hitters)[,-1]
y=Hitters$Salary

# Ridge Regression

library(glmnet)
grid=10^seq(10,-2,length=100)
ridge.mod=glmnet(x,y,alpha=0,lambda=grid)
dim(coef(ridge.mod))
ridge.mod$lambda[50]
coef(ridge.mod)[,50]
sqrt(sum(coef(ridge.mod)[-1,50]^2))
ridge.mod$lambda[60]
coef(ridge.mod)[,60]
sqrt(sum(coef(ridge.mod)[-1,60]^2))
predict(ridge.mod,s=50,type="coefficients")[1:20,]
set.seed(1)
train=sample(1:nrow(x), nrow(x)/2)
test=(-train)
y.test=y[test]
ridge.mod=glmnet(x[train,],y[train],alpha=0,lambda=grid, thresh=1e-12)
ridge.pred=predict(ridge.mod,s=4,newx=x[test,])
mean((ridge.pred-y.test)^2)
mean((mean(y[train])-y.test)^2)
ridge.pred=predict(ridge.mod,s=1e10,newx=x[test,])
mean((ridge.pred-y.test)^2)
ridge.pred=predict(ridge.mod,s=0,newx=x[test,],exact=T,x=x[train,],y=y[train])
mean((ridge.pred-y.test)^2)
lm(y~x, subset=train)
predict(ridge.mod,s=0,exact=T,type="coefficients",x=x[train,],y=y[train])[1:20,]
set.seed(1)
cv.out=cv.glmnet(x[train,],y[train],alpha=0)
plot(cv.out)
bestlam=cv.out$lambda.min
bestlam
ridge.pred=predict(ridge.mod,s=bestlam,newx=x[test,])
mean((ridge.pred-y.test)^2)
out=glmnet(x,y,alpha=0)
predict(out,type="coefficients",s=bestlam)[1:20,]

# The Lasso

lasso.mod=glmnet(x[train,],y[train],alpha=1,lambda=grid)
plot(lasso.mod)
set.seed(1)
cv.out=cv.glmnet(x[train,],y[train],alpha=1)
plot(cv.out)
bestlam=cv.out$lambda.min
lasso.pred=predict(lasso.mod,s=bestlam,newx=x[test,])
mean((lasso.pred-y.test)^2)
out=glmnet(x,y,alpha=1,lambda=grid)
lasso.coef=predict(out,type="coefficients",s=bestlam)[1:20,]
lasso.coef
lasso.coef[lasso.coef!=0]

# Chapter 6 Lab 3: PCR and PLS Regression

# Principal Components Regression

library(pls)
set.seed(2)
pcr.fit=pcr(Salary~., data=Hitters,scale=TRUE,validation="CV")
summary(pcr.fit)
validationplot(pcr.fit,val.type="MSEP")
set.seed(1)
pcr.fit=pcr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV")
validationplot(pcr.fit,val.type="MSEP")
pcr.pred=predict(pcr.fit,x[test,],ncomp=7)
mean((pcr.pred-y.test)^2)
pcr.fit=pcr(y~x,scale=TRUE,ncomp=7)
summary(pcr.fit)

# Partial Least Squares

set.seed(1)
pls.fit=plsr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV")
summary(pls.fit)
validationplot(pls.fit,val.type="MSEP")
pls.pred=predict(pls.fit,x[test,],ncomp=2)
mean((pls.pred-y.test)^2)
pls.fit=plsr(Salary~., data=Hitters,scale=TRUE,ncomp=2)
summary(pls.fit)


# FUNCTIONS

sum_of_squares <- function(vec) {
    sum(vec ^ 2)
}

square_of_sum <- function(vec) {
    sum(vec) ^ 2
}

# SCRIPT

ten <- 1:10
hundred <- 1:100

stopifnot(sum_of_squares(ten) == 385)
stopifnot(square_of_sum(ten) == 3025)
stopifnot(square_of_sum(ten) - sum_of_squares(ten) == 2640)

cat(square_of_sum(hundred) - sum_of_squares(hundred), "\n")


## Helper function to evaluate a string formula -------------------------------
EvalFormula <- function(k, expr_str) {
  .env <- new.env()
  sapply(c(k), function(k) {
    .env$k <- k
    eval(expr = parse(text = expr_str),
         envir = .env)
  })
}

## PARAMS ---------------------------------------------------------------------
MAX_TERMS <- 10
r_PTS <- c(1, 7/8, 3/4, 1/2)
color_palette <- RColorBrewer::brewer.pal(n = 3 + length(r_PTS), name = "Set3")

## INPUTS ---------------------------------------------------------------------

# example 1
pattern <- "(-1)^(k)"
abel_series_sum <- "1/(1+r)"

# # example 2
# pattern <- "(-1)^(k+1)"
# abel_series_sum <- "-1/(1+r)"

# # example 3
# pattern <- "(-1)^(k)*(k+1)"
# abel_series_sum <- "1/(1+r)^2"

## Comparison and Demonstration of Summation Methods --------------------------

# construct terms of the sequence
indices <- seq(from = 0, to = MAX_TERMS - 1, by = 1) # starting from 0
series <- EvalFormula(indices, pattern)

# compute Cauchy partial sum
partial_sum <- cumsum(series)

# compute Cesaro partial mean
cesaro_mean <- cumsum(partial_sum) / ( indices + 1 )

# compute Abel mean at a few points
abel_mean_func <- function(r)
  EvalFormula(r, gsub(pattern = "r", replacement = "k", x = abel_series_sum))
abel_mean <- abel_mean_func(r_PTS)
abel_weights <- t(sapply(r_PTS, function(r) r^indices))
abel_weights <- abel_weights[2:nrow(abel_weights),]

# plot

p <- plotly::plot_ly()

p <- plotly::add_trace(
  p, type = "scatter", mode = "lines",
  x = as.ordered(indices), y = abel_mean[1], yaxis = "y",
  name = "Limit --> Sum", hoverlabel = list(namelength = -1),
  line = list(color = "#000000", width = 2) )

for ( idx in seq(from = 2, to = length(r_PTS)) ) {
  p <- plotly::add_trace(
    p, type = "bar", alpha = 0.5, yaxis = "y2",
    x = as.ordered(indices), y = abel_weights[idx-1,],
    name = paste0("Abel Weights with r = ", sprintf("%.4f", r_PTS[idx])),
    hoverlabel = list(namelength = -1),
    color = color_palette[idx] )
  p <- plotly::add_trace(
    p, type = "scatter", mode = "lines",
    x = as.ordered(indices), y = abel_mean[idx], yaxis = "y",
    name = paste0("Abel Sum with r = ", sprintf("%.4f", r_PTS[idx])),
    hoverlabel = list(namelength = -1),
    color = color_palette[idx], alpha = 0.5 )
}

p <- plotly::add_trace(
  p, type = "scatter", mode = "lines+markers",
  x = as.ordered(indices), y = series, yaxis = "y",
  name = "Sequence a_k", hoverlabel = list(namelength = -1),
  color = color_palette[length(r_PTS) + 1], alpha = 0.7 )
p <- plotly::add_trace(
  p, type = "scatter", mode = "lines+markers",
  x = as.ordered(indices), y = partial_sum, yaxis = "y",
  name = "Cauchy Partial Sum s_k", hoverlabel = list(namelength = -1),
  color = color_palette[length(r_PTS) + 2] )
p <- plotly::add_trace(
  p, type = "scatter", mode = "lines+markers",
  x = as.ordered(indices), y = cesaro_mean, yaxis = "y",
  name = "Cesaro Partial Mean sigma_k", hoverlabel = list(namelength = -1),
  color = color_palette[length(r_PTS) + 3] )

p <- plotly::layout(
  p, hovermode = "compare", legend = list(orientation = "h", yanchor = "top"),
  barmode = "overlay",  # bargap = 0,
  yaxis  = list(title = "Value", side = "left", automargin = TRUE,
                showgrid = TRUE, zeroline = FALSE, overlaying = "y2"),
  yaxis2 = list(title = "Abel Weight", side = "right", automargin = TRUE, tickformat = ".2%",
                showgrid = FALSE, zeroline = FALSE),
  xaxis  = list(title = "Index", dtick = "L1",
                showgrid = TRUE, automargin = TRUE)
)

p


euclidean <- function(a, b) {
  return (sqrt(sum((a - b) ^ 2)))
}

kNN <- function(dset, labels, point, k, dist = euclidean) {
  distance <- array(dim=dim(dset)[1])
  for (j in 1:dim(dset)[1]) {
    distance[j] <- dist(dset[j,], point)
  }
  sortedDataset <- dset[order(distance),]
  sortedLabels <- labels[order(distance)]

  classScores <- array(0L, dim = length(unique(labels)))
  names(classScores) = unique(labels)
  for (j in 1:k) {
    classScores[sortedLabels[j]] <- classScores[sortedLabels[j]] + 1
  }
  classScores <- classScores / k

  return (classScores)
}

gaussKernel <- function(dist, h) exp(sqrt(h / pi * 0.5) * -0.5 * (dist * h) ^ 2)

parzen <- function(dset, labels, point, h, kernel, dist = euclidean) {
  dsetLength <- length(dset[,1])
  distances <- array(dim = c(dsetLength))

  uLabels <- unique(labels)
  classScores <- array(0L, dim = c(length(uLabels)))
  names(classScores) = uLabels;
  # classScores["undefined"] <- 0.000001

  for (i in 1:dsetLength) {
    classScores[labels[i]] <- classScores[labels[i]] + kernel(dist(point, dset[i,]), h)
  }

  return(classScores)
}

computeMargins <- function(dset, labels) {
  dsetLen <- dim(dset)[1]
  margins <- array(0L, dim = dsetLen)
  for (i in 1:dsetLen) {
    cat("\rProcessing", i, "of", dsetLen)
    # classScores <- kNN(dset[-i,], labels[-i], dset[i,], 6)
    classScores <- parzen(dset[-i,], labels[-i], dset[i,], 1.6, gaussKernel)
    # cat(paste(labels[i]), names(classScores[which.max(classScores)]), "\n")

    margins[i] <- classScores[labels[i]] - max(classScores[-as.integer(labels[i])])

    if (paste(labels[i]) != names(classScores[which.max(classScores)])) {
      #cat(classScores, labels[i], classScores[labels[i]], max(classScores[-which.max(classScores)]), classScores[-labels[i]], margins[i], "\n")
    }
  }
  cat("\n")

  return (margins)
}

# tt <- kNN(iris[3:4], iris$Species, c(2.5, 1.1), 6)
# tt <- parzen(iris[3:4], iris$Species, c(2.5, 1.1), 1.6, kernel = gaussKernel)

margins <- computeMargins(iris[3:4], iris$Species)

margins <- margins / max(abs(margins))
colors <- array(dim = length(margins))

for (i in 1:length(margins)) {
  colors[i] <- if (margins[i] > 0) rgb(1 - margins[i], 1, 0) else rgb(1, 1 - abs(margins[i]), 0)
}

par(mfcol = c(1,1))
plot(iris[,3], iris[,4], col = colors, pch = 16)

# 1 => rgb(0, 1, 0)
# 0.5 => rgb()
# 0 => rgb(1, 1, 0)
# -1 => rgb(1, 0, 0)

4 - Selection of reference objects/margin-plot.r


=begin
[((<index|URL:index.html>))]
((<Polynomial>))
/
((<PolynomialFactorization>))
/
((<Algebra::SplittingField>))
/
((<Algebra::Galois>))

= Polynomial
((*(Class of Polynomial Ring)*))

This class expresses the polynomial ring over arbitrary ring.
For creating the actual class, use the class method ((<::create>))
or ((<Algebra.Polynomial>)), giving the coefficient ring.

== File Name:
* ((|polynomial.rb|))

== SuperClass:

* ((|Object|))

== Included Modules

* ((|Enumerable|))
* ((|Comparable|))
* ((<Algebra::EuclidianRing>))
#* ((<PolynomialFactorization>))

== Associated Functions:

--- Algebra.Polynomial(ring [, obj0 , obj1 [, ...]])
    Same as ((<::create>))(ring, obj0[, obj1 [, ...]]).

== Class Methods:

--- ::create(ring, obj0[, obj1[, ...]])
    Creates a polynomial ring class over the coefficient ring
    expressed by the class: ((|ring|)).

    The objects designated in (({obj0, obj1, ...})) express the variables,
    and the polynomial ring on the polynomial ring is recursively created,
    if this is multiple.

    The value of this method is the subclass of Polynomial class.
    This subclass has the class methods: ((|ground|)), ((|var|)),
    and ((|vars|)), which return the coefficient ring ((|ring|)),
    the primary variable object(the latest one) and all variables,
    respectively.

    The objects (({obj0, obj1, ...})) are to utilize for the name
    (the value of ((|to_s|)) ) of the variable.

    Example: Polynomial ring over Integer
      require "polynomial"
      P = Algebra::Polynomial.create(Integer, "x")
      x = P.var
      p((x + 1)**100) #=> x^100 + 100x^99 + ... + 100x + 1
      p P.ground #=> integer

    Example: Multi variate Polynomial ring over Integer
      require "polynomial"
      P = Algebra::Polynomial.create(Integer, "x", "y", "z")
      x, y, z = P.vars
      p((-x + y + z)*(x + y - z)*(x - y + z))
      #=> -z^3 + (y + x)z^2 + (y^2 - 2xy + x^2)z - y^3 + xy^2 + x^2y - x^3
      p P.var #=> z

    This (({P})) is equal to

      Algebra::Polynomial.create(
        Algebra::Polynomial.create(
          Algebra::Polynomial.create(
            Integer,
          "x"),
        "y"),
      "z")

    and the last variable ((|z|)) is the primary variable.

--- ::var
    Returns the (primary) variable of the polynomial ring.

--- ::vars
    Returns the array of the variables of the polynomial rings,
    collecting recursively.

--- ::mvar
    Same as ((<::vars>)).

--- ::to_ary
    Returns (({[self, *vars]})).

    Example: Define Polynomial ring and variables simulteniously
      P, x, y, z = Algebra::Polynomial.create(Integer, "x", "y", "z")

--- ::variable
    Returns the object which expresses the (primary) variable of
    the polynomial ring.

--- ::variables
    Returns the array of the objects which express the variables of
    the polynomial rings, collecting recursively.

--- ::indeterminate(obj)
    Returns the variable expressed by ((|obj|)).

--- ::monomial([n])
    Returns the monomial of degree ((|n|)).

    Example:
      P = Polynomial(Integer, "x")
      P.monomial(3) #=> x^3

--- ::const(c)
    Returns the constant value ((|c|)).

    Example:
      P = Polynomial(Integer, "x")
      P.const(3)      #=> 3
      P.const(3).type #=> P

--- ::zero
    Returns the zero.

--- ::unity
    Returns the unity.

#--- ::euclidian?

== Methods:

--- var
    Same as ((<::var>)).

--- variable
    Same as ((<::variable>)).

--- each(&b)
    Iterates of coefficients in the ascendant power series.

    Example:
      P = Polynomial(Integer, "x")
      x = P.var
      (x**3 + 2*x**2 + 4).each do |c|
        p c #=> 4, 0, 2, 1
      end

--- reverse_each(&b)
    Iterates of coefficients in the descendent power series.

    Example:
      P = Polynomial(Integer, "x")
      x = P.var
      (x**3 + 2*x**2 + 4).reverse_each do |c|
        p c #=> 1, 2, 0, 4
      end

--- [](n)
    Returns the coefficient of degree ((|n|)).

--- []=(n, v)
    Sets the coefficient of degree ((|n|)) into ((|v|)).

--- monomial
    Same as ((<::monomial>)).

--- monomial?
    Returns true if self is a monomial.

--- zero?
    Returns true if self is the zero.

--- zero
    Returns the zero.

--- unity
    Returns the unity.

#--- variable=(bf)
#--- size
#--- compact!
#--- ground_div(n, d)

--- ==(other)
    Returns true if ((|self|)) is equal to ((|other|)).

--- <=>(other)
    Returns positive if ((|self|)) is greater than ((|other|)).

--- +(other)
    Returns the sum of ((|self|)) and ((|other|)).

--- -(other)
    Returns the difference of ((|self|)) from ((|other|)).

--- *(other)
    Returns the product of ((|self|)) and ((|other|)).

--- **(n)
    Returns the ((|n|))-th power of ((|self|)).

--- /(other)
    Returns the quotient of ((|self|)) by ((|other|)).
    Same as ((<div>)).

--- divmod(other)
    Returns the array [quotient, remainder] by ((|other|)).

--- div(other)
    Returns the quotient of ((|self|)) by ((|other|)).
    Same as (({divmod(other).first})).

--- %(other)
    Returns the remainder of ((|self|)) by ((|other|)).
    Same as (({divmod(other).last})).

--- divide?(other)
    Returns true if ((|self|)) is divisible by ((|other|)).
    Same as (({divmod(other).last == zero?})).

--- deg
    Returns the degree.

    Example:
      P = Polynomial(Integer, "x")
      x = P.var
      (5*x**3 + 2*x + 1).deg #=> 3

--- lc
    Returns the leading coefficient.

    Example:
      (5*x**3 + 2*x + 1).lc #=> 5

--- lm
    Returns the leading monomial.

    Example:
      (5*x**3 + 2*x + 1).lm #=> x**3

--- lt
    Returns the leading term).
    Same as (({lc * lm})).

    Example:
      (5*x**3 + 2*x + 1).lt #=> 5*x**3

--- rt
    Returns the rest term, which has the same value as (({self - lt})).

    Example:
      (5*x**3 + 2*x + 1).rt #=> 2*x + 1

--- monic
    Returns the polynomial, which corrected the maximum order coefficient in 1.
    Same as (({self / lc})) .

--- cont
    Returns the content (i.e. L.C.M of coefficients).

--- pp
    Returns the primitive part.
    Same as(({self / cont})).

--- to_s
    Returns the expression in strings.
    Use ((|display_type|)) in order to change the display format.
    The possible value of ((|display_type|)) is
    ((|:norm|))(default) and  ((|:code|)).

    Example:
      P = Polynomial(Integer, "x")
      x = P.var
      p 5*x**3 + 2*x + 1 #=>5x^3 + 2x + 1
      P.display_type = :code
      p 5*x**3 + 2*x + 1 #=> 5*x**3 + 2*x + 1

--- derivate
    Return the derivative.

    Example:
      (5*x**3 + 2*x + 1).derivate #=> 15*x**2 + 2

--- sylvester_matrix(other)
    Return the Sylvester matrix of ((|self|)) and ((|other|)).

--- resultant(other)
    Return the resultant of ((|self|)) with ((|other|))

--- project(ring[, obj]){|c, n| ... }
    Returns the sum of the evaluations
    of ... for each monomial of coefficient ((|c|)) and degree ((|n|)).
    If ((|obj|)) is omitted, it is assumed to be (({ring.var})).

    Example:
      require "polynomial"
      require "rational"
      P = Algebra::Polynomial(Integer, "x")
      PQ = Algebra::Polynomial(Rational, "y")
      x = P.var
      f = 5*x**3 + 2*x + 1
      p f.convert_to(PQ) #=> 5y^3 + 2y + 1
      p f.project(PQ) {|c, n| Rational(c) / (n + 1)} #=> 5/4y^3 + y + 1

--- evaluate(obj)
    Returns the value of ((|self|)) at ((|obj|)).
    This is equivalent to (({ project(ground, obj){|c, n| c} })).

    Example:
      require "polynomial"
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      f = x**3 - 3*x**2 + 1
      p f.evaluate(-1)    #=> -3 (in Integer)
      p f.evaluate(x + 1) #=> x^3 - 3x - 1 (in P)

--- call(obj)
    Same as ((<evaluate>)).

--- sub(var, value)
    Returns the value of substitution of a variable ((|var|)) by ((|value|)).

    Example:
      require "polynomial"
      P = Algebra::Polynomial(Integer, "x", "y", "z")
      x, y, z = P.vars
      f = (x - y)*(y - z - 1)
      p f.sub(y, z+1)    #=> 0

--- convert_to(ring)
    Returns the polynomial the one converted on ((|ring|)).
    This is equivalent to (({ project(ring){|c, n| c} })).

= PolynomialFactorization
((*(Module of Factorization)*))

The module of factorization of polynomials.

== File Name:
((|polynomial-factor.rb|))

== Methods:

--- sqfree
    Returns the square free parts.

--- sqfree?
    Returns true if square free.

--- irreducible?
    Returns true if irreducible

--- factorize
    Returns the factorization.

    The following type can be factorized:
    * Integer
    * Rational
    * prime field
    * Algebraic Field

= Algebra::SplittingField
((*(Module of Splitting Field)*))

The module of the minimal splitting field of polynomials.

== File Name:
* ((|splitting-field.rb|))

== Methods:

--- decompose([fac0])
    Returns

      [field, modulus, facts, roots, addelems]

    Here the elements are:
    ((|field|)) the mimimal splitting field of ((|poly|)),
    ((|def_polys|)) the irreducible polynomial needed for the splitting,
    ((|facts|)) the linear factors of ((|poly|)) over ((|field|)),
    ((|roots|)) the roots of ((|poly|)) and
    ((|proots|)) the sorted array of ((|roots|)) in order that
    the added elements to the base field first.

    ((|fac0|)) makes the factorization fast. (((|facts|)) and ((|fact0|))
    are the instance of ((|Algebra::Factors|))).
    Generally, ((|field|)) is the object of
    ((<AlgebraicExtensionField|algebraic-extension-field.html>)).
    If ((|self|)) is splitted linearlly,
    that is the ((<ground>)) ring own.

    Example:
      require "algebra"
      PQ = Polynomial(Rational, "x")
      x = PQ.var
      f = x**5 - x**4 + 2*x - 2
      field, def_polys, facts, roots, proots = f.decompose
      p def_polys #=> [a^4 + 2, b^2 + a^2]
      p facts    #=> (x - 1)(x - a)(x + a)(x - b)(x + b)
      p roots    #=> [1, a, -a, b, -b]
      p proots   #=> [a, b, 1, -a, -b]
      fp = Polynomial(field, "x")
      x = fp.var
      facts1 = Factors.new(facts.collect{|g, n| [g.call(x), n]})
      p facts1.pi == f.convert_to(fp) #=> true

--- splitting_field([fac0]))
    Returns the infomation of the splitting field of ((|self|)).
    Each field corresponds to the return value of ((<decompose>)):

    poly, field, roots, proots, def_polys

    The values of ((|roots|)) and ((|proots|)) are transrated in
    the elements of ((|fields|)).

    Example:
      require "algebra"
      PQ = Polynomial(Rational, "x")
      x = PQ.var
      f = x**5 - x**4 + 2*x - 2
      sf = f.splitting_field
      p sf.roots     #=> [1, a, -a, b, -b]
      p sf.proots     #=> [a, b, 1, -a, -b]
      p sf.def_polys #=> [a^4 + 2, b^2 + a^2]

= Algebra::Galois
((*(Module of Galois Group)*))

The module of Galois Group of polynomials

== File Name:
* ((|galois-group.rb|))

== Included Module:
(none)

== Associated Method

--- GaloisGroup.galois_group(poly)
    Same as ((<galois_group>)).

== Method:

--- galois_group
    Retuns the galois group of ((|self|)).
    Each elements of this is the object of
    ((<FiniteGroup|finite-group.html>)) of which elements are
    in ((<PermutationGroup|permutation-group.html>)).

    Example:
      require "rational"
      require "polynomial"

      P = Algebra.Polynomial(Rational, "x")
      x = P.var
      p( (x**3 - 3*x + 1).galois_group.to_a )
      #=>[[0, 1, 2], [1, 2, 0], [2, 0, 1]]

      (x**3 - x + 1).galois_group.each do |g|
        p g
      end
      #=> [0, 1, 2]
      #   [1, 0, 2]
      #   [2, 0, 1]
      #   [0, 2, 1]
      #   [1, 2, 0]
      #   [2, 1, 0]

=end


# Goals: Do bootstrap inference, as an example, for a sample median.

library(boot)

samplemedian <- function(x, d) {        # d is a vector of integer indexes
  return(median(x[d]))                  # The genius is in the x[d] notation
}

data <- rnorm(50)                          # Generate a dataset with 50 obs
b  <-  boot(data, samplemedian, R=2000)    # 2000 bootstrap replications
cat("Sample median has a sigma of ", sd(b$t[,1]), "\n")
plot(b)

# Make a 99% confidence interval
boot.ci(b, conf=0.99, type="basic")

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


probability_light=0.50
probability_medium=0.30
probability_heavy=0.20
# probability that member is light , medium and heavy  and no books borrow
probability_0_light=0.60
probability_0_medium=0.15
probability_0_heavy=0.05
#  the probability that the member is a light purchaser and purchases no books in 3 months
p=(probability_light*probability_0_light)/((probability_light*probability_0_light)+(probability_medium*probability_0_medium)+(probability_heavy*probability_0_heavy))
print(p)


pbenford <- function(d){
  return(log10(1+(1/d)))
}

get_lead_digit <- function(number){
  return(as.numeric(substr(number,1,1)))
}

fib_iter <- function(n){
  first <- 1
  second <- 0
  for(i in 1:n){
    sum <- first + second
    first <- second
    second <- sum
  }
  return(sum)
}

fib_sequence <- mapply(fib_iter,c(1:1000))
lead_digits <- mapply(get_lead_digit,fib_sequence)

observed_frequencies <- table(lead_digits)/1000
expected_frequencies <- mapply(pbenford,c(1:9))

data <- data.frame(observed_frequencies,expected_frequencies)
colnames(data) <- c("digit","obs.frequency","exp.frequency")
dev_percentage <- abs((data$obs.frequency-data$exp.frequency)*100)
data <- data.frame(data,dev_percentage)

print(data)


## Author: Sergio García Prado
## Title: Exercises with Solutions 4

rm(list = ls())

Q <- matrix(c(-4/10, 4/10,      0,      0,    0,
                1/2, -4/5,   3/10,      0,    0,
                  0,  3/4, -19/20,   2/10,    0,
                  0,    0,      1, -11/10, 1/10,
                  0 ,   0,      0,      1,    -1),
              5, 5, byrow = TRUE)

A <- cbind(Q[, 1:(nrow(Q) - 1)], rep(1, nrow(Q)))

## Should be solved via detailed balance equations...
(stationary <- solve(A)[nrow(Q), ])
# 0.456537618699781 0.365230094959825 0.14609203798393 0.029218407596786 0.00292184075967864

(machines.mean <- sum(4:0 * stationary))
# 3.24324324324324

(all.busy.ratio <- sum(stationary[3] / 2, stationary[4:5]))
# 0.10518626734843


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     17.10.2019
#modificado: 05.11.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")
library("modelr")

## 1. Modelling example
library("hexbin")

#diamonds data
?diamonds

fnam <- "../results/modelling/diamonds1.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
   geom_boxplot(aes(cut,price))
dev.off()

fnam <- "../results/modelling/diamonds2.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
   geom_boxplot(aes(clarity,price))
dev.off()

fnam <- "../results/modelling/diamonds3.tiff"
tiff(file=fnam,units="in",width=4,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
   geom_hex(aes(carat,price),bins=50)
dev.off()

diamonds2 <- diamonds %>%
  filter((x > 0) & (y > 0 & y < 20) & (z > 0 & z < 10)) %>%
  filter(carat <= 2.5) %>%
  select(carat,cut,color,clarity,price) %>%
  mutate(lprice = log(price), lcarat = log(carat))

fnam <- "../results/modelling/diamonds4.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_hex(aes(lcarat,lprice),bins=50)
dev.off()

#model 1
diamonds_mod <- lm(lprice ~ lcarat,data=diamonds2)
summary(diamonds_mod)

diamonds2 <- diamonds2 %>%
  add_predictions(diamonds_mod,"lpred") %>%
  add_residuals(diamonds_mod,"lresid") %>%
  mutate(pred = exp(lpred))

fnam <- "../results/modelling/diamonds5.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_hex(aes(carat,price),bins=50) +
    geom_line(aes(carat,pred),color="red")
dev.off()

fnam <- "../results/modelling/diamonds6.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_boxplot(aes(cut,lresid))
dev.off()

fnam <- "../results/modelling/diamonds7.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_boxplot(aes(clarity,lresid))
dev.off()

fnam <- "../results/modelling/diamonds8.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_hex(aes(lcarat,lresid),bins=50)
dev.off()

fnam <- "../results/modelling/diamonds9.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_point(aes(pred,price)) +
    geom_abline(aes(intercept=0,slope=1),size=1,color="white")
dev.off()

#model 2
diamonds_mod2 <- lm(lprice ~ lcarat + clarity + cut,data=diamonds2)
summary(diamonds_mod2)

diamonds2 <- diamonds2 %>%
  add_predictions(diamonds_mod2,"lpred2") %>%
  add_residuals(diamonds_mod2,"lresid2") %>%
  mutate(pred2 = exp(lpred2))

fnam <- "../results/modelling/diamonds10.tiff"
tiff(file=fnam,units="in",width=9,height=4.5,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_hex(aes(carat,price),bins=50) +
    geom_line(aes(carat,pred2),color="red") +
    facet_grid(cut ~ clarity)
dev.off()

fnam <- "../results/modelling/diamonds11.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_hex(aes(lcarat,lresid2),bins=50)
dev.off()

fnam <- "../results/modelling/diamonds12.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_point(aes(pred2,price)) +
    geom_abline(aes(intercept=0,slope=1),size=1,color="white")
dev.off()

## 2. Model Fitting
set.seed(12345)

#synthetic data
real_a1 <- 4.22
real_a2 <- 2.05
x <- round(runif(n=30,min=0,max=10),digits=2)
y <- real_a1*x + real_a2 + rnorm(n=30,mean=0,sd=1)
sim1 <- tibble(x,y)

#plot synthetic data
fnam <- "../results/modelling/synthetic1.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_point(aes(x,y))
dev.off()

#### 2.1. fit model (random search)
models <- tibble(
  a1 = runif(250,-20,40),
  a2 = runif(250,-5,5))

fnam <- "../results/modelling/synthetic2.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_abline(data=models,aes(intercept=a1,slope=a2),alpha=0.24) +
    geom_point(aes(x,y))
dev.off()

#Linear regression model
model1 <- function(a,dat){
  res <- a[1] + dat$x*a[2]
  return(res)
}

#Calculate Root-mean-squared-deviation
measure_distance <- function(params,dat){
  diff <- dat$y - model1(params,dat)
  res <- sqrt(mean(diff^2))
  return(res)
}

#Helper function to calculate RMSD for synthetic data "sim1"
sim1_dist <- function(a1,a2){
  res <- measure_distance(c(a1,a2),dat=sim1)
  return(res)
}

models <- models %>%
  mutate(RMSD = map2_dbl(a1,a2,sim1_dist))
print(models)

best_models <- models %>%
  filter(rank(RMSD) <= 10)

fnam <- "../results/modelling/synthetic3.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_point(aes(x,y),size=2,color="grey30") +
    geom_abline(data=best_models,aes(intercept=a1,slope=a2,color=-RMSD))
dev.off()

fnam <- "../results/modelling/synthetic4.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
models %>%
  ggplot() +
    geom_point(data=best_models,aes(a1,a2),size=4,color="red") +
    geom_point(aes(a1,a2,color=-RMSD))
dev.off()

#### 2.2. fit model (grid search)
models_grid <- expand.grid(
  a1 = seq(0,15,length=25),
  a2 = seq(2,5,length=25)) %>%
    mutate(RMSD=map2_dbl(a1,a2,sim1_dist))
head(models_grid,n=15)

best_grid <- models_grid %>%
  filter(rank(RMSD) <= 10)

fnam <- "../results/modelling/synthetic5.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_point(aes(x,y),size=2,color="grey30") +
    geom_abline(data=best_grid,aes(intercept=a1,slope=a2,color=-RMSD))
dev.off()

fnam <- "../results/modelling/synthetic6.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
models_grid %>%
  ggplot() +
    geom_point(data=best_grid,aes(a1,a2),size=4,color="red") +
    geom_point(aes(a1,a2,color=-RMSD))
dev.off()

#### 2.3. fit model (Newton-Raphson optimization)
best_optim <- optim(c(0,0),measure_distance,dat=sim1)
best_a1 <- best_optim$par[1]
best_a2 <- best_optim$par[2]

fnam <- "../results/modelling/synthetic7.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_point(aes(x,y),size=2,color="grey30") +
    geom_abline(aes(intercept=best_a1,slope=best_a2))
dev.off()

#### 2.4. fit model (Least-Squares method)
best_lm <- lm(y ~ x,data=sim1)
best_a1 <- best_lm$coef[1]
best_a2 <- best_lm$coef[2]

fnam <- "../results/modelling/synthetic8.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_point(aes(x,y),size=2,color="grey30") +
    geom_abline(aes(intercept=best_a1,slope=best_a2))
dev.off()

#### 2.5. summary
res1 <- models %>%
  filter(rank(RMSD) == 1)

res2 <- models_grid %>%
  filter(rank(RMSD) == 1)

res3 <- tibble(
  a1 = best_optim$par[1],
  a2 = best_optim$par[2],
  RMSD = best_optim$value)

res4 <- tibble(
  a1 = best_lm$coef[1],
  a2 = best_lm$coef[2],
  RMSD = sqrt(mean(best_lm$residuals^2)))

tab1 = round(data.frame(rbind(res1,res2,res3,res4)),digits=2)
rownames(tab1) = c("random","grid","NR","LS")
fnam = "../results/modelling/fitting1.txt"
write.table(tab1,fnam,sep=",",row.names=TRUE,col.names=NA)

## 3. Model Diagnostic
set.seed(12345)

#synthetic data
real_a1 <- 4.22
real_a2 <- 2.05
x <- round(runif(n=30,min=0,max=10),digits=2)
y <- real_a1*x + real_a2 + rnorm(n=30,mean=0,sd=1)
sim1 <- tibble(x,y)

#fit model
sim1_mod <- lm(y ~ x,data=sim1)

sim1 <- sim1 %>%
  add_predictions(sim1_mod) %>%
  add_residuals(sim1_mod)
print(sim1)

#scatterplot y~x
fnam <- "../results/modelling/visualization1.tiff"
tiff(file=fnam,units="in",width=3,height=2.4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_point(aes(x,y),size=2,color="grey30") +
    geom_line(aes(x,pred)) +
	geom_segment(aes(x=x,xend=x,y=y,yend=pred),alpha=0.2)
dev.off()

#scatterplot y~pred
fnam <- "../results/modelling/visualization2.tiff"
tiff(file=fnam,units="in",width=3,height=2.4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_abline(aes(intercept=0,slope=1),size=2,color="white") +
    geom_point(aes(pred,y),size=2,color="grey30")
dev.off()

#density(residuals)
fnam <- "../results/modelling/visualization3.tiff"
tiff(file=fnam,units="in",width=3,height=2.4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_density(aes(resid)) +
    stat_function(fun=dnorm,color="red",args=list(mean=0,sd=1))
dev.off()

#scatterplot res~x
fnam <- "../results/modelling/visualization4.tiff"
tiff(file=fnam,units="in",width=3,height=2.4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_hline(aes(yintercept=0),size=2,color="white") +
    geom_point(aes(x,resid))
dev.off()

#qqplot(residuals)
fnam <- "../results/modelling/visualization5.tiff"
tiff(file=fnam,units="in",width=3,height=2.4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_qq_line(aes(sample=resid),size=2,color="white") +
    geom_qq(aes(sample=resid)) +
    labs(x="Theoretical Quantiles",y="Sample Quantiles")
dev.off()

#lagplot(residuals)
fnam <- "../results/modelling/visualization6.tiff"
tiff(file=fnam,units="in",width=3,height=2.4,res=300,compression="lzw")
sim1 %>%
  ggplot() +
    geom_point(aes(c(resid[-1],NA),resid)) +
    labs(x=expression(resid[i-1]),y=expression(resid[i]))
dev.off()


############################################
# Part v
p = 0.1
rho = 0.5
n = 200

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataAR1 = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    prob = p + rho*(dat[j]-p)
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataAR1(n,p,rho)
}

write(t(x),"p.10_ar50_n200_r100.txt",ncol=n) # each row in this file is a different simulated song

#############################################
# Part vi
p = 0.1
rho = 0.5
n = 600

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataAR1 = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    prob = p + rho*(dat[j]-p)
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataAR1(n,p,rho)
}

write(t(x),"p.10_ar50_n600_r100.txt",ncol=n) # each row in this file is a different simulated song

#############################################
# Part vii
p = 0.1
rho = 0.3
n = 200

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataAR1 = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    prob = p + rho*(dat[j]-p)
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataAR1(n,p,rho)
}

write(t(x),"p.10_ar30_n200_r100.txt",ncol=n) # each row in this file is a different simulated song

#############################################
# Part viii
p = 0.1
rho = 0.3
n = 600

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataAR1 = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    prob = p + rho*(dat[j]-p)
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataAR1(n,p,rho)
}

write(t(x),"p.10_ar30_n600_r100.txt",ncol=n) # each row in this file is a different simulated song

#############################################
# Part ix
p = 0.2
rho = 0.5
n = 200

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataAR1 = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    prob = p + rho*(dat[j]-p)
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataAR1(n,p,rho)
}

write(t(x),"p.20_ar50_n200_r100.txt",ncol=n) # each row in this file is a different simulated song

#############################################
# Part x
p = 0.2
rho = 0.5
n = 600

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataAR1 = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    prob = p + rho*(dat[j]-p)
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataAR1(n,p,rho)
}

write(t(x),"p.20_ar50_n600_r100.txt",ncol=n) # each row in this file is a different simulated song


=begin
= Algebra

2006.09.14

*Version: 0.72
*Author: Shin-ichiro HARA
*e-mail: sinara@blade.nagaokaut.ac.jp
*Home Page: ((<URL:http://blade.nagaokaut.ac.jp/~sinara/ruby/math/>))

== Preface

This is a library for mathematical computations.
Our purpose is to express the mathematical object naturally in Ruby.
Though it is not operated fast, we can see the algorithm of the
mathematical processing not in black box but in scripts.

This library is in development stage.
At present, things we can handle are as follows:

* One-variate polynomial
  * Fundamental operations (addition, multiplication, quotient/remainder, ...)
  * factorization
  * Galois group
* Multi-variate polynomial
  * Fundamental operations (addition, multiplication, ...)
  * factorization
  * Creating Groebner-basis, quotient/remainder by Groebner-basis.
* Algebraic systems
  * Creating quotient fields
  * Creating residue class fields
  * Operating matrices
  * Operating permutation groups
* Sets and Maps

== Installation

Install Ruby (See: ((<URL:http://www.ruby-lang.org/>)) ).

After expanding this archive, do

  ruby install.rb

Then all files and directories under ((|lib|)) are copyed in
the directory where Ruby can load.

To accelerate calculation, it is better to use an extension
library of rational number:
(((<URL:http://blade.nagaokaut.ac.jp/~sinara/ruby/rational/>))
than to use the stardard library rational.rb.

== Usage and Samples

See ((<index.html|URL:index.html>)) in ((|doc|)) directory, where
manuals and sample codes are.

== Reference
* D.Cox, J.Little and D.O'Shea, "IDEALS, VARIETIES AND ALGORITHMS", 1997, Springer.
* K. Kodama, "Polynomial", ((<URL:http://www.math.kobe-u.ac.jp/HOME/kodama/tips-RubyPoly.html>))
* H.Anai, M.Noro and K.Yokoyama, "Computation of the splitting fields and the Galois groups of polynomials", Progres in Mathematics, 28-50, Vo.143, 1996

=end


compute_π <- function(trials) {
    points <- matrix(runif(2*trials), nrow=2)
    inside <- sum(colSums(points^2) <= 1.0)
    return(4.0*inside/trials)
}

args = commandArgs(trailingOnly=TRUE)
if(length(args) < 1) {
    error("must provide number of trials")
}
trials = as.integer(args[1])
set.seed(2018)

start.time <- Sys.time()
invisible(compute_π(trials))
stop.time <- Sys.time()
cat("First invocation: ", stop.time - start.time, "s\n")

start.time <- Sys.time()
π <- compute_π(trials)
stop.time <- Sys.time()
cat("Second invocation:", stop.time - start.time, "s\n")

cat("π ≈ ", π, "\n")


##########################################################
#### R code for adding noise to correlation matrices  ####
#### J. Hardin, S.R. Garcia, D. Golan                 ####
#### last updated 1/18/2013                           ####
##########################################################

#################
##   EXAMPLE   ##
#################

# adding noise to a 15x15 identity matrix

noise.iden <- noisecor(diag(15), epsilon = .5, eidim=2)

# adding noise to a 2 block constant correlation matrix
rho.blck = c(.9,.2)
eps.blck = 0.99 - max(rho.blck)
samp.blck <- simcor(k = 2, size = c(10, 5), rho = c(0.9, 0.2), delta = 0.39, epsilon = eps.blck, eidim = 2)

# adding noise to a 2 block correlation matrix with an AR(1) strucutre
rho.Top = c(.7,.9)
eps.Top = (1-max(rho.Top))/(1+max(rho.Top)) - .01
samp.Top <- simcorTop(k=2, size=c(10,5), rho=c(.7,.9), epsilon = eps.Top, eidim=2)

# adding noise to a 2 block correlation matrix with a Hub structure
rho.Hub = c(.9,.7)
tau.Hub = c( (.9 - .7) / (10-2), (.7-.6)/(5-2))
eps.Hub = min(1-(rho.Hub) - 0.75*(tau.Hub) ) - .01
samp.Hub <- simcor.H(k=2, size=c(10,5),	rho=rbind(c(.9,.7), c(.7,.6)), power=1,
	epsilon=eps.Hub, eidim=2)

########################
## The Basic Function ##
########################

# this adds noise to any user specified correlation matrix

noisecor <- function(cormat, epsilon = .01, eidim=2){

ndim=dim(cormat)[1]
diag(cormat) <- 1 - epsilon

### adding noise to the correlation matrix

eivect <- c( )
for (i in 1:ndim) {
	ei <- runif(eidim, -1, 1)
	eivect <- cbind(eivect, sqrt(epsilon) * ei / sqrt(sum(ei^2) ) )
}

bigE <- t(eivect) %*% eivect
cor.nz <- cormat + bigE
cor.nz

}

#######################################
##  Simulating different correlation ##
##  structures as in Hardin et al.   ##
#######################################

################################
##  Simulating the Constant Correlation
################################

# this function simulates a block correlation matrix
# The size and base correlation for each block is user specified
# There is an additional delta parameter for the off diagonal correlations

# k is the number of groups
# size is a vector of length k specifying the size of each group
# rho is a vector of length k specifying base correlation values
# epsilon <- 0.99 - max(rho)
# eidim is the space from which the noise is generated, the smaller the more noise
# delta is the correlation of the off diagonal blocks

simcor = function (k = 6, size = c(10, 5, 8, 2, 15, 50), rho = c(0.7,
    0.7, 0.5, 0.9, 0.85, 0.4), delta = 0.39, epsilon = 0.99 -
    max(rho), eidim = 2)
{
    ndim <- sum(size)
    bigcor <- matrix(rep(delta, ndim * ndim), ncol = ndim)
    for (i in 1:k) {
        cor <- matrix(rep(rho[i], size[i] * size[i]), ncol = size[i])
        if (i == 1) {bigcor[1:size[1], 1:size[1]] <- cor}
        if (i != 1) {bigcor[(sum(size[1:(i - 1)]) + 1):sum(size[1:i]),
                (sum(size[1:(i - 1)]) + 1):sum(size[1:i])] <- cor}
    }
    diag(bigcor) <- 1 - epsilon

    eivect <- c()
    for (i in 1:ndim) {
        ei <- runif(eidim, -1, 1)
        eivect <- cbind(eivect, sqrt(epsilon) * ei/sqrt(sum(ei^2)))
    }
    bigE <- t(eivect) %*% eivect
    cor.nz <- bigcor + bigE
    cor.nz
}

################################
##  Simulating the Toeplitz Matrix
################################

# this function calculates an AR(1) Toeplitz matrix
# with a block diagonal structure.  The size and base correlation for each
# block is user specified

# k is the number of groups
# size is a vector of length k specifying the size of each group
# rho is a vector of length k specifying base correlation values
# epsilon <- (1-max(rho))/(1+max(rho)) - .01
# eidim is the space from which the noise is generated, the smaller the more noise

simcorTop <- function(k=6,size=c(10,5,8,2,15,50),rho=c(.7,.7,.5,.9,.85,.4),epsilon= .01, eidim=2) {

ndim <- sum(size)# dim of correlation matrix
bigcor<- matrix(rep(0, ndim*ndim), ncol=ndim)

### generating the basic correlation matrix

for (i in 1:k){

	top <- c(1,rho[i]^(seq(1:(size[i]-1))))
	cor <- toeplitz(top)

	if (i==1){bigcor[1:size[1], 1:size[1]] <- cor}
	if (i!=1){bigcor[(sum(size[1:(i-1)]) + 1):sum(size[1:i]),
		(sum(size[1:(i-1)]) + 1):sum(size[1:i])] <- cor}
	}

diag(bigcor) <- 1 - epsilon

### adding noise to the correlation matrix

eivect <- c( )
for (i in 1:ndim) {
	ei <- runif(eidim, -1, 1)
	eivect <- cbind(eivect, sqrt(epsilon) * ei / sqrt(sum(ei^2) ) )
}

bigE <- t(eivect) %*% eivect
cor.nz <- bigcor + bigE
cor.nz

}

################################
##  Simulating the Hub Matrix (entries filled in using Toeplitz structure)
################################

# this function calculates a Toeplitz matrix with values descending
# from a user specified maximum to minimum.  The matrix has a
# block diagonal structure.  The size and base correlation for each
# block is user specified.

# k is the number of groups
# size is a vector of length k specifying the size of each group
# rho is a vector of length k specifying base correlation values
# epsilon <- (1-min(rho) - 0.75*min(tau) ) - .01
# tau_k = (max(rho_k) - min(rho_k) )/ (size_k -2)
# eidim is the space from which the noise is generated, the smaller the more noise
# power = 2 makes the correlations stay high
# power = 0.5 makes the correlations descent rapidly

simcor.H <- function(k=6, size=c(10,5,8,7,15,50),
	rho=rbind(c(.9,.7), c(.7,.7), c(.7,.2), c(.5,.3), c(.9,.85), c(.3,.2)), power=1,
	epsilon=.08, eidim=2){

	ndim <- sum(size)# dim of correlation matrix
	bigcor<- matrix(rep(0, ndim*ndim), ncol=ndim)

### generating the basic correlation matrix

	for (i in 1:(k) ){

	cor <- toeplitz(rho.func(rho[i,1],rho[i,2],power,size[i]) )

	if (i==1){bigcor[1:size[1], 1:size[1]] <- cor}
	if (i!=1){bigcor[(sum(size[1:(i-1)]) + 1):sum(size[1:i]),
		(sum(size[1:(i-1)]) + 1):sum(size[1:i])] <- cor}
	}
	diag(bigcor) <- 1 - epsilon

### adding noise to the correlation matrix

	eivect <- c( )
	for (i in 1:ndim) {
	ei <- runif(eidim, -1, 1)
	eivect <- cbind(eivect, sqrt(epsilon) * ei / sqrt(sum(ei^2) ) )
	}

	bigE <- t(eivect) %*% eivect
	cor.nz <- bigcor + bigE
	cor.nz
	}

# rho.func is needed for filling in the rest of the structure of the Hub
# correlation matrix
# r.max is the maximum user specified correlation
# r.min is the minimum user specified correlation
# power is the power at which the correlations descend
# p is the size of the correlation block

rho.func <- function(r.max, r.min, power,p){
	rhovec <-c()

	rhovec[1] <- 1
	for(i in 2:p){
	rhovec[i] <- r.max - ((i-2)/(p-2))^power*(r.max-r.min)
	}
	rhovec}


# 4. faza: Analiza podatkov

# 1.regresijska premica: ŠTEVILO UMRLIH V CESTNOPROMETNIH NESREČAH NA 10.000 REGISTRIRANIH MOTORNIH VOZIL V NASLEDNJIH LETIH

grupa <- group_by(preminuli, Leto)
preminuli_Slovenija <- summarise(grupa, Stevilo=(sum(Preminuli, na.rm = TRUE)))
preminuli_Slovenija <- transform(preminuli_Slovenija, Stevilo = (Stevilo / 12))
preminuli_Slovenija$Stevilo <- round(preminuli_Slovenija$Stevilo, digits=2)
prileganje <- lm(data = preminuli_Slovenija, Stevilo ~ Leto )
m <- data_frame(Leto=seq(2019,2023,1))
predvidevanje <- mutate(m, Stevilo=predict(prileganje,m))
predvidevanje$Stevilo <- round(predvidevanje$Stevilo, digits = 2)

graf_regresijska_premica_preminulih <- ggplot(preminuli_Slovenija, aes(x=Leto, y=Stevilo)) +
  geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=predvidevanje, aes(x=Leto, y=Stevilo), color='red', size=2) +
  geom_point() +
  labs(title='Predvidevanje števila smrti v prometu v naslednjih letih', y="Stevilo")

# 2.regresijska premica: ŠTEVILO OSEBNIH AVTOMOBILOV NA 1000 PREBIVALCEV V PRIHODNOSTI
oseb_avto <- group_by(osebni_avtomobili,Leto)
oseb_avto1 <- summarise(oseb_avto, Stevilo=sum(Osebni_avtomobili, na.rm=TRUE))
oseb_avto_regije <- transform(oseb_avto1, Stevilo = Stevilo / 12)
oseb_avto_regije$Stevilo <- round(oseb_avto_regije$Stevilo, digits=2)
prileganje <- lm(data = oseb_avto_regije, Stevilo ~ Leto )
n <- data_frame(Leto=seq(2020,2024,1))
predvidevanje_oseb_avto <- mutate(n, Stevilo=predict(prileganje, n))

graf_regresijske_premice_oseb_avto <- ggplot(oseb_avto_regije, aes(x=Leto, y=Stevilo)) +
  geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=predvidevanje_oseb_avto, aes(x=Leto, y=Stevilo), color='red', size=2) +
  geom_point() +
  labs(title='Predvidevanje števila osebnih avtomobilov na 1000 prebivalcev v prometu v prihodnosti', y="Stevilo")

# Cluster regij: ŠTEVILO UMRLIH V CESTNOPROMETNIH NESREČAH

# Preminuli
grup <- group_by(preminuli, Regija)
preminuli_sum <- summarise(grup, vsote=sum(Preminuli, na.rm = TRUE))

preminuli_e <- dcast(preminuli, Regija~Leto, value.var = 'Preminuli' )
preminuli_e <- left_join(preminuli_e, preminuli_sum, by = 'Regija')
preminuli_e <- preminuli_e[order(preminuli_e$vsote, decreasing = FALSE),]
preminuli_b <- preminuli_e[,-19]
preminuli_b <- preminuli_b[,-1]

n <- 5
fit <- hclust(dist(scale(preminuli_b)))
skupine <- cutree(fit, n)

cluster <- mutate(preminuli_e, skupine)
cluster <- cluster[,-2:-19]
colnames(cluster) <- c("Regija", "Preminuli")

# zemljevid

Regije <- unique(zemljevid$NAME_1)
Regije <- as.data.frame(Regije, stringsAsFactors=FALSE)
names(Regije) <- "Regija"
skupaj <- left_join(Regije, cluster, by="Regija")

zemljevid_cluster_preminuli <- ggplot() + geom_polygon(data=left_join(zemljevid, skupaj, by=c("NAME_1"="Regija")),
                                                   aes(x=long, y=lat, group=group,
                                                       fill=factor(Preminuli))) +
  geom_line() +
  theme(axis.text.x=element_blank(), axis.ticks.x=element_blank(), axis.text.y=element_blank(),
        axis.ticks.y=element_blank()) +
  guides(fill=guide_colorbar(title="Skupine")) +
  ggtitle('Razvrstitev regij v skupine glede na število preminulih v cestnoprometnih nesrečah na 10.000 registriranih motornih vozil') +
  labs(x = " ") +
  labs(y = " ") +
  scale_fill_brewer(palette="YlOrRd", na.value = "#e0e0d1")

#SHINY

graf.regije <- function(regija){
  ggplot(preminuli %>% filter(Regija %in% regija)) + aes(x=Leto, y=Preminuli, group=Regija, color=Regija) +
    geom_line() + geom_point()+ xlab("Leto") + ylab("Število preminulih") +
    theme(axis.text.x = element_text(angle = 90, vjust = 0.3, hjust=1))
}

graf_osebni_avto <- function(cifra) {
  ggplot(osebni_avtomobili %>% filter(Leto==cifra), aes(x=Regija, y=Osebni_avtomobili, fill=factor(Regija))) +
    ylim(0, 650) + geom_bar(stat = "identity") +
    xlab("Regija") + ylab("Število osebnih avtomobilov") +
    theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1, vjust = 0.5)) +
    labs(fill='Regija')

}