# gp regression stan

library(rstan)
library(tidyverse)
library(bridgesampling)
source("/home/alexander/r_programming/modelsplitting/R/f_dataset_loader_logistic_reg.R")
source("/home/alexander/r_programming/modelsplitting/R/f_helper.R")
source("/home/alexander/r_programming/modelsplitting/R/functions_logistic_reg.R")
source("/home/alexander/r_programming/modelsplitting/R/functions_product_normal.R")
source("/home/alexander/r_programming/rstan/f_data_splits_stan.R")

fileName <- "./gp_reg.stan"
stan_code <- readChar(fileName, file.info(fileName)$size)
mod <- stan_model(model_code = stan_code, auto_write = T)

N = 400
if(F){
  x = 4*pi*runif(N)
  y = cos(x)+rnorm(N)*0.1
  plot(x,y)
  dat <- list(N        = N,
              x        = x,
              y    = y
              )

  resStan <- sampling(mod, data = dat, chains = 1, iter = 10000, warmup = 2000, thin = 1, seed = 1)
  bridge_sampler(resStan)
  interres <- rstan::extract(resStan, pars="beta", permuted=F)
  plot(density(interres[,,1]))
  plot(density(interres[,,2]))
  plot(density(interres[,,3]))
}

scale <-  1
dataset <- "gp_test"
ssplits <- 4
iter <- 10
dataset_loaded <- f_dataset_load_logistic_regression(dataset, nobs=N)
splitted_data <- f_pack_split_data(dataset_loaded$X, dataset_loaded$y, d=3, ssplits=ssplits, iseed=iter, typesplit="random")
splitted_data <- f_prep_prior_logistic(splitted_data, scale = scale)

res <-  f_stan_sampling_splitted_data_logistic(mod, splitted_data, dataset = dataset, i_seed = iter, iter = iter, typesplit = "random", epapprox = F, bridgepack = T)


# title: "Fossil Data Quality and Analysis"
#author: "Niket Choudhary"

q1 <- read.csv(file.choose(), header = T, na.strings = c("NA",""," ",".")) # Load the data from file, after saving xlsx file as csv in Excel.

summary(q1)

# See if our Data has Missing values
sapply(q1, function(x){sum(is.na(x))})

# We have two empty columns, Transaction.Amount.in.USD..Pre.Tax. and Local.Time. We have 2 missing values in Zip, 2685 missing in State.

#Transaction.Code should have unique values, let's check
length(unique(q1$Transaction.Code))

length(unique(q1$Store.Name))

#Well it seems we have repetitions here, we should only consider rows with unique Transaction.Code
q1 <- q1[!duplicated(q1$Transaction.Code),]

#Let's check again
length(unique(q1$Transaction.Code))

#In our analysis we can drop certain columns
q1$Transaction.Amount.in.USD..Pre.Tax. <- NULL
q1$State <- NULL
q1$Zip <- NULL
q1$CN.ZIP..First.4. <- NULL
q1$Local.Time <- NULL
q1$YYYYMMDD <- NULL

#Let us extract name of the month
q1$Date <- as.Date(q1$Date.and.Time.In.China, format="%m/%d/%Y")

q1$Month_name <- as.factor(format(q1$Date, "%B" ))
q1$Month <- as.factor(format(q1$Date, "%m" ))

#Let's look at the Age distribution
summary(q1$Age)

#Let's classify Age in groups
q1$Age_group <- '65+'
q1$Age_group[q1$Age < 65 & q1$Age >= 55] <- '55-65'
q1$Age_group[q1$Age < 55 & q1$Age >= 45] <- '45-55'
q1$Age_group[q1$Age < 45 & q1$Age >= 35] <- '35-45'
q1$Age_group[q1$Age < 35] <- '21-35'

#Let's look at the Month distribution
table(q1$Month_name)

#Let's classify Month in Quarters
q1$Quarters <- quarters(q1$Date)

#Let's look which gender is purchasing more
agg_gender <- aggregate(Customer.ID ~ Gender , data = q1, length)
agg_gender

#We have more Male customers.

#Total spending per country
agg_amount <- aggregate(Transaction.Amount.in.USD ~ Country , data = q1, sum)
agg_amount <- agg_amount[with(agg_amount,order(-Transaction.Amount.in.USD)),]
agg_amount

library(ggplot2)

ggplot(agg_amount, aes(x = Country, y = Transaction.Amount.in.USD)) +
geom_bar(aes(fill = Transaction.Amount.in.USD), stat = "identity") +
xlab("Country") + ylab("Total Amount of Transactions") + labs(title = "Total Transactions  per Country", fill="Transaction Amount") +
theme(text = element_text(size = 20), axis.text.x = element_text(angle = 90, vjust = 0.6))
# geom_text(aes(label = Country), vjust = -1)

#The 5 biggest market for Fossil are Canada, Germany, USA, Italy, UK

#Let's look in detail at top 5 countries
agg_country <- aggregate(Transaction.Amount.in.USD ~ Country + Quarters + Gender, data = q1, sum)
agg_country <- agg_country[with(agg_country,order(-Transaction.Amount.in.USD)),]
agg_country

Canada <- agg_country[agg_country$Country == "Canada",]
Germany <- agg_country[agg_country$Country == "Germany",]
USA <- agg_country[agg_country$Country == "USA",]
Italy <- agg_country[agg_country$Country == "Italy",]
UK <- agg_country[agg_country$Country == "UK",]

ggcanada <- ggplot(Canada, aes(x = Quarters, y = Transaction.Amount.in.USD, colour = Gender, group = Gender)) +
  geom_line(size = 1.5) +
  geom_point(size = 2.8, shape = 21) +
  labs(y = " ", x = " ") + theme(text = element_text(size=20))
#scale_colour_manual(values=c("blue", "red"))

gggermany <- ggplot(Germany, aes(x = Quarters, y = Transaction.Amount.in.USD, colour = Gender, group = Gender)) +
  geom_line(size = 1.5) +
  geom_point(size = 2.8, shape = 21) +
  labs(y = " ", x = " ") + theme(text = element_text(size=20))
# scale_colour_manual(values=c("blue", "red"))

ggusa <- ggplot(USA, aes(x = Quarters, y = Transaction.Amount.in.USD, colour = Gender, group = Gender)) +
  geom_line(size = 1.5) +
  geom_point(size = 2.8, shape = 21) +
  labs(y = " ", x = " ") + theme(text = element_text(size=20))
# scale_colour_manual(values=c("blue", "red"))

gggitaly <- ggplot(Italy, aes(x = Quarters, y = Transaction.Amount.in.USD, colour = Gender, group = Gender)) +
  geom_line(size = 1.5) +
  geom_point(size = 2.8, shape = 21) +
  labs(y = " ", x = " ") + theme(text = element_text(size=20))
#scale_colour_manual(values=c("blue", "red"))

gguk <- ggplot(UK, aes(x = Quarters, y = Transaction.Amount.in.USD, colour = Gender, group = Gender)) +
  geom_line(size = 1.5) +
  geom_point(size = 2.8, shape = 21) +
  labs(y = " ", x = "Quarters") + theme(text = element_text(size=20))
#scale_colour_manual(values=c("blue", "red"))

#library("gridExtra")
#library("cowplot")
library(ggpubr)

figure <- ggarrange(ggcanada, gggermany, ggusa, gggitaly, gguk, heights = c(8, 8, 8, 8, 8),
                    ncol = 1, nrow = 5, labels = c("CA", "GE", "US", "IT", "UK"), common.legend = TRUE)

annotate_figure(figure, bottom = text_grob("Transactions per Quarter by Gender across Canada, Germany, USA, Italy, UK", color = "black", face = "bold", size = 12.9))

#We can see a general trend of lower transactions in Q4 compared to Q1.

#Now let's look at total spending per City in USA by age group
agg_amount_USA <- aggregate(Transaction.Amount.in.USD[q1$Country == 'USA'] ~ City[q1$Country == 'USA'] + Age_group[q1$Country == 'USA'], data = q1, sum)
agg_amount_USA <- agg_amount_USA[with(agg_amount_USA,order(-`Transaction.Amount.in.USD[q1$Country == "USA"]`)),]
agg_amount_USA <- agg_amount_USA[1:30,]
agg_amount_USA

#Let's plot a graph with the top 30 transactions across major cities
ggplot(agg_amount_USA, aes(x = `City[q1$Country == "USA"]`, y = `Transaction.Amount.in.USD[q1$Country == "USA"]`, fill = `Age_group[q1$Country == "USA"]`)) +
  geom_bar(stat = "identity", position = position_dodge()) +
  xlab("City") + ylab("Total Amount of Transactions") + labs(title = "Total Transactions  per City across Age Groups in USA",  fill="# Age Group") +
  theme(text = element_text(size = 19), axis.text.x = element_text(angle = 90, vjust = 0.6))

#We observe that Age group 21-35 does most shopping followed by others

library(ggplot2)
theme_set(theme_classic())

# Plot
g <- ggplot(agg_amount_USA, aes(`Transaction.Amount.in.USD[q1$Country == "USA"]`))

g + geom_density(aes(fill = factor(`Age_group[q1$Country == "USA"]`), y=..scaled..), alpha = 0.5) +
  coord_cartesian(xlim=c(1200, 10600)) +
  labs(title = "Density plot",
       subtitle = "Transaction Grouped by Number of Age",
       x = "Transaction",
       fill="# Age Group")

#Here we can clearly observe that Age group 21-35 has a high Transaction amount.


library(data.table)
library(clusterCrit)
library(parallel)
library(caret)
library(corrplot)
library(sf)
library(mclust)
library(ggsci)
library(car)

source("~/Dropbox/git/retail_typology/clustergram.r")

options(max.print = 3600)

################################################################ Functions ####################################################################################

##### 1. z-standardise ########################################################################################################################################

fun_std <- function(x){
  ifelse(max(x) - min(x) != 0, (x - min(x)) / (max(x) - min(x)), 0)
}

##### 2. Create a plot of the centrality measure of each explanatory variable conditional on cluster level ####################################################

centrality_per_level <- function(Df, id_vars = "clustering", measure_vars = names(Df)[-which(names(Df) %in% id_vars)], fun_central = mean, out_csv_name = NULL, ...){

  Df_long <- data.table::melt(Df, id.vars = id_vars, measure.vars = measure_vars)

  centrality <- aggregate(Df_long$value, by = list(Df_long[[id_vars]], Df_long$variable), fun_central)
  names(centrality) <- c("cluster", "category", "mean_pct")
  centrality$cluster <- as.factor(centrality$cluster)
  # write.csv(centrality, "mean_per_cluster.csv", row.names = F)

  if (!is.null(out_csv_name)) fwrite(centrality, out_csv_name)

  return(ggplot(centrality, aes(x = category, fill = cluster, y = mean_pct)) + geom_dotplot(binaxis = "y", stackdir = "center") +
           theme(axis.text.x = element_text(size = 15, angle=90,vjust = 0.5,hjust = 1)) +
           ylab("Mean of Variable (%)") + scale_fill_discrete(name = "Cluster ID") + scale_fill_d3())

}

##### 3. Produce clustergram to decide on the number of clusters ##############################################################################################

get_clustergram <- function(Df, z_std = T, which_many = c("many_kmeans", "many_pam"), k_vec = 2:20, ...){
  Dt <- as.data.table(Df)
  if (z_std){
    n <- ncol(Dt)
    Dt[, (1:n) := lapply(.SD, fun_std), .SDcols = 1:n]
  }
  if (which_many == "many_kmeans"){
    cl_many <- many_kmeans(Dt, k_vec, ...)
  } else if (which_many == "many_pam"){
    cl_many <- many_pam(Dt, k_vec, ...)
  }
  pr_c <- princomp(Dt)
  pr1_c <- predict(pr_c)[, 1]
  pr2_c <- predict(pr_c)[, 2]
 return(list(Dt, clustergram(cl_many, pr1_c)))
}

##### 4. Cluster analysis with stats ##########################################################################################################################

get_ca <- function(k, vars_df, id, cl_boundaries, out_data_dir, out_plots_dir){

  set.seed(1234)
  m_pam <- pam(x = vars_df, k = k, diss = F, metric = "euclidean", stand = F)
  tryCatch({
    tiff(paste0(out_plots_dir, "/cluster_analysis_", k, ".tiff"), width = 1600, height = 1600, compression = "none")
    plot(m_pam, which.plots = 1)
    dev.off()
  }, error = function(err){
    error_file <- file(paste0(out_plots_dir, "/error_received_k_", k, ".txt"), "w")
    cat("The following error was received:", err$message, file = error_file, sep = "\n")
    close(error_file)
    }
  )

  vars_df$pam <- m_pam$clustering

  ggp <- centrality_per_level(Df = vars_df, id_vars = "pam",fun_central = median, out_csv_name = paste0(out_data_dir, "/medians_pam", k, ".csv"))
  ggsave(paste0(out_plots_dir, "/medians_pam", k, ".tiff"), ggp, width = 297, height = 210, units = "mm")

  vars_df$id <- id

  cl_boundaries <- inner_join(cl_boundaries, vars_df, by = "id")
  st_write(cl_boundaries, paste0(out_data_dir, "/boundaries_pam", k, ".gpkg"))

  vars_df <- as.data.table(vars_df)

  sum_per_cluster <- vars_df[, lapply(.SD, sum), keyby = "pam", .SDcols = 1:(ncol(vars_df)-2)]
  sum_total <- vars_df[, lapply(.SD, sum), .SDcols = 1:(ncol(vars_df)-2)]

  index_scores <- data.table(pam = 1:k)
  for (n in names(sum_per_cluster)[2:ncol(sum_per_cluster)]){
    set(index_scores, j = n, value = round(100*sum_per_cluster[[n]] / sum_total[[n]]))
  }

  fwrite(index_scores, paste0(out_data_dir, "/index_score_pam", k, ".csv"))
}

############################################################# Statistical Analysis #####################################################################

##### 1. Import data ###################################################################################################################################

working_dir <- "~/Dropbox/liverpool/retail_typology/analysis/clustering"
# dir.create(working_dir)
setwd(working_dir)
# dir.create("plots")
# dir.create("plots/qq_plots")
all_data <- fread("~/Dropbox/liverpool/retail_typology/analysis/indicators/all_data.csv")
boundaries <- st_read("~/Dropbox/liverpool/boundaries/new_boundaries/all_boundaries_fin.gpkg", stringsAsFactors = F)

##### 2. Select variables ##############################################################################################################################

all_data[,catchment_area := NULL] # catchment area and catch_area are the same, remove the first one
all_data[, retail_density := stores_nr / retail_area]
all_data[, working_pop_density := working_pop / catch_area]
all_data[, resident_pop_density := resident_pop / catch_area]
all_data[, working_pop := NULL]
all_data[, resident_pop := NULL]

data_sele <- as.data.table(all_data)
data_sele[, cluster_id := NULL]

tiff("plots/correlogram_all_untrans.tiff", width = 1600, height = 1600, compression = "none")
corrplot(cor(data_sele, method = "spearman"), order = "hclust")
dev.off()

rm_vars <- c("working_pop_density", "large_multi_pct", "ethnic_pct", "attractive_leisure_pct", "local_services_diversity_pct", "attractive_convenience_pct",
             "attractive_consumer_pct", "attractive_comparison_pct", "local_small_multi_pct", "department_stores_pct", "financial_services")

data_sele <- data_sele[,-which(names(data_sele) %in% rm_vars),with=F]

tiff("plots/correlogram_sele_untrans.tiff", width = 1600, height = 1600, compression = "none")
corrplot(cor(data_sele, method = "spearman"), order = "hclust")
dev.off()

##### 3. Transform variables (Box-Cox) #################################################################################################################

data_sele_trans <- do.call(cbind, lapply(1:ncol(data_sele), function(x) unlist(ifelse(min(data_sele[, x, with = F]) < 1, data_sele[,x, with = F] + 1, data_sele[,x, with=F]))))
colnames(data_sele_trans) <- names(data_sele)
trans <- preProcess(data_sele_trans, method = "BoxCox")
data_sele_trans <- as.data.frame(predict(trans, data_sele_trans))

tiff("plots/correlogram_sele_trans.tiff", width = 1600, height = 1600, compression = "none")
corrplot(cor(data_sele_trans, method = "spearman"), order = "hclust")
dev.off()

# data_trans2 <- data_sele
# trans2 <- preProcess(data_trans2, method = "invHyperbolicSine")
# data_trans2 <- as.data.frame(predict(trans2, data_trans2))

##### 4. Compare data distributions ####################################################################################################################

for (n in names(data_sele)){
  tiff(paste0("plots/qq_plots/",n,".tiff"), width = 1200, height = 900, compression = "none")
  par(mfrow=c(1,2))
  qqnorm(data_sele[[n]], main = n)
  qqline(data_sele[[n]])
  qqnorm(data_sele_trans[[n]], main = paste(n, "lambda =", trans$bc[[n]]$lambda))
  qqline(data_sele_trans[[n]])
  dev.off()

}

##### 5. Create clustergram, standaridisation of the variables is performed by the get_clustergram function ############################################

clustergram_list <- get_clustergram(Df = data_sele_trans, which_many = "many_pam")
ggsave("plots/clustergram.tiff", plot(clustergram_list[[2]]), width = 297, height = 210, units = "mm")

# clustergram1 <- get_clustergram(Df = data_sele_trans, which_many = "many_kmeans", iter.max = 20, nstart=10000)

##### 6. PAM cluster analysis ##########################################################################################################################

# set.seed(1234)
for (k in 4:9) get_ca(k, vars_df = clustergram_list[[1]], id = all_data$cluster_id, cl_boundaries = boundaries, out_data_dir = getwd(), out_plots_dir = "plots")

# m_pam2 <- pam(x = data_sele_trans_std2, k = 6, diss = F, metric = "euclidean", stand = F)

##### 7. Second tier ###################################################################################################################################

# We selected 5 clusters, create the second tier

first_tier <- st_read("boundaries_pam5.gpkg", stringsAsFactors = F)
first_tier[first_tier$id %in% c("RC0167", "RC0312", "RC0379", "RC0026", "RC0456"),]$pam <- 2

dir.create("second_tier")
setwd("second_tier")
for (cl in 1:5){
  out_dir <- paste0("tier_of_cluster_", cl)
  out_plots_dir <- paste0(out_dir, "/plots")
  dir.create(out_dir)
  dir.create(out_plots_dir)
  subset_typology <- first_tier[first_tier$pam == cl, ]
  vars_only <- as.data.frame(subset_typology)[,4:51]
  tryCatch(
    {clustergram_list <- get_clustergram(Df = vars_only, z_std = F, which_many = "many_pam", k_vec = 2:5)
      ggsave(paste0(out_plots_dir, "/clustergram_",cl, ".tiff"), plot(clustergram_list[[2]]), width = 297, height = 210, units = "mm")
      for (k in 2:5){
        get_ca(k = k, vars_df = vars_only, id = subset_typology$id, cl_boundaries = subset_typology[, c("id", "name", "geom")], out_data_dir = out_dir, out_plots_dir = out_plots_dir)
      }
    }, error = function(err){
      error_file <- file(paste0(out_dir, "/error_received.txt"), "w")
      cat("The following error was received:", err$message, file = error_file, sep = "\n")
      close(error_file)
      }
    )
}

##### 7. mclust ########################################################################################################################################

# m1 <- Mclust(all_data_trans_std)
# summary(m1)
# Mclust EEV (ellipsoidal, equal volume and shape) model with 4 components:
#
#   log.likelihood    n   df      BIC      ICL
#         89340.49 2485 4373 144492.7 144476.3
#
# Clustering table:
#   1    2    3    4
# 265  433  770 1017

# summary(m1, parameters = T)
# plot(m1)

# m2 <- mclustBIC(all_data_trans_std)
# summary(m2, all_data_trans_std)
# Best BIC values:
#   EEV,4     VEV,4      VEV,6
# BIC      144492.7 142726.72 142113.294
# BIC diff      0.0  -1766.03  -2379.453
#
# Classification table for model (EEV,4):
#   1    2    3    4
# 265  433  770 1017

# m1_b <- Mclust(all_data_trans_std, prior = priorControl())
# summary(m2)
#
#   Mclust VVV (ellipsoidal, varying volume, shape, and orientation) model with 4 components:
#
#   Prior: defaultPrior()
#
# log.likelihood    n   df      BIC      ICL
#       94374.14 2485 4511 153481.2 153471.8
#
# Clustering table:
#   1    2    3    4
# 340  568  517 1060
# plot(m2)
#
# m2 <- Mclust(all_data_trans_std2)
# m2_b <- Mclust(all_data_trans_std2, prior = priorControl())
#
# m3 <- Mclust(all_data_trans_std3)
# m3_b <- Mclust(all_data_trans_std3, prior = priorControl())


#'@title calcHMWaveMakingRes
#'
#'@description Calculate wave resistance (\code{Rw}) (kN) from the Holtrop &
#'Mennen method.
#'
#'@param lwl Waterline length (vector of numericals, m) (see
#'\code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param Cp Prismatic coefficient (vector of numericals, dimensionless) (see
#'\code{\link{calcCp}})
#'@param Cwp Water plane area coefficient (vector of numericals, see
#'\code{\link{calcCwp}})
#'@param Cm Midship section coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCm}})
#'@param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param froudeNum Froude number (vector of numericals, dimensionless) (see
#'\code{\link{calcFroudeNum}})
#'@param At Transom area (vector of numericals, m^2) (see \code{\link{calcAt}})
#'@param hb Center of bulb area above keel line (vector of numericals, m) (see
#' \code{\link{calchb}})
#'@param Abt Traverse bulb area (vector of numericals, m^2) (see
#'\code{\link{calcAbt}})
#'@param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'@param forwardDraft Forward draft (deviation from actual draft indicates trim)
#' (vector of numericals, m)
#'@param lcb Longitudinal position of center of buoyancy (vector of numericals,
#'see \code{\link{calclcb}})
#'
#'@details
#'Note: This calculates resistance, not a coefficient.Therefore, it does not
#'need to be multiplied by wetted surface area like the frictional resistance
#'coefficient is.
#'
#'Note: In "A Statistical Re-Analysis of Resistance and Propulsion Data" the
#'authors re-analyze with the inclusion of Series 64 hull forms for a total of
#'334 models included in the analysis. Their original paper insufficiently
#'modeled high speed craft with Froude number >= 0.55, thus the original wave
#'making resistance equation is used for \code{froudeNum} < 0.55 and the new
#'wave making resistance equation is used for \code{froudeNum} >= 0.55. The
#'authors also include wave making resistance equations in the updated paper for
#'Froude number < 0.55, but these require more computing power and they mention
#'that they closely resemble the original equation. Therefore, the original
#'equation is used for \code{froudeNum} < 0.55.
#'
#'Extra Info:
#'
#'\code{c2}: Accounts for the reduction of the wave resistance due to action of
#'a bulbous bow
#'
#'\code{c5}: Represents the influence of a transom stern on the wave resistance
#'
#'\code{i_E}: The angle of the waterline at the bow in the degrees with reference
#' to center plane but neglecting the local shape at the stem
#'
#'@return \code{Rw} (vector of numericals, kN)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'Holtrop, J. and Mennen, G. G. J. 1984. "A Statistical Re-Analysis of Resistance
#'and Propulsion Data'.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCp}}
#'\item \code{\link{calcCwp}}
#'\item \code{\link{calcCm}}
#'\item \code{\link{calcFroudeNum}}
#'\item \code{\link{calcAt}}
#'\item \code{\link{calchb}}
#'\item \code{\link{calcAbt}}
#'\item \code{\link{calclcb}}}
#'
#'@family Holtrop-Mennen Calculations
#'@family Resistance Calculations
#'
#' @examples
#'  calcHMWaveMakingRes(lwl=c(218.75,209.25),
#'                      breadth=c(32.25,32.20),
#'                      Cp=c(0.81,0.67),
#'                      Cwp=c(0.91,0.84),
#'                      Cm=c(0.99,0.98),
#'                      maxDisplacement=c(80097,52382.04),
#'                      maxDraft=c(13.57,11.49),
#'                      froudeNum=c(0,0.25),
#'                      At=c(22.2,18.5),
#'                      hb=c(5.43,4.6),
#'                      Abt=c(32.02,27.98),
#'                      seawaterDensity=1.025,
#'                      forwardDraft=c(13.57,11.49))
#' @export

calcHMWaveMakingRes<- function(lwl,breadth,Cp,Cwp,
                               Cm,maxDisplacement,maxDraft,
                               froudeNum,
                               At,
                               hb,
                               Abt,
                               seawaterDensity,
                               forwardDraft,
                               lcb=0){

c1<- ifelse(breadth/lwl<0.11,
  2223105*(
    #c7
    (
     0.229577*(breadth/lwl)^0.33333
    )^3.78613)*
    ((maxDraft/breadth)^1.07961)*(90-

                                   #i_E
                                   (
                                    1+89*exp(-(lwl/breadth)^0.80856*
                                               ((1-Cwp)^0.30484)*
                                               (1-Cp-0.0225*lcb)^0.6367*
                                               ((#Lr
                            (lwl*(1-Cp+(0.06*Cp*lcb)/(4*Cp-1)))/
                                                   breadth
                                               )^0.34574)*
                                               (100*maxDisplacement/(lwl^3))^0.16302
                                             )
                                   )
                                   )^-1.37565
,ifelse(breadth/lwl<0.25, #case 2 (<=0.11b/lwl<0.25)
  2223105*(
    #c7
    (
     breadth/lwl
    )^3.78613)*
    ((maxDraft/breadth)^1.07961)*(90-

                                   #i_E
                                   (
                                     1+89*exp(-(lwl/breadth)^0.80856*
                                                ((1-Cwp)^0.30484)*
                                                (1-Cp-0.0225*lcb)^0.6367*
                                                ((#Lr
                                                  (lwl*(1-Cp+(0.06*Cp*lcb)/(4*Cp-1)))/
                                                    breadth
                                                )^0.34574)*
                                                (100*maxDisplacement/(lwl^3))^0.16302
                                     )
                                   )
    )^-1.37565
,#case #3 (b/lwl>= 0.25)
  2223105*(
    #c7
    (
      0.5-0.0625*(lwl/breadth)
    )^3.78613)*
    ((maxDraft/breadth)^1.07961)*(90-

                                   #i_E
                                   (
                                     1+89*exp(-(lwl/breadth)^0.80856*
                                                ((1-Cwp)^0.30484)*
                                                (1-Cp-0.0225*lcb)^0.6367*
                                                ((#Lr
                                                  (lwl*(1-Cp+(0.06*Cp*lcb)/(4*Cp-1)))/
                                                    breadth
                                                )^0.34574)*
                                                (100*maxDisplacement/(lwl^3))^0.16302
                                     )
                                   )
    )^-1.37565
))
#=========================================
#both methods
c2<-exp(-1.89*sqrt(
  #c3
  0.56*Abt^1.5/(breadth*maxDraft*(
    0.31*sqrt(Abt)+forwardDraft-hb
  ))
))
#=========================================
#both methods
c5<-1-0.8*At/(breadth*maxDraft*Cm)
#=========================================
m1<- ifelse(Cp<0.8,#case 1
  0.0140407*(lwl/maxDraft)-(1.75254*(maxDisplacement^(1/3))/lwl)-
  4.79323*(breadth/lwl)-
  #c16
  (
    8.07981*Cp-13.8673*(Cp^2)+6.984388*(Cp^3)
  ),#case 2
    0.0140407*(lwl/maxDraft)-(1.75254*(maxDisplacement^(1/3))/lwl)-
      4.79323*(breadth/lwl)-
      #c16
      (
     1.73014-0.7067*Cp
      ))
#=========================================
#both methods
c15<-ifelse((lwl^3/maxDisplacement)<512,
            -1.69385,
            ifelse((lwl^3/maxDisplacement)<1726.91,
                   -1.69385+(
                     (lwl/(maxDisplacement^(1/3)))-8
                   )/2.36,
                   0
            )
)
#=========================================
#orig

m2<-c15*(Cp^2)*exp(-0.1*froudeNum^-2)
#=========================================
#both methods
alpha<- ifelse((lwl/breadth)<12,#case 1
  1.446*Cp-0.03*(lwl/breadth)
,#case 2
  1.446*Cp-0.36
)
#=========================================
#Fn>0.55

 m4<-c15*0.4*exp(-0.034*(froudeNum^-3.29))
#=========================================
#Fn>0.55
c17<-6919.3*(Cm^-1.3346)*
  ((maxDisplacement/(lwl^3))^2.00977)*
  (((lwl/breadth)-2)^1.40692)
#=========================================
#Fn>0.55
m3<- -7.2035*((breadth/lwl)^0.326869)*
  ((maxDraft/breadth)^0.605375)
#=========================================
#Avoids causing errors by calculating with 0 Froude Num from 0 speed
Rw<-froudeNum

index<-which(froudeNum>0)
Rw[index]<- ifelse(froudeNum[index]<0.55,
   #case 1: from 'An Approximate Power Prediction Method'(Holtrop & Mennen, 1982)
  c1[index]*c2[index]*c5[index]*maxDisplacement[index]*seawaterDensity*9.81*
  exp(m1[index]*(froudeNum[index]^-0.9)+
    m2[index]*cos(alpha[index]*froudeNum[index]^-2)
    ),
  #case 2: from 'Statistical Re-Analysis of Resitance and Propulsion Data'(Holtrop,1984)
c17[index]*c2[index]*c5[index]*maxDisplacement[index]*seawaterDensity*9.81*
  exp(m3[index]*(froudeNum[index]^-0.9)+
        m4[index]*cos(alpha[index]*froudeNum[index]^-2)
    )
  )

  return(Rw)
}


rm(list=ls(all=TRUE))

plot_pca = function(pca_obj, predict_obj, xlim, ylim,
                    xlab = 'PC1', ylab = 'PC2') {
    plot(pca_obj$scores[,1], pca_obj$scores[,2],
         xlab = xlab,
         ylab = ylab,
         xlim = xlim,
         ylim = ylim)
    points(predict_obj[1], predict_obj[2],
           col='blue',
           lwd=3,
           pch=8)
}

observed_path = '../../response-redux/results/sampling-error/pymsbayes-results/observed-summary-stats/observed-1.txt'
m1_path = '../priors-for-pc-plot/pymsbayes-results/pymsbayes-output/prior-stats-summaries/m3-prior-sample.txt'
m1a_path = '../priors-for-pc-plot/pymsbayes-results/pymsbayes-output/prior-stats-summaries/m2-prior-sample.txt'
m1b_path = '../priors-for-pc-plot/pymsbayes-results/pymsbayes-output/prior-stats-summaries/m1-prior-sample.txt'
m3_path = '../priors-for-pc-plot/pymsbayes-results/pymsbayes-output/prior-stats-summaries/m4-prior-sample.txt'
m4_path = '../priors-for-pc-plot/pymsbayes-results/pymsbayes-output/prior-stats-summaries/m5-prior-sample.txt'
m5_path = '../priors-for-pc-plot/pymsbayes-results/pymsbayes-output/prior-stats-summaries/m6-prior-sample.txt'
plot_path = '../priors-for-pc-plot/pc-plots.pdf'

stat_indices = c(94:181)

observed <- read.table(observed_path, skip=1)
m1 = read.table(m1_path, skip=1)[stat_indices]
colnames(m1) = colnames(observed)
m1a = read.table(m1a_path, skip=1)[stat_indices]
colnames(m1a) = colnames(observed)
m1b = read.table(m1b_path, skip=1)[stat_indices]
colnames(m1b) = colnames(observed)
m3 = read.table(m3_path, skip=1)[stat_indices]
colnames(m3) = colnames(observed)
m4 = read.table(m4_path, skip=1)[stat_indices]
colnames(m4) = colnames(observed)
m5 = read.table(m5_path, skip=1)[stat_indices]
colnames(m5) = colnames(observed)

m1_pca <- princomp(m1)
m1a_pca <- princomp(m1a)
m1b_pca <- princomp(m1b)
m3_pca <- princomp(m3)
m4_pca <- princomp(m4)
m5_pca <- princomp(m5)

observed_m1 = predict(m1_pca, observed)
observed_m1a = predict(m1a_pca, observed)
observed_m1b = predict(m1b_pca, observed)
observed_m3 = predict(m3_pca, observed)
observed_m4 = predict(m4_pca, observed)
observed_m5 = predict(m5_pca, observed)
plot_letters = LETTERS[1:6]

pdf(plot_path, width=7.087, height=4.0)
    par(yaxs = "i", xaxs = "i")
    par(cex.axis=0.7)
    par(mgp = c(1.5,0.6,0)) # mgp adjusts space of axis labels
    # oma is space around all plots
    par(oma = c(0,0,0.7,0.4), mar = c(2.6,2.9,0.5,0.1))
    par(mfrow = c(2, 3))

    xlim = c(-0.4, 0.4)
    ylim = c(-0.2, 0.2)
    plot_pca(m1_pca, observed_m1, xlim, ylim, xlab = '')
    mtext(plot_letters[[1]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote(italic(M)[1]), side=3, adj=0.5, line=0, cex=0.75)

    plot_pca(m1a_pca, observed_m1a, xlim, ylim, xlab = '', ylab = '')
    mtext(plot_letters[[2]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote(italic(M)['1A']), side=3, adj=0.5, line=0, cex=0.75)

    plot_pca(m1b_pca, observed_m1b, xlim, ylim, xlab = '', ylab = '')
    mtext(plot_letters[[3]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote(italic(M)['1B']), side=3, adj=0.5, line=0, cex=0.75)

    xlim = c(-1.0, 1.5)
    ylim = c(-0.8, 0.8)
    plot_pca(m3_pca, observed_m3, xlim, ylim)
    mtext(plot_letters[[4]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote(italic(M)[3]), side=3, adj=0.5, line=0, cex=0.75)

    plot_pca(m4_pca, observed_m4, xlim, ylim, ylab = '')
    mtext(plot_letters[[5]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote(italic(M)[4]), side=3, adj=0.5, line=0, cex=0.75)

    xlim = c(-1.0, 2.0)
    ylim = c(-1.2, 1.2)
    plot_pca(m5_pca, observed_m5, xlim, ylim, ylab = '')
    mtext(plot_letters[[6]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote(italic(M)[5]), side=3, adj=0.5, line=0, cex=0.75)
dev.off()


library(lme4)
library(lmerTest)
# library(readr)
# library(tidyverse) #for all data wrangling
# library(cowplot) #for manuscript ready figures
library(sjPlot) #for plotting lmer and glmer mods
# library(lattice)
# library(sjstats) #use for r2 functions
# library(rstatix)

# read in data from 4-way ANOVA with between-subject and within-subject factors
df_full <- read_csv("longitudinal_analysis/glob_eff_auc_df.csv")
df_full$timepoint = as.factor(df_full$timepoint) # converting to categorical
df_full$time_group = with(df_full, interaction(timepoint,  group))

df_st <- subset(df_full, group == "st")

# get parameter estimates from a linear regression with random effects

# this model might be wrong as measures from hc count into timepoint
overall_model_fit <- lmer(glob_eff_auc ~ group * timepoint + (1|subject), df_full)

# probably better to separate into two models
timepoint_model_fit <- lmer(glob_eff_auc ~ timepoint + (1|subject), df_st)
group_model_fit <- lmer(glob_eff_auc ~ time_group + (1|subject), df_full)

model_fit <- timepoint_model_fit

# display results of linear regression
summary(model_fit)

plot(model_fit)
res<-resid(model_fit)
plot(res)

sjPlot::plot_model(model_fit)
sjPlot:: tab_model(model_fit)
qqmath(model_fit, id = 0.05)
anova(model_fit)

qqnorm(resid(model_fit))


fptcdf=function(z,x0max,chi,driftrate,sddrift) {
  zs=z*sddrift;
  zu=z*driftrate;
  chiminuszu=chi-zu;
  xx=chiminuszu-x0max
  chizu=chiminuszu/zs;
  chizumax=xx/zs
  tmp1=zs*(dnorm(chizumax)-dnorm(chizu))
  tmp2=xx*pnorm(chizumax)-chiminuszu*pnorm(chizu)
  1+(tmp1+tmp2)/x0max
}

fptpdf=function(z,x0max,chi,driftrate,sddrift) {
  zs=z*sddrift
  zu=z*driftrate
  chiminuszu=chi-zu
  chizu=chiminuszu/zs
  chizumax=(chiminuszu-x0max)/zs
  (driftrate*(pnorm(chizu)-pnorm(chizumax)) +
    sddrift*(dnorm(chizumax)-dnorm(chizu)))/x0max
}

allrtCDF=function(t,x0max,chi,drift,sdI) {
  # Generates CDF for all RTs irrespective of response.
  N=length(drift) # Number of responses.
  tmp=array(dim=c(length(t),N))
  for (i in 1:N) tmp[,i]=fptcdf(z=t,x0max=x0max,chi=chi,driftrate=drift[i],sddrift=sdI)
  1-apply(1-tmp,1,prod)
}

n1PDF=function(t,x0max,chi,drift,sdI) {
  # Generates defective PDF for responses on node #1.
  N=length(drift) # Number of responses.
  if (N>2) {
    tmp=array(dim=c(length(t),N-1))
    for (i in 2:N) tmp[,i-1]=fptcdf(z=t,x0max=x0max,chi=chi,driftrate=drift[i],sddrift=sdI)
    G=apply(1-tmp,1,prod)
  } else {
    G=1-fptcdf(z=t,x0max=x0max,chi=chi,driftrate=drift[2],sddrift=sdI)
  }
  G*fptpdf(z=t,x0max=x0max,chi=chi,driftrate=drift[1],sddrift=sdI)
}

n1CDF=function(t,x0max,chi,drift,sdI) {
  # Generates defective CDF for responses on node #1.
  outs=numeric(length(t)) ; bounds=c(0,t)
  for (i in 1:length(t)) {
    tmp="error"
    repeat {
      if (bounds[i]>=bounds[i+1]) {outs[i]=0;break}
      tmp=try(integrate(f=n1PDF,lower=bounds[i],upper=bounds[i+1],
        x0max=x0max,chi=chi,drift=drift,sdI=sdI)$value,silent=T)
      if (is.numeric(tmp)) {outs[i]=tmp;break}
      # Try smart lower bound.
      if (bounds[i]<=0) {
	bounds[i]=max(c((chi-0.98*x0max)/(max(mean(drift),drift[1])+2*sdI),0))
	next
      }
      # Try smart upper bound.
      if (bounds[i+1]==Inf) {
	bounds[i+1]=0.02*chi/(mean(drift)-2*sdI)
	next
      }
      stop("Error in n1CDF that I could not catch.")
    }
  }
  cumsum(outs)
}

n1mean=function(x0max,chi,drift,sdI) {
  # Generates mean RT for responses on node #1.
   pc=n1CDF(Inf,x0max,chi,drift,sdI)
   fn=function(t,x0max,chi,drift,sdI,pc) t*n1PDF(t,x0max,chi,drift,sdI)/pc
   tmp=integrate(f=fn,lower=0,upper=100*chi,x0max=x0max,chi=chi,pc=pc,
     drift=drift,sdI=sdI)$value
   list(mean=tmp,p=pc)
}

actCDF=function(z,t,x0max,chi,drift,sdI) {
  # CDF for the distribution (over trials) of activation values at time t.
  zat=(z-x0max)/t ; zt=z/t ; sdi2=2*(sdI^2)
  exp1=exp(-((zt-drift)^2)/sdi2)
  exp2=exp(-((zat-drift)^2)/sdi2)
  tmp1=t*sdI*(exp1-exp2)/sqrt(2*pi)
  tmp2=pnorm(zat,mean=drift,sd=sdI)
  tmp3=pnorm(zt,mean=drift,sd=sdI)
  (tmp1+(x0max-z+drift*t)*tmp2+(z-drift*t)*tmp3)/x0max
}

actPDF=function(z,t,x0max,chi,drift,sdI) {
  # CDF for the distribution (over trials) of activation values at time t.
  tmp1=pnorm((z-x0max)/t,mean=drift,sd=sdI)
  tmp2=pnorm(z/t,mean=drift,sd=sdI)
  (-tmp1+tmp2)/x0max
}

lbameans=function(Is,sdI,x0max,Ter,chi) {
  # Ter should be a vector of length ncond, the others atomic,
  # except Is which is ncond x 2.
  ncond=length(Is)/2
  outm<-outp<-array(dim=c(ncond,2))
  for (i in 1:ncond) {
    for (j in 1:2) {
      tmp=n1mean(x0max,chi,drift=Is[i,switch(j,1:2,2:1)],sdI)
      outm[i,j]=tmp$mean+Ter[i]
      outp[i,]=tmp$p
  }}
  list(mns=c(outm[1:ncond,2],outm[ncond:1,1]),ps=c(outp[1:ncond,2],outp[ncond:1,1]))
}

deadlineaccuracy=function(t,x0max,chi,drift,sdI,guess=.5,meth="noboundary") {
  # Works out deadline accuracy, using one of three
  # methods:
  #   - noboundary = no implicity boundaries.
  #   - partial =  uses implicit boundaries, and partial information.
  #   - nopartial = uses implicit boundaries and guesses otherwise.
  meth=match.arg(meth,c("noboundary","partial","nopartial"))
  noboundaries=function(t,x0max,chi,drift,sdI,ulimit=Inf) {
    # Probability of a correct response in a deadline experiment
    # at times t, with no implicit boundaries.
    N=length(drift)
    tmpf=function(x,t,x0max,chi,drift,sdI) {
      if (N>2) {
	tmp=array(dim=c(length(x),N-1))
	for (i in 2:N) tmp[,i-1]=actCDF(x,t,x0max,chi,drift[i],sdI)
	G=apply(tmp,1,prod)*actPDF(x,t,x0max,chi,drift[1],sdI)
      } else {
	G=actCDF(x,t,x0max,chi,drift[2],sdI)*actPDF(x,t,x0max,chi,drift[1],sdI)
    }}
    outs=numeric(length(t))
    for (i in 1:length(t)) {
      if (t[i]<=0) {
	outs[i]=.5
      } else {
	outs[i]=integrate(f=tmpf,lower=-Inf,upper=ulimit,t=t[i],
          x0max=x0max,drift=drift,sdI=sdI)$value
      }
    }
    outs
  }
  if (meth=="noboundary") {
    noboundaries(t,x0max,chi,drift,sdI,ulimit=Inf)
  } else {
    pt=n1CDF(t=t,x0max=x0max,chi=chi,drift=drift,sdI=sdI)
    pa=allrtCDF(t=t,x0max=x0max,chi=chi,drift=drift,sdI=sdI)
    pguess=switch(meth,"nopartial"=guess*(1-pa),"partial"=
      noboundaries(t=t,x0max=x0max,chi=chi,drift=drift,sdI=sdI,ulimit=chi))
    pt+pguess
  }
}


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

same = function(test, truth) stopifnot(identical(test, truth))
tester = function(s, x, test)
{
  same(s >  test, x > test)
  same(s >= test, x >= test)
  same(s == test, x == test)
  same(s <  test, x < test)
  same(s <= test, x <= test)

  same(test >  s, test > x)
  same(test >= s, test >= x)
  same(test == s, test == x)
  same(test <  s, test < x)
  same(test <= s, test <= x)
}

x = matrix(-4:5, 5)
s = fl(x)

tester(s, x, 0L)
tester(s, x, 0.0)
tester(s, x, fl(0))
tester(s, x, s)
tester(s, x, x)


[[[[[
   Show that a real r is Martin-Lof random
   iff it is Chaitin random.

   An effective covering A_k of k is a function
   of k that enumerates bit strings s,
   which are the initial bits of the covered
   reals.  We assume that no s in A_k is a
   proper prefix or extension of another.
   Thus the measure of the cover A_k of k is
   exactly Sum_{s in A_k} of 2^{-|s|},
   where |s| is the length of the bit string s.
]]]]]

[Second part: not Ch random ===> not M-L random]

define (is-in? x l) [is x an element of list l?]
   if atom l     false
   if = x car l  true
   (is-in? x cdr l)

define      is-in?
value       (lambda (x l) (if (atom l) false (if (= x (car l))
             true (is-in? x (cdr l)))))

define (is-prefix-of? x y) [is bit string x a prefix of bit string y?]
   if atom x  true
   if atom y  false
   if = car x car y (is-prefix-of? cdr x cdr y)
   false

define      is-prefix-of?
value       (lambda (x y) (if (atom x) true (if (atom y) false
             (if (= (car x) (car y)) (is-prefix-of? (cdr x) (c
            dr y)) false))))

define (is-bit-string? x) [is x a list of 0's and 1's?]
   if = x nil   true
   if atom x    false
   if = 0 car x (is-bit-string? cdr x)
   if = 1 car x (is-bit-string? cdr x)
   false

define      is-bit-string?
value       (lambda (x) (if (= x nil) true (if (atom x) false
            (if (= 0 (car x)) (is-bit-string? (cdr x)) (if (=
            1 (car x)) (is-bit-string? (cdr x)) false)))))

define C [test computer---real thing is eval read-exp]
   let (loop) [doubles all bits up to & including first 1]
     if = 1 read-bit '(1 1)
     cons 0 cons 0 (loop)
   (loop)

define      C
value       ((' (lambda (loop) (loop))) (' (lambda () (if (= 1
             (read-bit)) (' (1 1)) (cons 0 (cons 0 (loop))))))
            )

[Now let's do stage n of A_k = strings s with H(s) <= |s| - k.]
[At stage n we look at programs p up to n bits in size for time up to n.]

define (compressible-by-k n k)
   (look-at nil)

define      compressible-by-k
value       (lambda (n k) (look-at nil))

[this routine has free parameters n, k, C]

define (look-at p) [produces strings compressible by k within time n]
   let v try n C ['eval read-exp] p
   if = success car v
      let w cadr v
      if (is-bit-string? w)
         if >= length w + k length p
            cons w nil
         nil
      nil
   [otherwise failure]
   if = n length p nil [stop!]
   append (look-at append p cons 0 nil)
          (look-at append p cons 1 nil)

define      look-at
value       (lambda (p) ((' (lambda (v) (if (= success (car v)
            ) ((' (lambda (w) (if (is-bit-string? w) (if (>= (
            length w) (+ k (length p))) (cons w nil) nil) nil)
            )) (car (cdr v))) (if (= n (length p)) nil (append
             (look-at (append p (cons 0 nil))) (look-at (appen
            d p (cons 1 nil)))))))) (try n C p)))

[list of intervals in covering so far]
[used to avoid overlapping intervals in covering]
define intervals ()

define      intervals
value       ()

define (process-all x) [process list of intervals x]
   if atom x  intervals
   let intervals append (process car x) intervals
   (process-all cdr x)

define      process-all
value       (lambda (x) (if (atom x) intervals ((' (lambda (in
            tervals) (process-all (cdr x)))) (append (process
            (car x)) intervals))))

define (process interval) [process individual interval]
   if (new-interval-covered-by-previous-one? interval intervals)
      [then don't need to repeat it]
      nil
   let holes (new-interval-covers-previous-ones interval intervals)
   if atom holes
      [then interval is fine as is]
      cons display interval nil
   [get max granularity needed]
   let max (max-length holes)
   [convert everything to same granularity]
   let holes (extend-all holes max)
   [and remove overlap]
   (subtract (extend interval max) holes)

define      process
value       (lambda (interval) (if (new-interval-covered-by-pr
            evious-one? interval intervals) nil ((' (lambda (h
            oles) (if (atom holes) (cons (display interval) ni
            l) ((' (lambda (max) ((' (lambda (holes) (subtract
             (extend interval max) holes))) (extend-all holes
            max)))) (max-length holes))))) (new-interval-cover
            s-previous-ones interval intervals))))

[returns true/false]
define (new-interval-covered-by-previous-one? interval intervals)
   if atom intervals  false
   if (is-prefix-of? car intervals interval)  true
   (new-interval-covered-by-previous-one? interval cdr intervals)

define      new-interval-covered-by-previous-one?
value       (lambda (interval intervals) (if (atom intervals)
            false (if (is-prefix-of? (car intervals) interval)
             true (new-interval-covered-by-previous-one? inter
            val (cdr intervals)))))

[returns set of previous intervals covered by this one]
define (new-interval-covers-previous-ones interval intervals)
   if atom intervals  nil
   if (is-prefix-of? interval car intervals)
      [then] cons car intervals (new-interval-covers-previous-ones interval cdr intervals)
      [else]                    (new-interval-covers-previous-ones interval cdr intervals)

define      new-interval-covers-previous-ones
value       (lambda (interval intervals) (if (atom intervals)
            nil (if (is-prefix-of? interval (car intervals)) (
            cons (car intervals) (new-interval-covers-previous
            -ones interval (cdr intervals))) (new-interval-cov
            ers-previous-ones interval (cdr intervals)))))

[get maximum length of a list of bit strings]
define (max-length list)
   if atom list   0
   let len1 length car list
   let len2 (max-length cdr list)
   if > len1 len2
      [then] len1
      [else] len2

define      max-length
value       (lambda (list) (if (atom list) 0 ((' (lambda (len1
            ) ((' (lambda (len2) (if (> len1 len2) len1 len2))
            ) (max-length (cdr list))))) (length (car list))))
            )

[produce set of all extensions of a given bit string to a given length]
[(assumed >= to its current length)]
define (extend bit-string len)
   if = len length bit-string
      [has correct length; return singleton set]
      cons bit-string nil
   append (extend append bit-string cons 0 nil len)
          (extend append bit-string cons 1 nil len)

define      extend
value       (lambda (bit-string len) (if (= len (length bit-st
            ring)) (cons bit-string nil) (append (extend (appe
            nd bit-string (cons 0 nil)) len) (extend (append b
            it-string (cons 1 nil)) len))))

[extend all the bit strings in a given list to the same length]
define (extend-all list len)
   if atom list   nil
   append (extend     car list len)
          (extend-all cdr list len)

define      extend-all
value       (lambda (list len) (if (atom list) nil (append (ex
            tend (car list) len) (extend-all (cdr list) len)))
            )

[subtract set of intervals y from set of intervals x]
define (subtract x y)
   if atom x   nil
   if (is-in? car x y)
   [then]                          (subtract cdr x y)
   [else] cons debug display car x (subtract cdr x y)

define      subtract
value       (lambda (x y) (if (atom x) nil (if (is-in? (car x)
             y) (subtract (cdr x) y) (cons (debug (display (ca
            r x))) (subtract (cdr x) y)))))

[
 Put it all together---Here is cover A_k
 covering all reals r having any n-bit prefix r_n
 with H(r_n) <= n - k.
 And we have measure \mu A_k <= 2^{-k+c}.
 Actual proof uses A_{k+c}
 so that measure \mu A_{k+c} <= 2^{-k}.
 Hence a real r with prefixes whose complexity
 dips arbitrarily far below their length will be
 in all the A_k and hence will not be M-L random.
]
define (A k)
   let intervals nil
   let (stage n)
      let compressible-strings (compressible-by-k n k)
      let intervals (process-all compressible-strings)
      if = n 12 stop! [to stop test run---remove if real thing]
      (stage + 1 n)
   [go!!!!!]
   (stage 0)

define      A
value       (lambda (k) ((' (lambda (intervals) ((' (lambda (s
            tage) (stage 0))) (' (lambda (n) ((' (lambda (comp
            ressible-strings) ((' (lambda (intervals) (if (= n
             12) stop! (stage (+ 1 n))))) (process-all compres
            sible-strings)))) (compressible-by-k n k))))))) ni
            l))

[k = compression amount = 8 bits]
(A 8)

expression  (A 8)
display     (0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
display     (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
display     (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
display     (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
value       stop!


#!/usr/bin/env Rscript

# Command line arguments
args = commandArgs(trailingOnly=TRUE)

input <- as.character(args[1:length(args)])

# Load / install required packages
if (!require("limma")){
    source("http://bioconductor.org/biocLite.R")
    biocLite("limma", suppressUpdates=TRUE)
    library("limma")
}

if (!require("edgeR")){
    source("http://bioconductor.org/biocLite.R")
    biocLite("edgeR", suppressUpdates=TRUE)
    library("edgeR")
}

if (!require("statmod")){
    install.packages("statmod", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("statmod")
}

if (!require("data.table")){
    install.packages("data.table", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("data.table")
}

if (!require("gplots")) {
    install.packages("gplots", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("gplots")
}

if (!require("methods")) {
    install.packages("methods", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("methods")
}

# Put mature and hairpin count files in separated file lists
filelist<-list()
filelist[[1]]<-input[grep(".mature.stats",input)]
filelist[[2]]<-input[grep(".hairpin.stats",input)]
names(filelist)<-c("mature","hairpin")
print(filelist)

for (i in 1:2) {
    header<-names(filelist)[i]

    # Prepare the combined data frame with gene ID as rownames and sample ID as colname
    data<-do.call("cbind", lapply(filelist[[i]], fread, header=FALSE, select=c(3)))
    unmapped<-do.call("cbind", lapply(filelist[[i]], fread, header=FALSE, select=c(4)))
    data<-as.data.frame(data)
    unmapped<-as.data.frame(unmapped)

    temp <- fread(filelist[[i]][1],header=FALSE, select=c(1))
    rownames(data)<-temp$V1
    rownames(unmapped)<-temp$V1
    colnames(data)<-gsub(".stats","",basename(filelist[[i]]))
    colnames(unmapped)<-gsub(".stats","",basename(filelist[[i]]))

    data<-data[rownames(data)!="*",,drop=FALSE]
    unmapped<-unmapped[rownames(unmapped)=="*",,drop=FALSE]

    # Write the summary table of unmapped reads
    write.table(unmapped,file=paste(header,"_unmapped_read_counts.txt",sep=""),sep='\t',quote=FALSE)

    # Remove genes with 0 reads in all samples
    row_sub = apply(data, 1, function(row) all(row ==0 ))

    data<-data[!row_sub,]
    write.csv(t(data),file=paste(header,"_counts.csv",sep=""))

    # Normalization
    dataDGE<-DGEList(counts=data,genes=rownames(data))
    o <- order(rowSums(dataDGE$counts), decreasing=TRUE)
    dataDGE <- dataDGE[o,]

    # Save log10(TPM)
    tpm = cpm(dataDGE, normalized.lib.sizes=F, log = F, prior.count = 0.001)
    tpm = tpm + 0.001
    tpm = log10(tpm)
    ttpm = t(tpm)
    write.table(ttpm,file=paste(header,"_logtpm.txt",sep=""),sep='\t',quote=FALSE)
    write.csv(ttpm,file=paste(header,"_logtpm.csv",sep=""))

    # TMM
    dataNorm <- calcNormFactors(dataDGE)

    # Print normalized read counts to file
    dataNorm_df<-as.data.frame(cpm(dataNorm))
    write.table(dataNorm_df,file=paste(header,"_normalized_CPM.txt",sep=""),sep='\t',quote=FALSE)

    if (ncol(data)>1){ # with more than 1 sample
        # Print heatmap based on normalized read counts
        pdf(paste(header,"_CPM_heatmap.pdf",sep=""))
        heatmap.2(cpm(dataNorm),col=redgreen(100),key=TRUE,scale="row",density.info="none",trace="none")
        dev.off()
    }

    # Make MDS plot (only perform with 3 or more samples)
    if (ncol(data)>2){
        pdf(paste(header,"_edgeR_MDS_plot.pdf",sep=""))
        MDSdata <- plotMDS(dataNorm)
        dev.off()

        # Print distance matrix to file
        write.table(MDSdata$distance.matrix, paste(header,"_edgeR_MDS_distance_matrix.txt",sep=""), quote=FALSE, sep="\t")

        # Print plot x,y co-ordinates to file
        MDSxy = MDSdata$cmdscale.out
        colnames(MDSxy) = c(paste(MDSdata$axislabel, '1'), paste(MDSdata$axislabel, '2'))

        write.table(MDSxy, paste(header,"_edgeR_MDS_plot_coordinates.txt",sep=""), quote=FALSE, sep="\t")

        # Get the log counts per million values
        logcpm <- cpm(dataNorm, prior.count=2, log=TRUE)

        # Calculate the euclidean distances between samples
        dists = dist(t(logcpm))

        # Plot a heatmap of correlations
        pdf(paste(header,"_log2CPM_sample_distances_heatmap.pdf",sep=""))
        hmap <- heatmap.2(as.matrix(dists),main="Sample Correlations", key.title="Distance", trace="none",dendrogram="row", margin=c(9, 9))
        dev.off()

        # Plot the heatmap dendrogram
        pdf(paste(header,"_log2CPM_sample_distances_dendrogram.pdf",sep=""))
        plot(hmap$rowDendrogram, main="Sample Dendrogram")
        dev.off()

        # Write clustered distance values to file
        write.table(hmap$carpet, paste(header,"_log2CPM_sample_distances.txt",sep=""), quote=FALSE, sep="\t")
    }
}

file.create("corr.done")

# Print sessioninfo to standard out
print("Sample correlation info:")
sessionInfo()


# Generate virtual shell data

# Function used to linearly subsample data at new depth values
subsample_mean <- function(dailydata, dailydepth, newdepth, plot=FALSE){
    newdata <- vector()
    for(i in 1:length(newdepth)){ # Loop through all new depth values (samples)
        # Find start and end positions of range to average
        if(i == 1){
            pos1 <- 1 # If first sample of the record, then start position is equal to start of the record (pos1 = 1)
            pos2 <- length(which((newdepth[i + 1] + newdepth[i]) / 2 > dailydepth)) # End position is equal to the middle between the sample depth and the depth of the next sample
        }else{
            if(i == length(newdepth)){
                pos1 <- length(which((newdepth[i - 1] + newdepth[i]) / 2 > dailydepth)) # Start position is equal to the middle between the sample depth and the depth of the previous sample
                pos2 <- length(dailydepth) # If last sample of the record, then the last position is equal to the end of the record (pos2 = length(dailydepth))
            }else{
                pos1 <- length(which((newdepth[i - 1] + newdepth[i]) / 2 > dailydepth)) # Start position is equal to the middle between the sample depth and the depth of the previous sample
                pos2 <- length(which((newdepth[i + 1] + newdepth[i]) / 2 > dailydepth)) # End position is equal to the middle between the sample depth and the depth of the next sample
            }
        }
        newdata <- append(newdata, mean(dailydata[pos1:pos2])) # Calculate the new data value for each sample by averaging the range of datapoints between start and end position
    }
    if(plot == TRUE){ # Create plot showing subsampling if requested
        dev.new()
        plot(dailydepth, dailydata, type = "l")
        points(newdepth, newdata, col = "red")
    }
    return(newdata)
}

# Function for creating d18Oc and D47 data from set of growth conditions and sampling resolution.
# All input data are vectors at daily resolution, except for D, which depends on the sampling resolution and shell length
shellmodel <- function(time, SST, GR, d18Osw, D, AV = FALSE, plot = FALSE){
    Dday <- cumsum(GR) # Create vector linking days to depth values
    if(AV == FALSE){
        SSTnew <- subsample(SST, Dday, D) # Subsample SST along the new sample set
        d18Oswnew <- subsample(d18Osw, Dday, D) # Subsample d18Osw along the new sample set
        Tynew <- subsample(Ty, Dday, D) # Subsample time (yr) along the new sample set
    }else{
        SSTnew <- subsample_mean(SST, Dday, D) # Subsample SST along the new sample set using mean values
        d18Oswnew <- subsample_mean(d18Osw, Dday, D) # Subsample d18Osw along the new sample set using mean values
        Tynew <- subsample_mean(Ty, Dday, D) # Subsample time (yr) along the new sample set using mean values
    }
    # alpha = exp((18.03*1000/(SSTnew+273.15)-33.42)/1000) # Calculate alpha of calcite fractionation
    # d18Osw_PDB = (0.97002*d18Oswnew-29.98) # Convert d18Osw to PDB
    # d18Oc = ((alpha * (d18Osw_PDB/1000 + 1)) - 1)*1000
    d18Oc <- (exp((18.03 * 1000 / (SSTnew + 273.15) - 33.42) / 1000) * ((0.97002 * d18Oswnew - 29.98) / 1000 + 1) - 1) * 1000 # Calculate d18O of calcite for each sample according to Kim and O'Neil, 1997
    D47 <- (0.0449 * 10^6) / (SSTnew + 273.15) ^ 2 + 0.167 # Calculate D47 of calcite for each sample according to Kele et al., 2015 modified by Bernasconi et al., 2018
    if(plot == TRUE){ # Create plots of new data if requested
        dev.new()
        plot(D, d18Oc, col = "blue")
        par(new = TRUE)
        plot(D, D47, axes = FALSE, bty = "n", xlab = "", ylab = "", col = "red")
        axis(side = 4, at = pretty(range(D47)))
    }
    dat <- cbind(Tynew, D, d18Oc, D47) # Combine new data for export
    return(dat) # Return the new depth, d18Oc and D47 series
}

# Set boundary conditions
Td <- seq(1, 6 * 365, 1) # Create timeline of 6 years in days
Ty <- Td / 365 # Convert to years
MAT <- 20 # Set mean annual temperature
Amp <- 10 # Set seasonal amplitude
Sext <- 2 * Amp # Calculate extent of seasonal variability
TSD <- 1.5 # Set the degree of random non-seasonal noise on the SST curve ("weather")
SST <- rnorm(length(Ty), MAT + Amp * sin(2 * pi * Ty), TSD) # Create virtual daily SST data
GR <- rep(10 / 365, length(Ty)) # Set growth rate to 10 mm/yr, create daily GR vector
DSD <- 0.6 # Set the degree of random non-seasonal noise on the d18Osw curve ("salinity fluctuations")
d18Osw <- rnorm(length(Ty), rep(0, length(Ty)), DSD) # Set d18Osw to 0 permille VSMOW, create daily d18Osw vector

SR <- 0.75 # Set uneven sampling resolutions

# Create vector for all samples along entire shell length by applying constant sampling resolution
D <- seq(SR, sum(GR), SR)

# Calculate virtual data
Virtual_shell <- as.data.frame(shellmodel(Ty, SST, GR, d18Osw, D, AV = TRUE))
Virtual_shell$D <- Virtual_shell$D * 1000 # Convert to micrometers
Virtual_shell$D_err <- rep(100, length(Virtual_shell[, 1])) # Add uncertainties on D (in mm)
Virtual_shell$d18Oc_err <- rep(0.1, length(Virtual_shell[, 1])) # Add uncertainties on d18Oc (in permille)
Virtual_shell$D47 <- NULL # D47 data is removed

# Add YEARMARKER column based on user identification of the year transitions
Virtual_shell$YEARMARKER <- rep(0, nrow(Virtual_shell))
Virtual_shell$YEARMARKER[c(10, 23, 37, 50, 64, 77)] <- 1


suppressPackageStartupMessages(library(kazaam))
comm.set.seed(1234)

if (comm.rank() == 0){
  x = matrix(rnorm(30), 10)
  y = matrix(rnorm(40), 10)
  cp_x = crossprod(x)
  cp_xy = crossprod(x, y)
} else {
  x = NULL
  y = NULL
}

dx = expand(x)
dy = expand(y)

### Tests
test = crossprod(dx)
comm.print(all.equal(cp_x, test))

test = crossprod(dx, dy)
comm.print(all.equal(cp_xy, test))

finalize()


#-- this code is used if there is more than two groups
#-- it does the svm analysis, get 3 output text for each svm (p1,p2,p3)

## save original data,
if (!is.na(Projects_metadata$confound_by)) {
Multi_datainput_m2_ori = Multi_datainput_m2
} else {Multi_datainput_m2_ori= Multi_datainput_m} # put something in here when the object do not exist

Multi_datainput_m_ori = Multi_datainput_m

## Select couple and run svm: 1,2

Multi_datainput_m = Multi_datainput_m_ori %>%
  filter (groupingvar %in% levels (Multi_datainput_m_ori$groupingvar)[1:2])

Multi_datainput_m2 = Multi_datainput_m2_ori %>%
            filter (groupingvar %in% levels (Multi_datainput_m_ori$groupingvar)[1:2] )

Multi_datainput_m= droplevels(Multi_datainput_m)
Multi_datainput_m2= droplevels(Multi_datainput_m2)
# make svm!
source ("Rcode/multidimensional_analysis_svm.r")
Acc_sampled= c() # set
source ("Rcode/multidimensional_analysis_perm_svm.r") # returns Acc_sampled
k <- sum(abs(Acc_sampled) >= abs(Accuracyreal))   # Two-tailed test
R=binconf(k, length(Acc_sampled), method='exact')
p1=print(paste0 ("For the groups ", paste (unique(Multi_datainput_m$groupingvar), collapse= " "),": ", Accuracy,
                 ". doing ",length(Acc_sampled) , " permutations, we find the p value lies between ", R[2], " and ", R[3]))

## Select couple and run svm: 1,3

Multi_datainput_m = Multi_datainput_m_ori %>%
  filter (groupingvar %in% levels (Multi_datainput_m_ori$groupingvar)[c(1,3)])

Multi_datainput_m2 = Multi_datainput_m2_ori %>%
  filter (groupingvar %in% levels (Multi_datainput_m_ori$groupingvar)[c(1,3)] )
Multi_datainput_m= droplevels(Multi_datainput_m)
Multi_datainput_m2= droplevels(Multi_datainput_m2)
# make svm!
source ("Rcode/multidimensional_analysis_svm.r")
Acc_sampled= c() # set
source ("Rcode/multidimensional_analysis_perm_svm.r") # returns Acc_sampled
k <- sum(abs(Acc_sampled) >= abs(Accuracyreal))   # Two-tailed test
R=binconf(k, length(Acc_sampled), method='exact')
p2=print(paste0 ("For the groups ", paste (unique(Multi_datainput_m$groupingvar), collapse= " "),": ", Accuracy,
                 ". doing ",length(Acc_sampled) , " permutations, we find the p value lies between ", R[2], " and ", R[3]))

## Select couple and run svm: 2,3

Multi_datainput_m = Multi_datainput_m_ori %>%
  filter (groupingvar %in% levels (Multi_datainput_m_ori$groupingvar)[2:3])

Multi_datainput_m2 = Multi_datainput_m2_ori %>%
  filter (groupingvar %in% levels (Multi_datainput_m_ori$groupingvar)[2:3] )
Multi_datainput_m= droplevels(Multi_datainput_m)
Multi_datainput_m2= droplevels(Multi_datainput_m2)
# make svm!
source ("Rcode/multidimensional_analysis_svm.r")
Acc_sampled= c() # set
source ("Rcode/multidimensional_analysis_perm_svm.r") # returns Acc_sampled
k <- sum(abs(Acc_sampled) >= abs(Accuracyreal))   # Two-tailed test
R=binconf(k, length(Acc_sampled), method='exact')
p3=print(paste0 ("For the groups ", paste (unique(Multi_datainput_m$groupingvar), collapse= " "),": ", Accuracy,
                 ". doing ",length(Acc_sampled) , " permutations, we find the p value lies between ", R[2], " and ", R[3]))

# recreate original data

Multi_datainput_m_ori -> Multi_datainput_m
Multi_datainput_m2_ori -> Multi_datainput_m2


# 20200708 plink1 350 pca test
# https://github.com/chiarabarbieri/Bio373_Blockcourse

args = commandArgs(trailingOnly=TRUE)
path_basename <- args[1]
title <- args[2]
dir_basename <- dirname(path_basename)
if(is.na(args[3])){
  pca <- "12"
}else{
  pca <- args[3]
}
if(is.na(args[2])){
  cat("usage: Rscript plink1_pca12.r path_basename title (pca=12)\n")
  q()
}

library.path <- "/usr/local/ngseq/packages/Dev/R/4.0.1/lib/R/library"
.libPaths(c(library.path, .libPaths()))
library("ggplot2")
library("RColorBrewer")
#library("colorRamps")

plink_pca <- function(basename, title, file_out=F, pca="12"){
  eigenvec<-read.table(paste(basename, ".eigenvec_new", sep=""))
  eigenval<-read.table(paste(basename, ".eigenval", sep=""))
  eigenval_sum <- sum(eigenval)
  if(pca == '12'){
    gg <- ggplot(eigenvec,aes(V3,V4, color=V2))+
      geom_point()+
      labs(x = paste("PC1", round(eigenval[1,]/eigenval_sum*100, digits=2), "%"), y=paste("PC2", round(eigenval[2,]/eigenval_sum*100, digits=2), "%"),title = title)
  }else{
    gg <- ggplot(eigenvec,aes(V3,V5, color=V2))+
      geom_point()+
      labs(x = paste("PC1", round(eigenval[1,]/eigenval_sum*100, digits=2), "%"), y=paste("PC3", round(eigenval[3,]/eigenval_sum*100, digits=2), "%"),title = title)
  }

  if(file_out){
    file_basename <- basename(basename)
    if(pca == '12'){
      out_file = paste(file_basename, "12.png", sep="")
    }else{
      out_file = paste(file_basename, "13.png", sep="")
    }
    print(out_file)
    gg
    ggsave(out_file)
  #  png(out_file)
  #  print(gg)
  #  dev.off()
  }else{
    gg
  }
}

#plink_pca("Run1A_plink1_pca", "Run1A")
plink_pca(path_basename, title, T, pca)


# Casino winnings from Monday to Friday
poker_vector <- c(140, -50, 20, -120, 240)
roulette_vector <- c(-24, -50, 100, -350, 10)
days_vector <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
names(poker_vector) <- days_vector
names(roulette_vector) <- days_vector

# Total winnings with poker: total_poker
total_poker <- sum(poker_vector)
# Print total_poker
print(total_poker)

# Total winnings with roulette: total_roulette
total_roulette <- sum(roulette_vector)
# Print total_roulette
print(total_roulette)

# Total winnings overall: total_week
total_week <- total_poker + total_roulette

# Print total_week
print(total_week)


suppressPackageStartupMessages(library(float))

same = function(test, truth) stopifnot(all.equal(dbl(test), truth, tol=1e-6))

x = matrix(1:30, 10, 3)
s = fl(x)

test = sweep(s, 1, STATS=1L, FUN='+')
truth = sweep(x, 1, STATS=1L, FUN='+')
same(test, truth)

test = sweep(s, 1, STATS=1L, FUN='-')
truth = sweep(x, 1, STATS=1L, FUN='-')
same(test, truth)

test = sweep(s, 1, STATS=1L, FUN='*')
truth = sweep(x, 1, STATS=1L, FUN='*')
same(test, truth)

test = sweep(s, 1, STATS=1L, FUN='/')
truth = sweep(x, 1, STATS=1L, FUN='/')
same(test, truth)

test = sweep(s, 1, STATS=1:5, FUN='-')
truth = sweep(x, 1, STATS=1:5, FUN='-')
same(test, truth)

test = sweep(s, 2, STATS=1:3, FUN='-')
truth = sweep(x, 2, STATS=1:3, FUN='-')
same(test, truth)

test = sweep(s, 1, STATS=fl(pi), FUN='+')
truth = sweep(x, 1, STATS=pi, FUN='+')
same(test, truth)


# Day 22: Reactor Reboot

get_day22_input_path <- function() {
    paste(getwd(), "/2021/Day 22/Day22_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day22_input_path())[1:20]

    reactor <- array("off", dim = c(100, 100, 100))

    for (i in seq_len(length(readings))) {
        direction <- unlist(strsplit(readings[i], " "))
        state <- direction[1]

        axes <- unlist(strsplit(direction[2], ","))
        x_range <- parse_points(axes[1])
        y_range <- parse_points(axes[2])
        z_range <- parse_points(axes[3])

        for (x in x_range) {
            x_index <- x + 50
            for (y in y_range) {
                y_index <- y + 50
                for (z in z_range) {
                    z_index <- z + 50
                    reactor[x_index, y_index, z_index] <- state
                }
            }
        }
    }

    print(sum(reactor == "on"))
}

part2 <- function() {
    print("TODO")
}

parse_points <- function(axis) {
    range <- unlist(strsplit(axis, "="))
    points <- as.numeric(unlist(strsplit(range[2], "\\..")))
    points[1]:points[2]
}

part1()
part2()


#' Calculate common descriptive statistics
#'
#' \code{describe_data} returns a set of common descriptive statistics
#' (e.g., n, mean, sd) for numeric variables.
#'
#' @param data A data frame.
#' @param ... One or more unquoted (numerical) column names from the data frame,
#' separated by commas.
#' @param na.rm Logical. Should missing values (including NaN) be removed?
#'
#' @details The data set can be grouped using \strong{dplyr}'s \code{group_by}
#' so that descriptives will be calculated for each group level.
#'
#' Skew and kurtosis are based on the \code{skewness} and \code{kurtosis}
#' functions of the \strong{moments} package (Komsta & Novomestky, 2015).
#'
#' @examples
#' library(dplyr)
#'
#' # 1 variable
#' describe_data(cox, avoidance)
#'
#' # 1 variable, 1 group
#' cox %>%
#'   group_by(condition) %>%
#'   describe_data(avoidance)
#'
#' # 2 variables
#' describe_data(cox, avoidance, anxiety)
#'
#' # 2 variables, 1 group
#' cox %>%
#'   group_by(condition) %>%
#'   describe_data(avoidance, anxiety)
#'
#' # 1 variable, 2 groups
#' cox %>%
#'   group_by(condition, sex) %>%
#'   describe_data(avoidance)
#'
#' # 2 variables, 2 groups
#' cox %>%
#'   group_by(condition, sex) %>%
#'   describe_data(avoidance, anxiety)
#'
#' @export
describe_data <- function(data, ..., na.rm = TRUE) {

  # Get variables
  vars <- dplyr::quos(...)

  # Throw an error if no vars are supplied
  if (length(vars) == 0) {
    stop("No variables supplied")
  }

  # Check whether all variables are numeric
  if (sum(!sapply(data[, stringr::str_sub(as.character(vars), start = 2)],
    class) %in% c("numeric", "integer")) > 0) {
    stop("Variables contain unsupported variable type")
  }

  # Get grouping
  grouping <- dplyr::group_vars(data)

  # Select all relevant columns from the data frame
  data <- dplyr::select(data, dplyr::group_vars(data), !!! vars)

  # If there are multiple variables, restructure them into 'var' and their
  # values into 'value'
  # Else add a 'var' column and rename the one variable to 'value'
  if (length(vars) > 1) {
    data <- tidyr::gather(data, "var", "value", !!! vars)
  } else {
    data$var <- as.character(vars[[1]])[2]
    data <- data %>%
      dplyr::ungroup() %>% # Temporary fix for a bug
      dplyr::rename_at(vars(!!! vars), ~"value")
  }

  # Re-group the data frame
  data <- data %>%
    dplyr::ungroup() %>%
    dplyr::group_by_at(vars(dplyr::one_of(grouping), var))

  # Calculate descriptives
  output <- data %>%
    dplyr::summarize(
      missing  = sum(is.na(value)),
      n        = dplyr::n() - missing,
      M        = mean(value, na.rm = na.rm),
      SD       = sd(value, na.rm = na.rm),
      SE       = SD / sqrt(n),
      min      = min(value, na.rm = na.rm),
      max      = max(value, na.rm = na.rm),
      range    = diff(range(value, na.rm = na.rm)),
      median   = median(value, na.rm = na.rm),
      mode     = unique(value)[which.max(tabulate(match(value,
                   unique(value))))],
      skew     = (sum((value-mean(value, na.rm = na.rm))^3, na.rm = na.rm) /
                  n) / (sum((value - mean(value, na.rm = na.rm))^2,
                  na.rm = na.rm) / n)^(3 / 2),
      kurtosis = n * sum((value-mean(value, na.rm = na.rm))^4, na.rm = na.rm)/
                  (sum((value-mean(value, na.rm = na.rm))^2, na.rm = na.rm)^2)
    )

  # Re-order output and sort by var
  output <- dplyr::select(output, var, everything()) %>%
    dplyr::arrange(var)

  return(output)
}


# Author: Nikos Kougianos
# Date: 18/12/2020

# Use these 2 lines to set working directory as the current directory of the
# file. Tested on Rstudio @ Windows 10 OS.
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir);

# Read data
data <- read.table("data.csv", sep=",",header=TRUE)

# Create dataframe with 2 columns instead of 4
df <- data.frame('Plant_Height'=c(data$Plant.Height,data$Plant.Height.1), 'Geo_Position'=c(data$Geo.Position,data$Geo.Position.1))

# Subset dataframe, extract height plants where plant is from North
plantsNorth <- df$Plant_Height[df$Geo_Position==1]
# Subset dataframe, extract height plants where plant is from South
plantsSouth <- df$Plant_Height[df$Geo_Position==2]

# Create a boxplot that contains both plants from North and plants from South in the same graph
# You can set horizontal=FALSE to swap x and y axis
boxplot(plantsNorth, plantsSouth,
        col = c("orange","red"),
        names = c("Plants from North", "Plants from South"),
        horizontal=TRUE,
        main="Boxplots of plant heights separated by geo_position")


#' mph2kmh
#'
#' Conversion speed from mile per hour in kilometer per second.
#'
#' @param numeric  mph Speed in mile per hour.
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  mph2kmh
#'
#' @export
#'
#'
#'
#'
mph2kmh<-function(mph)
{
  return (mph * 1.60934);
}