# Clase 08-03
# Factores
help("factor")
civil <- c(
    "soltero/a", "viudo/a", "casado/a", "soltero/a", "viudo/a", "divorciado/a",
    "soltero/a", "casado/a", "soltero/a", "divorciado/a"
)
civil.f <- factor(civil)
civil.f
class(civil)
class(civil.f)
attributes(civil)
attributes(civil.f)

# Ordenado
factor(civil, levels = c("soltero/a", "casado/a", "divorciado/a", "viudo/a"))
sexo.f <- factor(
    c(1, 1, 2, 1, 1, 2, 2, 1, 2, 1),
    labels = c("hombre", "mujer")
)
sexo.f
unclass(sexo.f)
unclass(civil.f)
# Acceder y modificar
civil.f[1]
civil.f[-(1:5)]
levels(sexo.f)
levels(sexo.f)[2]
levels(sexo.f) <- c("masculino", "femenino")
sexo.f
# Aplicaciones
edad <- c(23, 25, 20, 19, 20, 22, 24, 20, 23, 19)
mean(edad[sexo.f == "hombre"])
mean(edad[sexo.f == "mujer"])
# tapply
help("tapply")
tapply(edad, sexo.f, mean)
aggregate(edad, by = list(sexo.f), mean)

tapply(edad, sexo.f, sd)
aggregate(edad, list(sexo.f), sd)

tapply(edad, sexo.f, summary)
aggregate(edad, list(sexo.f), summary)

tapply(edad, civil.f, summary)
# plotting
boxplot(edad ~ sexo.f)
help("boxplot")

rm(list = ls())
# Segunda parte: matrices, arrays
# dim(x) <-
x <- 1:10
x
class(x)
attributes(x)
dim(x) <- c(2, 5)
attributes(x)
class(x)
# matrix
x <- 1:10
x <- matrix(1:10, nrow = 2, ncol = 5)
x <- matrix(1:10, nrow = 2, ncol = 5, byrow = TRUE)
# bind
cbind(1:3, 4:6, 7:9)
rbind(1:3, 4:6, 7:9)
x
cbind(x, c(2, 555))
rbind(x, 51:55)

A <- matrix(1:9, 3, 3)
rownames(A) <- c("fila.1", "fila.2", "fila.3")
A
class(A)
attributes(A)

A <- matrix(1:9, 3, 3)

A[, 1]
A[, -1]
A[-1, 1]
A[-1, -1]
A[1:2, 2:3]
A > 3

B <- A
B[A > 3] <- NA
B

# Ejercicio
# Matrix cuadrada dimension 3 runif
set.seed(1)
A <- matrix(runif(9), 3, 3)
# i)
matriz_bools <- A >= 0.5
matriz_bools
A[matriz_bools]
# ii)
sum(matriz_bools)
# iii)
B <- A
B
B[!matriz_bools] <- 0
B
# iv)
C <- A
C[col(A) < row(A)] <- NA

D <- A
D[col(A) > row(A)] <- NA
D

# Arrays
x <- 1:24
dim(x) <- c(3, 4, 2)
x
x <- array(1:24, dim = c(3, 4, 2))
attributes(x)
x[, , ]

# Operaciones con matrices
A <- matrix(c(0, 1, -1, 2), 2, 2)
A
# * es elemento a elemento
A * A

A %*% A
crossprod(A, A)
A <- matrix(c(3, 5, 2, 4, -2, -2, -1, 1, 1), 3, 3)
b <- c(8, 4, 1)
solve(A, b)

AA <- crossprod(A, A)
solve(AA)
chol2inv(chol(AA))

f <- function(x, y) 2 * y / (1 + x^2)
xx <- seq(0, 1, length.out = 5)
yy <- xx + 1
outer(xx, yy, f)


library(foreign)
data <- read.dta('MPDataset.dta')
sweden <- droplevels(subset(data, country == 'sweden'))
levels(sweden$party) <- c("MP",
                          "V",
                          "S",
                          "FP",
                          "KD",
                          "M",
                          "SD",
                          "C",
                          "NyD")
sweden$party <- factor(sweden$party, levels=levels(sweden$party)[c(2,3,1,8,5,4,6,7,9)])
colors <- c("#b70410", "#f9232b", "#79cf49", "#00993c", "#211974",
            "#5cb7e9", "#0049d8", "#dedd37", "#ffff41")
# These are the additive scaled dimensions from Lowe et.al., pp. 135 sqq.
freemarket.l <- c(401, 402)
freemarket.r <- c(403, 412, 413, 415)
environment.l <- c(501, 416)
environment.r <- c(410)
stateconomy.l <- c(403, 404, 406, 412, 413, 504, 506, 701)
stateconomy.r <- c(401, 402, 407, 414, 505)
stateservices.l <- c(504, 506)
stateservices.r <- c(505, 507)
logrile.l <- c(103, 105, 106, 107, 202, 403, 404, 406, 412, 413, 504, 506, 701)
logrile.r <- c(104, 201, 203, 305, 401, 402, 407, 414, 505, 601, 603, 605, 606)
logplaneco.l <- c(403, 404, 412)
logplaneco.r <- c(401, 414)
libcons.l <- c(103, 105, 106, 107, 202)
libcons.r <- c(104, 201, 203, 305, 601, 603, 605, 606)
logitm <- function(dataset, vars.l, vars.r) {
    log(rowSums(dataset[paste0("per", vars.l)] + 0.5) / rowSums(dataset[paste0("per", vars.r)] + 0.5))
}
sweden$freemarket <- logitm(sweden, freemarket.l, freemarket.r)
sweden$environment <- logitm(sweden, environment.l, environment.r)
sweden$stateconomy <- logitm(sweden, stateconomy.l, stateconomy.r)
sweden$stateservices <- logitm(sweden, stateservices.l, stateservices.r)
sweden$logrile <- -logitm(sweden, logrile.l, logrile.r)
sweden$logplaneco <- logitm(sweden, logplaneco.l, logplaneco.r)
sweden$libcons <- logitm(sweden, libcons.l, libcons.r)
# These are logit scales for bipolar categories (again, Lowe et.al., pp. 131 sqq.)
logits <- function(dataset, var.l, var.r) {
    log(rowSums(dataset[paste0("per", var.l)] + 0.5) / rowSums(dataset[paste0("per", var.r)] + 0.5))
}
sweden$foreignalliances <- logits(sweden, 101, 102)
sweden$militarism <- -logits(sweden, 105, 104)
sweden$internationalism <- logits(sweden, 107, 109)
sweden$logeu <- logits(sweden, 108, 110)
sweden$constitutionalism <- logits(sweden, 203, 204)
sweden$decentralization <- logits(sweden, 301, 302)
sweden$protectionism <- logits(sweden, 406, 407)
sweden$keynesian <- logits(sweden, 409, 414)
sweden$nationalism <- -logits(sweden, 602, 601)
sweden$morality <- -logits(sweden, 604, 603)
sweden$multiculturalism <- logits(sweden, 607, 608)
sweden$laborpolicy <- logits(sweden, 701, 702)
sweden$logwelfare <- logits(sweden, 504, 505)
sweden$education <- logits(sweden, 506, 507)

## TODO: plot interesting 2d graph(s)
library(ggplot2)
library(reshape2)
library(Hmisc)

# Plot all variables from Lowe et.al.
vars <- c("freemarket", "environment", "stateconomy", "stateservices", "logrile",
          "logplaneco", "libcons", "foreignalliances", "militarism", "internationalism",
          "logeu", "constitutionalism", "decentralization", "protectionism", "keynesian",
          "nationalism", "morality", "multiculturalism", "laborpolicy", "logwelfare",
          "education")
for(var in vars) {
    pdf(paste0(var, ".pdf"), width=11.70, height=4.1)
    p <- ggplot(sweden, aes_string(x="edate", y=var, group="party", colour="party"))
    print(
      p + geom_line() + geom_point() + scale_colour_manual(name="Parti", values=colors) +
          labs(x = "År") +
          stat_summary(aes(group=country), fun.data="mean_cl_normal", geom="smooth", colour="#666666", fill="#cccccc")
    )
    dev.off()
}

# References
# Lowe, W., Benoit, K., Mikhaylov, S. and Laver, M. 2011. ”Scaling Policy Preferences from Coded Political Texts.” Legislative Studies Quarterly 36 (1): 123–155.


# ***********************************************************
# s-kmeans.r
# ***********************************************************
s_kmeans <- setRefClass (

	Class  = "s_kmeans",

	methods = list (
		initCluster_random = function (dat, NUM_CLUSTER)
		{
			index        <- 1:nrow (dat)
			center_index <- sample (index, NUM_CLUSTER, replace = FALSE)
			cur_center   <- list ()
			for (i in seq_len (NUM_CLUSTER))
				cur_center[[i]] <- unlist (dat[center_index[i],])
			dist <- sapply (seq_len (NUM_CLUSTER),
							function (k) {
								center_ <- cur_center[[k]]
								rowSums ((sweep (dat, 2, center_, "-")) **2)
							})
			cur_clusters <- max.col (-dist)
			return (list (cur_center   = cur_center,
						  cur_clusters = cur_clusters))
		},
		initCluster_kmeanspp = function (dat, NUM_CLUSTER)
		{
			index        <- 1:nrow (dat)
			center_index <- sample (index, 1)
			center_      <- unlist (dat[center_index, ])
			min_dist     <- rowSums ((sweep (dat, 2, center_, "-")) ** 2)
			while (length (center_index) < NUM_CLUSTER) {
				prob         <- min_dist[-center_index] / sum (min_dist[-center_index])
				new_center   <- sample (index[-center_index], 1, prob = prob)
				center_      <- unlist (dat[new_center, ])
				new_dist     <- rowSums ((sweep (dat, 2, center_, "-")) ** 2)
				min_dist     <- pmin (min_dist, new_dist)
				center_index <- c (center_index, new_center)
			}
			cur_center <- list ()
			for (i in seq_len (NUM_CLUSTER))
				cur_center[[i]] <- unlist (dat[center_index[i],])
			dist <- sapply (seq_len (NUM_CLUSTER),
							function (k) {
								center_ <- cur_center[[k]]
								rowSums ((sweep (dat, 2, center_, "-")) **2)
							})
			cur_clusters <- max.col (-dist)
			return (list (cur_center   = cur_center,
						  cur_clusters = cur_clusters))
		},
		updateCenter = function (dat, cur_clusters)
		{
			cur_center <-
			 	cbind (dat, cc = cur_clusters) %>%
				group_by (cc) %>%
				do (rtn = colMeans (dplyr::select (., -cc))) %>%
				as.list () %>%
				"$"(rtn)
			return (cur_center)
		},
		simple_kmeans = function (dat_, K_ = 2, kmeanspp = TRUE)
		{
			dat          <- na.omit (dat_[, sapply (dat_, is.numeric)])
			NUM_CLUSTER  <- as.integer (K_)
			SIZE         <- as.integer (nrow (dat))
			if (kmeanspp)
				tmp <- .self$initCluster_kmeanspp (dat, NUM_CLUSTER)
			else
				tmp <- .self$initCluster_random (dat, NUM_CLUSTER)
			cur_clusters <- tmp$cur_clusters
			cur_center   <- tmp$cur_center
			old_clusters <- cur_clusters
			convergence  <- FALSE
			iter         <- 1L
			while (!convergence)
			{
				iter <- iter + 1L
				if (iter > 100L) {
					cat ("iter reached MAX_ITER\n")
					break
				}
				distances <-
					sapply (seq_len (NUM_CLUSTER),
							function (k) {
								center_ <- cur_center[[k]]
								d_      <- sweep (dat, 2, center_, "-")
								return (rowSums (d_ * d_))
							})
				cur_clusters  <- max.col (- distances)
				print (cur_clusters)
				if (length (unique (cur_clusters)) != NUM_CLUSTER)
					if (kmeanspp)
						cur_clusters <- .self$initCluster_kmeanspp (dat, NUM_CLUSTER)$cur_clusters
					else
						cur_clusters <- .self$initCluster_random (NUM_CLUSTER, SIZE)$cur_clusters
				convergence   <- identical (old_clusters, cur_clusters)
				old_clusters  <- cur_clusters
				cur_center    <- .self$updateCenter (dat, cur_clusters)
			}
			return (as.integer (cur_clusters))
		}
	)
)


# PAWS preprocessing - create grid for discretization
# Lily Xu
# December 2018

# create grids.rds file for the given resolution

library(rgdal)
library(raster)

gridFilename <- paste(path, outputPath, "grid.rds", sep="")

createGrid <- function(boundary, outFilename, resolution) {
  gridExtents <- extent(boundary)

  # create a grid to match major UTM coordiantes
  dim1 <- ceiling((
      ceiling(xmax(gridExtents) / resolution) * resolution -
        floor(xmin(gridExtents) / resolution) * resolution)
    / resolution)
  dim2 <- ceiling((
      ceiling(ymax(gridExtents) / resolution) * resolution -
        floor(ymin(gridExtents) / resolution) * resolution)
    / resolution)

  grid <- GridTopology(
    cellcentre.offset = c(
      floor(xmin(gridExtents) / resolution) * resolution,
      floor(ymin(gridExtents) / resolution) * resolution),
    cellsize = c(resolution, resolution),
    cells.dim = c(dim1, dim2))

  # save grid output
  saveRDS(grid, file=outFilename)

  # return(grid)
}

createGrid(boundary, gridFilename, resolution)

# rasterize grid
loadGridRast <- function(gridFilename, crs_use) {
  # load the grid to match major UTM coordinates
  grid <- readRDS(gridFilename)
  grid <- SpatialGrid(grid)
  proj4string(grid) <- CRS(crs_use)

  # convert to raster
  rast <- raster(grid)

  # # load the grid to match major UTM coordinates
  # grid <- readRDS(gridFilename)
  #
  # # change to spatial pixels
  # dataGridPixels <- as(SpatialGrid(grid), "SpatialPixels")
  # proj4string(dataGridPixels) <- CRS(crs_use)
  # dataGridPixels <- spTransform(dataGridPixels, CRS(crs_use))
  #
  # rast <- as(dataGridPixels, "SpatialPixels")
  # fullgrid(rast) <- FALSE
  # rast <- raster(rast)
  # proj4string(rast) <- CRS(crs_use)

  return(rast)
}

# create spatial points
loadGridSpatialPixels <- function(gridFilename, crs_use) {
  # load the grid to match major UTM coordinates
  grid <- readRDS(gridFilename)

  # change to spatial pixels
  dataGridPixels <- as(SpatialGrid(grid), "SpatialPixels")
  proj4string(dataGridPixels) <- CRS(crs_use)
  dataGridPixels <- spTransform(dataGridPixels, CRS(crs_use))

  return(dataGridPixels)
}


library(rbenchmark)

cols <- c("test", "replications", "elapsed", "relative")
reps <- 5

x = matrix(rnorm(10000*1250), 10000)
benchmark(fastmap:::.cma(x, 2), fastmap::cma(x, 2), replications=reps, columns=cols)


#' tidy_stats method for summary.glm objects
#'
#' Creates a tidystats data frame for a summary.glm object.
#'
#' @param model A summary.glm object
#'
#' @import dplyr
#' @import tidyr
#' @importFrom magrittr %>%
#'
#' @export
tidy_stats.summary.glm <- function(model) {

  # Get summary statistics
  summary <- summary(model)

  # Extract statistics
  output <- as_data_frame(summary$coefficients) %>%
    rename(
      b = Estimate,
      SE = `Std. Error`,
      z = `z value`,
      p = `Pr(>|z|)`
    ) %>%
    mutate(
      `odds ratio` = exp(coef(model)),
      term = names(model$coefficients),
      order = 1:n()) %>%
    gather("statistic", "value", -term, -order) %>%
    arrange(order) %>%
    select(-order) %>%
    bind_rows(
      data_frame(
        term = "(Model)",
        statistic = c("null deviance", "null deviance df", "residual deviance",
                      "residual deviance df", "AIC"),
        value = c(summary$null.deviance, summary$df.null, summary$deviance,
                  summary$df.residual, summary$aic)
      )
    )

  # Add method
  output <- mutate(output, case_when(method =
    model$family$family == "binomial" ~ "Logistic regression",
    model$family$family == "poisson" ~ "Poisson regression"
  ))

  return(output)
}


# ===
# R code to create function plots
# ===

# ---
# Helper to check for NA
# "all(is.na(sample))" because "is.na()" alone proceeds to first element testing on "sample" if
# "sample" is actually not NA and then emits a warning! R language: too clever by half.
# ---

check_na <- function(x) {
   return (all(is.na(x)))
}

# ---
# "Histogram of 'area' randvar for all property transactions in Ames, Iowa, 2006-2010"
# ---

plot1 <- function(binwidth, x_max, filename=NA) {
   load_libraries()
   ames_area <- load_dataset_ames_area()
   titlestr <- "Histogram of 'area' randvar for all property transactions in Ames, Iowa, 2006-2010"
   plot <- plot_histogram_of_ames_area_data(ames_area, binwidth=binwidth, x_max=x_max, titlestr=titlestr)
   # maybe save plot to file, if filename given, using https://ggplot2.tidyverse.org/reference/ggsave.html
   # an existing file will be overwritten w/o warning
   if (!is.na(filename)) {
      ggsave(filename, plot=plot, device="png", width=plot_width, height=plot_height, units="cm", dpi=plot_dpi)
   }
   # actually plot
   print(plot)
}

# ---
# Approximating PDF of 'area' randvar for all property transactions in Ames, Iowa, 2006-2010
# ---

plot2 <- function(smoothing, x_max, filename=NA) {
   load_libraries()
   ames_area <- load_dataset_ames_area()
   titlestr <- "Approx. PDF for 'area' randvar for all property transactions in Ames, Iowa, 2006-2010"
   plot <- plot_pdf_of_ames_area_data(ames_area, adjust=smoothing, x_max=x_max, titlestr=titlestr)
   # maybe save plot to file, if filename given, using https://ggplot2.tidyverse.org/reference/ggsave.html
   # an existing file will be overwritten w/o warning
   if (!is.na(filename)) {
      ggsave(filename, plot=plot, device="png", width=plot_width, height=plot_height, units="cm", dpi=plot_dpi)
   }
   # actually plot
   print(plot)
}

# ---
# "Histogram of 'area' randvar for a single sample of property transactions in Ames, Iowa, 2006-2010"
# ---

plot3 <- function(sample=NA, binwidth, x_max, sample_size, filename=NA) {
   load_libraries()
   ames_area <- load_dataset_ames_area()
   if (check_na(sample)) {
      sample <- create_single_sample_of_ames_area_observations(ames_area, sample_size=sample_size)
   }
   else {
      # just use the sample provided!
      str(sample)
   }
   titlestr <- "Histogram of 'area' randvar for a single sample of property transactions in Ames, Iowa, 2006-2010"
   plot <- plot_histogram_of_ames_area_data(sample, binwidth=binwidth, x_max=x_max, titlestr=titlestr)
   # maybe save plot to file, if filename given, using https://ggplot2.tidyverse.org/reference/ggsave.html
   # an existing file will be overwritten w/o warning
   if (!is.na(filename)) {
      ggsave(filename, plot=plot, device="png", width=plot_width, height=plot_height, units="cm", dpi=plot_dpi)
   }
   # actually plot
   print(plot)
   return(sample)
}

# ---
# "PDF of 'area' randvar for a single sample of property transactions in Ames, Iowa, 2006-2010"
# ---

plot4 <- function(sample=NA, smoothing, x_max, sample_size=NA, filename=NA) {
   load_libraries()
   ames_area <- load_dataset_ames_area()
   if (check_na(sample)) {
      assert("if 'sample' is not set, then 'sample_size' must be", {
         !check_na(sample_size)
      })
      sample <- create_single_sample_of_ames_area_observations(ames_area, sample_size=sample_size)
   }
   titlestr <- "Approx. PDF of 'area' randvar for a single sample of property transactions in Ames, Iowa, 2006-2010"
   plot <- plot_pdf_of_ames_area_data(sample, adjust=smoothing, x_max=x_max, titlestr=titlestr)
   # maybe save plot to file, if filename given, using https://ggplot2.tidyverse.org/reference/ggsave.html
   # an existing file will be overwritten w/o warning
   if (!is.na(filename)) {
      ggsave(filename, plot=plot, device="png", width=plot_width, height=plot_height, units="cm", dpi=plot_dpi)
   }
   # actually plot
   print(plot)
   return(sample)
}

# ----
# Histogram of "mean" for several samples, with Gaussian expected by CLT superimposed
# ----

plot5 <- function(sample_size,sample_count,sample_stats_binwidth,sample_stats_min,sample_stats_max,filename=NA) {
   load_libraries()
   ames_area <- load_dataset_ames_area()
   multiple_sample_stats <- create_multiple_ames_area_sample_stats(
             ames_area,
             sample_size=sample_size,
             sample_count=sample_count)
   str(multiple_sample_stats)
   plot <- plot_histogram_of_ames_area_sample_stats_for_mean(
             multiple_sample_stats,
             binwidth=sample_stats_binwidth,
             mean_min=sample_stats_min,
             mean_max=sample_stats_max)
   population_stats <- compute_ames_area_stats(ames_area)
   plot <- overlay_clt_normal(
             plot,
             binwidth=sample_stats_binwidth,
             mean_min=sample_stats_min,
             mean_max=sample_stats_max,
             population_mean=population_stats$mean,
             population_stddev=population_stats$stddev,
             sample_size=sample_size,
             sample_count=sample_count)
   # maybe save plot to file, if filename given, using https://ggplot2.tidyverse.org/reference/ggsave.html
   # an existing file will be overwritten w/o warning
   if (!is.na(filename)) {
      ggsave(filename, plot=plot, device="png", width=plot_width, height=plot_height, units="cm", dpi=plot_dpi)
   }
   # actually plot
   print(plot)
}

# ---
# Empirically test the confidence interval by creating "trial_count" samples of
# "sample_size" individuals to compute the proportion of samples which indeed have
# the actual population mean within their "sample-based confidence interval".
# ---

empiricially_test_confidence_interval <- function(sample_size, confidence, trial_count) {
   load_libraries()
   assert("confidence is in [0.5,1[", {
      0.5 <= confidence
      confidence < 1.0
   })
   assert("sample_size is in [10,1000]", {
      is.integer(sample_size)
      10 <= sample_size
      sample_size <= 1000
   })
   assert("trial_count is in [1,1000]", {
      is.integer(trial_count)
      1 <= trial_count
      trial_count <= 1000
   })
   ames_area        <- load_dataset_ames_area()
   population_stats <- compute_ames_area_stats(ames_area)
   population_mean  <- population_stats$mean
   results <- replicate(trial_count,
                        check_confidence_interval(ames_area,population_mean,sample_size,confidence))
   actual_confidence = mean(results)
   message("At confidence level "
           ,(confidence*100)
           ,"% and sample size "
           ,sample_size
           ," the proportion of samples (of "
           ,trial_count
           ," samples) with population mean inside their confidence interval is: "
           ,actual_confidence)
   return(actual_confidence)
}


args <- commandArgs(TRUE)

#open File

directory<-args[1];
print(directory);
filename<-args[2];
print(filename);
start_stats<-args[3];
end_stats<-args[4];
start_param<-args[5];
end_param<-args[6];
numComp<-args[7];
numComp<-as.numeric(numComp);
print(numComp);

#read file
a<-read.table(paste(directory, filename, sep=""), header=T, nrows=10000, skip=0);
print(names(a));
stats<-a[,c(start_stats:end_stats)]; params<-a[,c(start_param:end_param)]; rm (a);

#standardize the params
for(i in 1:length(params)){params[,i]<-(params[,i]-mean(params[,i]))/sd(params[,i]);}

#force stats in [1,2]
myMax<-c(); myMin<-c(); lambda<-c(); myGM<-c();
for(i in 1:length(stats)){
	myMax<-c(myMax, max(stats[,i]));
	myMin<-c(myMin, min(stats[,i]));
	stats[,i]<-1+(stats[,i]-myMin[i])/(myMax[i]-myMin[i]);
}

#transform statistics via boxcox
library("MASS");
for(i in 1:length(stats)){
	d<-cbind(stats[,i], params);
	mylm<-lm(as.formula(d), data=d)
	myboxcox<-boxcox(mylm, lambda=seq(-50, 80, 1/10), plotit=F, interp=T, eps=1/50);
	lambda<-c(lambda, myboxcox$x[myboxcox$y==max(myboxcox$y)]);
	myGM<-c(myGM, exp(mean(log(stats[,i]))));
}

#standardize the BC-stats
myBCMeans<-c(); myBCSDs<-c();
for(i in 1:length(stats)){
	stats[,i]<-(stats[,i]^lambda[i] - 1)/(lambda[i]*myGM[i]^(lambda[i]-1));
	myBCSDs<-c(myBCSDs, sd(stats[,i]));
	myBCMeans<-c(myBCMeans, mean(stats[,i]));
	stats[,i]<-(stats[,i]-myBCMeans[i])/myBCSDs[i];
}

#perform pls
install.packages("pls", repos='http://cran.us.r-project.org')
library("pls");
myPlsr<-plsr(as.matrix(params) ~ as.matrix(stats), scale=F, ncomp=numComp);

#write pls to a file
myPlsrDataFrame<-data.frame(comp1=myPlsr$loadings[,1]);
for(i in 2:numComp) { myPlsrDataFrame<-cbind(myPlsrDataFrame, myPlsr$loadings[,i]); }
write.table(cbind(names(stats), myMax, myMin, lambda, myGM, myBCMeans, myBCSDs, myPlsrDataFrame), file=paste(directory, "Routput_", filename, sep=""), col.names=F, row.names=F, sep="\t", quote=F);

#make RMSE plot
pdf(paste(directory, "RMSE_", filename, ".pdf", sep=""), width=12, height=12);
plot(RMSEP(myPlsr));
dev.off();


#  James Rekow

identifyNumSubgroups = function(infoMat){

  #  ARGS: infoMat - matrix of info weights corresponding to pairs of samples from an abundance list
  #
  #  RETURNS: numClust - predicted number of clusters in infoMat

  library(cluster)

  #  B = 100 works pretty well, but is slow. Left as a note in case a good value is forgotten
  #  compute statistics for kmeans results with various numbers of clusters
  cmr = clusGap(x = infoMat, FUNcluster = kmeans, K.max = 9, d.power = 2, B = 10)

  #  identify the optimal number of clusters, standard SE.factor is 1.0 (from Tibshirani et al.)
  numClust = maxSE(f = cmr$Tab[ , "gap"], SE.f = cmr$Tab[ , "SE.sim"], SE.factor = 1.0,
                   method = "Tibs2001SEmax")

  return(numClust)

#   backupTest = function(infoMat){
#
#     #  B = 100 works pretty well, but is slow. Left as a note in case a good value is forgotten
#     #  compute statistics for kmeans results with various numbers of clusters
#     cmr = clusGap(x = infoMat, FUNcluster = kmeans, K.max = 9, d.power = 2, B = 10)
#
#     #  identify the optimal number of clusters
#     numClust = maxSE(f = cmr$Tab[ , "gap"], SE.f = cmr$Tab[ , "SE.sim"], SE.factor = 1,
#                      method = "Tibs2001SEmax")
#
#     return(numClust)
#
#   } #  end backupTest function
#
#   defaultTest = function(infoMat){
#
#     #  add 10 to infoMat to prevent high condition number. For some reason NbClust doesn't like these
#     #  matrices even if ther det is very far from zero (0.1). Adding random noise should make nonzero det,
#     #  (it does) but that didn't help. Don't know what the problem was
#     nbcr = NbClust(data = infoMat + 10, method = "kmeans")
#
#     #  select optimal predicted partition
#     partition = nbcr$Best.partition
#
#     #  identify number of clusters in optimal partition
#     numClust = length(unique(partition))
#
#     return(numClust)
#
#   } #  end defaultTest function
#
#   # numClustTest = function(infoMat){
#   #   tryCatch(defaultTest(infoMat), error = function(infoMat) backupTest(infoMat))
#   # } #  end numClustTest function
# #
# #   numClust = numClustTest(infoMat)
#   numClust = defaultTest(infoMat)
#
#   return(numClust)

} #  end identifyNumSubgroups function


result <- rnorm(1000, mean=1, sd=0.5)


###Standardize

# Load Library caret
library(caret)
library(mlbench)

# load the dataset PimaIndiansDiabetes
data(PimaIndiansDiabetes)

# view the data
summary(PimaIndiansDiabetes[,1:2])
# to standardise we will scale and center
params <- preProcess(PimaIndiansDiabetes[,1:2], method=c("center", "scale"))

# transform the dataset
new_dataset <- predict(params, PimaIndiansDiabetes[,1:2])

# summarize the transformed dataset
summary(new_dataset)


# Poker and roulette 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

# Select poker results for Monday, Tuesday and Wednesday
poker_start <- poker_vector[c("Monday", "Tuesday", "Wednesday")]

# Calculate the average of the elements in poker_start
print(mean(poker_start))


# demo of PCA fitting
# phase shifted data courtesy of Vladimir Galogaza.

# list of image files
# these are stored in zernike/psidata in the R library, so must expand path name

require(zernike)

fpath <- file.path(find.package(package="zernike"), "psidata")
files <- scan(file.path(fpath, "files_pca.txt"), what="character")
for (i in 1:length(files)) files[i] <- file.path(fpath, files[i])

# load the images into an array

images <- load.images(files)
nr <- dim(images)[1]
nc <- dim(images)[2]
nf <- dim(images)[3]

# parameters for this run

source(file.path(fpath, "parameters.txt"))

# phase shifts

phases <- wrap((0:(nf-1))/frames.per.cycle*2*pi)
phases <- switch(ps.dir, ccw = -phases, cw = phases, phases)

# target SA coefficients for numerical null.

sa.t <- sconic(diam,roc,lambda=wavelength)
zopt <- psfit_options()
zopt$plots <- FALSE
zopt$satarget <- sa.t

cat("Performing PSI analysis. Please wait...\n")
flush.console()
system.time(psfit <- psifit(images, phases, psialg="ls", options=zopt))

cat("Zernike fit to wavefront from PSI analysis\n")
flush.console()

plot(psfit$wf.smooth)
mtext(paste("RMS =",format(pupilrms(psfit$wf.smooth),digits=3)))

cat("Performing PCA analysis. Please wait...\n")
system.time(pcfit <- psifit(images, phases, cp=psfit$cp, psialg="pc1", options=zopt))

cat("Wavefront from PCA routine\n")
flush.console()

if (tolower(.Platform$OS.type) == "windows") windows() else x11()
plot(pcfit$wf.smooth)
mtext(paste("RMS =",format(pupilrms(pcfit$wf.smooth),digits=3)))

cat("Performing 'Advanced iterative algorithm'. Please wait...\n")
system.time(aifit <- psifit(images, phases=pcfit$phases, cp=psfit$cp, psialg="aia", options=zopt))

cat("Wavefront from 'AIA'\n")
flush.console()

if (tolower(.Platform$OS.type) == "windows") windows() else x11()
plot(aifit$wf.smooth)
mtext(paste("RMS =",format(pupilrms(aifit$wf.smooth),digits=3)))

# full intercomparison

wfnets <- array(0, dim=c(nr, nc, 3))
wfsmooth <- array(0, dim=c(nr,nc,3))

legends=c("baseline PSI", "PCA", "AIA")

plotn(psfit, pcfit, aifit, labels=legends)
plotn(psfit, pcfit, aifit, labels=legends, wftype="smooth", qt=c(0,1))

cat("Why it works\n")
cat("Calculating principal components...\n")
flush.console()
im.mat <- matrix(images,nr*nc,nf)
im.mat <- im.mat-rowMeans(im.mat)
im.svd <- svd(im.mat)
pcs <- array(im.svd$u, dim=c(nr,nc,nf))
cat("And here they are...\n")
cat("The quadrature signal is assumed to be in the first two slots\n")
flush.console()

if (tolower(.Platform$OS.type) == "windows") {
  windows(width=10, height=2.5*nf)} else {
  x11(width=10, height=2.5*nf)
}
par(mar=rep(0,4))
split.screen(figs=c(nf/2,2))
for (i in 1:nf) {
  screen(i)
  image(pcs[,,i], col=grey256, axes=FALSE, asp=nc/nr, useRaster=TRUE)
}
close.screen(all.screens=TRUE)

#clean up
rm(im.mat, im.svd, pcs)


#==============================================================================
#	Test for svm
#==============================================================================

source("tests.r")

test.data <- list(
	call = list(
		substitute(svm(Sepal.Length ~ ., data = iris, probability = TRUE)),
		substitute(svm(Species ~ ., data = iris, probability = TRUE))
	),
	formula = list(
		Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width + Species,
		Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
	),
	model.type = list("regression", "classification")
)

test.model.adapter("svm", iris, test.data)

rm(test.data)


# Refer my jupyter notebook for more details:
# http://nbviewer.jupyter.org/github/ajhalthor/statistical-learning-with-R/blob/master/Chapter%202/notebooks/question%208.ipynb

college = read.csv("Datasets/College.csv")
head(college) #Use fix(college) in R-Studio to display in internal beditor

names(college)

rownames(college)[1:10] #Display the first 10 row names

rownames(college) = college[ , 1]
head(college)

college = college[ , -1] #Exclude first column
head(college)

summary(college)

pairs(college[,1:10])

plot(college$Private, college$Outstate, xlab="Public/Private Indicator", ylab="Out of State Tuition($)", main="Boxplot of Outstate Vs. Private")

Elite = rep("No", length(rownames(college))) #Initialize all entries of Elite to 'No'
Elite[college$Top10perc > 50] = "Yes" #If Top10Perc > 50, assign field as 'Yes'
Elite = as.factor(Elite)
college = data.frame(college, Elite)

head(college)

summary(college$Elite)

plot(college$Elite, college$Outstate, ylab="Out of State Tuition ($)", xlab="Is the University Elite?",main="Elite Vs. Outstate")

par(mfrow=c(2,2))
for (numBins in 1:20){
    hist(college$Outstate, breaks=numBins, xlab="OutState", ylab="Freq", main=paste("Bins = ",numBins))
}

par(mfrow=c(2,2))
for (numBins in 1:20){
    hist(college$Books, breaks=numBins, xlab="Book Cost", ylab="Freq", main=paste("Bins = ",numBins))
}

par(mfrow=c(5,2))
for (numBins in 1:20){
    hist(college$Books, breaks=numBins, xlab="Book Cost", ylab="Freq", main=paste("Bins = ",numBins))
}


year <- function(planet){
  res <- switch(planet,
    "Mercury" = 87.969,
    "Venus" = 224.701,
    "Earth" = 365.256,
    "Mars" = 686.980,
    "Jupiter" = 4332.6,
    "Saturn" = 10759.2,
    "Uranus" = 30685.0,
    "Neptune" = 60190.0,
    "Pluto" = 90465.0,
    stop("unknown planet")
  )
  return(res)
}

orbit <- function(planet){
  res <- switch(planet,
    "Mercury" = 57.91,
    "Venus" = 108.21,
    "Earth" = 149.60,
    "Mars" = 227.92,
    "Jupiter" = 778.57,
    "Saturn" = 1433.5,
    "Uranus" = 2872.46,
    "Neptune" = 4495.1,
    "Pluto" = 5869.7,
    stop("unknown planet")
  )
  return(res)
}

black <- "#000000"
blue <- "#0000FF"
red <- "#FF0000"
green <- "#00FF00"
purple <- "#800080"
maroon <- "#800000"
navy <- "#8B0000"
dark_red <- "#8B0000"
orange <- "#FFA500"

canvas_len = 400

dance <- function(outer_planet, inner_planet, orbits){
   outer_planet_year = year(outer_planet)
   inner_planet_year = year(inner_planet)
   outer_planet_radius = orbit(outer_planet)
   inner_planet_raidus = orbit(inner_planet)
   interval_days = outer_planet_year / 75.0
   ycenter = canvas_len / 2
   xcenter = canvas_len / 2
   r1 = ycenter
   r2 = r1 * inner_planet_raidus / outer_planet_radius
   r <- 0
   rstop = outer_planet_year * orbits
   a1 <- 0
   a1_interval = 2 * pi * interval_days / outer_planet_year
   a2 <- 0
   a2_interval = 2 * pi * interval_days / inner_planet_year

   orbit_text = sprintf("%.f orbits", orbits)
   text(10, canvas_len - 30, labels=outer_planet, col="blue")
   text(10, canvas_len - 50, labels=inner_planet, col="blue")
   text(10, 20, orbit_text, col="blue")

   while (r < rstop){
      i = floor(r / interval_days / 75)

      color <- if(i == 0) "#000000"
      else if (i == 1) "#0000FF"
      else if (i == 2) "#FF0000"
      else if (i == 3) "#00FF00"
      else if (i == 4) "#800080"
      else if (i == 5) "#800000"
      else if (i == 6) "#8B0000"
      else if (i == 7) "#8B0000"
      else "#FFA500"

      a1 <- a1 - a1_interval
      a2 <- a2 - a2_interval
      x1 <- r1 * cos(a1) + xcenter
      y1 <- - r1 * sin(a1) + ycenter
      x2 <- r2 * cos(a2) + xcenter
      y2 <- - r2 * sin(a2) + ycenter
      segments(x1, y1, x2, y2, col=color)
      r <- r + interval_days
   }
}

png('dance.png', width=canvas_len, height=canvas_len)
plot(NULL, type="n", xlim=c(0, canvas_len), ylim=c(0, canvas_len), axes=F, ann=F)
dance("Earth", "Venus", 8.0)
invisible(dev.off())


### function power it

power.it <- function(a, b){
  if(!is.numeric(a) | !is.numeric(b)){
    stop('one argument at least is not a number')
  }
  if(b < 1){
    warning('computing a root')
  }
  return(a ^ b)
}

power.it(3, .5)

# ratio as percentage #####

ratio.as.percent <- function(a, b){
  my.percentage <- round((a/b) * 100, 0)
  return(paste(my.percentage, '%'))
}


#Import the dataset
dataset= read.csv('Cereals2.csv')

#install.packages('caTools')
library(caTools)
set.seed(123)
split=sample.split(dataset$Customer_Segment,SplitRatio = 0.8)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

#Feature Scaling
training_set[-7]=scale(training_set[-7])
test_set[-7]=scale(test_set[-7])

#Fitting SVM
#install.packages('e1071')
library(e1071)

classifier= svm(formula=Customer_Segment ~ .,
                data=training_set,
                type='C-classification',
                kernel = 'linear')

#Predicting the test results
y_pred=predict(classifier, newdata=test_set[-7])

#Confusion Matrix
cm = table(test_set[,7], y_pred)
cm


#' Compute one component of the periodogram.
#'
#' @param t Sampling times.
#' @param x Value of timeseries at each sample time, after demeaning and standardizing.
#' @param omega Angular frequency to evaluate periodogram at.
#' @param tau Time-shift parameter tau.
#' @param sincos Either "sin" or "cos": whichever component is desired.
#'
#' @return Periodogram component value.
#'
#' @examples
#' periodogram.component(1:10, sin(1:10), 1, tau(1:10, 1), "sin")
#'
#' @export
periodogram.component <- function(t, x, omega, tau, sincos) {

    ## Input Validation ##

    # Parse the strings "sin" and "cos" into their respective functions,
    # and raise an error if neither provided.
    sincos.fn <- switch(sincos, sin = sin, cos = cos)
    if (is.null(sincos.fn)) {
        stop("Invalid value '", sincos, "' provided for 'sincos'. ",
             "Must be either 'sin' or 'cos'.")
    }

    t.minus.tau <- outer(tau, t, FUN = `-`)
    sincos.vec <- sincos.fn(t.minus.tau * omega)

    (sincos.vec %*% x) / sqrt(rowSums(sincos.vec^2))

}


# sem_ul_lwl.R

sem <- function(x) sd(x,na.rm = T)/sqrt(length(x))

upper <- function(x) mean(x,na.rm = T) + sem(x)
lower <- function(x) mean(x,na.rm = T) - sem(x)


## Created on Friday, November 12, 2021 at 3:02pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

library("gsDesign")                                    # For ciBinomial()

##
## Simple-minded efficacy computation, with confidence limits using a scaled binomial model.
## (To be eventually replaced by my super-duper Beta ratios stuff with Gauss hypergeometric magic!)
##

## Molnupiravir example, hospitalizations:
## > signif(efficacyAndCL(384, 28, 376, 53), digits = 3)
##   LCL   Eff   UCL
## 0.205 0.483 0.665
##
## Paxlovid example, hospitalizations:
## > signif(efficacyAndCL(389, 3, 385, 27), digits = 3)
##   LCL   Eff   UCL
## 0.663 0.890 0.964
##
## Paxlovid example, deaths:
## > signif(efficacyAndCL(389, 0, 385, 7), digits = 3)
##  LCL  Eff  UCL
## 0.46 1.00 1.00
##
## Paxlovid final report, hospitalizations:
## > signif(efficacyAndCL(1039, 8, 1046, 66), digits = 3)
##   LCL   Eff   UCL
## 0.751 0.878 0.940
##
## Paxlovid final report, deaths:
## > signif(efficacyAndCL(1039, 0, 1046, 12), digits = 3)
##   LCL   Eff   UCL
## 0.679 1.000 1.000
##
## Try the qBetaRatio() method here?  Are these numbers small enough for the naive implementation?
## For molnumpiravir
## > 1 - medianCLBetaRatio(28 + 1, 384 - 28 + 1, 53 + 1, 376 - 53 + 1, 0.05, 0, 10)
efficacyAndCL <- function(Ntrt, Ktrt, Ncnt, Kcnt) {    # Treatment efficacy & 95% conf limit
  ## Ntrt = number of subjects in treatment arm
  ## Ktrt = number of sick in treatment arm
  ## Ncnt = number of subjects in control arm
  ## Kcnt = number of sick in control arm
  eff   <- 1 - (Ktrt / Ntrt) / (Kcnt / Ncnt)           # Point estimate, then confidence limits
  effCL <- rev(1 - ciBinomial(Ktrt, Kcnt, Ntrt, Ncnt, scale = "RR"))
  c(LCL = effCL[[1]], Eff = eff, UCL = effCL[[2]])     # Return 3-vector of LCL, estimate, and UCL
}                                                      #


library(shiny)

shinyUI(fluidPage(

  sidebarLayout(
    sidebarPanel(
      numericInput('k', 'No of securities', 3),
      textInput('names', 'Security Names', 'Alpha Beta Gamma'),
      textInput('mean', 'Expected Returns (%)', '10 15 20'),
      textInput('sigmas', 'Standard Deviations (%)', '20 25 30'),
      textInput('correl',
                'Correlations (R2,1 .. Rk,1 R3,2.. Rk,2 ... Rk,k-1)',
                '0.3 0.2   0.1'),
      selectInput('type', 'Plot type',
                  list('Efficient Frontier',
                       'Portfolio Composition'),
                  selected = 'Efficient Frontier'),
      conditionalPanel(
        condition = "input.type == 'Efficient Frontier'",
        checkboxInput('frontier.twoasset',
                      'Plot All Two Asset Frontiers',
                      value = TRUE),
        checkboxInput('montecarlo', 'Plot Random Portfolios',
                      value = FALSE),
        numericInput('npoints', 'No of Random Portfolios', 200)
      )
    ) ,

    mainPanel(
      h1('Efficient Frontier'),
      tabsetPanel(
        tabPanel("Plot", plotOutput("plot")),
        tabPanel("Input Data",
                 h4('Means and Standard Deviations'),
                 tableOutput("mu.sd"),
                 h4('Correlation Matrix'),
                 tableOutput("rho")
        )
      )
    )
  ),
  title ="Efficient Frontier"
))


control.data.1 <- NULL

n.cols <- 11
n <- 1000
for(i in 1:n.cols){
  this.col <- rnorm(n)
  if(i==n.cols){  this.col[this.col>=0] <- 1; this.col[this.col<0] <- 0 }
  control.data.1 <- cbind(control.data.1,this.col )
}

write.table(control.data.1, file = paste(downloaded.ml.data, "control1.data.txt",sep=""), quote = FALSE,row.names=FALSE, sep=",", na="", col.names = FALSE)

m.rank <- 11
mu <- rep(0,m.rank)
corr.matrix <- matrix(runif(m.rank*m.rank, min=0, max=1), nrow=m.rank, ncol=m.rank)
diag(corr.matrix)<-1

corr.matrix.t <- t(corr.matrix)

corr.matrix[lower.tri(corr.matrix)] <- corr.matrix.t[lower.tri(corr.matrix.t)]

corr.matrix <- as.matrix(genPositiveDefMat("unifcorrmat",dim=m.rank)$Sigma)

control.data.2 <- mvrnorm(n=1000, mu=mu, Sigma=corr.matrix)

control.data.2[,m.rank] <- ifelse(control.data.2[,m.rank]>0,1,0)

write.table(control.data.2, file = paste(downloaded.ml.data, "control2.data.txt",sep=""), quote = FALSE,row.names=FALSE, sep=",", na="",col.names = FALSE)


# 3. faza: Vizualizacija podatkov

library(tidyverse)
warning=FALSE
#graf, ki ga zelimo narisati plot(graf)

#================================================================================================
#stevilo, povprecna cena, starost in skupna cena prestopov

prestopi <- read.csv("analiza/prestopi.csv")

#povprecno stevilo prestopov
prestopi_stevilo <- prestopi %>% select(X,stevilo_prihodov, stevilo_odhodov)
prestopi_stevilo <- reshape2::melt(prestopi_stevilo, id.var = 'X')

prestopi_stevilo_plot <- ggplot(prestopi_stevilo, aes(x=X,y=value,colour = variable))+geom_path(size = 1)+
                          geom_point()+xlab("Leto")+ylab("stevilo prestopov")+
                          scale_color_manual(name = "Prestop", labels = c('Prihodi','Odhodi'),values=c('Blue','Red'))

#povprecna cena prestopa
prestopi_cena <- prestopi %>% select(X,Povprecna_vrednost_prihoda,Povprecna_vrednost_odhoda)
prestopi_cena <- reshape2::melt(prestopi_cena, id.var = 'X')

prestopi_cena_plot <- ggplot(prestopi_cena, aes(x=X,y=value,colour = variable))+geom_path(size = 1)+
                      geom_point()+xlab("Leto")+ylab("Povprecna cena prestopov")+
                      geom_smooth(method='lm',se=F)+
                      scale_color_manual(name = "Prestop", labels = c('Prihodi','Odhodi'),values=c('Blue','Red'))

#povprecna starost prestopa
prestopi_starost <- prestopi %>% select(X,Povprecna_starost_prihoda,Povprecna_starost_odhoda)
prestopi_starost <- reshape2::melt(prestopi_starost, id.var = 'X')

prestopi_starost_plot <- ggplot(prestopi_starost, aes(x=X,y=value,colour = variable))+geom_path(size = 1)+
  geom_point()+xlab("Leto")+ylab("Povprecna starost prestopov")+ scale_x_continuous(breaks=seq(2010, 2020, 2))+
  scale_color_manual(name = "Prestop", labels = c('Prihodi','Odhodi'),values=c('Blue','Red'))

#plot(prestopi_starost_plot)

#skupna cena prestopov
prestopi_skupna <- prestopi %>% select(X,Skupna_vrednost_prihodov,Skupna_vrednost_odhodov)
prestopi_skupna <- reshape2::melt(prestopi_skupna, id.var = 'X')

prestopi_skupna_plot <- ggplot(prestopi_skupna, aes(x=X,y=value,colour = variable))+geom_path(size = 1)+
  geom_point()+xlab("Leto")+ylab("Skupna vrednost prestopov")+geom_vline(xintercept = 2017)+
  scale_x_continuous(breaks=seq(2010, 2020, 2))+
  scale_color_manual(name = "Prestop", labels = c('Prihodi','Odhodi'),values=c('Blue','Red'))

#plot(prestopi_skupna_plot)
#========================================================================================================
#napredna analiza napoved
leta <- data.frame(X=seq(2020,2022,1))
prestopi_skupna_prihod <- prestopi %>% select(X,Skupna_vrednost_prihodov)
prestopi_skupna_odhod <- prestopi %>% select(X,Skupna_vrednost_odhodov)

napoved_prihod <- lm(data=prestopi_skupna_prihod,prestopi_skupna_prihod$Skupna_vrednost_prihodov ~ X)
napoved_vrednost_prihod <- mutate(leta, Skupna_vrednost_prihodov=predict(napoved_prihod, leta))

napoved_odhod <- lm(data=prestopi_skupna_odhod,prestopi_skupna_odhod$Skupna_vrednost_odhodov ~ X)
napoved_vrednost_odhod <- mutate(leta, Skupna_vrednost_odhodov=predict(napoved_odhod, leta))

prestopi_skupna_prihod_plot <- ggplot(prestopi_skupna_prihod, aes(x=X,y=Skupna_vrednost_prihodov,colour = 'Blue'))+geom_path(size = 1)+
  geom_smooth(method = lm, color="#ffff00",se=FALSE,size=1.2)+geom_point()+
  geom_point(data=napoved_vrednost_prihod, aes(x=X,y=Skupna_vrednost_prihodov,colour='Green'))+
  scale_x_continuous('Leto', breaks=seq(2010, 2022, 1), limits=c(2010, 2022))+
  xlab("Leto")+ylab("Skupna vrednost prestopov")+geom_vline(xintercept = 2017)+
  scale_color_manual(name = "Vrednost prestopov", labels = c('Prihodi','Napoved'),values=c('Blue','Green'))

prestopi_skupna_odhod_plot <- ggplot(prestopi_skupna_odhod, aes(x=X,y=Skupna_vrednost_odhodov,colour = 'Red'))+geom_path(size = 1)+
  geom_smooth(method = lm, color="Blue",se=FALSE,size=1.2)+geom_point()+
  geom_point(data=napoved_vrednost_odhod, aes(x=X,y=Skupna_vrednost_odhodov,colour='Green'))+
  scale_x_continuous('Leto', breaks=seq(2010, 2022, 1), limits=c(2010, 2022))+
  xlab("Leto")+ylab("Skupna vrednost prestopov")+geom_vline(xintercept = 2017)+
  scale_color_manual(name = "Vrednost prestopov", labels = c('Napoved','Odhodi'),values=c('Green','Red'))

#print(c(napoved_prihod$coefficients,napoved_odhod$coefficients))
#plot(prestopi_skupna_prihod_plot)
#plot(prestopi_skupna_odhod_plot)
#================================================================================================
#polozaj prestopov

polozaj <- read.csv("analiza/polozaj.csv")
polozaj_prihod_stevilo <- polozaj %>% select(X,Napadalec_prihod,Vezist_prihod,Branilec_prihod,Vratar_prihod)
polozaj_prihod_stevilo <- reshape2::melt(polozaj_prihod_stevilo, id.var = 'X')
polozaj_odhod_stevilo <- polozaj %>% select(X,Napadalec_odhod,Vezist_odhod,Branilec_odhod,Vratar_odhod)
polozaj_odhod_stevilo <- reshape2::melt(polozaj_odhod_stevilo, id.var = 'X')

vloge1 <- c('Napadalec-Prihod','Vezist-Prihod','Branilec-Prihod','Vratar-Prihod')
vloge2 <- c('Napadalec-Odhod','Vezist-Odhod','Obramba-Odhod','Vratar-Odhod')

barve1 <- c("#00F5FF", "#0276FD", "#009ACD", "#00688B")
barve2 <- c("#ffb2b2", "#ff0000", "#b20000", "#4c0000")

polozaj_stevilo_prihod_plot <- ggplot(polozaj_prihod_stevilo, aes(x=X,y=value,colour = variable))+geom_path(size = 1.5)+
  scale_color_manual(name = "Polozaj-Prestop", labels = vloge1,values=barve1)+
  xlab('Leto')+ylab('stevilo prestopov')+
  theme(legend.text = element_text(size = 14))+guides(colour = guide_legend(override.aes = list(size=5)))

polozaj_stevilo_odhod_plot <- ggplot(polozaj_odhod_stevilo, aes(x=X,y=value,colour = variable))+geom_path(size = 1.5)+
  scale_color_manual(name = "Polozaj-Prestop", labels = vloge2,values=barve2)+
  xlab('Leto')+ylab('stevilo prestopov')+
  theme(legend.text = element_text(size = 14))+guides(colour = guide_legend(override.aes = list(size=5)))

#================================================================================================
#drzave -> zemljevid/geoplot

#uvoz in ureditev stevila prestopov
drzave_prihodi <- read.csv("analiza/drzave_prihodi.csv")
drzave_prihodi <- drzave_prihodi[-1]
colnames(drzave_prihodi) <- c('Drzava',2010:2019)
drzave_prihodi <- data.frame(drzave_prihodi$Drzava,rowSums(drzave_prihodi[2:11]))
colnames(drzave_prihodi) <- c('drzava','stevilo')

drzave_odhodi <- read.csv("analiza/drzave_odhodi.csv")
drzave_odhodi <- drzave_odhodi[-1]
colnames(drzave_odhodi) <- c('Drzava',2010:2019)
drzave_odhodi <- data.frame(drzave_odhodi$Drzava,rowSums(drzave_odhodi[2:11]))
colnames(drzave_odhodi) <- c('drzava','stevilo')

#zemljevid
source("./lib/uvozi.zemljevid.r")
zemljevid <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip", "ne_50m_admin_0_countries", encoding="UTF-8")%>% fortify()

#izris zemljevida stevila prestopov
drzave_prihodi <- drzave_prihodi %>% right_join(zemljevid, by=c('drzava'='NAME'))
map_prihodi <- ggplot() + geom_polygon(data=drzave_prihodi, aes(x=long, y=lat, group=group, fill=stevilo))+
  xlab('Zemljepisna sirina')+ylab('Zemljepisna dolzina')+
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank(),
        legend.key.size = unit(1.5, "cm"),legend.key.width = unit(0.5,"cm"))+
  scale_fill_gradient(high="#008800", low="#CCFFCC")+labs(fill = "Skupno stevilo prihodov")

drzave_odhodi <- drzave_odhodi %>% right_join(zemljevid, by=c("drzava"='NAME'))
map_odhodi <- ggplot() + geom_polygon(data=drzave_odhodi, aes(x=long, y=lat, group=group, fill=stevilo))+
  xlab('Zemljepisna sirina')+ylab('Zemljepisna dolzina')+
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank(),
        legend.key.size = unit(1.5, "cm"),legend.key.width = unit(0.5,"cm"))+
  scale_fill_gradient(high="#008800", low="#CCFFCC")+labs(fill = "Skupno stevilo odhodov")

#analogno za skupne vrednosti
drzave_prihodi_vrednost <- read.csv("analiza/drzave_prihodi_vrednost.csv")
drzave_prihodi_vrednost <- drzave_prihodi_vrednost[-1]
colnames(drzave_prihodi_vrednost) <- c('Drzava',2010:2019)
drzave_prihodi_vrednost <- data.frame(drzave_prihodi_vrednost$Drzava,rowSums(drzave_prihodi_vrednost[2:11]))
colnames(drzave_prihodi_vrednost) <- c('drzava','stevilo')

drzave_prihodi_vrednost <- drzave_prihodi_vrednost %>% right_join(zemljevid, by=c('drzava'='NAME'))
map_prihodi_vrednost <- ggplot() + geom_polygon(data=drzave_prihodi_vrednost, aes(x=long, y=lat, group=group, fill=stevilo))+
  xlab('Zemljepisna sirina')+ylab('Zemljepisna dolzina')+
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank(),
        legend.key.size = unit(1.5, "cm"),legend.key.width = unit(0.5,"cm"))+
  scale_fill_gradient(high="#008800", low="#CCFFCC")+labs(fill = "Skupna vrednost prihodov")

drzave_odhodi_vrednost <- read.csv("analiza/drzave_odhodi_vrednost.csv")
drzave_odhodi_vrednost <- drzave_odhodi_vrednost[-1]
colnames(drzave_odhodi_vrednost) <- c('Drzava',2010:2019)
drzave_odhodi_vrednost <- data.frame(drzave_odhodi_vrednost$Drzava,rowSums(drzave_odhodi_vrednost[2:11]))
colnames(drzave_odhodi_vrednost) <- c('drzava','stevilo')

drzave_odhodi_vrednost <- drzave_odhodi_vrednost %>% right_join(zemljevid, by=c("drzava"='NAME'))
map_odhodi_vrednost <- ggplot() + geom_polygon(data=drzave_odhodi_vrednost, aes(x=long, y=lat, group=group, fill=stevilo))+
  xlab('Zemljepisna sirina')+ylab('Zemljepisna dolzina')+
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank(),
        legend.key.size = unit(1.5, "cm"),legend.key.width = unit(0.5,"cm"))+
  scale_fill_gradient(high="#008800", low="#CCFFCC")+labs(fill = "Skupna vrednost odhodov")

#================================================================================================
#izris vseh prestopov
drzave_vsi <- read.csv("analiza/drzave_vsi.csv")
drzave_vsi <- drzave_vsi[-1]
colnames(drzave_vsi) <- c('Drzava',2010:2019)
drzave_vsi <- data.frame(drzave_vsi$Drzava,rowSums(drzave_vsi[2:11]))
colnames(drzave_vsi) <- c('drzava','stevilo')

drzave_vsi <- drzave_vsi %>% right_join(zemljevid, by=c('drzava'='NAME'))
map_vsi <- ggplot() + geom_polygon(data=drzave_vsi, aes(x=long, y=lat, group=group, fill=stevilo))+
  xlab('Zemljepisna sirina')+ylab('Zemljepisna dolzina')+
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank(),
        legend.key.size = unit(1.5, "cm"),legend.key.width = unit(0.5,"cm"))+
  scale_fill_gradient(high="#008800", low="#CCFFCC")+labs(fill = "Skupno število prestopov")

#================================================================================================
#shiny


############################
# A function that estimates the
# bivariate probit model and outputs the results
# We require a specific version of GJRM:
# remotes::install_version("GJRM", "0.2-2")
library(GJRM)

estimate_bivariate_selection <- function(data = serosurvey_data, subset_condition = NULL, selection_type = "2step", agreementvar = "agreed", clinicvisitvar = "agreed_and_tested", outcomevar = "IgG_testB", regressors = "age + male", semiparametric_age = T, exclusion_restriction_agreement = NULL, exclusion_restriction_clinicvisit = NULL, error_distribution = "N", surveyweightsvar = NULL) {

	# Debug: data = serosurvey_data; subset_condition = NULL; regressors = "agegroup + male"; semiparametric_age = F; exclusion_restriction_agreement = NULL; exclusion_restriction_clinicvisit = "offered_taxi"; error_distribution = "N"; clinicvisitvar = "agreed_and_tested"; outcomevar = "IgA_or_G_or_M_testC"; agreementvar = "agreed"; selection_type = "2step"; surveyweightsvar = "raking_weight"

	# Define selection and outcome equations
	if( grepl("age +", regressors, fixed = T) & semiparametric_age ) {

		agreement_equation <- as.formula(paste0(agreementvar, "~",
											gsub("age +", "s(age) +", regressors, fixed = T),
											ifelse(!is.null(exclusion_restriction_agreement), paste0(" + ", exclusion_restriction_agreement), ""))
										)

		visit_equation <- as.formula(paste0(clinicvisitvar, "~",
											gsub("age +", "s(age) +", regressors, fixed = T),
											ifelse(!is.null(exclusion_restriction_clinicvisit), paste0(" + ", exclusion_restriction_clinicvisit), ""))
										)

		outcome_equation <- as.formula(paste0(outcomevar, "~", gsub("age +", "s(age) +", regressors, fixed = T)))

	} else {

		agreement_equation <- as.formula(paste0(agreementvar, "~",
											regressors,
											ifelse(!is.null(exclusion_restriction_agreement), paste0(" + ", exclusion_restriction_agreement), ""))
										)

		visit_equation <- as.formula(paste0(clinicvisitvar, "~",
											regressors,
											ifelse(!is.null(exclusion_restriction_clinicvisit), paste0(" + ", exclusion_restriction_clinicvisit), ""))
										)

		outcome_equation <- as.formula(paste0(outcomevar, "~", regressors ))

	}

	# Subset fit
	if( !is.null(subset_condition) ) {

		eval(parse(text = paste0("data <- data[ ", subset_condition, " ]")))

	}

	# Testing the hypothesis of absence of non-random sample selection
	pvalue_sample_select_agreed <- LM.bpm(list(agreement_equation, outcome_equation), data, Model = "BSS")
	pvalue_sample_select_visited <- LM.bpm(list(visit_equation, outcome_equation), data, Model = "BSS")

	# Fit the model
	if( selection_type == "2step") {

		model_fit <- gjrm(list(visit_equation,
								outcome_equation),
								data = data,
								Model = "BSS", BivD = error_distribution, gamlssfit = F,
								margins = c("probit", "probit"))

	} else {

		model_fit <- gjrm(list(agreement_equation,
								visit_equation,
								outcome_equation),
								data = data,
								Model = "TSS", BivD = error_distribution, gamlssfit = F,
								margins = c("probit", "probit", "probit"))

	}

	# Add survey weights to model fit
	if( !is.null(surveyweightsvar) ) {

		# Attach survey weights to the model object
		model_fit$survey_weights_visit <- unname(unlist(data[as.numeric(rownames(model_fit$gam1$model))][, surveyweightsvar, with = F]))
		model_fit$survey_weights_outcome <- unname(unlist(data[as.numeric(rownames(model_fit$gam2$model))][, surveyweightsvar, with = F]))

	}

	# Output object
	output <- list(fit = model_fit, agreed_selection_p_value = pvalue_sample_select_agreed, visited_selection_p_value = pvalue_sample_select_visited)

	return(output)

}


test.apk <- function()
{
    checkEqualsNumeric(apk(2, 1:5, c(6,4,7,1,2)), 1/4)
    checkEqualsNumeric(apk(5, 1:5, c(1,1,1,1,1)), 0.2)
    checkEqualsNumeric(apk(20, 1:100, c(1:20,200:600)), 1)
    checkEqualsNumeric(apk(3, c(1,3), 1:5), 5/6)
    checkEqualsNumeric(apk(3, 1:3, c(1,1,1)), 1/3)
    checkEqualsNumeric(apk(3, 1:3, c(1,2,1)), 2/3)
}

test.mapk <- function()
{
    checkEqualsNumeric(mapk(10, list(1:5,1:3), list(1:10,c(1:2,4:11,3))), 5/6)
    checkEqualsNumeric(mapk(3, list(1:4), list(1:4)), 1.0)
    checkEqualsNumeric(mapk(3, list(c(1,3,4),c(1,2,4),c(1,3)), list(1:5,1:5,1:5)), 0.685185185185185)
    checkEqualsNumeric(mapk(5, list(1:5,1:5), list(c(6,4,7,1,2),c(1,1,1,1,1))), 0.26)
    checkEqualsNumeric(mapk(3, list(c(1,3),1:3,1:3), list(1:5,c(1,1,1),c(1,2,1))), 11/18)

}


library(linmod2)
library(rbenchmark)
set.seed(1234)

cols = cols <- c("test", "replications", "elapsed", "relative")
reps = 25

m = 2000
n = 500
x = matrix(rnorm(m*n), m, n)
y = rnorm(m)

benchmark(.lm.fit(x, y), .lm_fit(x, y), .lm_fit_minimal(x, y), replications=reps, columns=cols)

m = 500
n = 2000
x = matrix(rnorm(m*n), m, n)
y = rnorm(m)

benchmark(.lm.fit(x, y), .lm_fit(x, y), .lm_fit_minimal(x, y), replications=reps, columns=cols)


#' @title calcAdmPwr
#'
#' @description Calculates ship power (kW) using the admiralty formula.
#'
#' @param totalInstalledPwr Total installed main engine power (vector of numericals,
#' kW) (maximum continuous rated power)
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param refSpeed Reference speed of the ship (service speed or maximum speed)
#' (vector of numericals, m/s)
#' @param actualDraft Actual draft (vector of numericals, m)
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item At-sea operations = 15 (Default) \item Coastal operations = 10}
#' Can supply either a vector of numericals, a single number, or rely on the default.
#' @param n Exponential relationship applied to the ship speed ratio (dimensionless).
#' Default = 3. This argument is not vectorized, so supply a single number or rely
#' on the default
#' @param refSpeedType Indicates if the reference speed is service speed or
#' maximum speed: \itemize{
#' \item "serviceSpeed (Default)"
#' \item "maxSpeed"}
#' Can supply either a vector of strings, a single value, or rely on the default.
#'
#' @details
#' Ship speed and actual draft are typically obtained from sources such as AIS
#' messages or ship records.
#'
#' This implementation assumes the following default values:
#'
#' n = 3 (IMO greenhouse gas study)
#'
#' serviceMargin = 10 or 15, based on IMO (Prpic Orsic and Faltinsen, 2012).
#' 15 indicates 15\% increased resistance in at-sea water conditions, and 10
#' indicates 10\% increased resistance in coastal water conditions.
#'
#' Note that service margin is treated as an added resistance here
#' (instead of as a reduced efficiency) to maintain consistency with the other
#' power models used in this library. (See MAN, 2011).
#'
#' @return power (vector of numericals, kW)
#'
#' @references
#'International Maritime Organization. 2014. "Third IMO GHG study 2014 - Final
#'report." London: International Maritime Organization.
#'
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcPropPwr}}
#'\item \code{vignette("OverviewOfPowerModels", package="ShipPowerModel")}
#'\item \code{vignette("Admiralty.Formula.Example", package="ShipPowerModel")}
#'}
#'
#' @examples
#' calcAdmPwr(9363, seq(0,13,1), 15, 12.48, 13.57, serviceMargin = 15, n=3)
#'
#' @export

calcAdmPwr <- function(totalInstalledPwr, shipSpeed, refSpeed, actualDraft, maxDraft,
                           serviceMargin = 15, n=3,
                           refSpeedType = "serviceSpeed"){

  #The admiralty formula method requires the the reference speed to be maximum speed, to be consistent with the other terms.
  #Convert service speed to maximum speed by assuming service speed is 94% of maximum speed.
  refSpeed<-ifelse(tolower(refSpeedType) == "servicespeed",
                   refSpeed/0.94,
                   refSpeed
                  )#end ifelse

  power <- ifelse(shipSpeed==0,
                  0,
                  totalInstalledPwr*
                   pmin(1, #set maximum power to 100%
                        pmax(.02, #limit minimum power to 2%
                             ((actualDraft/maxDraft)^(2/3)*
                              (shipSpeed/refSpeed)^(n))*
                              ((100+serviceMargin)/100)
                            )
                       )
                 )#end ifelse
  return(power)

}#end of calcAdmPwr


library(vegan)
library(ggplot2)
library(dplyr)
library(tidyr)

#####################################################################

## Log transformed data
setwd("/Users/kai/Desktop/software/tax-e/data/freqs_1/log") #//set the working directory here:

### All data

# Load data
combined <- as.data.frame(read.csv(file = "all.csv",header = TRUE))
combined <- combined %>% select(-sample)
targets <- combined %>% select(target)
combined <- combined %>% select(-target)
combined <- cbind(targets,combined)

# doing pcoa on my data
my.dis <- vegdist(decostand(combined[,-1],"hellinger"))
my.pcoa <- cmdscale(my.dis, eig = TRUE)

with(combined, levels(target))
colors_vec <-palette(rainbow(8))
#try to fix it from here https://www.fromthebottomoftheheap.net/2012/04/11/customising-vegans-ordination-plots/
#get the species names
my.pcoa$species <- wascores(my.pcoa$points, combined[,-1], expand = TRUE)

#plot the figure
fig <- ordiplot(my.pcoa, type = "none")
#text(fig, "species", col="#d43e24", cex=0.9)
points(fig, "sites", col=colors_vec,  cex=1, pch=19)

### filter GO terms =< depth 4

# Load data
combined <- as.data.frame(read.csv(file = "depth_04.csv",header = TRUE))
combined <- combined %>% select(-sample)
targets <- combined %>% select(target)
combined <- combined %>% select(-target)
combined <- cbind(targets,combined)

# doing pcoa on my data
my.dis <- vegdist(decostand(combined[,-1],"hellinger"))
my.pcoa <- cmdscale(my.dis, eig = TRUE)

with(combined, levels(target))
colors_vec <-palette(rainbow(8))
#try to fix it from here https://www.fromthebottomoftheheap.net/2012/04/11/customising-vegans-ordination-plots/
#get the species names
my.pcoa$species <- wascores(my.pcoa$points, combined[,-1], expand = TRUE)

#plot the figure
fig <- ordiplot(my.pcoa, type = "none")
#text(fig, "species", col="#d43e24", cex=0.9)
points(fig, "sites", col=colors_vec,  cex=1, pch=19)

### filter GO terms =< depth 7

# Load data
combined <- as.data.frame(read.csv(file = "depth_07.csv",header = TRUE))
combined <- combined %>% select(-sample)
targets <- combined %>% select(target)
combined <- combined %>% select(-target)
combined <- cbind(targets,combined)

# doing pcoa on my data
my.dis <- vegdist(decostand(combined[,-1],"hellinger"))
my.pcoa <- cmdscale(my.dis, eig = TRUE)

with(combined, levels(target))
colors_vec <-palette(rainbow(8))
#try to fix it from here https://www.fromthebottomoftheheap.net/2012/04/11/customising-vegans-ordination-plots/
#get the species names
my.pcoa$species <- wascores(my.pcoa$points, combined[,-1], expand = TRUE)

#plot the figure
fig <- ordiplot(my.pcoa, type = "none")
#text(fig, "species", col="#d43e24", cex=0.9)
points(fig, "sites", col=colors_vec,  cex=1, pch=19)


# Create the two vectors
A_vector <- c(1, 2, 3)
B_vector <- c(4, 5, 6)

# Take the sum of A_vector and B_vector
total_vector <- A_vector + B_vector

# Print out total_vector
total_vector

# Poker and roulette 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

# Assign to total_daily how much you won/lost on each day
total_daily <- poker_vector + roulette_vector

# 1. Review the total weekly movements
# Poker and roulette 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 <- sum(poker_vector)

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

# Total winnings overall
total_week <- sum(total_poker, total_roulette)

# Print out total_week
total_week

# 2. Check to see are the returns better in poker compared to roulette
# Poker and roulette 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

# Calculate total gains for poker and roulette
total_poker <- sum(poker_vector)
total_roulette <- sum(roulette_vector)

# Check if you realized higher total gains in poker than in roulette - prints message of TRUE
total_poker > total_roulette


#################################################################
#######    Risk Analysis for Wind Turbine Toolkit        ########
#################################################################

## FEM.mean.R  (2014-2020)
##
## Copyright 2014-2020 Alexandre Brouste

##    INPUT VARIABLES
#################################################################
##  x    :
## theta :
## Delta :
#################################################################

##    OUTPUT VARIABLES
#################################################################
##  forecast
#################################################################

# parameters = (kappa,theta,sigma) --> theta[1,2,3] respectively

af<-function(x,theta){return(theta[1]*(theta[2]-x))}

bf<-function(x,theta){return(theta[3]^2)}

bfprime<-function(x,theta){return(0)}

OU.FEM<-function(x0,theta,DeltaTime,param=list(Minf=-8,Msup=8,N=200),R=10){

  Minf<-param$Minf
  Msup<-param$Msup
  N<-param$N

  space<-seq(Minf,Msup,length=N+1)
  Delta<-(Msup-Minf)/N

  # Elements finis

  phi<-function(x,n){
    (1-1/Delta*abs(x-space[n+1]))*(x>space[n])*(x<space[n+2])
  }

  # Matrice C

  res1th<-2/3*Delta
  res2th<-Delta/6

  ##- Fill the matrix C

  C<-diag(rep(res1th,N-1))
  C[1,2]<-res2th

  for (i in 1:(N-2)){
    C[i,i+1]<-res2th
    C[i+1,i]<-res2th
  }

  # Matrice K

  phiprime<-function(x,n){
    ((x<space[n+1])*(x>space[n]) - (x>space[n+1])*(x<space[n+2]))/Delta
  }

  ## fill matrix K

  K<-C

  for (i in 2:(N-2)){

    j<-0
    functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j)}
    K[i,i]<-integrate(functmp,space[i],space[i+2],stop.on.error = FALSE)$value

    j<-1
    functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j)}
    K[i,i+1]<-integrate(functmp,space[i+1],space[i+2],stop.on.error = FALSE)$value

    j<--1
    functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j)}
    K[i,i-1]<-integrate(functmp,space[i],space[i+1],stop.on.error = FALSE)$value
  }

  #i==1
  i<-1;

  j<-0
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[1,1]<-integrate(functmp,space[1],space[3],stop.on.error = FALSE)$value

  j<-1
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[1,2]<-integrate(functmp,space[2],space[3],stop.on.error = FALSE)$value

  #i==N-1

  i<-N-1;

  j<-0
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[N-1,N-1]<-integrate(functmp,space[N-1],space[N+1],stop.on.error = FALSE)$value

  j<--1
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[N-1,N-2]<-integrate(functmp,space[N-1],space[N],stop.on.error = FALSE)$value

  # Resolution du schema numerique

  T<-DeltaTime

  Deltat<-T/R
  lambda<-matrix(0,N-1,R+1)

  ##### Condition initiale
  psi<-0

  for (i in 1:(N-1)){
    psi[i]<-phi(x0,i)
  }

  lambda[1:(N-1),1]<-solve(C)%*%psi

  for (ti in 2:(R+1)){

    ### Schéma implicite
    lambda[,ti]<-1/Deltat*solve(C/Deltat-K)%*%C%*%lambda[,ti-1,drop=FALSE]

  }

  densf<-function(x,R){
    S<-0

    for (i in 1:(N-1)){
      S<-S+lambda[i,R]*phi(x,i)
    }

    return(S)
  }

  x<-seq(Minf,Msup,length=1001)
  EW<-sum(x*densf(x,R+1))*(Msup-Minf)/1000

  return(list(m=EW,density=densf(x,R+1),x=x))
}


epistasis_problem.simulate_system <- function(nid, r, p1, p2, p3, rsq)
{
	cis <- simulate_geno(nid, r, p1, p2)
	trans <- rbinom(nid, 2, p3)
	y <- scale(cis[,1]) * sqrt(rsq) + stats::rnorm(nid, sd=sqrt(1-rsq))
	dat <- data.frame(
		cis=cis[,1],
		cist=cis[,2],
		trans=trans,
		y=y
	)
	return(dat)
}

epistasis_problem.run1 <- function(param, i)
{
	set.seed(param$seed[i])
	a <- with(param[i, ], simulate_system(nid, r, p1, p2, p3, rsq))
	moda1 <- lm(y ~ as.factor(cis) + as.factor(trans), a)
	moda2 <- lm(y ~ as.factor(cis) * as.factor(trans), a)
	moda <- anova(moda1, moda2)
	modb1 <- lm(y ~ as.factor(cist) + as.factor(trans), a)
	modb2 <- lm(y ~ as.factor(cist) * as.factor(trans), a)
	modb <- anova(modb1, modb2)
	param$pint[i] <- moda$P[2]
	param$pintt[i] <- modb$P[2]
	return(param)
}

epistasis_problem <- function()
{
	a <- simulate_haplotypes(563, 0.9, 0.5, 0.5)
	b <- simulate_geno(1000, 0.9, 0.5, 0.5)
	a <- correlated_binomial(10000, 0.5, 0.5, 0.1)
	a <- simulate_system(1000, 0.8, 0.5, 0.5, 0.5, 0.3)

	param <- expand.grid(
		sim=1:300,
		nid=1000,
		r=c(sqrt(0.1), sqrt(0.5), sqrt(0.9)),
		p1=0.5,
		p2=0.5,
		p3=0.5,
		rsq=c(0.01, 0.1, 0.5),
		seed=NA,
		pint=NA,
		pintt=NA
	)
	param$seed <- 1:nrow(param)

	for(i in 1:nrow(param))
	{
		message(i)
		param <- run1(param, i)
	}

	graphics::hist(param$pintt)
	min(param$pintt)

	graphics::hist(param$pint, breaks=20)
	min(param$pint)

}


library(tidyverse)
library(caret)
library(randomForest)
library(plotROC)
library(lime)

# Load the data and remove NAs
data("PimaIndiansDiabetes2", package = "mlbench")
PimaIndiansDiabetes2 <- na.omit(PimaIndiansDiabetes2)
# Inspect the data
sample_n(PimaIndiansDiabetes2, 3)
# Split the data into training and test set
set.seed(123)
training.samples <- PimaIndiansDiabetes2$diabetes %>%
  createDataPartition(p = 0.8, list = FALSE)
train.data  <- PimaIndiansDiabetes2[training.samples,]
test.data <- PimaIndiansDiabetes2[-training.samples,]

# Fit the model on the training set
set.seed(123)
model <- train(
  diabetes ~ .,
  data = train.data,
  method = "rf",
  trControl = trainControl(
    method = "cv",
    summaryFunction = twoClassSummary,
    classProbs = T,
    savePredictions = T
  ),
  importance = TRUE
)
# Best tuning parameter
model$bestTune

# Final model
model$finalModel

model

# Select a parameter setting
selectedIndices <- model$pred$mtry == 2

model_data <- model$pred[selectedIndices,]

roc_plot <-
  ggplot(model_data, aes(m = pos, d = factor(obs, levels = c("neg", "pos")))) +
  geom_roc(n.cuts = 10) +
  geom_rocci(ci.at = quantile(model_data$pos, c(0.2, 0.5, 0.8)), linetype = 1) +
  coord_equal() +
  style_roc(theme = theme_grey)

roc_plot <-
  roc_plot + annotate("text",
                      x = 0.75,
                      y = 0.25,
                      label = paste("AUC =", round((calc_auc(
                        roc_plot
                      ))$AUC, 4)))

# Make predictions on the test data
predicted.classes <- model %>% predict(test.data)
head(predicted.classes)

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

importance(model$finalModel)

# Plot MeanDecreaseAccuracy
varImpPlot(model$finalModel, type = 1)
# Plot MeanDecreaseGini
varImpPlot(model$finalModel, type = 2)

varImp(model)

plot(varImp(model))

# pregnant Number of times pregnant
# glucose Plasma glucose concentration (glucose tolerance test)
# pressure Diastolic blood pressure (mm Hg)
# triceps Triceps skin fold thickness (mm)
# insulin 2-Hour serum insulin (mu U/ml)
# mass Body mass index (weight in kg/(height in m)\^2)
# pedigree Diabetes pedigree function
# age Age (years)
# diabetes Class variable (test for diabetes)

head(test.data)
hist(test.data$age)

pregnant <- 1
glucose <- 130.1
pressure <- 70.1
triceps <- 30
insulin <- 335
mass <- 30
pedigree <- 0.5
age <- 30.1

example.data <-
  data.frame(pregnant,
             glucose,
             pressure,
             triceps,
             insulin,
             mass,
             pedigree,
             age)

save(model, file = "model.rda")

# cat(predict(model, example.data, type = "prob")[[2]])


suppressMessages(library(gmp))
ONE <- as.bigz("1")
TWO <- as.bigz("2")
THREE <- as.bigz("3")
FOUR <- as.bigz("4")
SEVEN <- as.bigz("7")
TEN <- as.bigz("10")

q <- as.bigz("1")
r <- as.bigz("0")
t <- as.bigz("1")
k <- as.bigz("1")
n <- as.bigz("3")
l <- as.bigz("3")

char_printed <- 0

how_many <- 1000

first <- TRUE
while (how_many > 0) {
  if ((FOUR * q + r - t) < (n * t)) {
    if (char_printed == 80) {
      cat("\n")
      char_printed <- 0
    }
    how_many <- how_many - 1
    char_printed <- char_printed + 1
    cat(as.integer(n))
    if (first) {
      cat(".")
      first <- FALSE
      char_printed <- char_printed + 1
    }
    nr <- as.bigz(TEN * (r - n * t))
    n <- as.bigz(((TEN * (THREE * q + r)) %/% t) - (TEN * n))
    q <- as.bigz(q * TEN)
    r <- as.bigz(nr)
  } else {
    nr <- as.bigz((TWO * q + r) * l)
    nn <- as.bigz((q * (SEVEN * k + TWO) + r * l) %/% (t * l))
    q <- as.bigz(q * k)
    t <- as.bigz(t * l)
    l <- as.bigz(l + TWO)
    k <- as.bigz(k + ONE)
    n <- as.bigz(nn)
    r <- as.bigz(nr)
  }
}
cat("\n")


# Databricks notebook source
# MAGIC %md
# MAGIC #Try it out on your own
# MAGIC ## Build a Decision Tree and Random Forest - Compare both models

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

# MAGIC %r
# MAGIC # install.packages("e1071")

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

#packages

library(randomForest)
library(rpart)
library(caret)
# library(e1071)

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

# MAGIC %r
# MAGIC
# MAGIC #load my data
# MAGIC # Data Source: https://archive.ics.uci.edu/ml/machine-learning-databases/car/
# MAGIC
# MAGIC # Load the dataset and explore
# MAGIC data1 <- read.csv("https://archive.ics.uci.edu/ml/machine-learning-databases/car/car.data", header = TRUE)
# MAGIC

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

display(head(data1))

#display(class(data1))

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

class(data1)
colnames(data1) <- c("BuyingPrice", "Maintenance","NumDoors","NumPersons", "BootSpace","Safety","Condition")

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

head(data1)

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

str(data1)

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

summary(data1)

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

# head(data1)
# str(data1)

# Split into Train and Validation sets
# Training Set : Validation Set = 70 : 30 (random)
set.seed(100)
train <- sample(nrow(data1), 0.7*nrow(data1), replace = FALSE)
TrainSet <- data1[train,]
ValidSet <- data1[-train,]
summary(TrainSet)

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

summary(ValidSet)

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

# Create a Random Forest model with default parameters
model1 <- randomForest(Condition ~ ., data = TrainSet, importance = TRUE)
model1

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

# Fine tuning parameters of Random Forest model
model2 <- randomForest(Condition ~ ., data = TrainSet, ntree = 500, mtry = 6, importance = TRUE)
model2

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

# Predicting on train set
predTrain <- predict(model2, TrainSet, type = "class")
# Checking classification accuracy
table(predTrain, TrainSet$Condition)

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

# Predicting on Validation set
predValid <- predict(model2, ValidSet, type = "class")
# Checking classification accuracy
mean(predValid == ValidSet$Condition)

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

table(predValid,ValidSet$Condition)

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

importance(model2)

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

# MAGIC %r
# MAGIC
# MAGIC # To check important variables
# MAGIC # importance(model2)
# MAGIC varImpPlot(model2)

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

# MAGIC %r
# MAGIC
# MAGIC # Using For loop to identify the right mtry for model
# MAGIC a=c()
# MAGIC i=5
# MAGIC for (i in 3:8) {
# MAGIC   model3 <- randomForest(Condition ~ ., data = TrainSet, ntree = 500, mtry = i, importance = TRUE)
# MAGIC   predValid <- predict(model3, ValidSet, type = "class")
# MAGIC   a[i-2] = mean(predValid == ValidSet$Condition)
# MAGIC }
# MAGIC
# MAGIC a
# MAGIC
# MAGIC plot(3:8,a)

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

summary(TrainSet)

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

library(rpart)
library(caret)
library(e1071)

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

# We will compare model 1 of Random Forest with Decision Tree model

model_dt = train(Condition ~ ., data = TrainSet, method = "rpart")
# model_dt =rpart(Condition ~ ., data = TrainSet,method = "class")
model_dt_1 = predict(model_dt, data = TrainSet)

class(model_dt)

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

table(model_dt_1, TrainSet$Condition)

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

mean(model_dt_1 == TrainSet$Condition)

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

# MAGIC %r
# MAGIC # Running on Validation Set
# MAGIC model_dt_vs = predict(model_dt, newdata = ValidSet)
# MAGIC table(model_dt_vs, ValidSet$Condition)
# MAGIC

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

mean(model_dt_vs == ValidSet$Condition)

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

confusionMatrix(model_dt_vs, ValidSet$Condition)

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

library("rpart.plot")
rpart.plot(model_dt)

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

plot(model_dt$finalModel)
text(model_dt$finalModel)

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


require(Hmisc)
set.seed(1)
var <- c(rep('A', 100), rep('B', 100))
trt <- sample(c('T1','T2'), 200, TRUE)
x <- c(runif(100), 10*runif(100))
y <- x + c(runif(100)/10, runif(100))
N <- tapply(x, llist(var, trt), function(x) sum(!is.na(x)))
print(N)
#trt <- factor(paste(trt, ' (n=', N[cbind(var,trt)], ')', sep=''))

#var <- factor(paste(var, ' (n=', N[cbind(var,trt)], ')', sep=''))

vn <- var
for(v in unique(var)) {
  i <- var == v
  n <- tapply(!is.na(x[i]), trt[i], sum)
  nam <- names(n)
#  n <- sprintf('%s,(n[%s]==%g, n[%s1]==%g)', nam[1], n[1], nam[2], n[2])
#  w <- sprintf('paste(%s,"     (", n[%s]==%g,~~n[%s]==%g,")")',
#               v, nam[1], n[1], nam[2], n[2])
#  cat(w, '\n')
#  vn[var == v] <- parse(text=w)
  n <- sprintf('%s      (n%s=%g, n%s=%g)', v, nam[1],n[1], nam[2],n[2])
  vn[var == v] <- n
}
trt <- factor(trt)

xyplot(as.integer(trt) ~ x | vn, panel=panel.bpplot, ylim=c(0,3),
       scale=list(y=list(at=1:2, labels=levels(trt)),
         x=list(relation='free', limits=list(c(0,1),c(0,13)))),
       ylab='Treatment', layout=c(1,2))

# strip.default or strip.custom may provide workarounds
# http://r.789695.n4.nabble.com/Expressions-in-lattice-conditional-variables-td4660089.html

bpl <- function(x, group, lab, cex.labels=.75) {
  quants=c(0.025, 0.05, 0.125, 0.25, 0.375, 0.5, 0.625,
    0.75, 0.875, 0.95, 0.975)
  group <- factor(group)
  xlim <- quantile(x, c(.025,.975), na.rm=TRUE)
  sfn <- function(x, quants) {
    o <- options(digits=10)
    ## So won't lose precision in quantile names
    on.exit(options(o))
    c(quantile(x,quants), Mean=mean(x), SD=sqrt(var(x)), N=sum(!is.na(x)))
  }

  qu <- tapply(x, group, sfn, simplify=TRUE, quants)
  qu$Combined <- sfn(x, quants)
  sm <- matrix(unlist(qu), ncol=length(quants)+3,
               byrow=TRUE,
               dimnames=list(names(qu),
                 c(format(quants),'Mean','SD','N')))
  bpplt(sm[,-ncol(sm)], xlab=lab, xlim=xlim, cex.points=.5)
  upedge <- par('usr')[4]
  outerText('N',
            upedge+strheight('N', cex=cex.labels)/2,
            cex=cex.labels)
  for(i in 1:nrow(sm))
    outerText(sm[i,'N'], 4-i, cex=cex.labels)
}

spar(mfrow=c(2,1), left=-1,rt=3,bot=1.5, mgp=c(2.5,.6,0), tcl=-.3, ps=12)
set.seed(2)
trt <- c(rep('T1',100), rep('T2',100))
x1 <- runif(100)
x2 <- 10*runif(100)
trt <- sample(c('T1','T2'), 100, TRUE)
bpl(x1, trt, expression(x[1]))
title(sub=expression(F[1,20] == 2.53), cex.sub=.75, adj=0, line=2)
bpl(x2, trt, expression(x[list(2,23)]))


#!/usr/bin/env Rscript

#-m pearson
#-m kendall
#-m spearman

# ./rcor.r -i ../result/10262016/ -m pearson -c ClusterName!=\'-1\'

# _result
library('stringr');
library("tools");
library("optparse");
option_list = list(
    make_option(
        c('-i',"--input"),
        type = "character",
        default = NULL,
        help ="input directory",
        metavar = "character"
    ),
    make_option(
        c('-m',"--mode"),
        type = "character",
        default = 'default',
        help ="plot model data",
        metavar = "character"
    ),
    make_option(
        c('-c',"--condition"),
        type = "character",
        default = "ClusterName!=\'-1\'",
        help ="subset condition",
        metavar = "character"
    ),
    make_option(
        c('-x',"--xcolumn"),
        type = "character",
        default = NULL,
        help ="x column name",
        metavar = "character"
    ),
    make_option(
        c('-y',"--ycolumn"),
        type = "character",
        default = NULL,
        help ="y column name",
        metavar = "character"
    ),
    make_option(
        c('-p',"--perfix"),
        type = "character",
        default = NULL,
        help ="prefix file name of result ",
        metavar = "character"
    )
);
opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser)

opt_i = opt$i
opt_c = opt$c;
opt_x = opt$x;
opt_y = opt$y;
opt_m = tolower(opt$m);
opt_p = tolower(opt$p);

APP_TOOLS_DIRNAME = 'tools'
APP_TOOLS_DATA_DIRNAME = '_data'
APP_TOOLS_RESULT_DIRNAME = '_result'
APP_DATA_DIRNAME = 'data'
APP_RESULT_DIRNAME = 'result'

if (is.null(opt_i)) {
    print_help(opt_parser)
    stop("at least one argument must be supplied (input directory).n", call.=FALSE);
}

generateResultFilePath <- function(dataFilePath,prefix=""){

    initial.options =  commandArgs(trailingOnly = FALSE)
    file.arg.name = "--file="
    script.name = sub(file.arg.name, "", initial.options[grep(file.arg.name, initial.options)])

    filename = basename(dataFilePath);
    fileext = file_ext(dataFilePath);
    if (prefix==''){
       resultFileName = paste('r_',filename,'.pdf',sep="");
    }else{
       resultFileName = paste('r_',prefix,filename,'.pdf',sep='');
    }
    dataFileAbsPath =file_path_as_absolute(dataFilePath);

    app_root_dir = dirname(dirname(file_path_as_absolute(script.name)))
    app_data_dir = file.path(app_root_dir,APP_DATA_DIRNAME);
	app_result_dir =file.path(app_root_dir , APP_RESULT_DIRNAME);

	result_tmp_dirstr = str_replace_all(dirname(dataFileAbsPath),app_data_dir,'');
	result_tmp_dirstr = str_replace_all(dirname(dataFileAbsPath),app_result_dir,'');

	resultFileDir =file.path(app_result_dir,result_tmp_dirstr);
    if (!dir.exists(resultFileDir)){
        dir.create(path=resultFileDir,recursive=TRUE);
    }

    resultFilePath =file.path(resultFileDir,resultFileName);

    return(resultFilePath);
}

rcor <- function(opt_i,opt_c,opt_x,opt_y,opt_m,opt_p){

    fls = list.files(opt_i,pattern='*.csv',full.names=TRUE,recursive=TRUE);

    for (fl in fls){
        res_fl = generateResultFilePath(fl,opt_p);
        #res = read.table(fl, header=TRUE);
        res = read.csv(fl, sep='\t',header=TRUE);
        print(res_fl);
        #res = subset(res, eval(parse(text=opt_c)))
        #head(res);

        sink(res_fl);

        opt_x = 'res$Coverage';
        opt_y = 'res$Frequency';

        x = eval(parse(text=opt_x));
        y = eval(parse(text=opt_y));

        switch(opt_m,
            "pearson"=cor.test(x,y,method="pearson"),
            "kendall"=cor.test(x,y,method="kendall"),
            "spearman"=cor.test(x,y,method="spearman")
        );

        #dev.off();

    }

}
#generateResultFilePath(opt_i);
rcor(opt_i,opt_c,opt_x,opt_y,opt_m,opt_p)


#:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
#** @author  Aashish Yadavally; Jayant Parashar
#*  @version 1.0
#*  @date    Feb 25, 2019
#*  @see     LICENSE (MIT style license file)
#*/

library(ggplot2)
library(caret)
library(lattice)
library(lmridge)
library(lars)

# Returns rSq value for a linear regression model
get_adj_rSq <- function(r.squared, n, p) {
	rsq.cv <- 1 - (1 - r.squared)*(n - 1) / (n - p - 1)
	return(rsq.cv)
}

# Returns rSquared value based on minimum RSS/ maximum rSquared
get_rSq <- function(data.frame, choice) {
	if(choice == "1") {	# Simple Regression
		model <- lm(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")), data=data.frame)
		r.squared <- summary(model)[[8]]
	} else if(choice == "2") { # Ridge Regression
		if(as.integer(dim(data.frame)[2]) <=3) {	# Requires atleast two features in 'x' matrix
			r.squared <- 0
		} else {
			model <- lmridge(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")), data = data.frame, K = c(0.1, 0.001))
			r.squared <- max(rstats1(model)$R2)
		}
	} else if(choice == "3") {	# Lasso Regression
		if(as.integer(dim(data.frame)[2]) <=3) {	# Requires atleast two features in 'x' matrix
			r.squared <- 0
		} else {
			x <- as.matrix(data.frame[, 2:dim(data.frame)[2]])
			y <- as.vector(data.frame[, 1])
			model <- lars(x, y, type = 'lasso')
			r.squared <- max(model$R2)
		}
	} else if(choice == "4") {	# Quad Regression
		model <- lm(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")), data=data.frame)
		r.squared <- summary(model)[[8]]
	} else if(choice == "5") {	# Response Surface
		model <- lm(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")), data=data.frame)
		r.squared <- summary(model)[[8]]
	} else {
		print("InvalidChoice: Please enter choice between '1' and '5'.")
	}
return(100*r.squared)
}

# Performs cross validation on input data frame
cross_validation <- function(data.frame, choice) {
	train.control <-trainControl(method = "cv", number = 10)
	if(choice == "1") {	# Simple Regression
		cv.results <- train(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")),
							data=data.frame, method="lm", trControl= train.control)
		return.value <- 100*cv.results$results$Rsquared
	} else if(choice == "2") {	# Ridge Regression
		if(as.integer(dim(data.frame)[2]) <=3){	# Requires atleast two features in X-matrix
			return.value <- 0
		} else {
		cv.results <- train(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")),
							data=data.frame, method="ridge", trControl= train.control)
		return.value <- 100*cv.results$results$Rsquared
		}
	} else if(choice == "3") {	# Lasso Regression
		if(as.integer(dim(data.frame)[2]) <=3){	# Requires atleast two features in X-matrix
			return.value <- 0
		} else {
		cv.results <- train(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")),
							data=data.frame, method="lasso", trControl= train.control)
		return.value <- 100*cv.results$results$Rsquared
		}
	} else if(choice == "4") {	# Quad Regression
		cv.results <- train(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")),
							data=data.frame, method="lm", trControl= train.control)  # The dataframe will be different for Quad Regression
		return.value <- 100*cv.results$results$Rsquared
	} else if(choice == "5") {	# Response Surface
		cv.results <- train(as.formula(paste(colnames(data.frame)[1], "~", paste('.', collapse = "+"),sep = "")),
							data=data.frame, method="lm", trControl= train.control) # The dataframe will be different for Response Surface
		return.value <- 100*cv.results$results$Rsquared
	} else {
		print("InvalidChoice: Please enter choice between '1' and '5'.")
	}
	return(return.value)
}

# Main function
main <- function() {
	cat(" Select dataset: \n\t 1. Auto MPG \n\t 2. Beijing PM2.5 Dataset \n\t 3. Concrete Compressive Strength Dataset \n\t 4. Real Estate Valuation Dataset \n\t 5. Parkinson's Tele Monitoring \n\t 6. Computer Hardware")
	cat("\n\t 7. Appliances Energy Prediction  \n\t 8. Combined Cycle Powerplant \n\t 9. CSM Dataset \n\t 10. Naval Propulsion Dataset \n\t 11. For other datasets, enter: /correct/path/to/data/csv\n")
	dataset.choice <- readline(prompt="\t\tEnter your choice:")

	if(as.integer(dataset.choice)>0 && as.integer(dataset.choice)<11) {
		path <- paste("D:/Spring2019/DataScienceII/Projects/CSCI-6360-Project01/data/", dataset.choice, ".csv", sep="")
	}
	else if(as.integer(dataset.choice)==11) {path <- readline(prompt="Enter correct path of your dataset: ")}
	else {
		print("Invalid Choice: Please enter choice between '1' and '11'.")
		quit()
	}

	file <- read.table(file=path, header=TRUE, sep=",")
	imp.file <- data.frame(sapply(file, function(x) ifelse(is.na(x), mean(x, na.rm = TRUE), x)))  # Mean Imputation
	column.names <- colnames(file)
	y.column.name <- column.names[1]
	x.column.names <- column.names[2:length(column.names)]
	model.choice <- readline(prompt="1. Linear Regression\n2. Ridge Regression\n3. Lasso Regression\n4. Quad Regression\n5. Response Surface\n\n\tChoose model: ")

	# Forward Selection
	fs.columns <- c(y.column.name) # Forward selection column vector
	rSq <- vector()
	adj.rSq <- vector()
	rSqCv <- vector()
	for(i in 1:length(x.column.names)) {
		model.rss.values <- vector() # Vector to track RSS values
		model.rsq.values <- vector() # Vector to track rSq values
		model.adj.rsq.values <- vector() # Vector to track adjusted rSq values
		for(j in 1:length(x.column.names)) {
			new.column.vector <- fs.columns
			new.column.vector <- append(fs.columns, x.column.names[j])
			model.rsq.values <- append(model.rsq.values, get_rSq(imp.file[,new.column.vector], model.choice))
		}
		max.index <- which.max(model.rsq.values) # Column name with maximum rSquared value
		fs.columns <- append(fs.columns, x.column.names[max.index]) # Forward selection column vector
		x.column.names <- x.column.names[x.column.names != x.column.names[max.index]] # Removing 'max.index' from column names vector

		# R-Squared and Adjusted R-Squared on Test set; Cross validation on full dataframe
		# If model choice is 4, column names corresponding to Quad Regression are attached to dataframe
		# If model choice is 5, column names corresponding to Response Surface are attached to dataframe
		# Else, other models are implemented, which require a Linear Model, but for model choice 2 and 3,
		# lambda regularization parameter is added.
		if(model.choice == "4") {
			cv.data.frame <- imp.file[,fs.columns]
			for(column in fs.columns[2:length(fs.columns)]) {
				new.column = paste(column,'^2')
				cv.data.frame[, new.column] <- cv.data.frame[, column] * cv.data.frame[, column]
			}
			data.n <- nrow(cv.data.frame)
			data.p <- ncol(cv.data.frame) - 1
  			rSq <- append(rSq, get_rSq(cv.data.frame, model.choice)) # Adding rSq value for column with maximum criterion
			adj.rSq <- append(adj.rSq, get_adj_rSq(rSq[i], data.n, data.p)) # Adding adjusted rSq value for column with maximum critrion
			rSqCv <- append(rSqCv, cross_validation(cv.data.frame, model.choice)) # Adding rSqCV value for forward selection vector
		} else if(model.choice == "5") {
			cv.data.frame <- imp.file[,fs.columns]
			for(i in 1:length(fs.columns)) {
				for(j in i:length(fs.columns)) {
					if(i==j) {new.column = paste(fs.columns[i],'^2')}
					else {new.column = paste(fs.columns[i], '_', fs.columns[j])}
					cv.data.frame[, new.column] <- cv.data.frame[, fs.columns[i]] * cv.data.frame[, fs.columns[i]]
				}
			}
			data.n <- nrow(cv.data.frame)
			data.p <- ncol(cv.data.frame) - 1
  			rSq <- append(rSq, get_rSq(cv.data.frame, model.choice)) # Adding rSq value for column with maximum criterion
			adj.rSq <- append(adj.rSq, get_adj_rSq(rSq[i], data.n, data.p)) # Adding adjusted rSq value for column with maximum critrion
			rSqCv <- append(rSqCv, cross_validation(cv.data.frame, model.choice)) # Adding rSqCV value for forward selection vector
		} else {
			cv.data.frame <- imp.file[,fs.columns]
			data.n	<- nrow(cv.data.frame)
			data.p <- ncol(cv.data.frame) - 1
 			rSq <- append(rSq, get_rSq(cv.data.frame, model.choice)) # Adding rSq value for column with maximum criterion
			adj.rSq <- append(adj.rSq, get_adj_rSq(rSq[i], data.n, data.p)) # Adding adjusted rSq value for column with maximum critrion
			rSqCv <- append(rSqCv, cross_validation(cv.data.frame, model.choice)) # Adding rSqCV value for forward selection vector
		}
	}
	#Plotting rSq and rSqCV
	plot(rSq[1:length(rSq)], type = 'l', col = 'red', main = "Regression Problem in R", ylab = "Percentage", ylim = c(0,100))
	lines(adj.rSq[1:length(adj.rSq)],  col = 'green')
	lines(rSqCv[1:length(rSqCv)],  col = 'blue' )
	legend(1,95, legend = c("R-Squared","Adjusted R-Squared", "R=Squared CV"), col = c("red","green", "blue"), lty = 1:2, cex = 0.8)
}

main()


#' @export
#' @title bufferRange
#' @description This function adds a bit of negative a positive buffer to a range.
#' @param \code{buffer.percent} = buffer amount (default = 2)
#' @return 2 values, each buffered to extend the range by the selected percentage
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @examples
#' x=-1000:10
#' bufferRange(x,2)
#' [1] -1020.0    10.2
#' @export
bufferRange <- function(x,buffer.percent = 2) {
	xr = range(x)
	if(xr[1]<0) xr[1] = xr[1]*(1+buffer.percent/100)
	if(xr[2]<0) xr[2] = xr[2]*(1-buffer.percent/100)
	if(xr[1]>0) xr[1] = xr[1]*(1-buffer.percent/100)
	if(xr[2]>0) xr[2] = xr[2]*(1+buffer.percent/100)
	return(xr)
}


require(rms)
n <- 40
set.seed(1)
y  <- runif(n)
x1 <- runif(n)
x2 <- rnorm(n)
g  <- sample(letters[1:4], n, TRUE)
dd <- datadist(x1, x2, g); options(datadist='dd')

f <- ols(y ~ pol(x1, 2) * g + x2)
pol2 <- function(x) {
  z <- cbind(x, xsq=x^2)
  attr(z, 'nonlinear') <- 2
  z
}
h <- ols(y ~ gTrans(x1, pol2) * g + x2)
specs(h, long=TRUE)
rbind(coef(f), coef(h))
summary(f)
summary(h)
ggplot(Predict(f))
ggplot(Predict(h))

k1 <- list(x1=c(.2, .4), g='b')
k2 <- list(x1=c(.2, .4), g='d')
contrast(f, k1)
contrast(h, k1)
contrast(f, k1, k2)
contrast(h, k1, k2)

f <- ols(y ~ lsp(x1, c(.2, .4)))
# Duplicate lsp but give custom names for columns
lspline <- function(x) {
  z <- cbind(x, x.2=pmax(x - .2, 0), x.4=pmax(x - .4, 0))
  attr(z, 'nonlinear') <- 2:3
  z
}
h <- ols(y ~ gTrans(x1, lspline))
rbind(coef(f), coef(h))
ggplot(Predict(f))
ggplot(Predict(h))
anova(f)
anova(h)

yl <- c(-0.25, 1.25)

# Fit a straight line from x1=0.1 on, but force a flat relationship for x1 in [0, 0.1]
# First do it forcing continuity at x1=0.1
h <- ols(y ~ pmax(x1, 0.1))
xseq <- c(0, 0.099, 1, 0.101, seq(0.2, .8, by=0.1))
ggplot(Predict(h, x1=xseq))
# Now allow discontinuity without a slope change
flin <- function(x) cbind(x < 0.1, x)
h <- ols(y ~ gTrans(x1, flin))
ggplot(Predict(h, x1=xseq), ylim=yl) + geom_point(aes(x=x1, y=y), data=data.frame(x1, y))
# Now have a discontinuity with a slope change
flin <- function(x) cbind(x < 0.1, pmax(x - 0.1, 0))
h <- ols(y ~ gTrans(x1, flin))
ggplot(Predict(h, x1=xseq), ylim=yl) + geom_point(aes(x=x1, y=y), data=data.frame(x1, y))

# Discontinuous linear spline
dlsp <- function(x) {
  z <- cbind(x, x >= 0.2, pmax(x - .2, 0), pmax(x - .4, 0))
  attr(z, 'nonlinear') <- 2:4
  z
}
h <- ols(y ~ gTrans(x1, dlsp))
ggplot(Predict(h), ylim=yl)
ggplot(Predict(h, x1=c(.1, .199, .2, .201, .3, .4, 1)), ylim=yl)

dlsp <- function(x) {
  z <- cbind(x, x >= 0.2, pmax(pmin(x, 0.6) - .2, 0), pmax(pmin(x, 0.6) - .4, 0))
  attr(z, 'nonlinear') <- 2:4
  z
}
h <- ols(y ~ gTrans(x1, dlsp))
ggplot(Predict(h), ylim=yl)

# Try on a categorical predictor
gr <- function(x) cbind(bc=x %in% c('b','c'), d=x == 'd')
h <- ols(y ~ gTrans(g, gr))
ggplot(Predict(h, g))

# Define a function that will be used by the latex method to customize typesetting of hrm model components
# Argument x will contain the variable's base name (here x1 but in LaTeX notation x_{1} for the subscript)
# tex works only in rms version 6.2-1 and higher
texhrm <- function(x) sprintf(c('%s', '(%s - 0.5)_{+}',
                                '\\sin(2\\pi \\frac{%s}{0.2})', '\\cos(2\\pi \\frac{%s}{0.2})'), x)
hrm <- function(x) {
  z <- cbind(x, slopeChange=pmax(x - 0.5, 0), sin=sin(2*pi*x/0.2), cos=cos(2*pi*x/0.2))
  attr(z, 'nonlinear') <- 2:4
  attr(z, 'tex')       <- texhrm
  z
}
h <- ols(y ~ gTrans(x1, hrm))
h
latex(h)
ggplot(Predict(h)) + geom_point(aes(x=x1, y=y), data=data.frame(x1, y))

## Try the above with interaction

h <- ols(y ~ gTrans(x1, hrm) * g)
ggplot(Predict(h, x1, g, conf.int=FALSE))
coef(h)
latex(h)

## Try with interaction with a continuous variable

h <- ols(y ~ gTrans(x1, hrm) * pol(x2, 2))
coef(h)
latex(h)

## Same but with restricted interaction
h <- ols(y ~ gTrans(x1, hrm) + pol(x2, 2) + gTrans(x1, hrm) %ia% pol(x2, 2))
coef(h)
latex(h)


library(rpart)
library(rpart.plot)
library(ggplot2)

# Build decision tree model
dm_model <- rpart(dm_model_formula, data=dm_traindf)

# Using rpart.plot build decision tree visual and save to file
png("rpt_tree_classification.png")
prp(dm_model)

# Using ggplot2 build scatter plot visual and save to file
png("rpt_ggscatter.png")
ggplot(data=dm_inputdf, aes(x=Horsepower, y=MSRP)) +
  geom_point(size=2, aes(color=DriveTrain)) +
  ggtitle("Data exploration(scatter plot) using CARS data")

# Using ggplot2 build density plot visual and save to file
png("rpt_ggdensity.png")
ggplot(data=dm_inputdf, aes(x=as.numeric(MSRP))) +
  geom_density(size=2, aes(color=DriveTrain)) +
  ggtitle("Data exploration(density plot) using CARS data")

# Using ggplot2 build heatmap visual and save to file
png("rpt_ggheatmap.png")
ggplot(data=dm_inputdf, aes(y=MSRP, x=factor(Cylinders))) +
  geom_bin2d() +
  ggtitle("Data exploration(heatmap) using CARS data")

dev.off()


library(timeSeries)
library(rugarch)

final.aic <- Inf
final.order <- c(0,0,0)

# estimate optimal ARIMA model order
for (p in 0:5) for (q in 0:5) { # limit possible order to p,q <= 5
	if (p == 0 && q == 0) next # p and q can't both be zero
    arimaFit <- tryCatch(arima(roll.returns, order = c(p,0,q)),
                         error = function( err ) FALSE,
                         warning = function( err ) FALSE )
    if (!is.logical( arimaFit)) {
		current.aic <- AIC(arimaFit)
		if (current.aic < final.aic) { # retain order if AIC is reduced
			final.aic <- current.aic
			final.order <- c(p,0,q)
			final.arima <- arima(roll.returns, order = final.order)
		}
    }
    else next
}

# specify and fit the GARCH model
spec = ugarchspec(variance.model <- list(garchOrder=c(1,1)),
                  mean.model <- list(
						armaOrder <- c(final.order[1], final.order[3]), include.mean = T),
						distribution.model = "sged")
fit = tryCatch(ugarchfit(spec, roll.returns, solver = 'hybrid'), error = function(e) e, warning = function(w) w)

# calculate next day prediction from fitted mode
# model does not always converge - assign value of 0 to prediction and p.val in this case
if (is(fit, "warning")) {
    forecasts <- 0
    p.val <- 0
}
else {
    next.day.fore = ugarchforecast(fit, n.ahead = 1)
    x = next.day.fore@forecast$seriesFor
    directions <- ifelse(x[1] > 0, 1, -1) # directional prediction only
    forecasts <- x[1] # actual value of forecast

    # analysis of residuals
    resid <- as.numeric(residuals(fit, standardize = TRUE))
    ljung.box <- Box.test(resid, lag = 20, type = "Ljung-Box", fitdf = 0)
    p.val <- ljung.box$p.value
  }
}