#' Populate Sample Columns
#'
#' Creates ConcAve and ConcLow based on Uncen. Removes any samples with NA values in ConcHigh.
#'
#' @param rawData dataframe with dateTime, ConcLow, ConcHigh, Uncen
#' @return Sample2 dataframe with columns: Date, ConcLow, ConcHigh, Uncen, ConcAve, Julian,
#' Month, Day, DecYear, MonthSeq, waterYear, SinDY, and CosDY (DY = decimal year)
#' @export
#' @examples
#' dateTime <- c('1985-01-01', '1985-01-02', '1985-01-03')
#' ConcLow <- c(1,2,0)
#' ConcHigh <- c(1,2,3)
#' Uncen <- c(1,1,0)
#' dataInput <- data.frame(dateTime, ConcLow, ConcHigh, Uncen, stringsAsFactors=FALSE)
#' Sample <- populateSampleColumns(dataInput)
populateSampleColumns <- function(rawData){  # rawData is a dataframe with dateTime, ConcLow, ConcHigh, Uncen
  Sample <- as.data.frame(matrix(ncol=3,nrow=length(rawData$dateTime)))
  colnames(Sample) <- c('Date', 'ConcLow','ConcHigh')
  Sample$Date <- rawData$dateTime
  Sample$ConcLow <- rawData$ConcLow
  Sample$ConcHigh <- rawData$ConcHigh
  Sample$Uncen <- rawData$Uncen
  Sample$ConcAve <- ifelse(Sample$ConcHigh == 0, Sample$ConcLow*1.5, (Sample$ConcLow + Sample$ConcHigh)/2)
  Sample$ConcLow <- ifelse((rawData$ConcLow == 0.0 & rawData$Uncen == 0),NA,rawData$ConcLow)
  Sample$ConcHigh <- ifelse((rawData$ConcHigh == 0 & rawData$Uncen == 0), NA, rawData$ConcHigh)

  dateFrame <- populateDateColumns(rawData$dateTime)
  Sample <- cbind(Sample, dateFrame[,-1])

  Sample$SinDY <- sin(2*pi*Sample$DecYear)
  Sample$CosDY <- cos(2*pi*Sample$DecYear)
  # Sample2 <- subset(Sample, (!is.na(Sample$ConcHigh)))  # Was just ConcHigh.....
  return (Sample)
}


# Databricks notebook source
# MAGIC %md
# MAGIC ## LASSO Regression model
# MAGIC Lasso stands for Least Absolute Shrinkage and Selection Operator. It makes use of L1 regularization technique in the objective function.
# MAGIC
# MAGIC Lasso regression is a parsimonious model that performs L1 regularization. The L1 regularization adds a penalty equivalent to the absolute magnitude of regression coefficients and tries to minimize them
# MAGIC
# MAGIC Lasso regression can perform in-built variable selection as well as parameter shrinkage. While using ridge regression one may end up getting all the variables but with Shrinked Paramaters.

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

# MAGIC %md

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

# MAGIC %sh
# MAGIC install.packages("lme4")

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

library(lme4)
library(tidyverse)
library(pscl)
library(parameters)
library(gt)
library(gsubfn)
library(proto)
library(sqldf)
library(RSQLite)
library(glmnet)
library(usethis)
library(devtools)
library(visdat)
library(skimr)
library(caret)
library(DataExplorer)

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

# MAGIC %sh ls /dbfs/FileStore/tables/

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

data<-read.csv("/dbfs/FileStore/tables/all_vars_for_zeroinf_analysis.csv")

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

head(data, 10)

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

dim(data)

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

glimpse(data)

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

summary(data)

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

str(data)

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

colnames(data)

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

colnames(data) <- c( "county", "confirmed_cases" , "confirmed_deaths" ,
 "state"  ,"length_of_lockdown" ,"cases" ,"deaths","POP_ESTIMATE_2018" , "total_state_pop",	'Active_Physicians_per_100000_Population_2018_AAMC',	'Total_Active_Patient_Care_Physicians_per_100000_Population_2018_AAMC',	'Active_Primary_Care_Physicians_per_100000_Population_2018_AAMC',	'Active_Patient_Care_Primary_Care_Physicians_per_100000_Population_2018_AAMC',	'Active_General_Surgeons_per_100000_Population_2018_AAMC',	'Active_Patient_Care_General_Surgeons_per_100000_Population_2018_AAMC',	'Percentage_of_Active_Physicians_Who_Are_Female_2018_AAMC',	'Percentage_of_Active_Physicians_Who_Are_Intertiol_Medical_Graduates_IMGs-2018_AAMC',	'Percentage_of_Active_Physicians_Who_Are_Age_60_or_Older_2018_AAMC',	'MD_and_DO_Student_Enrollment_per_100000_Population_AY_2018_2019_AAMC',	'Student_Enrollment_at_Public_MD_and_DO_Schools_per_100000_Population_AY_2018_2019_AAMC',	'Percentage_Change_in_Student_Enrollment_at_MD_and_DO_Schools_2008_2018_AAMC',	'Percentage_of_MD_Students_Matriculating_In_State_AY_2018_2019_AAMC',	'Total_Residents_Fellows_in_ACGME_Programs_per_100000_Population_as_of_December_31_2018_AAMC',	'Total_Residents_Fellows_in_Primary_Care_ACGME_Programs_per_100000_Population_as_of_Dec_31_2018_AAMC',	'Percentage_of_Residents_in_ACGME_Programs_Who_Are_IMGs_as_of_December_31_2018_AAMC',	'Ratio_of_Residents_and_Fellows_GME_to_Medical_Students_UME-AY_2017_2018_AAMC',	'Percent_Change_in_Residents_and_Fellows_in_ACGME_Accredited_Programs_2008_2018_AAMC',	'Percentage_of_Physicians_Retained_in_State_from_Undergraduate_Medical_Education_UME-2018_AAMC',	'All_Specialties_AAMC',	'State_Local_Government_hospital_beds_per_1000_people_2019',	'Non_profit_hospital_beds_per_1000_people_2019',	'For_profit_hospital_beds_per_1000_people_2019',	'Total_hospital_beds_per_1000_people_2019',	'Total_nurse_practitioners_2019',	'Total_physician_assistants_2019',	'Total_Hospitals_2019',	'Total_Primary_Care_Physicians_2019',	'Surgery_specialists_2019',	'Emergency_Medicine_specialists_2019',	'Total_Specialist_Physicians_2019',	'ICU_Beds',	'pop_fraction',	'Length_of_Life_rank',	'Quality_of_Life_rank',	'Health_Behaviors_rank',	'Clinical_Care_rank',	'Social-Economic_Factors_rank',	'Physical_Environment_rank',	'Adult_smoking_percentage',	'Adult_obesity_percentage',	'Excessive_drinking_percentage',	'Population_per_sq_mile',	'House_per_sq_mile',	'Share_of_Tests_with_Positive_COVID_19_Results', 'Number_of_Tests_with_Results_per_1000_Population'
)

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

view(data)

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

select(data, county, confirmed_cases)

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

data %>%
    group_by(county) %>%
    summarise(count = n())

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

vis_miss(data)
vis_dat(data)

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

skim(data)

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

#DataExplorer::create_report(data)

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

#colnames(data)

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

data %>%
select(county,length_of_lockdown, confirmed_cases,confirmed_deaths,POP_ESTIMATE_2018, POP_ESTIMATE_2018,ICU_Beds, Adult_obesity_percentage, Quality_of_Life_rank, Excessive_drinking_percentage, Population_per_sq_mile,
     Clinical_Care_rank, Adult_smoking_percentage,Total_Specialist_Physicians_2019,Physical_Environment_rank,  Number_of_Tests_with_Results_per_1000_Population) -> final_data

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

display(final_data)

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

#Creating dependent and independent variables.
final_data %>%
select(confirmed_deaths, ICU_Beds, Adult_obesity_percentage, Quality_of_Life_rank, Excessive_drinking_percentage, Population_per_sq_mile, Clinical_Care_rank, Adult_smoking_percentage, Total_Specialist_Physicians_2019, Physical_Environment_rank, Number_of_Tests_with_Results_per_1000_Population) -> X_variables

final_data %>%
select(confirmed_deaths) -> y_target

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

# MAGIC %md
# MAGIC
# MAGIC ### Linear Regression

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

set.seed(100)

index = sample(1:nrow(final_data), 0.7*nrow(final_data))

train = final_data[index,] # Create the training data
test = final_data[-index,] # Create the test data

dim(train)

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

train

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

dim(test)

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

lr = lm(confirmed_deaths ~  ICU_Beds + Adult_obesity_percentage + Quality_of_Life_rank + Excessive_drinking_percentage + Population_per_sq_mile + Clinical_Care_rank + Adult_smoking_percentage+ Total_Specialist_Physicians_2019 + Physical_Environment_rank + Number_of_Tests_with_Results_per_1000_Population, data = train)
summary(lr)

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

#Step 1 - create the evaluation metrics function

eval_metrics = function(model, df, predictions, target){
    resids = df[,target] - predictions
    resids2 = resids**2
    N = length(predictions)
    r2 = as.character(round(summary(model)$r.squared, 2))
    adj_r2 = as.character(round(summary(model)$adj.r.squared, 2))
    print(adj_r2) #Adjusted R-squared
    print(as.character(round(sqrt(sum(resids2)/N), 2))) #RMSE
}

# Step 2 - predicting and evaluating the model on train data
predictions = predict(lr, newdata = train)
eval_metrics(lr, train, predictions, target = 'confirmed_deaths')

# Step 3 - predicting and evaluating the model on test data
predictions = predict(lr, newdata = test)
eval_metrics(lr, test, predictions, target = 'confirmed_deaths')

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

# MAGIC %md
# MAGIC The above output shows that RMSE, one of the two evaluation metrics, is 80.82 for train data and 84.69  for test data. On the other hand, R-squared value is around 25 percent for both train and test data, which indicates bad performance.

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

# MAGIC %md
# MAGIC
# MAGIC ### Regularization

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

cols_reg = c('county', 'confirmed_deaths', 'ICU_Beds', 'Adult_obesity_percentage', 'Quality_of_Life_rank', 'Excessive_drinking_percentage', 'Population_per_sq_mile', 'Clinical_Care_rank', 'Adult_smoking_percentage', 'Total_Specialist_Physicians_2019', 'Physical_Environment_rank', 'Number_of_Tests_with_Results_per_1000_Population')

dummies <- dummyVars(confirmed_deaths ~ ., data = final_data[,cols_reg])

train_dummies = predict(dummies, newdata = train[,cols_reg])

test_dummies = predict(dummies, newdata = test[,cols_reg])

print(dim(train_dummies)); print(dim(test_dummies))

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

# MAGIC %md
# MAGIC
# MAGIC ## Ridge Regression
# MAGIC
# MAGIC Ridge regression is an extension of linear regression where the loss function is modified to minimize the complexity of the model.
# MAGIC
# MAGIC This modification is done by adding a penalty parameter that is equivalent to the square of the magnitude of the coefficients.

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

x = as.matrix(train_dummies)
y_train = train$confirmed_deaths

x_test = as.matrix(test_dummies)
y_test = test$confirmed_deaths

lambdas <- 10^seq(2, -3, by = -.1)
ridge_reg = glmnet(x, y_train, nlambda = 25, alpha = 0, family = 'gaussian', lambda = lambdas)

summary(ridge_reg)

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

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

cv_ridge <- cv.glmnet(x, y_train, alpha = 0, lambda = lambdas)
optimal_lambda <- cv_ridge$lambda.min
optimal_lambda

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

# MAGIC %md
# MAGIC The optimal lambda value comes out to be 7.943282 and will be used to build the ridge regression model

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

# Compute R^2 from true and predicted values
eval_results <- function(true, predicted, df) {
  SSE <- sum((predicted - true)^2)
  SST <- sum((true - mean(true))^2)
  R_square <- 1 - SSE / SST
  RMSE = sqrt(SSE/nrow(df))

  # Model performance metrics
data.frame(
  RMSE = RMSE,
  Rsquare = R_square
)

}

# Prediction and evaluation on train data
predictions_train <- predict(ridge_reg, s = optimal_lambda, newx = x)
eval_results(y_train, predictions_train, train)

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

# Prediction and evaluation on test data
predictions_test <- predict(ridge_reg, s = optimal_lambda, newx = x_test)
eval_results(y_test, predictions_test, test)

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

# MAGIC %md
# MAGIC 80.82 for train data and 84.69  for test data.
# MAGIC
# MAGIC The above output shows that the RMSE and R-squared values for the ridge regression model on the training data are 80.89787 and 25 percent, respectively. For the test data, the results for these metrics are 84 and 7 percent, respectively. There is an improvement in the performance compared with linear regression model.

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

# MAGIC %md
# MAGIC ### Lasso Regression model
# MAGIC
# MAGIC Lasso regression, or the Least Absolute Shrinkage and Selection Operator, is also a modification of linear regression.
# MAGIC
# MAGIC In lasso, the loss function is modified to minimize the complexity of the model by limiting the sum of the absolute values of the model coefficients (also called the l1-norm).
# MAGIC
# MAGIC The loss function for lasso regression can be expressed as below:
# MAGIC
# MAGIC Loss function = OLS + alpha * summation (absolute values of the magnitude of the coefficients)

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

# MAGIC %md
# MAGIC
# MAGIC The first step to build a lasso model is to find the optimal lambda value using the code below.

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

lambdas <- 10^seq(2, -3, by = -.1)

# Setting alpha = 1 implements lasso regression
lasso_reg <- cv.glmnet(x, y_train, alpha = 1, lambda = lambdas, standardize = TRUE, nfolds = 5)

# Best
lambda_best <- lasso_reg$lambda.min
lambda_best

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

# MAGIC %md
# MAGIC Once we have the optimal lambda value, we train the lasso model in the first line of code below.

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

lasso_model <- glmnet(x, y_train, alpha = 1, lambda = lambda_best, standardize = TRUE)

predictions_train <- predict(lasso_model, s = lambda_best, newx = x)
eval_results(y_train, predictions_train, train)

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

predictions_test <- predict(lasso_model, s = lambda_best, newx = x_test)
eval_results(y_test, predictions_test, test)

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

# MAGIC %md
# MAGIC
# MAGIC ## Elastic Net Regression model
# MAGIC
# MAGIC Elastic net regression combines the properties of ridge and lasso regression.
# MAGIC
# MAGIC It works by penalizing the model using both the 1l2-norm1 and the 1l1-norm1.
# MAGIC
# MAGIC The model can be easily built using the caret package, which automatically selects the optimal value of parameters alpha and lambda.

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

# MAGIC %md
# MAGIC
# MAGIC - The first line of code creates the training control object train_cont which specifies how the repeated cross validation will take place.
# MAGIC
# MAGIC - The second line builds the elastic regression model in which a range of possible alpha and lambda values are tested and their optimum value is selected. The argument tuneLength specifies that 10 different combinations of values for alpha and lambda are to be tested.

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

# Set training control
train_cont <- trainControl(method = "repeatedcv",
                              number = 10,
                              repeats = 5,
                              search = "random",
                              verboseIter = TRUE)

# Train the model
elastic_reg <- train(confirmed_deaths ~ .,
                           data = train,
                           method = "glmnet",
                           preProcess = c("center", "scale"),
                           tuneLength = 10,
                           trControl = train_cont)

# Best tuning parameter
elastic_reg$bestTune

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

# MAGIC %md
# MAGIC Once we have trained the model, we use it to generate the predictions and print the evaluation results for both the training and test datasets

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

# Make predictions on training set
predictions_train <- predict(elastic_reg, x)

eval_results(y_train, predictions_train, train)

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

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

# Make predictions on test set
predictions_test <- predict(elastic_reg, x_test)
eval_results(y_test, predictions_test, test)

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

# MAGIC %md
# MAGIC
# MAGIC The above output shows that the RMSE and R-squared values for the elastic net regression model on the training data are and  percent, respectively.
# MAGIC
# MAGIC The results for these metrics on the test data are  and 86 , respectively.
# MAGIC
# MAGIC Conclusion
# MAGIC
# MAGIC The performance of the models is summarized below:
# MAGIC
# MAGIC - Linear Regression Model: Test set RMSE of  and R-square of  percent.
# MAGIC
# MAGIC - Ridge Regression Model: Test set RMSE of and R-square of  percent.
# MAGIC
# MAGIC - Lasso Regression Model: Test set RMSE of  and R-square of percent.
# MAGIC
# MAGIC - ElasticNet Regression Model: Test set RMSE of  and R-square of  percent.

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

Y1 <- as.matrix(y_target)
is.matrix(Y1)
X1 <- as.matrix(X_variables)
is.matrix(X_variables)
CV = cv.glmnet(x=X1, y=Y1, family= "gaussian",standardize=FALSE, type.measure = "mae", alpha = 0)

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

plot(CV)

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

fit = (glmnet(x=X1, y=Y1, family= "gaussian", alpha=0,standardize=FALSE, lambda=CV$lambda.1se))

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

fit$beta[,1]
ridge <- as.matrix(fit$beta)

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

write.table(ridge,"/databricks/driver/ridge.txt", sep="\t")

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

plot(fit, label = TRUE)
plot(fit)
print(fit)

write.table

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


####### handling missing data

.nam <- names(.Mtrs); .attri <- .nam
.rnam <- row.names(.Mtrs)
n <- nrow(.Mtrs); p <- ncol(.Mtrs)

.kind <- 1; .kvec <- 0
for(i in 1:ncol(.Mtrs)){
    if(all(as.matrix(.Mtrs[,i])==.Mtrs[1,i])){
    print(i)
        if(.kind==1) cat("\n these constant variables will be omitted:\n")
        cat(.nam[i],"\t"); .kvec[.kind] <- i; .kind <- .kind + 1;
        }
}
if(.kind!=1) .Mtrs <- .Mtrs[-.kvec]

.nam <- names(.Mtrs); .attri <- .nam
p <- ncol(.Mtrs)

#.ind <- sort(as.numeric(na.action(na.omit(.Mtrs))))
.rr <- 1;  .ind <- 0
for(.i in 1:n){
      .j <- 1
      while(.j<=p&&grepl('[0-9]',.Mtrs[.i,.j]))  .j <- .j+1
      if(.j<=p) {.ind[.rr] <- .i; .rr <- .rr+1   }
 }

if(.ind[1]){
cat("missing data are detected.\nDo you want to exclude the corresponding columns or rows?\n")
cat("\n1. I want to exclude the rows\n")
cat("2. I want to exclude the columns\n")
#cat("3. I want to impute the missing counts as censored data with large detection limit\n")
.ans <- .scanf(1,c(1:2))
if(.ans == 1){
cat('these samples with missing data will be omitted:\n')
print(.rnam[.ind])
.Mtrs <- .Mtrs[-.ind,]
    }
if(.ans == 2){
  .rr <- 1;  .indC <- 0
  for(.j in 1:p){
      .i <- 1
      while(.i<=n&&grepl('[0-9]',.Mtrs[.i,.j]))  .i <- .i+1
      if(.i<=n) {.indC[.rr] <- .j; .rr <- .rr+1   }
   }
cat('these variables with missing data will be omitted:\n')
print(.nam[.indC])
.Mtrs <- .Mtrs[,-.indC]
    }
#if(.ans == 3){
#for(.i = 1:nrow(trs)){
#  for(.j = 1:ncol(trs)){
#     if(is.na(trs[.i,.j])) trs[.i,.j] <- 'NA'
#  }}}
}

.attri <- .nam <- names(.Mtrs)
.sites <- .rnam <- row.names(.Mtrs)
n <- nrow(.Mtrs); p <- ncol(.Mtrs)

.read()


1+1
w<-1:3
names(w)<-c('a','b','c')
w
"http://www.jaredlander.com/data/Tomato%20First.csv"
tomato<- read.csv(file="http://www.jaredlander.com/data/Tomato%20First.csv",header=TRUE,sep=',')
head(tomato)
class(tomato$Tomato)
tomato<- read.csv(file="http://www.jaredlander.com/data/Tomato%20First.csv",header=TRUE,sep=',',stringsAsFactors = FALSE)
class(tomato$Tomato)
hist(tomato$Price)
ggplot2(data=tomato)
library(ggplot2)
ggplot(data=tomato)+geom_histogram(aes(x=Price),fill=FALSE)


require(graphics)
require(Matrix)

pdf(file="plots/Experiment4a.pdf",
  width=5, height=4.0, family="serif", pointsize=14)

points = as.vector(2^seq(0,9));
input = as.matrix(read.table("results/Experiment4a_times.dat", sep=",")[3])
data = colMeans(matrix(input, 3, 60))/1000
data2 = data[1:10];
data1 = data[11:20];

plot_colors <- c("orange","black")

plot(   points, data2,
        type="o",
        pch=25,
        cex=1.1,
        col=plot_colors[1],
        ylim = c(0,1500),
        xlab="",
        ylab="",
        axes=FALSE,
        bg=plot_colors[1],
        log="x",
        lwd=1.1,
        lty=1
  )

axis(2, las=2) # horizontal y axis
axis(1, las=1, at=points, labels=c("1","2","4","8","16","32","64","128","256","512"))      # horizontal x axis
mtext(2, text="Execution Time [s]",line=2.7)
mtext(1, text="Hybrid TP/DP Block Size [# Slices]",line=2)

lines(points, data1[1:10], type="o", pch=17, lty=1, lwd=1.1, col=plot_colors[2], bg=plot_colors[2], cex=1.0)

segments(16,0,16,570, lty=2, lwd=1.1)
text(16,690,"default")

box()

legend( "top",
       c("USCensus","Covtype"), col=plot_colors, pt.bg=plot_colors,
       pch=c(25,17), lty=c(1), lwd=c(1.1), bty="n");

dev.off()


bubblesort <- function(v) {
  itemCount <- length(v)
  repeat {
    hasChanged <- FALSE
    itemCount <- itemCount - 1
    for(i in 1:itemCount) {
      if ( v[i] > v[i+1] ) {
        t <- v[i]
        v[i] <- v[i+1]
        v[i+1] <- t
        hasChanged <- TRUE
      }
    }
    if ( !hasChanged ) break;
  }
  v
}

executeTask <- function(i) {

v <- c(16+i,93,-99,95,-96,-24,-53,-71,96,-66,-21,72,-12,-32,-96,62,-42,-50,49,53,-65,52,-25,-69,88,-43,60,66,-94,-69,53,-71,-17,-58,-30,32,-16,-94,-42,-86,59,-53,94,97,-12,15,65,-35,-12,-82,-82,48,-48,66,-42,-63,33,-49,41,-85,94,66,-60,60,-65,-73,-50,-9,-48,-3,15,-77,81,95,-93,83,-21,34,-78,-61,-22,-58,65,78,41,-7,-59,20,88,-38,-15,-69,42,97,-35,61,8,2,-22,-85)
bubblesort (v)
	return(i)
}

r = 0
for(i in 0:1000000000) {
	r = executeTask(i)
}


model_tempmax <- function (Sdepth_cm = 0.0,
         prof = 0.0,
         tmax = 0.0,
         tminseuil = 0.0,
         tmaxseuil = 0.0){
    #'- Name: TempMax -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Maximum temperature  recalculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: recalculation of maximum temperature
    #'- inputs:
    #'            * name: Sdepth_cm
    #'                          ** description : snow depth
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : cm
    #'                          ** uri :
    #'            * name: prof
    #'                          ** description : snow cover threshold for snow insulation
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 1000
    #'                          ** unit : cm
    #'                          ** uri :
    #'            * name: tmax
    #'                          ** description : current maximum air temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: tminseuil
    #'                          ** description : minimum temperature when snow cover is higher than prof
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: tmaxseuil
    #'                          ** description : maximum temperature when snow cover is higher than prof
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : degC
    #'                          ** uri :
    #'- outputs:
    #'            * name: tmaxrec
    #'                          ** description : recalculated maximum temperature
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : degC
    #'                          ** uri :
    tmaxrec <- tmax
    if (Sdepth_cm > prof)
    {
        if (tmax < tminseuil)
        {
            tmaxrec <- tminseuil
        }
        else
        {
            if (tmax > tmaxseuil)
            {
                tmaxrec <- tmaxseuil
            }
        }
    }
    else
    {
        if (Sdepth_cm > 0.0)
        {
            if (tmax <= 0.0)
            {
                tmaxrec <- tmaxseuil - ((1 - (Sdepth_cm / prof)) * -tmax)
            }
            else
            {
                tmaxrec <- 0.0
            }
        }
    }
    return (list('tmaxrec' = tmaxrec))
}


#testing ddirch with missing data. both site-level and hierarhcical.
#clear environment, generate data.
rm(list = ls())
library(data.table)
source('NEFI_functions/crib_fun.r')

#### generate site-level and hierarchical multivariate data.####
n <- 10*4
mat <- c(rep(2,n/4),rep(4,n/4), rep(6,n/4), rep(8,n/4))
map <- c(rep(400,n/2), rep(200,n/2))
pH <- runif(n, 3,7)
core <- (data.frame(mat,map,pH))
core$y <- mat*0.5 + map*0.04 +pH*1 + rnorm(n,2)
core$plot <- c(rep('a1',n/4),rep('a2',n/4), rep('b1',n/4), rep('b2',n/4))
core$site <- c(rep('a',n/2), rep('b',n/2))
core$intercept <- rep(1, nrow(core))
core_plot <- as.factor(core$plot)
core_site <- as.factor(core$site)
plot_plot <- as.factor(unique(core$plot))
plot_site <- as.factor(substr(plot_plot,1,1))
site_site <- as.factor(unique(core$site))
y <- as.matrix(core$y)
#get two species abundances
y1 <- y
y2 <- rep(10, length(y1))
spp.y <- data.frame(cbind(y1,y2))
spp.y <- spp.y / rowSums(spp.y)

core_mu <- data.frame(core$intercept, core$pH)
site_mu <- data.frame(c(400,200))
plot_mu <- data.frame(c(2,4,6,8))
colnames(core_mu) <- c('intercept','pH')
colnames(site_mu) <- c('map')
colnames(plot_mu) <- c('mat')

#convert to just "site-level" for downstream testing.
core <- cbind(core_mu, core_plot)
plot <- cbind(plot_mu, plot_site)
plot <- cbind(plot, plot_plot)
site <- cbind(site_mu, site_site)
all.test <- merge(core,plot, by.x = 'core_plot',by.y ='plot_plot')
all.test <- merge(all.test,site, by.x = 'plot_site', by.y = 'site_site')
test.x <- all.test[,3:ncol(all.test)]

#### testing hierarchical dirichlet w/ pseudo data ####
source('testing_development/implement_missing_data_ddirch/ddirch_missing.data_function.r')

#go ahead and use the function to fit the model to data, summarize.
test <- hierarchical_dirlichet_jags(y = spp.y,
                                    core_mu = core_mu, plot_mu = plot_mu, site_mu = site_mu,
                                    core_plot = core_plot, core_site = core_site, plot_site = plot_site,
                                    plot_plot = plot_plot, site_site = site_site,
                                    adapt = 100, burnin = 200, sample = 200)

#Plot predicted vs. observed, 1:1 line, best fit line and R2 values
par(mfrow = c(1,2))
m1 <- lm(test$observed[,1] ~ test$predicted[,1])
plot(test$observed[,1] ~ test$predicted[,1], main = 'y1 obs vs. pred'); abline(0,1, lwd = 2);abline(m1, lty = 2, col = 'green')
mtext(paste0('R2 = ',round(summary(m1)$r.squared, 2)), side = 3, adj = 0.05, line = -2)
m2 <- lm(test$observed[,2] ~ test$predicted[,2])
plot(test$observed[,2] ~ test$predicted[,2], main = 'y2 obs vs. pred'); abline(0,1, lwd = 2);abline(m2, lty = 2, col = 'green')
mtext(paste0('R2 = ',round(summary(m1)$r.squared, 2)), side = 3, adj = 0.05, line = -2)

#### testing site level dirichlet w/ pseudo data ####
source('testing_development/implement_missing_data_ddirch/ddirch_missing.data_site.level.only_function.r')
#source('NEFI_functions/ddirch_site.level_JAGS.r')
test <- site.level_dirlichet_jags(y=spp.y,x_mu=test.x,adapt = 100, burnin = 200, sample = 200)

#plot predicted vs. observed, 1:1 line, vest fit line and R2 values.
par(mfrow = c(1,2))
plot(test$observed[,1] ~ test$predicted[,1])
mod <- lm(test$observed[,1] ~ test$predicted[,1])
abline(0,1,lwd=2);abline(mod, lty = 2, col = 'green')
mtext(paste0('R2 = ',round(summary(mod)$r.squared,2)),side = 3, line = -2, adj= 0.05)
plot(test$observed[,2] ~ test$predicted[,2])
mod <- lm(test$observed[,2] ~ test$predicted[,2])
abline(0,1,lwd=2);abline(mod, lty = 2, col = 'green')
mtext(paste0('R2 = ',round(summary(mod)$r.squared,2)),side = 3, line = -2, adj= 0.05)

#### testing site-level dirichlet w/ tedersoo prior data ####
#load data
d <- readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/ted_all_prior_data.rds')
d <- d[,.(Ectomycorrhizal,Saprotroph,Arbuscular,cn,pH,moisture,NPP,map,mat)]
d <- d[complete.cases(d),] #optional. This works with missing data.

#organize y data
y <- d[,.(Ectomycorrhizal,Saprotroph,Arbuscular)]
#make other column
y <- data.frame(lapply(y,crib_fun))
y$other <- 1 - rowSums(y)
y <- as.data.frame(y)
#reorder columns. other needs to be first.
y <- y[c('other','Ectomycorrhizal','Saprotroph','Arbuscular')]

#Drop in intercept, setup predictor matrix.
d$intercept <- rep(1,nrow(d))
x <- d[,.(intercept,cn,pH,moisture,NPP,mat,map)]
x$map <- log(x$map)

#source and run function
source('testing_development/implement_missing_data_ddirch//ddirch_missing.data_site.level.only_function.r')
test <- site.level_dirlichet_jags(y=y,x_mu=x,adapt = 50, burnin = 50, sample = 100)

#plot predicted vs. observed, 1:1 line, vest fit line and R2 values.
#4 "species" modeled, setting up 2x2 grid.
par(mfrow = c(2,2))
y.names <- names(test$species_parameter_output)
for(i in 1:ncol(test$predicted)){
  plot(test$observed[,i] ~ test$predicted[,i], main = paste(y.names[i]))
  mod <- lm(test$observed[,i] ~ test$predicted[,i])
  beta.mod <- betareg::betareg(test$observed[,i] ~ test$predicted[,i])
  abline(0,1,lwd=2);abline(mod, lty = 2, col = 'green')
  mtext(paste0('R2 = ',round(summary(beta.mod)$pseudo.r.squared,3)),side = 3, line = -2, adj= 0.05)
}

#Does this beat simple beta-regression? Looks about the same. Thank god we did all this work to get the same answer...
#Note- both fit the Arbuscular data very poorly, regardless of what the R2 values say.
for(i in 1:ncol(y)){
  mod <- betareg::betareg(y[,i] ~ x$cn + x$pH + x$moisture + x$NPP + x$mat + x$map)
  cat(paste0(y.names[i],': R2 = ',round(summary(mod)$pseudo.r.squared,3)),'\n')
}

#### testing hierarchical dirichlet w/ subset of NEON data. ####
#### Current hangup: some sites have observations but no core or plot level data, which throws off indexing. ####
rm(list=ls())
source('paths.r')
#source functions
source('testing_development/implement_missing_data_ddirch/ddirch_missing.data_function.r')
source('NEFI_functions/crib_fun.r')

#load data.
 obs.table <- readRDS( obs.table.path)
core.table <- readRDS(core.table.path)
plot.table <- readRDS(plot.table.path)
site.table <- readRDS(site.table.path)

##TESTING
#lets only look at complete cases for 2 sites right now.
 obs.table <-  obs.table[obs.table$siteID %in% c('BART','HARV','TALL'),]
core.table <- core.table[core.table$geneticSampleID %in% obs.table$geneticSampleID,]
plot.table <- plot.table[plot.table$plotID %in% obs.table$plotID,]
site.table <- site.table[site.table$siteID %in% obs.table$siteID,]

#put everything in correct order.
#Convert all factor vectors to character vectors - this line sucks and is a good argument for data.table/tidyverse
 obs.table[sapply( obs.table, is.factor)] <-  lapply( obs.table[sapply( obs.table, is.factor)], as.character)
core.table[sapply(core.table, is.factor)] <-  lapply(core.table[sapply(core.table, is.factor)], as.character)
plot.table[sapply(plot.table, is.factor)] <-  lapply(plot.table[sapply(plot.table, is.factor)], as.character)
site.table[sapply(site.table, is.factor)] <-  lapply(site.table[sapply(site.table, is.factor)], as.character)

#hierarchically order the rows as site/plot/core.
 obs.table <-  obs.table[order( obs.table$siteID, obs.table$plotID, obs.table$geneticSampleID),]
core.table <- core.table[order(core.table$siteID,core.table$plotID,core.table$geneticSampleID),]
plot.table <- plot.table[order(plot.table$siteID,plot.table$plotID),]
site.table <- site.table[order(site.table$siteID),]
core_mu <- core.table
plot_mu <- plot.table
site_mu <- site.table

#setup indexing
core_plot <- as.factor(core.table$plotID)
core_site <- as.factor(core.table$siteID)
plot_plot <- as.factor(plot.table$plotID)
plot_site <- as.factor(substring(plot_plot,1,4))
site_site <- as.factor(site.table$siteID)

#setup y, core, plot and site data frames, and associated sd tables where applicable.
y <- obs.table[,2:5]
#dropping soil moisture and soil pH for now because all NA values for two site-dates of interest.
#core <- core.table[,c('siteID','plotID','soilMoisture','soilInWaterpH','soilTemp')]
#colnames(core)[3:5] <- c('moisture','pH','temperature')
core <- core.table[,c('siteID','plotID','soilTemp')]
colnames(core)[3] <- c('temperature')
core_sd <- core.table[,c('siteID','plotID')]
plot <- plot.table[,c('siteID','plotID','organicCPercent','CNratio')]
plot_sd <- plot.table[,c('siteID','plotID','organicCPercent_sd','CNratio_sd')]
site <- site.table[,c('siteID','elevation','map','mat','n.dep')]
site_sd <- site.table[,c('siteID','map_sd','mat_sd')]

#drop plot-site indices from data frames. Those saved in index vectors.
core$intercept <- rep(1,nrow(core))
core <- core[,-c(1:2)]; core <- core[,c('intercept','temperature')]
plot <- plot[,-c(1:2)]
site <- site[,-c(1:2)]

core_sd <- NA
plot_sd <- NA
site_sd <- NA

#reorder the y columns
#drop AM fungi- no reads.
y$other <- NULL
y$Arbuscular <- NULL
y <- data.frame(lapply(y,crib_fun))
y$other <- 1 - rowSums(y)
y <- y[c('other','Ectomycorrhizal','Saprotroph')]

#fit the model.
test <- hierarchical_dirlichet_jags(y = y,
                                    core_mu = core, plot_mu = plot, site_mu = site,
                                    core_plot = core_plot, core_site = core_site, plot_site = plot_site,
                                    plot_plot = plot_plot, site_site = site_site,
                                    adapt = 100, burnin = 200, sample = 200)

#plot results
par(mfrow = c(2,2))
y.names <- names(test$species_parameter_output)
for(i in 1:ncol(test$predicted)){
  plot(test$observed[,i] ~ test$predicted[,i], main = paste(y.names[i]))
  mod <- lm(test$observed[,i] ~ test$predicted[,i])
  beta.mod <- betareg::betareg(test$observed[,i] ~ test$predicted[,i])
  abline(0,1,lwd=2);abline(mod, lty = 2, col = 'green')
  mtext(paste0('R2 = ',round(summary(beta.mod)$pseudo.r.squared,3)),side = 3, line = -2, adj= 0.05)
}

testing_development/proving ddirch models work.r


data  <- read.table("./ingredients-f.dat", header=T, sep="|")
counts <- table(data$fixed, data$veganity_id)
#counts <- table(data$veganity_id, data$fixed)
#counts <- table(data$veganity_id, data$fixed, data$hide)
#diff <- data$Quantity - data$fixed
#counts <- table(data$fixed, diff)

png(filename="./ingredients-f.png", height=500, width=500, bg="white")
desc = paste("Verteilung der", sum(counts), "Zutaten auf die Veganitäten", sep = " ")
#barplot(counts, density=4, ylim=c(1,round_up(max(counts), 50)), main=desc, names.arg=(data$Veganity),
barplot(counts, ylim=c(1,round_up(max(counts), 50)), main=desc, names.arg=(data$Veganity),
#barplot(counts, ylim=c(0,220), main=desc, names.arg=(data$Veganity),
		#col=c("#468847", "#c05b59", "#c09853", "#3a87ad"), legend =
		col=c("#468847", "#c05b59"), legend =
		#col=counts, legend =
		rownames(counts))
title(xlab="Veganität")
title(ylab="Anzahl Zutaten")


## 1. Lists: Objects That Can Contain Multiple Data Types ##

uni_clubs<-list('ballroom dancing','rugby','bird watching','pottery')

## 2. Anatomy of a List ##

club_title <- c("Chess Club")
club_description <- c("Meets two nights a week for members to play chess. Snacks are provided.")
club_dues <- c(50, 20, 15)
meeting_days <- c("Monday", "Wednesday")
meeting_times <- c("6:00 pm", "8:00 pm")
club_meetings<-rbind(meeting_days,meeting_times)
chess_club<-list(club_title,club_description,club_dues,club_meetings)
chess_club

## 3. Assigning Names to List Objects ##

chess_club <- list(club_title, club_description, club_dues, club_meetings)
chess_club_names <- c("club_title", "club_description", "club_dues", "club_meetings")
# Type your code below
names(chess_club)<-chess_club_names
chess_club

## 4. Indexing Lists ##

chess_club[[c(3,2)]]

## 5. Modifying List Elements ##

chess_club[[c(3,3)]]<-5
chess_club[[c(3,3)]]

## 6. Adding Elements to Lists ##

first_years <- c(12, 15)
names(first_years) <- c("fall", "spring")
chess_club[['first_years']]<-first_years
chess_club$first_years[[2]]

## 7. Combining Lists ##

uni_clubs<-list(rugby_club=rugby_club,ballroom_dancing=ballroom_dancing,chess_club=chess_club)
uni_clubs


#!/usr/bin/Rscript

library(methods)
library(grDevices)
library(reshape2)
library(stats)
library(ggplot2)
library(plyr)
library(scales)
library(data.table)
library(gridExtra)
require(grid)
library(lattice)

# Python source
c <- read.csv("./data_random/Old/inyo_north_python.csv", header = TRUE, sep=",")

DT <- data.table(c)
DT[DT == "--"] <- NA

py_mean <- DT[,.(ref_mean = mean(Reflectance)), by = .(Label,Wavelength,Band)] # Get mean of each band per location
py_mean <- dcast(py_mean, Label ~ Band , ) # Show std per band per label
py_std <- DT[,.(ref_std = sd(Reflectance)), by = .(Label,Wavelength,Band)] # Get std of each band per location
py_std <- dcast(py_std, Label ~ Band , ) # Show std per band per label

# GEE source
d <- read.csv("./data_random/Old/inyo_north_gee.csv", header = TRUE, sep=",")

gee_ref <- data.frame(Label=d$label, B1=d$B1_BCET, B2=d$B2_BCET, B3=d$B3_BCET, B4=d$B4_BCET, B5=d$B5_BCET, B6=d$B6_BCET, B7=d$B7_BCET)

ref_comp <- merge(gee_ref, py_mean, by="Label")

bands <- c('B1', 'B2', 'B3', 'B4', 'B5', 'B6', 'B7')
subtitles <- c('Ultra Blue', 'Blue', 'Green', 'Red', 'NIR', 'SWIR 1', 'SWIR 2')
colours <- c('deepskyblue2','dodgerblue3', 'green4', 'red3', 'red4', 'gray63', 'grey24')
lm_eqn = function(df){
    m = lm(y ~ 0 + x, df);
    eq <- substitute(italic(y) == a %.% italic(x)*","~~italic(r)^2~"="~r2,
         list(a = format(coef(m)[1], digits = 5),
              b = 0,
             r2 = format(summary(m)$r.squared, digits = 3)))
    as.character(as.expression(eq));
}

i = 1
grobs = c()
for (b in bands){

  df <- data.frame(x=ref_comp[,i+1],y=ref_comp[,i+7+1])
  fit = lm(y ~ 0 + x, df);
  cfs <- coef(fit)
  m <- cfs[[1]]
  conf <- confint(fit, level = 0.99999)
  lwr <- conf[1]
  upr <- conf[2]
  eq <- function(x){x*m}
  lwr_eq <- function(x){x*lwr}
  upr_eq <- function(x){x*upr}

  df <- data.frame(x=ref_comp[,i+1],y=ref_comp[,i+7+1])
  grobs[[i]] <- ggplot(df, aes_string(x='x',y='y')) +
	  geom_point(alpha=.15, col=colours[i]) +
	  ylim(low=0,high=200) +
	  xlim(low=0,high=200) +
	  geom_text(x = 80, y = 185, label = lm_eqn(df), parse = TRUE) +
	  stat_function(fun=eq, gem="line", linetype=2) +
	  labs(title=paste('Band',i,'-',subtitles[i]), x="R* (Composite)", y="R* (GEE)") +
	  theme_bw()
  ggsave(paste('./plots/random/nofilter_',b,".pdf", sep=''), width = 4, height = 4, dpi = 220)
  i = i+1
}


# This code assumes you've downloaded and unzipped the file
#   exdata-data-NEI_data.zip in your working directory.  If you haven't it's
#   easy enough to write the code to check using file.exists etc

## This first line will likely take a few seconds. Be patient!
NEI <- readRDS("summarySCC_PM25.rds")
SCC <- readRDS("Source_Classification_Code.rds")

Balt <- NEI[NEI$fips == "24510",]

# Plot 3

library(ggplot2)

png(filename = "plot3.png",
    width = 640,
    height = 480)

ggplot(Balt, aes(factor(year), Emissions, fill=type)) +
  geom_bar(stat="identity") +
  theme_bw() +
  guides(fill=FALSE) +
  facet_grid(. ~ type, scales = "fixed", space="fixed") +
  labs(x="Year", y=expression("Total PM"[2.5]*" Emission (Tons)")) +
  labs(title=expression("Plot 3: PM"[2.5]*" Emissions, Baltimore City 1999-2008 by Source Type"))

dev.off()


## ----load libraries, echo=FALSE------------------------------------------
library(tidyverse)
library(RColorBrewer)
library(gridExtra)
library(dichromat)
library(here)

## ----read TB data and wrangle and subset to USA--------------------------
tb <- read_csv(here::here("data/TB_notifications_2019-07-01.csv")) %>%
  select(country, iso3, year, new_sp_m04:new_sp_fu) %>%
  gather(stuff, count, new_sp_m04:new_sp_fu) %>%
  separate(stuff, c("stuff1", "stuff2", "sexage")) %>%
  select(-stuff1, -stuff2) %>%
  mutate(sex=substr(sexage, 1, 1),
         age=substr(sexage, 2, length(sexage))) %>%
  select(-sexage)

# Filter years between 1997 and 2012 due to missings
tb_us <- tb %>%
  filter(country == "United States of America") %>%
  filter(!(age %in% c("04", "014", "514", "u"))) %>%
  filter(year > 1996, year < 2013)

## ----focus on one year gender, side-by-side bars of males/females, fig.height=3----
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=sex, y=count, fill=sex)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Arrangement A")

## ----focus on one year age, side-by-side bars of age group, fig.height=3----
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=age, y=count, fill=age)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~sex, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Arrangement B")

## ----use a line plot instead of bar, fig.height=3------------------------
ggplot(tb_us, aes(x=year, y=count, colour=sex)) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  scale_colour_brewer("", palette="Dark2") +
  ggtitle("Type A")

## ----colour and axes fixes, fig.height=3---------------------------------
# This uses a color blind proof scale
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity") +
  facet_wrap(~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Type B")

## ----use a line plot for proportions, fig.height=3-----------------------
tb_us %>% group_by(year, age) %>%
  summarise(p = count[sex=="m"]/sum(count)) %>%
  ggplot(aes(x=year, y=p)) +
  geom_hline(yintercept = 0.50, colour="white", size=2) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  ylab("proportion of males") +
  ggtitle("Type A")

## ----compare proportions of males/females, fig.height=4------------------
# Fill the bars, note the small change to the code
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2") + ylab("proportion") +
  ggtitle("Type B") + theme(legend.position = "bottom")

## ----show different types of color palettes, fig.height=7, fig.width=12----
display.brewer.all()

## ----mapping numbers to rainbow sequential scale, echo=TRUE, out.width="60%", fig.width=7, fig.height=4----
dsamp <- diamonds[sample(nrow(diamonds), 1000), ]
(d <- ggplot(dsamp, aes(carat, price)) +
  geom_point(aes(colour = clarity)))

## ----mapping numbers to sequential scale, echo=TRUE, fig.width=7, fig.height=4, out.width="60%"----
d + scale_colour_brewer()

## ----mapping numbers to diverging scale, echo=TRUE, fig.width=7, fig.height=4, out.width="60%"----
d + scale_colour_brewer(palette="PRGn")

## ----mapping numbers to qualitative palette, echo=TRUE, , fig.width=7, fig.height=4, out.width="60%"----
d + scale_colour_brewer(palette="Set1")

## ----using the dichromat package to check color blind appearance, echo=TRUE, fig.show='hide'----
library(scales)
library(dichromat)
clrs <- hue_pal()(9)
d + theme(legend.position = "none")
clrs <- dichromat(hue_pal()(9))
d + scale_fill_manual("", values=clrs) + theme(legend.position = "none")

## ----show the default colour scheme and dichromat adjusted colors, echo=FALSE, fig.height=8----
clrs <- hue_pal()(9)
p1 <- d + theme(legend.position = "none") + scale_color_discrete()

clrs <- dichromat(hue_pal()(9))
p2 <- d + scale_color_manual("", values=clrs) + theme(legend.position = "none")

grid.arrange(p1, p2, ncol=1)

## ----is shape preattentive, echo=FALSE-----------------------------------
set.seed(20190715)
df <- data.frame(x=runif(100), y=runif(100), cl=sample(c(rep("A", 1), rep("B", 99))))
ggplot(data=df, aes(x, y, shape=cl)) + theme_bw() +
  geom_point(size=3) +
  theme(legend.position="None", aspect.ratio=1)

## ----is color preattentive, echo=FALSE-----------------------------------
ggplot(data=df, aes(x, y, colour=cl)) +
  geom_point(size=3) +
  theme_bw() +
  scale_colour_brewer(palette="Set1") +
  theme(legend.position="None", aspect.ratio=1)

## ----a line plot on sex, fig.height=3------------------------------------
ggplot(tb_us, aes(x=year, y=count, colour=sex)) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  scale_colour_brewer("", palette="Dark2") +
  ggtitle("Arrangement A")

## ----a line plot on age, fig.height=3, fig.width=6-----------------------
ggplot(tb_us, aes(x=year, y=count, colour=age)) +
  geom_line() + geom_point() +
  facet_wrap(~sex, ncol=6) +
  scale_colour_brewer("", palette="Dark2") +
  ggtitle("Arrangement B")

## ----side-by-side bars of males/females, fig.height=3--------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=sex, y=count, fill=sex)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Position - common scale ")

## ----piecharts of males/females, fig.height=3----------------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=1, y=count, fill=sex)) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Angle") + xlab("") + ylab("") +
  coord_polar(theta = "y")

## ----side-by-side bars of age, fig.height=3------------------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=age, y=count, fill=age)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~sex, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Position - common scale ")

## ----piecharts of age, fig.height=3--------------------------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=1, y=count, fill=age)) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(~sex, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Angle") + xlab("") + ylab("") +
  coord_polar(theta = "y")

## ----facetting plots can result in change blindness, echo=TRUE, out.width="50%", fig.width=6.5, fig.height=3.5----
ggplot(dsamp, aes(x=carat, y=price, colour = clarity)) +
  geom_point() +
  geom_smooth(se=FALSE) +
  scale_color_brewer(palette="Set1") +
  facet_wrap(~clarity, ncol=4)

## ----averlaying makes comparisons easier, echo=TRUE, out.width="70%", fig.width=7, fig.height=4----
ggplot(dsamp, aes(x=carat, y=price, colour = clarity)) +
  geom_point() +
  geom_smooth(se=FALSE) +
  scale_color_brewer(palette="Set1")


#!/usr/bin/env Rscript
# From https://github.com/berkeley-dsep-infra/datahub/issues/814
print("Installing packages for IA C188")

# rdd requested in https://github.com/berkeley-dsep-infra/datahub/issues/897
print("Installing rdd...")
devtools::install_github('cran/rdd', ref='0.57', upgrade_dependencies=FALSE, quiet=TRUE)

print("Installing stargazer...")
devtools::install_github('cran/stargazer', ref='5.2.2', upgrade_dependencies=FALSE, quiet=TRUE)

print("Installing lm.beta...")
devtools::install_github('cran/lm.beta', ref='1.5-1', upgrade_dependencies=FALSE, quiet=TRUE)

print("Installing multcomp...")
devtools::install_github('cran/multcomp', ref='1.4-8', upgrade_dependencies=FALSE, quiet=TRUE)

print("Installing lfe...")
devtools::install_github('cran/lfe', ref='2.8-2', upgrade_dependencies=FALSE, quiet=TRUE)

print("Done installing packages for IA C188")


library("gstsm")

events_data_path <-
  system.file("inst/extdata", "made_bangu_6x30.txt", package = "gstsm")

space_time_data_path <-
  system.file("extdata", "positions_2D_30.txt", package = "gstsm")

d <- read.table(
  events_data_path,
  header = FALSE,
  sep = " ",
  dec = ".",
  as.is = TRUE,
  stringsAsFactors = FALSE
)

p <- read.table(
  space_time_data_path,
  header = TRUE,
  sep = " ",
  dec = ".",
  as.is = TRUE,
  stringsAsFactors = FALSE
)

plot(
  p$x,
  p$y,
  main = "positions",
  xlab = "",
  ylab = "",
  col = "blue",
  pch = 19,
  cex = 1,
  lty = "solid",
  lwd = 2
)

text(
  p$x,
  p$y,
  labels = p$points,
  cex = 0.7,
  pos = 3
)

gamma <- 0.8
beta <- 2
sigma <- 1

result <- gstsm::gstsm(d, p, gamma, beta, sigma)


#clear environment, load packages.
rm(list=ls())
library(doMPI)
#clock functions
tic = function() {assign("timer", Sys.time(), envir=.GlobalEnv)}
toc = function() print(Sys.time()-timer)

#generate huge vectors to fit a model to.
n.sims <- 1000

#fit model without parallelization.
cat('Fitting model without parallelization...n')
output.list <- list()
tic()
for(i in 1:n.sims){
  set.seed(i)
  #x <- rnorm(1000000)
  #y <- x*0.5 + 1 + rnorm(length(x))
  #mod <- lm(y ~ x)
  #output.list[[i]] <- mod
  mean(rnorm(1e7))
}
toc()

#Use foreach and instructions to fit in parallel.
cat('Fitting model with parallelization...n')
cl <- startMPIcluster(count=30)
registerDoMPI(cl)
tic()
parallel.output <-
  foreach(i = 1:n.sims) %dopar% {
    set.seed(i)
    #x <- rnorm(1000000)
    #y <- x*0.5 + 1 + rnorm(length(x))
    #mod <- lm(y ~ x)
    #return(mod)
    return(mean(rnorm(1e7)))
  }
toc()

#close connection thing.
closeCluster(cl)
mpi.quit()


#!/usr/bin/env Rscript
#
# Read a phylip distance matrix and create a neighbor-joining tree from
# the output.

library(ape)

read_phylip_full_dist_mat = function(fname) {
    dist_handle = file(fname, 'rb')
    n_samples = scan(dist_handle, nlines=1, quiet=TRUE)
    d = matrix(nrow=n_samples, ncol=n_samples)
    sample_names = character(n_samples)
    input_matrix = scan(dist_handle, quiet=TRUE, what='character')
    for(i in 1:n_samples) {
        row = input_matrix[((i-1) * (n_samples + 1) + 1):(i * (n_samples + 1))]
        sample_names[i] = row[1]
        d[i, i] = 0
        for(j in seq_along(row[-1])) {
            d[i, j] = as.numeric(row[j+1])
        }
    }
    rownames(d) = sample_names
    colnames(d) = sample_names
    close(dist_handle)
    d
}

cargs = commandArgs(trailingOnly=TRUE)

dists = read_phylip_full_dist_mat(cargs[1])

tree = nj(as.dist(dists))
write.tree(tree, stdout())


//------------------------------
//
// A macro to decorate validation plots produced with "local" option.
//
// Usage:
//
// .x plotValidation.r("file",wheel,station)
//
// Some drawing options are set in the code (see below).
//
//
// Author: N. Amapane
//
//------------------------------

void plotValidation(){
  cout << endl << "Usage: .x plotValidation.r(\"inputFile.root\",<wheel>,<station>)" << endl << endl;
}

void plotValidation(TString filename, int wheel, int station) {

  if (! TString(gSystem->GetLibraries()).Contains("Histograms_h")) {
    gROOT->LoadMacro("$CMSSW_BASE/src/Validation/DTRecHits/test/Histograms.h+");
    gROOT->LoadMacro("macros.C");
  }

  //----------------------------------------------------------------------
  //  Configurable options
   addProfile = false;
   addSlice = true;

  int rbx =2; // rebin x in scatter plots
  int rby =1; // rebin y in scatter plots
  int rbp = 1; // rebin profiles
  float nsigma = 2; // interval for the fit of residual distributions

  // Canvases to plot
  bool doPhiAndThetaS3 =true;
  bool doHitPull = true;
  bool doEff = true;
  bool doT0= true;
  bool doSegRes=true;
  bool doSegPull = true;
  bool doAngularDeps = true;
  bool doEff4D = true;
  bool doNSeg = true;

  //----------------------------------------------------------------------

  TStyle * style = getStyle("tdr");
  style->cd();
  setPalette();
  gStyle->SetTitleSize(0.05,"XYZ"); // Set larger axis titles
  gStyle->SetTitleOffset(1.3,"Y");
  //  gStyle->SetOptTitle(0); // remove histogram titles

  //  gStyle->SetOptStat(111);

  float cmToMicron = 10000.;
  float vdrift = 54.3;

  TFile *file = new TFile(filename);

  HRes1DHit *hResPhi1  = new HRes1DHit(file, wheel, station, 1, "S3");
  HRes1DHit *hResTheta = new HRes1DHit(file, wheel, station, 2, "S3");
  //  HRes1DHit *hResPhi2  = new HRes1DHit(file, wheel, station, 4, "S3");
  HRes1DHit *hResPhi = hResPhi1;

  HEff1DHit* hEffS1RPhi= new HEff1DHit(file, wheel, station, 1, "S1");
  HEff1DHit* hEffS3RPhi= new HEff1DHit(file, wheel, station, 1, "S3");
  HEff1DHit* hEffS1RZ=0;
  HEff1DHit* hEffS3RZ=0;
  if (station!=4) {
    hEffS1RZ=   new HEff1DHit(file, wheel, station, 2, "S1");
    hEffS3RZ=   new HEff1DHit(file, wheel, station, 2, "S3");
  }

  HRes4DHit* hRes4D= new HRes4DHit(file, wheel, station, 0);
  HEff4DHit* hEff4D = new HEff4DHit(file, wheel, station, 0);

  // Result of fits
  float m_phi = 0.;
  float s_phi = 0.;
  float m_theta = 0.;
  float s_theta = 0.;
  float m_phi1 = 0.;
  float s_phi1 = 0.;
  float m_phi2 = 0.;
  float s_phi2 = 0.;
  float m_phiS1 = 0.;
  float s_phiS1 = 0.;
  float m_phiS2 = 0.;
  float s_phiS2 = 0.;
  float m_thetaS1 = 0.;
  float s_thetaS1 = 0.;
  float m_thetaS2 = 0.;
  float s_thetaS2 = 0.;
  float t0phi   =0.;
  float t0theta =0.;

  TString canvbasename = filename;
  canvbasename = canvbasename.Replace(canvbasename.Length()-5,5,"") + TString("_W") + (long) wheel + "_St" + (long) station ;

  //-------------------- Hit Residuals at step 3 in phi and theta (full distrib and vs distance from wire)
  if (doPhiAndThetaS3) {
    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_ResPhiTheta");
    c1->SetName(canvbasename+"_ResPhiTheta");
    c1->Divide(2,2);

    c1->cd(1);

    TH1F* hRes;
    hRes=hResPhi->hRes;

    hResPhi->hRes->Rebin(2);
    TF1* fphi=drawGFit(hRes, nsigma, -0.4, 0.4);

    c1->cd(2);

    plotAndProfileX(hResPhi->hResVsPos,rbx,rby,rbp,-.1, .1, 0, 2.1);

    m_phi = fphi->GetParameter("Mean")*cmToMicron;
    s_phi = fphi->GetParameter("Sigma")*cmToMicron;

    if (hResTheta->hRes) {

      c1->cd(3);
      hRes=hResTheta->hRes;

      hResTheta->hRes->Rebin(2);
      TF1* ftheta=drawGFit(hRes, nsigma, -0.4, 0.4);

      c1->cd(4);
      plotAndProfileX(hResTheta->hResVsPos,rbx,rby,rbp,-.1, .1, 0, 2.1);

      m_theta = ftheta->GetParameter("Mean")*cmToMicron;
      s_theta = ftheta->GetParameter("Sigma")*cmToMicron;
    }

    cout << canvbasename << "  Step3 W" << wheel << " St" << station << endl
	 << "   Res:          Phi: M= " << int(floor(m_phi+0.5))
	 << " S= "      << int(s_phi+0.5)
	 << "; Theta: M= " << int(floor(m_theta+0.5))
	 << " S= "  << int(s_theta+0.5) << endl;
  }

  //-------------------- Hit pulls
  if (doHitPull){
    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_PullPhiTheta");
    c1->SetName(canvbasename+"_PullPhiTheta");
    c1->Divide(2,2);

    c1->cd(1);

    TH1F* hPull;
    hPull=hResPhi->hPull;

    //    hResPhi->hPull->Rebin(2);
    TF1* fphi=drawGFit(hPull, nsigma, -5, 5);

    c1->cd(2);

    plotAndProfileX(hResPhi->hPullVsPos,rbx,rby,rbp,-5, 5, 0, 2.1);

    m_phi = fphi->GetParameter("Mean")*cmToMicron;
    s_phi = fphi->GetParameter("Sigma")*cmToMicron;

    if (hResTheta->hPull) {

      c1->cd(3);
      hPull=hResTheta->hPull;

      //      hResTheta->hPull->Rebin(2);
      TF1* ftheta=drawGFit(hPull, nsigma, -5, 5);

      c1->cd(4);
      plotAndProfileX(hResTheta->hPullVsPos,rbx,rby,rbp,-5, 5, 0, 2.1);

      m_theta = ftheta->GetParameter("Mean");
      s_theta = ftheta->GetParameter("Sigma");
    }

    cout << canvbasename << "  Step3 W" << wheel << " St" << station << endl
	 << "   Pulls:        Phi: M= " << int(floor(m_phi+0.5))
	 << " S= "      << int(s_phi+0.5)
	 << "; Theta: M= " << int(floor(m_theta+0.5))
	 << " S= "  << int(s_theta+0.5) << endl;
  }

  //-------------------- Hit efficiencies as a function of distance from wire
  if (doEff) {
    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_EffPhiTheta");
    c1->SetName(canvbasename+"_EffPhiTheta");
    c1->SetWindowSize(325,750);
    c1->Divide(1,2);
    c1->cd(1);
    plotEff(hEffS1RPhi->hEffVsDist, hEffS3RPhi->hEffVsDist);
    c1->cd(2);
    if (station!=4) plotEff(hEffS1RZ->hEffVsDist, hEffS3RZ->hEffVsDist);
//     c1->cd(2);
//     //plotEff(hEffS1RPhi->hEffVsPhi, hEffS3RPhi->hEffVsPhi);
//     plotEff(hEffS1RPhi->hEffVsEta, hEffS3RPhi->hEffVsEta);
//     c1->cd(4);
//     //    if (station!=4) plotEff(hEffS1RZ->hEffVsPhi, hEffS3RZ->hEffVsPhi);
//     if (station!=4) plotEff(hEffS1RZ->hEffVsEta, hEffS3RZ->hEffVsEta);

  }

  //-------------------- #hits, t0s
  if (doT0) {
    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_NHitsT0");
    c1->SetName(canvbasename+"_NHitsT0");
    c1->Divide(2,2);
    c1->cd(1);

    TH2F* hNh =  hRes4D->hHitMult;

    hNh->SetXTitle("#phi hits");
    hNh->SetYTitle("#theta hits");
    hNh->Draw("BOX");
    c1->cd(2);
    hNh->ProjectionY()->Draw();
    c1->cd(3);
    hNh->ProjectionX()->Draw();
    c1->cd(4);

    TH2F* ht =  hRes4D->ht0;
    ht->SetXTitle("t0 #phi");
    ht->SetYTitle("t0 #theta");
    ht->Draw("BOX");

  }

  //-------------------- Segment x, y, alpha, beta resolutions
  if (doSegRes){
    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_ResSeg");
    c1->SetName(canvbasename+"_ResSeg");
    c1->Divide(2,2);
    c1->cd(1);
    //    hRes4D->hResX->Rebin(2);
    drawGFit(hRes4D->hResX, nsigma, -0.1, 0.1);
    c1->cd(2);
    //    hRes4D->hResAlpha->Rebin(2);
    drawGFit(hRes4D->hResAlpha, nsigma, -0.01, 0.01);
    c1->cd(3);
    hRes4D->hResYRZ->Rebin(2);
    drawGFit(hRes4D->hResYRZ, nsigma, -0.4, 0.4);
    c1->cd(4);
    hRes4D->hResBeta->Rebin(2);
    drawGFit(hRes4D->hResBeta, nsigma, -0.4, 0.4);
  }

 //-------------------- Angular dependencies
  if (doAngularDeps) {
    TCanvas* c1= new TCanvas;

    float min;
    float max;
    c1->SetTitle(canvbasename+"_MeanVsAngles");
    c1->SetName(canvbasename+"_MeanVsAngles");
    c1->SetTitle(canvbasename+" Angles");

    c1->Divide(2,2);

    c1->cd(1);
    hRes4D->hSimAlpha->SetLineColor(kGreen);
    hRes4D->hSimAlpha->Draw();
    hRes4D->hRecAlpha->Draw("same");

    c1->cd(2);
    plotAndProfileX(hResPhi->hResVsAngle,1,1,1,-.04, .04, -1., 1.);

    c1->cd(3);
    hRes4D->hSimBetaRZ->SetLineColor(kGreen);
    hRes4D->hSimBetaRZ->Draw();
    hRes4D->hRecBetaRZ->Draw("same");

    c1->cd(4);
    plotAndProfileX(hResTheta->hResVsAngle,1,1,1,-.04, .04, -1.2.,1.2);

  }

  //------------------- Efficiencies Vs X, Y. alpha, beta

  if(doEff4D){
    // FIXME: should rebin histograms.

    TH1F* hEffX;
    TH1F* hEffY;
    TH1F* hEffalpha;
    TH1F* hEffbeta;

    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_Efficiencies");
    c1->SetName(canvbasename+"_Efficiencies");
    c1->SetTitle(canvbasename+"_Efficiencies");

    c1->Divide(2,2);

    c1->cd(1);
    hEffX = getEffPlot(hEff4D->hXRecHit, hEff4D->hXSimSegm,2);
    hEffX->Draw();

    c1->cd(2);
    hEffalpha = getEffPlot(hEff4D->hAlphaRecHit, hEff4D->hAlphaSimSegm,2);
    hEffalpha->Draw();

    c1->cd(3);
    hEffY = getEffPlot(hEff4D->hYRecHit, hEff4D->hYSimSegm,2);
    hEffY->Draw();

    c1->cd(4);
    hEffbeta = getEffPlot(hEff4D->hBetaRecHit, hEff4D->hBetaSimSegm,2);
    hEffbeta->Draw();

    }

 //-------------------- Segment x, y, alpha, beta pull
  if (doSegPull){
    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_PullSeg");
    c1->SetName(canvbasename+"_PullSeg");
    c1->Divide(2,2);
    c1->cd(1);

    hRes4D->hPullX->Rebin(2);
    drawGFit(hRes4D->hPullX, nsigma, -10.,10.);
    c1->cd(2);
    hRes4D->hPullAlpha->Rebin(2);
    drawGFit(hRes4D->hPullAlpha, nsigma, -10., 10.);
    c1->cd(3);
    hRes4D->hPullYRZ->Rebin(2);
    drawGFit(hRes4D->hPullYRZ, nsigma, -10., 10.);
    c1->cd(4);
    hRes4D->hPullBetaRZ->Rebin(2);
    drawGFit(hRes4D->hPullBetaRZ, nsigma, -10.,10.);

    //Fixme: Move these to another canvas. Note that the error used for hPullY is not computed correctly.q
//     c1->cd(3);
//     hRes4D->hPullY->Rebin(2);
//     drawGFit(hRes4D->hPullY, nsigma, -10., 10.);
//     c1->cd(4);
//     hRes4D->hPullBeta->Rebin(2);
//     drawGFit(hRes4D->hPullBeta, nsigma, -10.,10.);

  }

  //-------------------- #segments
  if (doNSeg) {
    TCanvas* c1= new TCanvas;
    c1->SetTitle(canvbasename+"_NSeg");
    c1->SetName(canvbasename+"_NSeg");
    // c1->Divide(2,2);
//     c1->cd(1);

    TH1F* hNs =  hEff4D->hNSeg;

    hNs->SetXTitle("#segments");
    hNs->Draw();

    double int_1 = hNs->Integral(2,21);
    double int_2 = hNs->Integral(3,21);

    double ratio = int_2/int_1;

    cout << "int_1: " << int_1 <<" int_2: " << int_2 << " ratio: " << ratio << endl;

  }

}


PCA_res= data.frame(scores)
class(PCA_res)
PCA_res$PC1
i_table =na.omit(f_table)
PCA_res$group = i_table[,2]

#Plot PC1 and 2 info on one graph
PCA1_2 = data.frame(PCA_res$PC1,PCA_res$PC2,PCA_res$group)
PCA1_2
Mean_PCA = create.mean.table(PCA1_2,levels(PCA1_2$PCA_res.group),1:2)

plot.new()
plot(PCA_res$PC2~PCA_res$PC1, type= "n")
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	points(X$PC2~ X$PC1, col=i)
	legend(list(x=6,y=-i/2-1), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,
#   cex=0.7)
   x=Mean_PCA$means$PCA_res.PC1[i]
y=Mean_PCA$means$PCA_res.PC2[i]
x2=Mean_PCA$ses$PCA_res.PC1[i]

y2=Mean_PCA$ses$PCA_res.PC2[i]
segments (x-x2,y,x+x2,y, col=i)
segments (x,y-y2,x,y+y2, col=i)
	}
	abline (v=0, h=0)

#Plot only the mean and ses

x=Mean_PCA$means$PCA_res.PC1
y=Mean_PCA$means$PCA_res.PC2
x2=Mean_PCA$ses$PCA_res.PC1
y2=Mean_PCA$ses$PCA_res.PC2

plot(Mean_PCA$means$PCA_res.PC1,Mean_PCA$means$PCA_res.PC2, ylim= c(-2,2),xlim= c(-2,2), type="n")
i=1:6
 text(x-0.05,y-0.05, rownames(Mean_PCA$means), col=i,
   cex=0.7)
segments (x-x2,y,x+x2,y, col=i)
segments (x,y-y2,x,y+y2, col=i)

x=Mean_PCA2$means$PCA_res.PC1
y=Mean_PCA2$means$PCA_res.PC3
x2=Mean_PCA2$ses$PCA_res.PC1
y2=Mean_PCA2$ses$PCA_res.PC3

plot(Mean_PCA2$means$PCA_res.PC1,Mean_PCA2$means$PCA_res.PC3, ylim= c(-2,2),xlim= c(-2,2), type="n")
i=1:6
 text(x-0.05,y-0.05, rownames(Mean_PCA2$means), col=i,
   cex=0.7)

segments (x-x2,y,x+x2,y, col=i)
segments (x,y-y2,x,y+y2, col=i)
X=cbind(PCA_res, f_table [,c(3:7)])
X$treatment=X$other

shapiro.test(PCA_res$PC1)
shapiro.test(PCA_res$PC2)
shapiro.test(PCA_res$PC3)

A=aov(PCA_res$PC1~PCA_res$group)
A=aov(X$PC1~ X$genotype*X$treatment)
summary(A)
A=aov(X$PC2~ X$genotype*X$treatment)
summary(A)
#A=aov(PCA_res$PC1~PCA_res$group)
A=aov(Y$PC1~ Y$genotype*Y$treatment)
summary(A)
A=aov(Y$PC2~ Y$genotype*Y$treatment)
summary(A)

A=aov(Y$PC3~ Y$genotype*Y$treatment)
summary(A)
A=aov(X$PC3~ X$genotype*X$treatment)
summary(A)

Y=X
X=subset (X, X$genotype !="rut1")
 X=subset (X, X$genotype !="rut2080")
 X=subset (X, X$genotype !="dnc")
X= droplevels(X)


require (ggplot2)
require (gridExtra)

mut.data <- read.table ("mut_profile_CDH11.txt", sep = "\t", header = TRUE)
text.p1.cdh11 <- data.frame (x = 1.5, y = 3300, label = c ("p < 0.001"))
text.p2.cdh11 <- data.frame (x = 2, y = 4000, label = c ("p < 0.001"))
mut.data$Group <- factor (mut.data$Group, levels = c ("Feat", "Rest", "WT"), labels = c ("IDR\n703-762", "Other CDH11\nregions", "WT"))
scatter.cdh11 <- ggplot (subset (mut.data, Pos > 0), aes (x = Pos, y = Score)) + geom_point (aes (color = Group)) + theme (axis.text = element_text (color = "black"), axis.ticks = element_line (color = "black"), axis.line = element_line (color = "black"), legend.position = "none", panel.background = element_blank()) + ylab ("ESTIMATE score\n") + scale_color_manual (values = c ("#FF6600", "#E1D4C0")) + geom_vline (xintercept = 703, linetype = 2) + geom_vline (xintercept = 762, linetype = 2) + xlab ("\nCDH11 position")
box.plot <- ggplot (mut.data, aes (x = Group, y = Score)) + geom_boxplot (aes(color = Group), outlier.shape = NA, position = position_dodge ()) + geom_point (position=position_jitter(width = 0.2), aes (fill = Group, color = Group, alpha = Group, size = Group), shape = 21) + scale_alpha_manual (values = c (1,1,0.1)) + scale_fill_manual (values = c ("#FF6600", "#E1D4C0", "lightgray")) + scale_color_manual (values = c ("#FF6600", "#E1D4C0", "lightgray")) + scale_size_manual (values = c (2,2,0.5)) + theme (axis.text = element_text (color = "black"), axis.ticks = element_line (color = "black"), axis.line = element_line (color = "black"), panel.background = element_blank(), legend.position = "none", axis.title.x = element_blank()) + ylab ("ESTIMATE score\n") + geom_text (data = text.p1.cdh11, aes (x = x, y = y, label = label), fontface = "italic", size = 3) + geom_text (data = text.p2.cdh11, aes (x = x, y = y, label = label), fontface = "italic", size = 3) + geom_segment (aes (x = 1, xend = 2, y = 3000, yend = 3000), size = 0.15) + geom_segment (aes (x = 1, xend = 3, y = 3700, yend = 3700), size = 0.15)

fig.top <- arrangeGrob (scatter.cdh11, box.plot, widths = c (3/5, 2/5), nrow = 1)

exp.data <- read.table ("correlations_CTNNB1.txt", sep = "\t", header = TRUE)

text.mrna <- data.frame (x = 500, y = 9.5, label = c ("p > 0.2"))
plot.mrna <- ggplot (exp.data, aes (x = ESTIMATE, y = CTNNB1)) + geom_point (alpha = 0.05) + geom_smooth (color = "#F67851", method = "lm") + theme (axis.ticks = element_line (color = "black"), axis.line = element_line (color = "black"), axis.text = element_text (color = "black"), panel.background = element_blank(), axis.text.x = element_blank(), axis.title.x = element_blank()) + ylab (expression (paste (beta, "-catenin mRNA"))) + geom_text (data = text.mrna, aes (x = x, y = y, label = label), fontface = "italic", size = 4)
text.prot <- data.frame (x = 500, y = -3, label = c ("p < 1e-10"))
plot.prot <- ggplot (exp.data, aes (x = ESTIMATE, y = Protein)) + geom_point (alpha = 0.05) + geom_smooth (color = "#F67851", method = "lm") + theme (axis.ticks = element_line (color = "black"), axis.line = element_line (color = "black"), axis.text = element_text (color = "black"), panel.background = element_blank()) + ylab (expression (paste (beta, "-catenin protein"))) + geom_text (data = text.prot, aes (x = x, y = y, label = label), fontface = "italic", size = 4) + xlab ("\nESTIMATE score")
fig.c <- arrangeGrob (plot.mrna, plot.prot, ncol = 1, heights = c (9/20, 11/20))

text.cd3 <- data.frame (x = 2, y = 7.2, label = c ("CD3E\np < 1e-10"))
text.cd8 <- data.frame (x = -2, y = 7, label = c ("CD8A\np < 1e-10"))
text.cdh11 <- data.frame (x = 2.2, y = 10.3, label = c ("CDH11\np < 2e-5"))
text.cdh1 <- data.frame (x = -2.2, y = 12.3, label = c ("CDH1\np < 1e-10"))

correlation.plot <- ggplot (exp.data, aes (x = Protein, y = CD3E)) + geom_smooth (method = "lm", color = "darkblue") + geom_smooth (aes (y = CD8A), method = "lm", color = "blue") + geom_smooth (aes (y = CDH1), color = "orange", method = "lm") + geom_smooth (aes (y = CDH11), color = "red", method = "lm") + xlab (expression (paste (beta, "-catenin protein"))) + ylab ("Gene level\n") + theme (axis.ticks = element_line (color = "black"), axis.line = element_line (color = "black"), axis.text = element_text (color = "black"), panel.background = element_blank()) + theme (plot.margin = unit (c (-0.5,-0.5,1,1), "lines")) + geom_text (data = text.cd3, aes (x = x, y = y, label = label), fontface = "italic", size = 3, color = "darkblue") + geom_text (data = text.cd8, aes (x = x, y = y, label = label), color = "blue", fontface = "italic", size = 3) + geom_text (data = text.cdh11, aes (x = x, y = y, label = label), fontface = "italic", size = 3, color = "red") + geom_text (data = text.cdh1, aes (x = x, y = y, label = label), size = 3, fontface = "italic", color = "orange")
histo.top <- ggplot (exp.data, aes (x = Protein)) + geom_density (color = "black", fill = "black", alpha = 0.2) + theme (axis.ticks = element_blank(), axis.line = element_line (color = "white"), line = element_blank(), axis.text = element_text (color = "white"), panel.background = element_blank(), axis.text.x = element_blank(), axis.title.x = element_blank(), axis.ticks.x = element_blank(), axis.title.y = element_text (color = "white")) + ylab ("\n") + theme (plot.margin = unit (c (1,-0.5,0,1), "lines"), panel.grid = element_blank())
histo.right <- ggplot (exp.data, aes (x = CD8A)) + geom_density (color = "blue", fill = "blue", alpha = 0.2) + geom_density (aes (x = CD3E), color = "darkblue", fill = "darkblue", alpha = 0.2) + theme (axis.ticks = element_blank(), axis.line = element_line (color = "white"), line = element_blank(), axis.text = element_text (color = "white"), panel.background = element_blank(), axis.text.y = element_blank(), axis.title.y = element_blank(), axis.title.x = element_text (color = "white"), axis.ticks.y = element_blank()) + ylab ("Samples") + coord_flip () + geom_density (aes (x = CDH11), color = "red", fill = "red", alpha = 0.2) + geom_density (aes (x = CDH1), color = "orange", fill = "orange", alpha = 0.2) + theme (plot.margin = unit (c (1,1,1,-0.5), "lines"), panel.grid = element_blank())
empty.plot <- ggplot (exp.data, aes (x = CDH1, y = CDH11)) + geom_blank() + theme (axis.text = element_blank(), axis.ticks = element_blank(), axis.line = element_blank(), panel.background = element_blank(), axis.title = element_blank(), line = element_blank())
fig.d <- arrangeGrob (histo.top, empty.plot, correlation.plot, histo.right, heights = c (4/20, 16/20), widths = c (16/20, 4/20))

fig.middle <- arrangeGrob (fig.c, fig.d, nrow = 1, widths = c (2/5, 5/5))

mech.data <- read.table ("table_correlation_MECHISMO_ESTIMATE.csv", sep = "\t", header = TRUE)
mech.text <- data.frame (x = 500, y = 2.3, text = c ("R > 0.9"))
mech.plot <- ggplot (mech.data, aes (x = ESTIMATE, y = Mechismo)) + geom_point (color = "orange") + geom_smooth (method = "lm") + theme (axis.text = element_text (color = "black"), axis.line = element_line (color = "black"), axis.ticks = element_line (color = "black"), panel.background = element_blank()) + xlab ("\nESTIMATE score") + ylab ("Mechismo score\n") + geom_text (data = mech.text, aes (x = x, y = y, label = text), size = 4, fontface = "italic")
fig.bottom <- arrangeGrob (empty.plot, mech.plot, nrow = 1, widths = c (2/3, 1/3))

figure.3 <- arrangeGrob (fig.top, fig.middle, fig.bottom, ncol = 1, heights = c (2/5, 3/5, 2/5))

ggsave (file = "Figure_3.pdf", figure.3)


context("testing singleconstraint")
test_that("H matrix with defined task on rhs has 0 sd for lambda", {
    lhs <- constraint_H_with_bounds(H_matrix_mini, c(1), bounds_tuple_of_numeric_mini)
    muscle_solutions <- lhs %>% eliminate_redundant %>% pb_har_sample(10000, mc.cores = 8,
        eliminate = FALSE) %>% as.matrix
    wrench_outputs <- H_matrix_mini %*% t(muscle_solutions) %>% as.numeric
    expect_equal(wrench_outputs, rep(1, nrow(muscle_solutions)))
    expect_equal(sd(wrench_outputs), 0)
})

test_that("H matrix mini can be combined and har'd successfully", {
    lhszero <- constraint_H_with_bounds(H_matrix_mini, c(0), bounds_tuple_of_numeric_mini)
    lhshalf <- constraint_H_with_bounds(H_matrix_mini, c(0.5), bounds_tuple_of_numeric_mini)
    lhsone <- constraint_H_with_bounds(H_matrix_mini, c(1), bounds_tuple_of_numeric_mini)
    list_of_constraints <- list(lhszero, lhshalf, lhsone)
    trajectory_miniH_constr <- diagonal_merge_constraint_list(list_of_constraints)
    context('make sure row amount matches')
    sum_rows <- sapply(list_of_constraints, function(x) nrow(x$constr)) %>% sum
    expect_equal(nrow(trajectory_miniH_constr$constr), sum_rows)

    context('make sure solutions are valid within the given jumboconstraint')
    muscle_solutions <- trajectory_miniH_constr %>% eliminate_redundant %>% pb_har_sample(10000,
        mc.cores = 8, eliminate = FALSE) %>% as.matrix
    expect_true(all(evaluate_solutions(muscle_solutions, trajectory_miniH_constr)))

    context('run har and split on independent constraints')
    har_constraint_pairs_independent <- har_and_split_trajectory_constraint(trajectory_miniH_constr, list_of_constraints,
    num_muscles=3, har_samples=1e5)

    context("now try with velocity constraints")
    st_constraint <- generate_and_add_velocity_constraint(trajectory_miniH_constr, 0.5,
    0.5, num_muscles=3)
    expect_true(constraint_is_feasible(st_constraint))
    plot_constraint_matrix(st_constraint)
    har_constraint_pairs_velocity_constrained <- har_and_split_trajectory_constraint(trajectory_miniH_constr, list_of_constraints,
    num_muscles=3, har_samples=1e5)
})


library(WheresCroc)

myFunction = function (moveInfo, readings, positions, edges, probs){
  checkIfInTop = 3
  # reset state if new game
  if((moveInfo$mem$status >= 0)) { # status new game has started
    #reset states
    dim = length(probs$salinity[,1])

    moveInfo$mem$state = rep(1/dim, dim)
    if ((moveInfo$mem$status == 0)) { # status first game has started
      connections = diag(1, nrow = dim, ncol = dim)

      # set connections in matrix
      connections[edges] = 1
      connections[edges[, c(2,1)]] = 1

      # calculate transition_matrix based on connections
      divide_by = colSums(connections)
      moveInfo$mem$connections = connections
      moveInfo$mem$transition_matrix = sweep(connections, 2, divide_by, FUN = '/')
      moveInfo$mem$checkIfInTop = 22
    }

    moveInfo$mem$status = -1
  }

  connections = moveInfo$mem$connections
  state = moveInfo$mem$state
  transition_matrix  = moveInfo$mem$transition_matrix
  player_pos = positions[3]

  # update sate based on backpackers
  if (is.na(positions[1]) == FALSE) {
    if (positions[1] < 0) { # gets eaten
      state[] = 0
      state[positions[1]] = 1
    } else {
      state[positions[1]] = 0
    }
  }
  if (is.na(positions[2]) == FALSE) {
    if (positions[2] < 0) { # gets eaten
      state[] = 0
      state[positions[2]] = 1
    } else {
      state[positions[2]] = 0
    }
  }

  probs_salinity = dnorm(readings[1],  mean = probs$salinity[,1], sd = probs$salinity[,2])
  probs_phosphate = dnorm(readings[2], mean = probs$phosphate[,1], sd = probs$phosphate[,2])
  probs_nitrogen = dnorm(readings[3],  mean = probs$nitrogen[,1], sd = probs$nitrogen[,2])

  # calculating the emission matrix
  emission_matrix = diag(probs_salinity * probs_phosphate * probs_nitrogen)

  # probabilityies of crocs position next turn
  state = emission_matrix %*% state

  # normalise state
  state = state / sum(state)

  node_to_move_to = which.max(state) # most likely next round
  path = c(0)
  if (node_to_move_to != player_pos) {
    path = findPath(player_pos, node_to_move_to, connections)
  } else {
    order = order(state, decreasing = TRUE)
    node_to_move_to_plan_b = order[2]
    path = append(node_to_move_to, findPath(player_pos, node_to_move_to_plan_b, connections))
  }
  ranks = rank(state)
  if((ranks[player_pos] > (length(ranks) - checkIfInTop)) & (ranks[path[1]] < ranks[player_pos] )) {
    moveInfo$moves = c(0, path[1])
    state[player_pos] = 0
  } else if(ranks[path[1]] > (length(ranks) - checkIfInTop)){
    moveInfo$moves = c(path[1], 0)
    state[path[1]] = 0
  } else {
    moveInfo$moves = c(path[1], path[2])
  }

  state = transition_matrix %*% state

  moveInfo$mem$state = state
  return(moveInfo)
}

findPath <- function(start, goal, matrix) {
  nodesNumber = length(matrix[1,])
  q = c(start)
  visited = rep(F, nodesNumber)
  visited[start] = T
  prev = rep(NULL, nodesNumber)

  while(length(q) > 0) {
    current = q[1]
    q = q[-1]

    if (current == goal) {
      path = c(goal)
      node = prev[goal]
      while (!is.na(prev[node])) {
        path = c(node, path)
        node = prev[node]
      }
      return(path)
    }

    neighbours = which(matrix[current,] > 0)

    for (neighbour in neighbours) {
      if (!visited[neighbour]) {
        q = c(q, neighbour)
        visited[neighbour] = T
        prev[neighbour] = current
      }
    }
  }
  return(NA)
}

#runWheresCroc(myFunction, showCroc = TRUE)
testWC(myFunction, verbose = 1)
#runWheresCroc(WheresCroc::manualWC)


## Just in case you want to go through the steps on an R tool like (RGui, RStudio or R Tools for VS)
##this script uses rpart instead of rxlogit
## these are the step by step to reproduce the lab

install.packages("RODBC")
library(RODBC)

##Connect to SQL Server 2016, assumes a Windows Authentication method
dbhandle <- odbcDriverConnect('driver={SQL Server};server=<yourservername>;database=taxidata;trusted_connection=true')

##Run the query to brin the data we'll use to create the model
res <- sqlQuery(dbhandle, 'select tipped,  passenger_count, trip_time_in_secs, trip_distance, direct_distance   from nyctaxi_features')

##Create the model...
model <- rxLogit(tipped ~ passenger_count + trip_distance + trip_time_in_secs + direct_distance, res)
summary(model)

##Now, let's create the frame with the parameters for the prediction
prediction_parameters <- data.frame(passenger_count = 1, trip_time_in_secs = 631, trip_distance = 2.5, direct_distance = 2)

##predict
OutputDataFrame <- rxPredict(model, prediction_parameters, outData = NULL, predVarNames = "Score", type = "response", writeModelVars = FALSE, overwrite = TRUE)
OutputDataFrame


qq.xy <- function(xy){

  sx <- sort(xy[ ,1])
  sy <- sort(xy[ ,2])
  lenx <- length(sx)
  leny <- length(sy)
  if (leny < lenx) sx <- approx(1L:lenx, sx, n = leny)$y
  if (leny > lenx) sy <- approx(1L:leny, sy, n = lenx)$y
  qq <- data.frame(q1 = sx,q2 = sy)
  colnames(qq) <- colnames(xy)
  qq
}


# 4. faza: Analiza podatkov

# združevanje v skupine

library(tmap)

zivlj_doba_razv <- data.frame(filter(zivlj_doba, SPOL=='m'))
zivlj_doba_razv <- zivlj_doba_razv[-c(3)]
prorac_razv <- filter(zdravstvo, LETO == '2016')
prorac_razv <- prorac_razv[c(1,3)]
postelje_razv <- filter(zdravstvo, LETO == '2016')
postelje_razv <- postelje_razv[c(1,4)]
tabela_razvrscanje1 <- inner_join(zivlj_doba_razv, prorac_razv, by="DRZAVA")
tabela_razvrscanje2 <- inner_join(tabela_razvrscanje1, postelje_razv, by="DRZAVA")
rownames(tabela_razvrscanje2) =  tabela_razvrscanje2$DRZAVA
tabela_razvrscanje <- tabela_razvrscanje2[-c(1)]

set.seed(1000)
clustri_zdr <- kmeans(scale(tabela_razvrscanje), 4, nstart=100)
tabela1 <- data.frame(DRZAVA = tabela_razvrscanje2$DRZAVA, ZIVLJENJSKA_DOBA = tabela_razvrscanje2$ZIVLJENJSKA_DOBA,
                      PRORACUN = tabela_razvrscanje2$PRORACUN, POSTELJE = tabela_razvrscanje2$POSTELJE,
                      SKUPINA = factor(clustri_zdr$cluster, ordered = TRUE))
skupaj3 <- left_join(drzave, tabela1, by="DRZAVA")
zemljevid_cluster_zdr <- ggplot() + geom_polygon(data=left_join(zemljevid_evrope, skupaj3, by=c("NAME"="DRZAVA")),
                                                aes(x=long, y=lat, group=group, fill=SKUPINA)) +
  geom_line() +
  theme(axis.text.x=element_blank(), axis.ticks.x=element_blank(), axis.text.y=element_blank(),
        axis.ticks.y=element_blank()) +
  scale_fill_manual(values = c('yellow', 'orange', 'orangered', 'red3'),
                    labels = c('1', '2', '3', '4'), na.value="grey") +
  labs(x = " ") +
  labs(y = " ") +
  ggtitle("Razvrstitev držav v skupine glede na zdravstveno stanje")

#print(zemljevid_cluster_zdr)

tabela_razvitost <- data.frame(filter(razvitost, LETO == '2016'))
tabela_razvitost$BREZPOSELNI <- -(tabela_razvitost$BREZPOSELNI)
rownames(tabela_razvitost) =  tabela_razvitost$DRZAVA
tabela_razvitost <- na.omit(tabela_razvitost)[-c(2)]
tabela_razvitost1 <- tabela_razvitost[-c(1)]

set.seed(1000)
clustri_razv <- kmeans(scale(tabela_razvitost1), 4, nstart=100)
tabela2 <- data.frame(DRZAVA = tabela_razvitost$DRZAVA, BDP = tabela_razvitost$BDP,
                      DOHODEK = tabela_razvitost$DOHODEK, BREZPOSELNI = tabela_razvitost$BREZPOSELNI,
                      SKUPINA = factor(clustri_razv$cluster, ordered = TRUE))
skupaj4 <- left_join(drzave, tabela2, by="DRZAVA")
zemljevid_cluster_razv <- ggplot() + geom_polygon(data=left_join(zemljevid_evrope, skupaj4, by=c("NAME"="DRZAVA")),
                                             aes(x=long, y=lat, group=group, fill=SKUPINA)) +
  geom_line() +
  theme(axis.text.x=element_blank(), axis.ticks.x=element_blank(), axis.text.y=element_blank(),
        axis.ticks.y=element_blank()) +
  scale_fill_manual(values = c('yellow', 'orange', 'orangered', 'red3'),
                    labels = c('1', '2', '3', '4'), na.value="grey") +
  labs(x = " ") +
  labs(y = " ") +
  ggtitle("Razvrstitev držav v skupine glede na gospodarsko razvitost")

#print(zemljevid_cluster_razv)

# regresija življenjske dobe

zivlj_doba_evropa <- group_by(zivlj_doba_regresija, LETO) %>% summarise(POVPRECJE=mean(ZIVLJ_DOBA))

prileganje <- lm(data = zivlj_doba_evropa, POVPRECJE ~ LETO)

napoved <- data.frame(LETO=seq(2019, 2025, 1)) %>% mutate(POVPRECJE=predict(prileganje, data.frame(LETO=seq(2019, 2025, 1))))

graf_regresija <- ggplot(zivlj_doba_evropa, aes(x=LETO, y=POVPRECJE)) +
  geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=napoved, aes(x=LETO, y=POVPRECJE), color='red', size=2) +
  geom_point() +
  labs(title='Napoved življenjske dobe za države Evropske unije', y="ŽIVLJENJSKA DOBA")

#print(graf_regresija)


#' Report model diagnostic statistics based on the PEST .res file.
#' This function requires a PEST .res file to be located in the PATH directory.
#'
#' @param PATH this is the full file path to the .res file.
#' @export

pstmodcal <- function(PATH){

    if(is.na(PATH)){
        PATH <- getwd()
    }

    res  <- MFtools::readpstres(PATH) %>%
            dplyr::mutate(SQUARE_RES = `Weight*Residual`^2)

    max_obs <- max(res$Measured, na.rm = TRUE)
    min_obs <- min(res$Measured, na.rm = TRUE)
    range_val <- max_obs - min_obs

    STATS <- res %>% dplyr::summarise(MEAN_RES = mean(`Weight*Residual`, na.rm = TRUE),
                                      MEAN_ABS_RES = mean(abs(`Weight*Residual`), na.rm = TRUE),
                                      ST_DEV = sd(`Weight*Residual`, na.rm = TRUE),
                                      SSQ = sum(SQUARE_RES),
                                      RMSE = mean(SQUARE_RES)^0.5,
                                      MIN = min(`Weight*Residual`, na.rm = TRUE),
                                      MAX = max(`Weight*Residual`, na.rm = TRUE),
                                      nOBS = n(),
                                      RANGE = range_val,
                                      SCALED_ST_DEV = ST_DEV / range_val,
                                      SCALED_MEAN_ABS_RES = MEAN_ABS_RES / range_val,
                                      SCALED_RMSE = RMSE / range_val,
                                      SCALED_MEAN_RES = MEAN_RES / range_val)
    return(STATS)
    }


library(XML)
library(reshape2)
library(rCharts)
library(plyr)

getAgeTable <- function(country, year) {
  c1 <- "http://www.census.gov/population/international/data/idb/region.php?N=%20Results%20&T=10&A=separate&RT=0&Y="
  c2 <- "&R=-1&C="
  yrs <- gsub(" ", "", toString(year))
  url <- paste0(c1, yrs, c2, country)
  df <- data.frame(readHTMLTable(url))
  nms <- c("Year", "Age", "total", "Male", "Female", "percent", "pctMale", "pctFemale", "sexratio")
  names(df) <- nms
  cols <- c(1, 3:9)
  df[,cols] <- apply(df[,cols], 2, function(x) as.numeric(as.character(gsub(",", "", x))))
  df <- df[df$Age != 'Total', ]
  ord <- 1:nrow(df)
  df <- cbind(df, ord)
  return(df)
}

# DimpleJS pyramid

dPyramid <- function(country, year, colors=NULL) {
  dat <- getAgeTable(country, year)
  dat$Male <- -1 * dat$Male

  keep <- c("Year", "Age", "Male", "Female", "ord")

  dat.sub <- dat[,keep]

  dat.melt <- melt(dat.sub,
                   value.name='Population',
                   variable.name = 'Gender',
                   id.vars=c('Age', 'ord', 'Year') )

  dat.melt$gencode <- ifelse(dat.melt$Gender == 'Male', 1, 2)

  d1 <- dPlot(
    x = "Population",
    y = "Age",
    groups = "Gender",
    data = dat.melt,
    type = 'bar')

  d1$yAxis(type = "addCategoryAxis", orderRule = "ord")
  d1$xAxis(type = "addMeasureAxis")
  d1$legend( x = 60, y = 10, width = 700, height = 20, horizontalAlign = "right")

  if (!is.null(colors)){
    d1$colorAxis(
      type = "addColorAxis",
      colorSeries = "gencode",
      palette = colors
    )
  }
  if (length(year) > 1) {
    d1$set(storyboard = "Year")
    max_x <- round_any(max(dat.melt$Population), 10000, f = ceiling)
    min_x <- round_any(min(dat.melt$Population), 10000, f = floor)
    d1$xAxis(overrideMax = max_x, overrideMin = min_x)
  }

  if (max(dat.melt$Population >= 1000000)) {
    d1$setTemplate( afterScript =
                      "

                    ")
  } else {
    d1$setTemplate( afterScript =
                      "

                    ")
  }

  d1
}

# Highcharts pyramid

hPyramid <- function(country, year, colors = NULL) {
  dat <- getAgeTable(country, year)
  dat$Male <- -1 * dat$Male

  dat$Age <- factor(dat$Age, levels = rev(dat$Age), labels = rev(dat$Age))

  keep <- c("Male", "Female", "Age")

  dat.sub <- dat[,keep]

  dat.melt <- melt(dat.sub,
                   value.name='Population',
                   variable.name = 'Gender',
                   id.vars='Age' )

  h1 <- hPlot(
    y = 'Population',
    x = 'Age',
    type = 'bar',
    data = dat.melt,
    group = 'Gender')

  h1$plotOptions(series = list(stacking = 'normal', pointPadding = 0, borderWidth = 0))

  h1$tooltip(formatter = "#! function() { return ''+ this.series.name +', age '+ this.point.category +'
' + 'Population: ' + Highcharts.numberFormat(Math.abs(this.point.y), 0);} !#")

  h1$legend(reversed = "true")

  if (max(dat.melt$Population >= 1000000)) {
    h1$yAxis(labels = list(formatter = "#! function() { return (Math.abs(this.value) / 1000000) + 'M';} !#"),
             title = list(enabled = TRUE, text = 'Population'))
  } else {
    h1$yAxis(labels = list(formatter = "#! function() { return (Math.abs(this.value) / 1000) + 'K';} !#"),
             title = list(enabled = TRUE, text = 'Population'))
  }

  if (!is.null(colors)) {
    h1$colors(colors)
  }
  if (length(year) > 1) {
    stop('Right now, hPyramid only accepts one year')
  }

  h1$exporting(enabled = TRUE)

  h1
}

# NVD3 pyramid

nPyramid <- function(country, year, colors = NULL) {
  dat <- getAgeTable(country, year)
  dat$Male <- -1 * dat$Male

  dat <- dat[order(rev(dat$ord)), ]

  keep <- c("Male", "Female", "Age")

  dat.sub <- dat[,keep]

  dat.melt <- melt(dat.sub,
                   value.name='Population',
                   variable.name = 'Gender',
                   id.vars='Age' )

  dat.melt$abs <- abs(dat.melt$Population)

  n1 <- nPlot(
    y = 'Population',
    x = 'Age',
    group = 'Gender',
    type = 'multiBarHorizontalChart',
    data = dat.melt)

  # n1$xAxis(axisLabel = "Age") ## Need to work out label placement

  n1$chart(stacked = TRUE)

  n1$chart(tooltipContent = "#! function(key, x, y, e){
           var format = d3.format('0,000');
           return '
' + key + ', age ' + x + '
' +
           '
' + 'Population: ' + format(e.point.abs) + '
'
} !#")

  if (max(dat.melt$Population >= 1000000)) {
    n1$yAxis(axisLabel = "Population",
             tickFormat = "#! function(d) {
                          return d3.format(',.1f')(Math.abs(d) / 1000000) + 'M'
                          } !#")
  } else {
    n1$yAxis(axisLabel = "Population",
             tickFormat = "#! function(d) {
                          return d3.format(',.0f')(Math.abs(d) / 1000) + 'K'
                          } !#")

  }

  if (!is.null(colors)) {
    n1$chart(color = colors)


bottom.contact.modal = function( sm, bcp ) {
  # Modal method: gating by looking for modal distribution and estimating sd of the modal group
  # until a target number of breaks, nbins with valid data are found
  # see density and bw.SJ for more options

  res = list( bc0=NA, bc1=NA)

  names(sm) = c("Z", "timestamp", "ts" ) # Z is used to abstract the variable name such that any variable can be passed
  N = nrow(sm)
  if ( N < 50 ) return(res)  # insufficient data

  sm$Z = sm$Z + runif( N, min=-0.5, max=0.5 ) * bcp$eps.depth   # add some noise as data are too "flat"

  # first pass to crudely determine location of mode
  Z0 = modes( sm$Z )

  r0 =1
  r1 =N
  # catch situations where there is no variance in data due to only bottom-track being recorded and truncated:
  # no discrimination possible
  if ( !is.finite(Z0$sd) || Z0$sd < 1e-3) {
    oo = which ( abs( sm$Z - Z0$mode ) < bcp$eps.depth )  # anything within eps m of the "mode"
    if (length(oo) > 50) {
      rr = range(oo)
      res = c( sm$timestamp[rr[1]], sm$timestamp[rr[2]] )
    }
    return(res)
  }

  # trim tails a bit more:
  fa = range( which( sm$Z < (Z0$mode + bcp$depth.range[2]/2) & sm$Z > (Z0$mode + bcp$depth.range[1]/2) ) )
  if ( abs( diff( fa)) > 30 ) {
    Z0 = modes( sm$Z[ fa[1]: fa[2] ] )
  }

  aoi.i = which( sm$Z > Z0$lb2 &  sm$Z < Z0$ub2 )
  aoi = min(aoi.i) : max(aoi.i)
  aoi.n = length(aoi)
  aoi.trunc = floor( aoi.n / 5 )
  aoi = aoi[ aoi.trunc] : aoi[ aoi.n-aoi.trunc ]  # trim off 1/5 off each tail

  aoi.inner = floor( length(aoi) / 3 )

  left = min(aoi.i) + c( 0 : aoi.inner )
  right = max(aoi.i) + c( - aoi.inner : 0 )

  modal.threshold = 0.5
  mwin = -bcp$modal.windowsize: bcp$modal.windowsize

  #final pass using the initial estimates as a filter .. operating on residuals
  # create a variable with any linear trend in the depths removed as this can increase the precision of the method
  if (length( aoi ) > 0 ) {

    botlm = lm( Z ~ ts , data=sm[ left,], weights=Z^2, na.action="na.omit")
    sm$Zl = sm$Z - predict( botlm, newdata=sm )
    Zrmodes.left = modes( sm$Zl[ left ] )
    i.left = which( sm$Zl[left] > Zrmodes.left$lb2 & sm$Zl[left] < Zrmodes.left$ub2    )
    i.mod = left[i.left]
    ill = 5:floor(median(i.mod) )

    if ( abs( min(sm$Zl[ill], na.rm=TRUE) - Zrmodes.left$mode ) <   bcp$modal.sd.multiplier* Zrmodes.left$sd ) {
      r0 = 1 # nothing to do .. assuming it is truncated without the left tail ..
    } else {
      for ( r0 in ill){
        ri = r0 + mwin
        ri = ri[ ri >= 1 & ri <=N ]
        nri = length(ri)
        if ( nri > 3 ) {
          nx = length( which( sm$Zl[ri] > Zrmodes.left$lb2 & sm$Zl[ri] < Zrmodes.left$ub2 )  )
          prx = nx / nri
          if (prx > modal.threshold) break()
        }
      }
    }

    botlm = lm( Z ~ ts , data=sm[ right,], weights=Z^2, na.action="na.omit")
    sm$Zr = sm$Z - predict( botlm, newdata=sm )
    Zrmodes.right = modes( sm$Zr[ right ] )
    i.right = which( sm$Zr[right] > Zrmodes.right$lb2 & sm$Zr[right] < Zrmodes.right$ub2 )
    i.mod = right[i.right]
    irr = (N-5):floor(median(i.mod))

    if ( abs( min(sm$Zr[irr], na.rm=TRUE) - Zrmodes.right$mode ) <  bcp$modal.sd.multiplier * Zrmodes.right$sd ) {
      r1 = N # nothing to do ... assuming it is truncated without the right tail ..
    } else {

      for ( r1 in irr ) {
        ri = r1+mwin
        ri = ri[ ri >= 1 & ri <=N ]
        nri = length(ri)
        if ( nri > 3 ) {
          nx = length( which( sm$Zr[ri] > Zrmodes.right$lb2 & sm$Zr[ri] < Zrmodes.right$ub2 )  )
          prx = nx / nri
          if (prx > modal.threshold) break()
        }
      }
    }
  }

  res = list( bc0=sm$timestamp[r0], bc1=sm$timestamp[r1] )

  return(res)
}