library(zoo)
library("ggplot2")
library(gridExtra)
library(grid)
library(qdapTools)

setwd("C:/Code/climData/glaser2019")

piAll <- read.csv("csv/p_1000_2018.csv", sep=",", na = "NA")

hiNew <- read.csv("csv/hhi_1500_2019.csv", sep=",", na = "NA")
hiNew <- subset(hiFull, hiFull$year<1996)

## Calculate summer average

hiSummer <- rollapply(hiNew$hhi, width=3, by=1, FUN=sum)
hiNew$hiSummer <- hiNew$hhi
hiNew$hiSummer[3:length(hiNew$hhi)] <- hiSummer/3.0
hiNewSummer <- subset(hiNew, hiNew$month==8)
hiNewSummer <- hiNewSummer[,c('year','month','time', 'hiSummer')]

piSummer <- rollapply(piAll$precipitation, width=3, by=1, FUN=sum)
piAll$piSummer <- piAll$precipitation
piAll$piSummer[3:length(piAll$precipitation)] <- piSummer/3.0
piAllSummer <- subset(piAll, piAll$month==8)

piNewSummer <- subset(piAllSummer, piAllSummer$year>1499 & piAllSummer$year<1996)
piNewSummer <- piNewSummer[,c('year','month', 'piSummer')]

## calibrate hhi vs average summper pi

hipi <- merge(hiNewSummer,piAllSummer, by=c("year","month"))

df <- data.frame(y = hipi[,"hiSummer"], x = hipi[,"piSummer"])
df <- subset(df, !is.na(df$x))
mx <- lm(y ~ x, df);
slope <- unname(coef(mx)[2])
eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2,
                 list(a = format(unname(coef(mx)[1]), digits = 3),
                      b = format(unname(coef(mx)[2]), digits = 5),
                      r2 = format(summary(mx)$r.squared, digits = 3)))
eq <- as.character(as.expression(eq))

p <- ggplot(data = df, aes(x = x, y = y)) +
  theme_classic(base_size=60) +
  scale_x_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-3.5,3.5)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3)) +
  geom_hline(aes(yintercept=0)) +
  geom_vline(aes(xintercept=0)) +
  labs(x="PI", y="HHI", title="", subtitle="") +
  geom_smooth(method = "lm", se=TRUE, color="cyan", formula = y ~ x) +
  geom_point(color="#0000AA", alpha=0.3, size=5) +
  geom_text(x = 2, y = -4, label = eq, parse = TRUE, size=15)

## Calculate 1000 years

piAllSummer$hhi <- piAllSummer$piSummer
piAllSummer$hdi <- piAllSummer$piSummer
piAllSummer$hwi <- piAllSummer$piSummer

for(i in 1:nrow(piAllSummer)) {
  piAllSummer$hhi[i] <- slope*piAllSummer$piSummer[i]
  if(is.na(piAllSummer$hhi[i])) {
    piAllSummer$hhi[i] <- 0.0
  }
  if(piAllSummer$year[i] < 1500) {
    #from cook comparison
    #piAllSummer$hhi[i] <- 0.6225*piAllSummer$hhi[i]
  }
  piAllSummer$hdi[i] <- min(0.0, piAllSummer$hhi[i])
  piAllSummer$hwi[i] <- max(0.0, piAllSummer$hhi[i])
}

hiNewSummer$hdi <- hiNewSummer$hiSummer
for(i in 1:nrow(hiNewSummer)) {
  hiNewSummer$hdi[i] <- min(0.0, hiNewSummer$hiSummer[i])
}

mp1 <- ggplot() +
  theme_classic(base_size=80) +
  #coord_cartesian(ylim=c(-4,4)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-5,5)) +
  labs(x="Year", y="HDI", title="", subtitle="") +
  geom_hline(aes(yintercept=0)) +
  geom_line(aes(y=-hiNewSummer$hdi, x=hiNewSummer$year, color="a:HDI"), size=2) +
  geom_line(aes(y=piAllSummer$hdi, x=piAllSummer$year, color="b:HDI"), size=2) +
  scale_color_manual(
    name = "",
    labels = c("HDI monthly", "HDI summer"),
    breaks  = c("a:HDI", "b:HDI"),
    values = c("a:HDI"="#33ccff", "b:HDI"="#ff9933")
  ) +
  theme( legend.key.width = unit(2,"cm"))
mp1

hhi <- piAllSummer[,c('year', 'hdi', 'hwi', 'hhi')]
hhi$hdi <- round(hhi$hdi, digits=6)
hhi$hwi <- round(hhi$hwi, digits=6)
hhi$hhi <- round(hhi$hhi, digits=6)

write.table(hhi, file = "csv/hhi_summer_1000_2019.csv", append = FALSE, quote = TRUE, sep = ",",
            eol = "\n", na = "NA", dec = ".", row.names = FALSE,
            col.names = TRUE, qmethod = "escape", fileEncoding = "UTF-8")


#' @title calcHMImmersedTransomRes
#'
#' @description
#' Calculate additional pressure resistance due to immersed transom (\code{Rtr})
#' (kN).
#'
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#'  \code{\link{calcSpeedUnitConversion}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param Cwp Water plane area coefficient (vector of numericals, see
#'  \code{\link{calcCwp}})
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param At Transom area (vector of numericals, m^2) (see \code{\link{calcAt}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @return \code{Rtr} (vector of numericals, kN)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcCwp}}
#'\item \code{\link{calcAt}} }
#'
#' @family Holtrop-Mennen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcHMImmersedTransomRes(seq(1,5,1),32.25,0.91,13.57,22.2,seawaterDensity=1.025)
#'
#' @export

calcHMImmersedTransomRes<-function(shipSpeed,breadth,Cwp,maxDraft,At,seawaterDensity=1.025){

Rtr<-
ifelse(shipSpeed/sqrt(2*9.81*At/(breadth+breadth*Cwp))<5,#case 1
  0.5*seawaterDensity*(shipSpeed^2)*At*(0.2*(1-0.2*(
    shipSpeed/sqrt(2*9.81*At/(breadth+breadth*Cwp))
    )
    ))
,#case 2
0)

return(Rtr)
}


# based on Rot-13 solution: http://rosettacode.org/wiki/Rot-13#R
ceasar <- function(x, key)
{
  # if key is negative, wrap to be positive
  if (key < 0) {
    key <- 26 + key
  }

  old <- paste(letters, LETTERS, collapse="", sep="")
  new <- paste(substr(old, key * 2 + 1, 52), substr(old, 1, key * 2), sep="")
  chartr(old, new, x)
}

# simple examples from description
print(ceasar("hi",2))
print(ceasar("hi",20))

# more advanced example
key <- 3
plaintext <- "The five boxing wizards jump quickly."
cyphertext <- ceasar(plaintext, key)
decrypted <- ceasar(cyphertext, -key)

print(paste("    Plain Text: ", plaintext, sep=""))
print(paste("   Cypher Text: ", cyphertext, sep=""))
print(paste("Decrypted Text: ", decrypted, sep=""))


#' Conducts PCA and returns scores
#'
#' @param first_configuration Point cloud to be aligned along principal components
#'
#' @keywords pca_align
#' @export
#' @examples
#' pca_align()

pca_align <- function(configuration = NULL) {
	results <- scale(configuration, scale=F)%*%eigen(var(configuration))$vectors
	return(results)
}


#' Simulations from day-to-day stochastic process models for traffic
#'
#' This functions generartes sequences of traffic flow patterns drawn from one of a number of day-to-day stochastic process models.
#' @param ODdemand Vector of origin-destination (OD) travel demands
#' @param ODpair Vector indicating the OD pair serviced by each route (ordered by columns of the path-link incidence matrix, A).
#' @param A Path-link incidence matrix
#' @param N.days Number of days to simulate. Defaults to 100.
#' @param N.sim Number of parallel simulation runs. Defaults to 1.
#' @param x.start Initial route flow pattern. Defaults to NA, when the initial flow is set to SUE.
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @param RUM Choice of random utility model. Can be "logit" (the default) or "probit".
#' @param theta A dispersion parameter. For the logit model, a single value specifying the logit parameter. For the probit model, a vector of standard deviations for the individual link cost errors. Defaults to 1.
#' @param psi Recency parameter, controlling weight assigned to most recent path costs when updating disutility. Defaults to 0.05.
#' @param process Defaults to "Standard", when a time-homogeneous Markoc process is employed in which route choice decisions are based on a utility which is a convex combination of the previous disutility and route costs. Alternatives are "TIDDS1" and "TIDDS2" time-inhomogeneous processes.
#' @variable.demand If FALSE (the default), travel demand is static through time. If TRUE, then travel demand is subject to Poisson variation with mean specified by \code{ODdemand}
#' @param prob.model Route choice probability model. One of "ProductMN" (product multinomial, the default), "Poisson", and "Approximate" (a quick and dirty approximation to the others).
#' @param tol Tolerance for convergence assessment for SUE. USed if \code{x.start} not specified. Defaults to 1e-4.
#' @param verbose Should progress of SUE algorithm be printed out? Defaults to FALSE.
#' @return The output is a list with components x and u, containing traffic path flows and disutilies respectively. Both x and u are 3-dimensional arrays. The first dimension indexes simulation run (if multiple parallel runs are required); the second indexes network path; and the third indexes day.
#' @keywords Day-to-day stochastic traffic assignment process
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' Alpha <- rep(10,7)
#' Beta <- rep(50,7)
#' pow <- rep(4,7)
#' ODpair <- c(1,1,2,2)
#' ODdemand <- c(50,50)
#' theta <- 0.7
#' N.sim <- 1
#' N.days <- 100
#' rDDSProcess(ODdemand,ODpair,A,N.days=N.days,N.sim=N.sim,x.start=c(20,0),Alpha=Alpha,Beta=Beta,pow=pow,RUM="logit",theta=theta,process="TIDDS1",variable.demand=F)
#' rDDSProcess(ODdemand,ODpair,A,N.days=N.days,N.sim=N.sim,x.start=c(20,0),Alpha=Alpha,Beta=Beta,pow=pow,RUM="logit",theta=theta,process="TIDDS2",variable.demand=F)
#' rDDSProcess(ODdemand,ODpair,A,N.days=N.days,N.sim=N.sim,x.start=c(20,0),Alpha=Alpha,Beta=Beta,pow=pow,RUM="logit",theta=theta,process="Standard",variable.demand=F)
#' @export

rDDSProcess <- function(ODdemand,ODpair,A,N.days=100,N.sim=1,x.start=NA,Alpha,Beta,pow=4,RUM="logit",theta=1,psi=0.05,process="Standard",variable.demand=F,tol=1e-4,verbose=F){
	psi.change <- process=="TIDDS1" | process=="TIDDS2"
	N.routes <- ncol(A)
  	N.OD <- length(ODdemand)
  	N.routes.per.OD <- unname(table(ODpair))
	if (variable.demand) mean.ODdemand <- ODdemand
  	ODdemand.rep <- rep(ODdemand,N.routes.per.OD)
  	indices <- c(0,cumsum(N.routes.per.OD))
  	x.sim <- array(0,dim=c(N.sim,N.routes,N.days))
  	u.sim <- array(0,dim=c(N.sim,N.routes,N.days))
    	if(any(is.na(x.start))){
		if (variable.demand) ODdemand <- rpois(N.OD,mean.ODdemand)
		x.start <- SUE(ODdemand=ODdemand,ODpair=ODpair,A=A,Alpha=Alpha,Beta=Beta,pow=pow,RUM=RUM,theta=theta,tol=tol,verbose=verbose)$x
    	}
	u.start <- PathCost(x.start,A=A,Alpha=Alpha,Beta=Beta,pow=pow)
	for (ii in 1:N.sim){
 		x.sim[ii,,1] <- x.start
		u.sim[ii,,1] <- u.start
		if (process=="TIDDS1") xbar <- x.start
		for (tt in 2:(N.days)){
			if (variable.demand) ODdemand <- rpois(N.OD,mean.ODdemand)
			if(psi.change) psi <- 1/tt
			if (process!="TIDDS1"){
	      		cost <- PathCost(x.sim[ii,,tt-1],A=A,Alpha=Alpha,Beta=Beta,pow=pow)
      			u <- psi*cost + (1-psi)*u.sim[ii,,tt-1]
			}
			if (process=="TIDDS1"){
				xbar <- (1-psi)*xbar + psi*x.sim[ii,,tt-1]
				u <- PathCost(xbar,A=A,Alpha=Alpha,Beta=Beta,pow=pow)
			}
      		pr <- PathProb(u,ODpair=ODpair,A=A,RUM=RUM,theta=theta)
      		for (i in 1:N.OD){
        			indx <- (indices[i]+1):(indices[i+1])
        			x.sim[ii,indx,tt] <- rmultinom(1,ODdemand[i],pr[indx])
      		}
			u.sim[ii,,tt] <- u
		}
	}
	list(x=x.sim,u=u.sim)
}


library(devtools)
library(parallel)
devtools::load_all()
RNGkind("L'Ecuyer-CMRG")
set.seed(999983)

taus <- seq(0.05, 0.95, length.out = 10)
k1 <- 11; ktau <- 2; m1 <- 4; mtau <- 3
v_k <- c(ktau, k1); v_m <- c(mtau, m1); v_dim <- v_k + v_m
n <- 400
ncores <- 16
m <- 20
v_sptau <- 10 ^ (-5 : 0); v_spx <- 10^ (-5:4)

# linear
f1 <- function(x) {0.2 + 0.4 * x}
# logarithm
f2 <- function(x) {log(x)}
# sinusoidal
f3 <- function(x) {sin(2 * pi * x)}
# square root sinusoidal
f4 <- function(x) {
    sqrt(x * (1 - x)) * sin(2 * pi * (1 + 2 ^ (-7 / 5)) / (x + 2 ^ (-7 / 5)))
}
obs_f <- function(sim, x) {
    if (sim == 1) {
        f1(x) + rnorm(length(x), mean = rep(0, length(x)), sd = 0.4 * (0.5 + x))
    } else if (sim == 2) {
        f2(x) + rnorm(length(x), mean = rep(0, length(x)), sd = 0.4 * (0.5 + x))
    } else if (sim == 3) {
        f3(x) + rnorm(length(x), mean = rep(0, length(x)), sd = 0.4 * (0.5 + x))
    } else if (sim == 4) {
        f4(x) + rnorm(length(x), mean = rep(0, length(x)), sd = 0.4 * (0.5 + x))
    }
}
truth_f <- function(sim, x, tau) {
    if (sim == 1) {
        f1(x) + qnorm(tau, sd = 0.4 * (0.5 + x))
    } else if (sim == 2) {
        f2(x) + qnorm(tau, sd = 0.4 * (0.5 + x))
    } else if (sim == 3) {
        f3(x) + qnorm(tau, sd = 0.4 * (0.5 + x))
    } else if (sim == 4) {
        f4(x) + qnorm(tau, sd = 0.4 * (0.5 + x))
    }
}

smooth_code2 <- function(sp, m = 20, sim = 2) {
    # L2 loss
    L2loss <- matrix(rep(0, 1 * length(taus)), nrow = 1)
    colnames(L2loss) <- taus
    rownames(L2loss) <- c("quantile sheets") #, "smooth_quan", "coco_quan")
    for (j in seq(m)) {
        #train
        x <- runif(n); ord <- order(x)
        x <- x[ord]
        y <- obs_f(sim, x)
        # test
        test_x <- seq(min(x), max(x), length.out = 1e4)
        #quantile sheets
        qs_fit <- qs_scam(x, y, maxit = 10, ntaus = 10,
                    arg_bs = c("tedmi", "ps"),
                    opt = "efs", dims = v_dim,
                    sp = sp[1:2])
        #smooth quan
#        smooth_fit <- f_smoothdescent(y, x, v_k, v_m,
#                        alpha = 0.1, bet = 0.8,
#                        v_smooth = sp,
#                        h = max((((log(length(y))+1)/length(y))^0.4), 0.05),
#                        s_ntau = 100,
#                        maxit = 500, eps = 1e-5, eta = 1e-3)
#        #coco_quan
#        coco_fit <- f_descent(y, x, v_k, v_m,
#                    alpha = 0.1, bet = 0.8, v_smooth = sp,
#                    maxit = 500, eps = 1e-5)
#
        for (i in seq_along(taus)) {
            tau <- taus[i]
            truth <- truth_f(sim, test_x, tau)
            L2loss[1, i] <- L2loss[1, i] + mean((c(predict(qs_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
#            L2loss[2, i] <- L2loss[2, i] + mean((c(cq_prediction(tau, smooth_fit, newdata = test_x)) - truth)^2)
#            L2loss[3, i] <- L2loss[3, i] + mean((c(cq_prediction(tau, coco_fit, newdata = test_x)) - truth)^2)
       }
    }
    list(loss = L2loss / m,
        model = qs_fit)
}

sim_smooth <- mclapply(v_sptau, outer_loop <- function(sptau) {
    mclapply(v_spx, inner_loop <- function(spx) {
        smooth_code2(sp = c(sptau, spx, spx), m)
    }, mc.cores = ncores)
}, mc.cores = ncores)

save(sim_smooth, file = "sim_smooth.RData")

lapply(sim_smooth, inner <- function(gri) {
        lapply(gri, fn <- function(gr) {
            if (!is.character(gr$loss)) {
                rowMeans(gr$loss)
            } else {
                0
            }
        })
})


# Databricks notebook source
# MAGIC %md
# MAGIC ##### Copyright (c) Microsoft Corporation.
# MAGIC ##### Licensed under the MIT license.
# MAGIC
# MAGIC ###### File: Step03b_Anomaly_Detection
# MAGIC ###### Date: 06/09/2020

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

# MAGIC %md
# MAGIC ####Step03b_Anomaly_Detection R notebook
# MAGIC
# MAGIC This notebook has the following process flow:
# MAGIC   1. Run Step01a_Setup for the Source and sink Configurations and Intialize the spark session.
# MAGIC   2. Load Libraries.
# MAGIC   3. Time series anomaly detection for the 311 safety data from 3 cities Chicago, Boston and the city of New York

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

# MAGIC  %run "./Step01a_Setup"

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

Libraries

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

# library(SparkR) #Spark R is already loaded from the Step01a_Setup notebook
library(anomalize)
library(tidyverse)

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

# MAGIC %md
# MAGIC Get the enriched data and register the temporary table

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

#Constructing the enriched absolute paths
#Notice here we are using all 3 cities
sink_blob_base_path = paste('wasbs://',dbutils.widgets.get("sink_blob_container_name"),'@',dbutils.widgets.get("sink_blob_account_name"),'.blob.core.windows.net',sep="")
enriched_blob_absolute_path_3cities = paste(sink_blob_base_path,"/city311",sep="")
#print the absolute paths
cat(enriched_blob_absolute_path_3cities)

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

#Read the enriched data in a dataframe for 3 cities
enriched_3cities_safety_df <- read.df(enriched_blob_absolute_path_3cities, source = "parquet")

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

#Register the DataFrame as a SQL temporary view: enriched_3cities_safety_view'
#Registers a DataFrame as a Temporary Table in the SQLContext
registerTempTable(enriched_3cities_safety_df, "enriched_3cities_safety_view")

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

monthly_count_chicago_pothole_2014_2019 = SparkR::collect(SparkR::sql('select to_date(concat(year,"-",month,"-","01"),"yyyy-MMM-dd") as startDayOfMonth,cnt  from (SELECT year,month, city,count(*) as cnt
               FROM enriched_3cities_safety_view
               WHERE city="Chicago" and (lower(category) like "%pothole%" OR lower(subcategory) like "%pothole%") and year > 2013 and year < 2020
               GROUP BY year,month, city) order by startDayOfMonth') )

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

head(monthly_count_chicago_pothole_2014_2019)

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

monthly_count_chicago_pothole_2014_2019_tib = as.tibble(monthly_count_chicago_pothole_2014_2019)

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

head(monthly_count_chicago_pothole_2014_2019_tib)

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

monthly_count_chicago_pothole_2014_2019_tib %>%
  time_decompose(cnt, method = "stl", frequency = "auto", trend = "auto") %>%
  anomalize(remainder, method = "gesd", alpha = 0.05, max_anoms = 0.2) %>%
  plot_anomaly_decomposition()

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

# MAGIC %md
# MAGIC Anomaly Detection and Plotting the detected anomalies are almost similar to what we saw above with Time Series Decomposition. It’s just that decomposed components after anomaly detection are recomposed back with time_recompose() and plotted with plot_anomalies() . The package itself automatically takes care of a lot of parameter setting like index, frequency and trend, making it easier to run anomaly detection out of the box with less prior expertise in the same domain.

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

monthly_count_chicago_pothole_2014_2019_tib %>%
  time_decompose(cnt) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  plot_anomalies(time_recomposed = TRUE, ncol = 3, alpha_dots = 0.5)

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

# MAGIC %md
# MAGIC If you are interested in extracting the actual datapoints which are anomalies, the following code could be used:

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

monthly_count_chicago_pothole_2014_2019_tib %>%
  time_decompose(cnt) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  filter(anomaly == 'Yes')

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

# MAGIC %md
# MAGIC If we get a bit more granular with breaking the count weekly on the start day of the week

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

str(enriched_3cities_safety_df)

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

weekly_count_chicago_pothole_2014_2019 = SparkR::collect(SparkR::sql('SELECT startDayOfWeek,cnt FROM (SELECT year,month, weekOfMonth,  min(to_date(date,"MM-dd-yyyy")) as startDayOfWeek, city,count(*) as cnt
               FROM enriched_3cities_safety_view
               WHERE city="Chicago" and (lower(category) like "%pothole%" OR lower(subcategory) like "%pothole%") and year > 2013 and year < 2020 and date is not null
               GROUP BY year,month, weekOfMonth, city) order by startDayOfWeek'))

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

head(weekly_count_chicago_pothole_2014_2019)

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

weekly_count_chicago_pothole_2014_2019_tib = as.tibble(weekly_count_chicago_pothole_2014_2019)

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

head(weekly_count_chicago_pothole_2014_2019_tib)

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

# MAGIC %md
# MAGIC anomalize has three main functions:
# MAGIC
# MAGIC time_decompose(): Separates the time series into seasonal, trend, and remainder components
# MAGIC
# MAGIC anomalize(): Applies anomaly detection methods to the remainder component.
# MAGIC
# MAGIC time_recompose(): Calculates limits that separate the “normal” data from the anomalies!

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

weekly_count_chicago_pothole_2014_2019_tib %>%
  time_decompose(cnt, method = "stl", frequency = "auto", trend = "auto") %>%
  anomalize(remainder, method = "gesd", alpha = 0.05, max_anoms = 0.2) %>%
  plot_anomaly_decomposition() +
 labs(title = "Decomposition of Anomalized Chicago Weekly Pothole Repair Complaints") +
    xlab("Year (Data collected as weekly aggregate)")

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

weekly_count_chicago_pothole_2014_2019_tib %>%
  time_decompose(cnt) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  plot_anomalies(time_recomposed = TRUE, ncol = 3, alpha_dots = 0.5)+
    labs(title = "Chicago Weekly Pothole Repair Complaints Anomalies")

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

weekly_count_chicago_pothole_2014_2019_tib %>%
    # Data Manipulation / Anomaly Detection
    time_decompose(cnt, method = "stl") %>%
    anomalize(remainder, method = "iqr") %>%
    time_recompose() %>%
    # Anomaly Visualization
    plot_anomalies(time_recomposed = TRUE, ncol = 3, alpha_dots = 0.5) +
    labs(title = "Tidyverse Chicago Weekly Pothole Repair Complaints Anomalies", subtitle = "STL + IQR Methods")   +
    xlab("Year (Data collected as weekly aggregate)")

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

#plot_anomaly_decomposition() for visualizing the inner workings of how algorithm detects anomalies in the “remainder”.
weekly_count_chicago_pothole_2014_2019_tib %>%
    ungroup() %>%
    time_decompose(cnt) %>%
    anomalize(remainder) %>%
    plot_anomaly_decomposition() +
    labs(title = "Decomposition of Anomalized Chicago Weekly Pothole Repair Complaints") +
    xlab("Year (Data collected as weekly aggregate)")

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

weekly_count_chicago_pothole_2014_2019_tib %>%
  time_decompose(cnt) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  filter(anomaly == 'Yes')

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

# MAGIC %md
# MAGIC observation from the data: Why there was bump in potholes repair complaints in 2018 February?
# MAGIC From the records 2018 Jan-Feb had a harsh winter and flooding. Also snow, ice and moisture all contribute to potholes but a cycle of freezing temperatures followed by higher temperatures helps the formation of potholes. and that explains the anamoly :
# MAGIC
# MAGIC https://abc7chicago.com/chicago-weather-potholes-heavy-rain-flood-watch/3112763/
# MAGIC https://digitaledition.chicagotribune.com/tribune/article_popover.aspx?guid=0815ff4c-6db6-4166-848c-eed12b08a702

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

# MAGIC %md
# MAGIC Going by the theme of our resrach i.e whether the 3 cities are related let us find the anamolies in New York City and Boston also.
# MAGIC We observe both the cities during the early 2018 had a rise in cases of pothole complaints. We also see from the data that the trends and anomalies in pothole complaints in Boston and New York City are very similar which can be attributed to their proximity and climate similarities.

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

weekly_count_boston_pothole_2014_2019 = SparkR::collect(SparkR::sql('SELECT startDayOfWeek,cnt FROM (SELECT year,month, weekOfMonth,  min(to_date(date,"MM-dd-yyyy")) as startDayOfWeek, city,count(*) as cnt
               FROM enriched_3cities_safety_view
               WHERE city="Boston" and (lower(category) like "%pothole%" OR lower(subcategory) like "%pothole%") and year > 2013 and year < 2020 and date is not null
               GROUP BY year,month, weekOfMonth, city) order by startDayOfWeek'))

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

weekly_count_boston_pothole_2014_2019_tib = as.tibble(weekly_count_boston_pothole_2014_2019)

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

weekly_count_boston_pothole_2014_2019_tib %>%
  time_decompose(cnt) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  filter(anomaly == 'Yes')

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

weekly_count_newyorkcity_pothole_2014_2019 = SparkR::collect(SparkR::sql('SELECT startDayOfWeek,cnt FROM (SELECT year,month, weekOfMonth,  min(to_date(date,"MM-dd-yyyy")) as startDayOfWeek, city,count(*) as cnt
               FROM enriched_3cities_safety_view
               WHERE city="NewYorkCity" and (lower(category) like "%pothole%" OR lower(subcategory) like "%pothole%") and year > 2013 and year < 2020 and date is not null
               GROUP BY year,month, weekOfMonth, city) order by startDayOfWeek'))

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

weekly_count_newyorkcity_pothole_2014_2019_tib = as.tibble(weekly_count_newyorkcity_pothole_2014_2019)

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

weekly_count_newyorkcity_pothole_2014_2019_tib %>%
  time_decompose(cnt) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  filter(anomaly == 'Yes')

#Integrate Azure Machine Learning


load_data <- function() {
    data <- read.csv('files/Employee_data.csv')
    return(data)
}

main <- function(){
    data <- load_data()
    data$id <- NULL

    png('images/correlation-plot.png')
    plot(data)
    dev.off()

    matrix <- cor(data)
    print("     --- Corelation Matrix ---")
    print(matrix)

    print("")
    print("     --- Corelation Summary ---")
    print(symnum(matrix))

    print("")
    print("     --- ACP ---")
    acp <- prcomp(data, scale=TRUE)
    print(summary(acp))
    png('images/acp-plot.png')
    plot(acp)
    dev.off()

    print("")
    print("     --- ACP Rotation ---")
    print(acp$rotation)

    png('images/bi-plot.png')
    biplot(acp)
    dev.off()
}

main()


library(readr)
data01 <- read.csv("data/data/inflammation-01.csv", header = FALSE, sep = ',')
class(data01)
dim(data01)
data01[30, 20]
data01[c(1, 3, 5), c(10, 20)]
data01
data01[1:4, 1:10]
data01[5:10, 1:10]
#first row, all of the columns
patient_1 <- data01[1, ]
#max inflammation for patient 1
max(patient_1)
sum(patient_1)
#max inflammation for patient 1
max(data01[1, ])
min(data01[2, 7])
max(data01[1, ])
mean(data01[1, ])
mean(as.numeric(data01[1, ]))
avg_patient_inflammation <- apply(data01, 1, mean)
avg_day_inflammation <- apply(data01, 2, mean)
plot(avg_day_inflammation)
max_day_inflammation <- apply(data01, 2, max)
plot(max_day_inflammation)
min_day_inflammation <- apply(data01, 2, min)
plot(min_day_inflammation)


# Loops - while
# Working with the while condition looping

# 1. Simple while loop
# Initialize the speed variable
speed <- 64

# Code the while loop
while (speed > 30) {
  print("Slow down!")
  speed <- speed - 7
}

# Print out the speed variable
speed

# 2. Additional while loop statement

# Extend/adapt the while loop - the paste() method lets the KW param speed to be added
while (speed > 30) {
  print(paste("Your speed is",speed))
  if (speed > 48) {
    print("Slow down big time!")
    speed <- speed - 11
  } else {
    print("Slow down!")
    speed <- speed - 6
  }
}

# 3. Including a break statement
# Initialize the speed variable
speed <- 88

while (speed > 30) {
  print(paste("Your speed is", speed))

  # Break the while loop when speed exceeds 80
  if (speed > 80) {
    break
  }

  if (speed > 48) {
    print("Slow down big time!")
    speed <- speed - 11
  } else {
    print("Slow down!")
    speed <- speed - 6
  }
}

# 4. Working with reciprocals
# Initialize i as 1
i <- 1

# Code the while loop
while (i <= 10) {
  print(3 * i)
  if (3 * i %% 8 == 0) {
    break
  }
  i <- i + 1
}


## This is a work in progress

plotxy <- function(df,xx,yy,model=1,xlimspec=NULL,ylimspec=NULL,bg="grey90") {
    ## create scatter plot with linear regression line and 95% confidence lines
    ## xx and yy are variables within dataframe df
    ## example usage: plotfit(df,hsub_in,power_ratio,ylimspec=c(0,1.1))
    xlabel <- deparse(substitute(xx))
    ylabel <- deparse(substitute(yy))
    xx <- eval(substitute(xx),df)   # need to recognize name passed into function as xx
    yy <- eval(substitute(yy),df)   # need to recognize name passed into function as yy
    newdf <- data.frame(xx,yy)
    xmin <- min(newdf$xx,na.rm=TRUE)
    xmax <- max(newdf$xx,na.rm=TRUE)
    ## xmax_plot <- xmax + (xmax-xmin)*1.2  # did this to make room for a legend
    ymin <- min(newdf$yy,na.rm=TRUE)
    ymax <- max(newdf$yy,na.rm=TRUE)
    if (missing(xlimspec)) { xlimspec <- c(xmin,xmax) }
    if (missing(ylimspec)) { ylimspec <- c(ymin,ymax) }
    par(bg=bg)  # changes background of plot to specified color
    plot(newdf$xx,newdf$yy,xlim=xlimspec,ylim=ylimspec,xlab=xlabel,ylab=ylabel)
    ##plot(newdf$power_ratio~newdf$g_ave,type="n")
    ##wx    <- par("usr")[1:2]
    ##new.x <- seq(wx[1],wx[2],len=length(newdf$power_ratio))
    ##new.x <- seq(min(log10(newdf$g_ave)),max(log10(newdf$g_ave)),len=100)
    new.xx <- seq(min(newdf$xx,na.rm=TRUE),max(newdf$xx,na.rm=TRUE),len=100)
    if        (model==0) {
        fit <- lm(yy~1,                      data=newdf)
    } else if (model == 1) {
        fit <- lm(yy~xx,                     data=newdf)
    } else if (model == 2) {
        fit <- lm(yy~xx + I(xx^2),           data=newdf)
    } else {
        fit <- lm(yy~xx + I(xx^2) + I(xx^3), data=newdf)
    }
    pred   <- predict(fit, new=data.frame(xx=new.xx), interval="conf", level=1-0.05)
    lines(new.xx,pred[,"fit"],lwd=2)
    if (model==1) {
        lines(new.xx,pred[,"lwr"],lty=3)
        lines(new.xx,pred[,"upr"],lty=3)
    }
    estbound(fit)
}


library(glmnet)
library(ncvreg)
source("lasso.r")
source("cv.lasso.r")

# SPEED TEST: CROSS-VALIDATION
set.seed(2020)
n <- 500
p <- 50000
sparse <- as.integer(0.001 * p)
idx <- sample(1:p, sparse, replace = FALSE)
X <- matrix(rnorm(n*p),n,p)
Z <- rnorm(n)
for(j in 1:p) {
  X[,j] <- Z + rnorm(n)
  X[,j] <- (X[,j]-mean(X[,j]))/sd(X[,j])
}
bt <- rnorm(length(idx))
y <- X[,idx] %*% bt + rnorm(n)

t0 <- Sys.time()
mm1 <- cv.glmnet(x=X, y=y, standardize=FALSE)
t1 <- Sys.time()
t1-t0
t0 <- Sys.time()
mm2 <- cv.ncvreg(X=X, y=y, penalty="lasso", lambda = 2*mm1$lambda)
t1 <- Sys.time()
t1-t0
t0 <- Sys.time()
mm3 <- cv.lasso(X=X, y=y, nfold =10)
t1 <- Sys.time()
t1-t0

mm1$lambda.min
mm2$lambda.min
mm3$lambda.min

# SPEED TEST: SINGLE PATH

t0 <- Sys.time()
m1 <- glmnet(x=X, y=y, standardize=FALSE)
t1 <- Sys.time()
t1-t0

t0 <- Sys.time()
m2 <- ncvreg(X=X, y=y)
t1 <- Sys.time()
t1-t0

t0 <- Sys.time()
m3 <- lasso0(X=X, y=y)
t1 <- Sys.time()
t1-t0

# SPEED TEST: SINGLE VALUE
lambda = mm3$lambda.min

t0 <- Sys.time()
m1 <- glmnet(x=X, y=y, lambda=lambda, standardize=FALSE)
t1 <- Sys.time()
t1-t0

t0 <- Sys.time()
m2 <- ncvreg(X=X, y=y, lambda=2*lambda)
t1 <- Sys.time()
t1-t0

t0 <- Sys.time()
m3 <- lasso0(X=X, y=y, lambda=lambda)
t1 <- Sys.time()
t1-t0

# ACCURACY TEST
b1 <- as.numeric(m1$beta)
a1 <- as.numeric(m1$a)
b2 <- as.numeric(m2$beta[-1])
a2 <- as.numeric(m2$beta[1])
b3 <- as.numeric(m3$b)
a3 <- as.numeric(m3$b0)

mean((y - X%*%b1 - a1)^2/2) + lambda*sum(abs(b1))
mean((y - X%*%b2 - a2)^2/2) + lambda*sum(abs(b2))
mean((y - X%*%b3 - a3)^2/2) + lambda*sum(abs(b3))

(mean((y - X%*%b3 - a3)^2/2) + lambda*sum(abs(b3))) - (mean((y - X%*%b1 - a1)^2/2) + lambda*sum(abs(b1)))
(mean((y - X%*%b3 - a3)^2/2) + lambda*sum(abs(b3))) - (mean((y - X%*%b2 - a2)^2/2) + lambda*sum(abs(b2)))


# coercionn is how R can flexible with data types
# for example

x <- c(1, "Canada", 3)

# R will coerce the data into characters for example > x
# also class(x)

# the function as.character() shifts numbers into characters
x <- 1:5
y <- as.character(x)
# y will return data in quotes ""

# the function as.numeric() shifts characters into numbers
x <- 1:5
y <- as.numeric(x)
# y will return as a number

# now if you declare the data type as a number the data you will return a NA
x <- c("1", "b", "3")
as.numeric(x)

# will return [1] 1 NA 3
# R will notify you of NAs introduced which is a resolution of coercion


# Multiple linear regression for machine learning.
#
# A linear regression model that contains more than one predictor variable is
# called a multiple linear regression model. It is basically the same as Simple
# Linear regression, but with more predictor variables (features). The idea is
# that linearly related predictor variables can approximate the labels with a
# 'best fitted' hyperplane or surface.

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

# Encode categorical data and make them into numeric categories.
dataset$State = factor(dataset$State,
                       levels = c('New York', 'California', 'Florida'),
                       labels = c(1,2,3))

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

# Don't need Feature Scaling

# Fit the training set with the mutliple linear regression model
regressor = lm(formula = Profit ~ ., data = training_set)
# summary(regressor)

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

# Building the optimal model using the Backward Elimenation method
regressor = lm(formula = Profit ~ R.D.Spend+Marketing.Spend, data = training_set)
summary(regressor)


men = data.frame(
    height = c(180,174,184,168,178),
    weight = c(75,71,83,63,70)
)
model = lm(weight ~ height, data = men)
print(model)


modLR <- new_resultFrame()

df.split <- h2o.splitFrame(df.hex, ratios = c(0.8), seed = 1234)
train <- df.split[[1]]
test <- df.split[[2]]
df.split_valid <- h2o.splitFrame(train, ratios = c(0.8), seed = 1234) #validation set to size of 5-fold
#code for sel_feat is in seperate_ED_model.r file.
# sel_feat <- rownames(feat_rank)[1:40]
vary = "alc_status"

df_glm_def <- h2o.glm(
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
model_id = "glm_1",
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_each_iteration = T,
seed = 1234
)

modLR <- add_results(df_glm_def, modLR)

df_glm_2 <- h2o.glm(
family = "binomial",
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
lambda_search = TRUE,
model_id = "glm_lambdaSearch",
# stopping_rounds = 5,
# stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
# stopping_metric = "AUCPR",
# score_each_iteration = T,
seed = 1234
)

modLR <- add_results(df_glm_2, modLR)

#Does not look good because have to disable early stopping
df_glm_3 <- h2o.glm(
family = "binomial",
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
model_id = "glm_3",
lambda = 0, #no penalty
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_each_iteration = T,
seed = 1234
)

modLR <- add_results(df_glm_3, modLR)

#Removing SCU as it has too many levels (16)
df_glm_4 <- h2o.glm(
family = "binomial",
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = grep("scu", sel_feat, value= TRUE, invert = TRUE),
y = vary,
model_id = "glm_noSCU_no stopping",
lambda = 0, #no penalty
# stopping_rounds = 5,
# stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
# stopping_metric = "AUCPR",
# score_each_iteration = T,
seed = 1234
)

modLR <- add_results(df_glm_4, modLR)

###Grid search over lamvbda

hyper_params <- list(
lambda = c(1, 0.5, 0.1, 0.01, 0.001, 0.0001, 0.00001, 0),
alpha = seq(0,1,0.01)
)
search_criteria = list(
strategy = "RandomDiscrete", #random grid search
max_runtime_secs = 3600 * 1,
max_models = 200,
seed = 1234)

t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = search_criteria,
algorithm = "glm",
grid_id = "glm_grid",
x = grep("scu", sel_feat, value= TRUE, invert = TRUE),
y = vary,
family = "binomial",
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
seed = 1234
)
print("Time elapsed for glm hyperTuning: ", Sys.time() - t)

sortedGrid <- h2o.getGrid("glm_grid", sort_by = "auc", decreasing = TRUE)
sortedGrid <- h2o.getGrid("glm_grid", sort_by = "AUCPR", decreasing = TRUE)

# H2O Grid Details
# ================

# Grid ID: glm_grid
# Used hyper parameters:
  # -  alpha
  # -  lambda
# Number of models: 200
# Number of failed models: 0

# Hyper-Parameter Search Summary: ordered by decreasing auc
   # alpha   lambda          model_ids                auc
# 1 [0.59] [1.0E-5] glm_grid_model_152 0.7886795460171198
# 2 [0.75] [1.0E-5]   glm_grid_model_9 0.7886746197066793
# 3 [0.97] [1.0E-5]  glm_grid_model_62 0.7886735717950397
# 4 [0.25] [1.0E-5]  glm_grid_model_34 0.7886733249166507
# 5  [1.0] [1.0E-5]  glm_grid_model_57 0.7886730009010012

# ---
     # alpha lambda         model_ids auc
# 195 [0.85]  [1.0] glm_grid_model_73 0.5
# 196 [0.29]  [0.5] glm_grid_model_75 0.5
# 197 [0.56]  [0.5] glm_grid_model_76 0.5
# 198 [0.87]  [0.5] glm_grid_model_88 0.5
# 199 [0.59]  [1.0] glm_grid_model_93 0.5
# 200 [0.98]  [1.0] glm_grid_model_97 0.5

lr <- h2o.getModel(sortedGrid@model_ids[[1]])
newLR <- do.call(h2o.glm,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- lr@parameters
		p$model_id = paste0("LR_ed_small_", 1)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$x = sel_feat_ed_small
		p
	})
modLR <- add_results(newLR, modLR)

newLR <- do.call(h2o.glm,
	{
		p <- lr@parameters
		p$model_id = paste0("LR_ed_big_", 1)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$x = sel_feat_ed_big
		p
	})
modLR <- add_results(newLR, modLR)

newLR <- do.call(h2o.glm,
	{
		p <- lr@parameters
		p$model_id = paste0("LR_ed_plusCIHI_", 1)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$x = sel_feat
		p
	})
modLR <- add_results(newLR, modLR)

write.csv(modLR, "./results_GLM_unseenTest.csv")

                  # Model Hit_Ratio Mean_PerC_Error LogLoss   AUC AUCPR Recall
# 1                 glm_1     0.810           0.308   0.314 0.789 0.333  0.538
# 2      glm_lambdaSearch     0.762           0.342   0.349 0.725 0.271  0.521
# 3                 glm_3     0.812           0.309   0.313 0.789 0.334  0.531
# 4 glm_noSCU_no stopping     0.814           0.310   0.314 0.789 0.333  0.526
# 5         LR_ed_small_1     0.791           0.356   0.333 0.723 0.268  0.450
# 6           LR_ed_big_1     0.783           0.352   0.332 0.727 0.271  0.469
# 7      LR_ed_plusCIHI_1     0.799           0.302   0.314 0.788 0.332  0.565
  # Precision Specificity max_F1 trshold training_AUC training_AUCPR
# 1     0.325       0.930  0.405   0.169        0.789          0.330
# 2     0.259       0.924  0.346   0.126        0.721          0.268
# 3     0.328       0.930  0.405   0.173        0.789          0.331
# 4     0.329       0.929  0.405   0.174        0.788          0.330
# 5     0.276       0.918  0.342   0.162        0.724          0.269
# 6     0.270       0.919  0.343   0.160        0.729          0.272
# 7     0.314       0.933  0.404   0.160        0.789          0.332
  # training_Recall training_Precision training_Spec
# 1           0.568              0.311         0.934
# 2           0.517              0.256         0.924
# 3           0.539              0.322         0.931
# 4           0.546              0.318         0.932
# 5           0.450              0.275         0.918
# 6           0.447              0.279         0.918
# 7           0.541              0.322         0.931


# Assignment 3 - Example Code
#QUESTION 1
base.samp = function(p,n) {   #DEFINE FUNCTION TO SAMPLE FROM SET {0,1/(p-1),...1}
  x = (p-1-p/2) * runif(n)    #NEED TO LIMIT TO RANGE OF (0, 1-delta)
  round(x) / (p-1)
}

mymorris = function(k,r,p,delta,par.mins,par.maxs,fun) {  #NOTE THE LAST INPUT IS THE MODEL NAME FOR SENS ANALYSIS

  par.range = par.maxs - par.mins
  effects = array(dim = c(k,r))

  for (r.ind in 1:r) {
    J = array(1,dim=c(k+1,k)) #AN ARRAY OF ONES
    B = lower.tri(J) * 1    #A LOWER TRIANGULAR ARRAY OF ONES
    xstar = base.samp(p,k)    #BASE VECTOR
    D = array(0,dim=c(k,k))   #AN ARRAY WITH EITHER 1 OR -1 IN DIAGONAL
    diag(D) = 1.0 -2*(runif(k) < .5)
    P = array(0,dim=c(k,k))   #A RANDOM PERMUTATION ARRAY
    diag(P) = 1
    P = P[,sample(c(1:k),k,replace=F)]
    Bstar =  (t(xstar*t(J)) + (delta/2) * ((2*B - J)%*%D + J)) %*% P

    y = numeric(length=(k+1)) #VECTOR TO HOLD MODEL OUTPUT
    for (i in 1:(k+1)) y[i] = fun(par.mins + par.range * Bstar[i,] )
    for (i in 1:k) {
      par.change = Bstar[i+1,] - Bstar[i,]  #FIND WHICH PARAMETER CHANGED AND WHETHER UP OR DOWN
      i2 = which(par.change != 0)
      effects[i2,r.ind] = (y[i+1] - y[i]) * (1 - 2 * (par.change[i2] < 0))
    }
  }
  effects   #RETURN THE k x r ARRAY OF COMPUTED EFFECTS
}


library(gtools)

solve24 <- function(vals=c(8, 4, 2, 1),
                    goal=24,
                    ops=c("+", "-", "*", "/")) {

  val.perms <- as.data.frame(t(
                  permutations(length(vals), length(vals))))

  nop <- length(vals)-1
  op.perms <- as.data.frame(t(
                  do.call(expand.grid,
                          replicate(nop, list(ops)))))

  ord.perms <- as.data.frame(t(
                   do.call(expand.grid,
                           replicate(n <- nop, 1:((n <<- n-1)+1)))))

  for (val.perm in val.perms)
    for (op.perm in op.perms)
      for (ord.perm in ord.perms)
        {
          expr <- as.list(vals[val.perm])
          for (i in 1:nop) {
            expr[[ ord.perm[i] ]] <- call(as.character(op.perm[i]),
                                          expr[[ ord.perm[i]   ]],
                                          expr[[ ord.perm[i]+1 ]])
            expr <- expr[ -(ord.perm[i]+1) ]
          }
          if (identical(eval(expr[[1]]), goal)) return(expr[[1]])
        }

  return(NA)
}


pdf_file<-"pdf/tablecharts_mosaicplot_1x2.pdf"
cairo_pdf(bg="grey98", pdf_file,width=10,height=6)

par(mai=c(0.25,0.0,0.0,0.25),omi=c(0.5,0.5,1.25,0.5),las=1,mfcol=c(1,2),family="Lato Light",las=1)
library(RColorBrewer)

# Import data and prepare chart

data<-read.csv("myData/1000.csv",as.is=c(F,T,F,T,T),sep=";")
data$DEKADE<-floor(data$YEAR/10) * 10
data$KDEKADE<-paste(data$DEKADE,"s",sep="")
data$KDEKADE[data$DEKADE < 1960]<-"1910s-50s"
tab<-table(data$KDEKADE,data$THEME)
utab<-chisq.test(tab)

# Create chart

mosaicplot(utab$expected,col=brewer.pal(7,"Accent"),main="",border=par("bg"))
mosaicplot(tab,col=brewer.pal(7,"Accent"),main="",border=par("bg"))

# Titling

mtext("1000 songs to hear before you die",3,line=3,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("Guardian 1000 Songs Distribution",3,line=1.5,adj=0,cex=0.9,font=3,outer=T)
mtext("Source: www.stubbornmule.net",1,line=1,adj=1.0,cex=0.85,font=3,outer=T)
dev.off()


#Get data from https://datacatalog.worldbank.org/dataset/gender-statistics
#Find the Gender Stats data and download the file in csv format
#Unzip and use Gender_StatsData.csv

getwd()
#setwd("~/Desktop/projects/r-projects")

rm(list = ls()) #cleaning up
library(utils)
library(tidyverse)

gender_data <- as.tibble(read.csv("Gender_StatsData.csv"))

str(gender_data) #show structure of R object
dim(gender_data) #dimensions
head(gender_data)

#equivalent commands: filter() dplyr == subset() base-R
#equivalent commands: select() dplyr == match() or which()
teenager_fr <- filter(gender_data, Indicator.Code == "SP.ADO.TFRT")

#we don't need anymore 'gender_date'
rm(gender_data)

#basic summary functions: mean(), sd(), min(), max(), sum()
mean(teenager_fr$X1975, na.rm = TRUE)

#reminder: n_distinct(), mutate(), summarise()
mean(teenager_fr$X1960, na.rm = TRUE)
sd(teenager_fr$X1960, na.rm = TRUE)

#extract the "low income", "middle income" and "high income". They are as Countries.
byincomelevel <- filter(teenager_fr, Country.Code %in% c("LIC","MIC","HIC"))

#just in case if fails, we set the name of the column (sometimes the following gather returns error)
colnames(byincomelevel)[1] <- "Country.Name"

#gather(): create 'Year' and 'FertilityRate' from columns X1960:X2015.
#        Using column name as 'Year' (key) and content of this field as 'FertilityRate' (value).
plotdata_bygroupyear <- gather(byincomelevel, Year, FertilityRate, X1960:X2015) %>%
                        select(Year, Country.Name, Country.Code, FertilityRate)

#saving a backup
plotdata_byyear <- plotdata_bygroupyear

#spread(): inverse of gather()
plotdata_byyear <- select(plotdata_byyear, Country.Code, Year, FertilityRate) %>%
                   spread(Country.Code, FertilityRate)

#plotting
ggplot(plotdata_bygroupyear, aes(x=Year, y=FertilityRate, group=Country.Code, color=Country.Code)) +
      geom_line() +
      labs(title='Fertility Rate by Country-Income-Level over Time')

#removing 'X' from years as 'X1960'
#   str_sub("X1960",-4)
#   str_sub("X1960",2,5)
#   str_replace("X1960","X","")

plotdata_bygroupyear <- mutate(plotdata_bygroupyear, Year=as.numeric( str_sub(Year,-4) ))

##########
# Part 2 #
##########

colnames(teenager_fr)[1] <- "Country.Name"
histdata_twoyears <- gather(teenager_fr, Year, FertilityRate, X1960,X2000) %>%
                     select(Year, Country.Name, Country.Code, FertilityRate)

#plotting histogram
ggplot(histdata_twoyears, aes(x=FertilityRate)) +
  geom_histogram(data=subset(histdata_twoyears, Year=="X1960"), color="darkred", fill="red", alpha=0.2) +
  geom_histogram(data=subset(histdata_twoyears, Year=="X2000"), color="darkblue", fill="blue", alpha=0.2)

ggsave("hist.png")

#plotting densities
ggplot(histdata_twoyears, aes(x=FertilityRate, group=Year, color=Year, alpha=0.2)) +
  geom_histogram(aes(y=..density..)) +
  geom_density(data=subset(histdata_twoyears, Year=="X1960"), color="darkred", fill="red", alpha=0.2, bw=5) +
  geom_density(data=subset(histdata_twoyears, Year=="X2000"), color="darkblue", fill="blue", alpha=0.2, bw=5)

##########
# Part 3 #
##########

rm(list = ls())
library(utils)

install.packages('plot3D')
library(plot3D)

M <- mesh(seq(0, 1, length=100), seq(0, 1, length=100))
x <- M$x
y <- M$y
z <- (6/5)*(M$x + M$y^2)

persp3D(x, y, z, xlab='X', ylab='Y', xlim=c(0,1), main='Plotting Joint PDF')

#Computing and Plotting CDF's
x <- seq(0, 1, length=1000)
y <- seq(0, 1, length=1000)
cdfx <- (6/5)*((1/3)*x + x^2/2)
cdfy <- (6/5)*((1/2)*y + y^3/3)

pdf("cumulative.pdf")
plot(x, cdfx, type="l", col="blue", xlab="", ylab="Cumulative Probability", xlim=c(0,1), main="CDF Plot")
lines(y, cdfy, lty=2, col="red", lwd=2)
legend("bottomright", ncol=1, legend=c("X","Y"), lty=c(1,2), col=c("blue","red"))
dev.off()


#
# Don't complain; just work harder! Dan Stanford
#
# Our responsibility is to do what we can, learn what we can, improve the solutions, and pass them on. RF
#
# @author: me@andreagirardi.it
# @since: Wed Jan 22 17:29:30 CET 2020
# @project: RExercises
# @module: Dplyr lesson
# @desc: Perform the following operations using only the dplyr library. We will be reviewing the following operations:
#   filter() (and slice())
#   arrange()
#   select() (and rename())
#   distinct()
#   mutate() (and transmute())
#   summarise()
#   sample_n() and sample_frac()
#
# @prerequisite
#   library(dplyr)
#   mtcars

# Exercises

# Return rows of cars that have an mpg value greater than 20 and 6 cylinders.
> filter(mtcars, mpg > 20, cyl == 6)
   mpg cyl disp  hp drat    wt  qsec vs am gear carb
1 21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
2 21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
3 21.4   6  258 110 3.08 3.215 19.44  1  0    3    1

# Reorder the Data Frame by cyl first, then by descending wt.
> head(arrange(mtcars, cyl, desc(wt)))
   mpg cyl  disp  hp drat    wt  qsec vs am gear carb
1 24.4   4 146.7  62 3.69 3.190 20.00  1  0    4    2
2 22.8   4 140.8  95 3.92 3.150 22.90  1  0    4    2
3 21.4   4 121.0 109 4.11 2.780 18.60  1  1    4    2
4 21.5   4 120.1  97 3.70 2.465 20.01  1  0    3    1
5 22.8   4 108.0  93 3.85 2.320 18.61  1  1    4    1
6 32.4   4  78.7  66 4.08 2.200 19.47  1  1    4    1

# Select the columns mpg and hp
> head(select(mtcars, mpg, hp))
                   mpg  hp
Mazda RX4         21.0 110
Mazda RX4 Wag     21.0 110
Datsun 710        22.8  93
Hornet 4 Drive    21.4 110
Hornet Sportabout 18.7 175
Valiant           18.1 105

# Select the distinct values of the gear column.
> distinct(select(mtcars, gear))
  gear
1    4
2    3
3    5

# Create a new column called "Performance" which is calculated by hp divided by wt.
> head(mutate(mtcars, Performance = hp / wt))
   mpg cyl disp  hp drat    wt  qsec vs am gear carb Performance
1 21.0   6  160 110 3.90 2.620 16.46  0  1    4    4    41.98473
2 21.0   6  160 110 3.90 2.875 17.02  0  1    4    4    38.26087
3 22.8   4  108  93 3.85 2.320 18.61  1  1    4    1    40.08621
4 21.4   6  258 110 3.08 3.215 19.44  1  0    3    1    34.21462
5 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2    50.87209
6 18.1   6  225 105 2.76 3.460 20.22  1  0    3    1    30.34682

# Find the mean mpg value using dplyr.
> summarise(mtcars, avg_mpg = mean(mpg))
   avg_mpg
1 20.09062

> mtcars %>% filter(cyl == 6) %>% summarise(avg_hp = mean(hp))
    avg_hp
1 122.2857

# Use pipe operators to get the mean hp value for cars with 6 cylinders.
> mtcars %>% filter(cyl == 6) %>% summarise(avg_mpg = mean(hp))
   avg_mpg
1 122.2857


sapply(salmon.data, FUN = mean, na.rm = TRUE)

sapply(salmon.data,
       FUN = function(a){
         test <- is.numeric(a)
         if(test == TRUE){
           mean.x <- mean(a, na.rm = TRUE)
         } else{
           mean.x <- 'cannot compute'
         }
         return(mean.x)
       }, simplify = FALSE)


#' Confidence intervals for MBM models
#'

#'
#' @param object An MBM object
#' @param parm Specification of what parameters to consider. Currently, only `fits` is
#' 		supported; this produces confidence intervals for the predictions of the original
#' 		data.
#' @param level Confidence level required
#' @param method How to compute confidence interval. The default uses a parametric estimate;
#'        this is the only method currently implemented.
#' @return A matrix with upper and lower confidence limits
#' @export
confint.mbm <- function(x, parm='fits', level = 0.95, method = c('parametric', 'sample'))
{
	method <- match.arg(method)
	if(method == 'sample') {
		warning("Sample not implemented; changing to method = 'parametric'")
		method <- 'parametric'
	}
	if(method == 'parametric')
		ci_method <- ci_parametric

	if(parm == 'fits') {
		ci <- ci_method(predict(x), level)
	} else {
		stop("Only parm = 'fits' is currently supported")
	}
	return(ci)
}

#' Parametric confidence intervals for mbm objects
#'
#' Computed via normal approximation.
#' @param x Predictions from an mbm object
#' @param level Confidence level required
#' @keywords internal
#' @return A matrix with upper and lower confidence limits in columns and observations in rows
ci_parametric <- function(x, level)
{
	quants <- qnorm(c((1 - level)/2, 1 - (1 - level)/2))
	cbind(lower = x[,1] + x[,2] * quants[1], upper = x[,1] + x[,2] * quants[2])
}


mod1 = function(v, n)
# mod1(1:20, 6)   =>   1 2 3 4 5 6 1 2 3 4 5 6 1 2 3 4 5 6 1 2
    ((v - 1) %% n) + 1

str2ints = function(s)
    as.integer(Filter(Negate(is.na),
        factor(levels = LETTERS, strsplit(toupper(s), "")[[1]])))

vigen = function(input, key, decrypt = F)
   {input = str2ints(input)
    key = rep(str2ints(key), len = length(input)) - 1
    paste(collapse = "", LETTERS[
        mod1(input + (if (decrypt) -1 else 1)*key, length(LETTERS))])}

message(vigen("Beware the Jabberwock, my son! The jaws that bite, the claws that catch!", "vigenerecipher"))
  # WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY
message(vigen("WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY", "vigenerecipher", decrypt = T))
  # BEWARETHEJABBERWOCKMYSONTHEJAWSTHATBITETHECLAWSTHATCATCH


fft <- function(timeScopeList, M) {
    N <- 2^M
    freqScopeList <- timeScopeList[1:N]

    LH <- N/2
    J <- N/2
    if (2<=N-1) {
        for (I in seq(2, N-1, 1)) {
            if (I<J) {
                temp <- freqScopeList[I]
                freqScopeList[I] <- freqScopeList[J+1]
                freqScopeList[J+1] <- temp
            }

            K=LH
            while(J>=K) {
                J=J-K
                K=K/2
            }
            J=J+K
        }
    }

    for (L in seq(1, M, 1)) {
        B <- 2^(L-1)
        for (J in seq(0, B-1, 1)) {
            P <- J*(2^(M-L))
            WNP <- exp(-1i * 2 * pi * P / N)
            for (k in seq(J, N-1, 2^L)) {
                temp <- freqScopeList[k+1]+freqScopeList[k+B+1]*WNP
                freqScopeList[k+B+1] <- freqScopeList[k+1]-freqScopeList[k+B+1]*WNP
                freqScopeList[k+1] <- temp
            }
        }
    }

    return(freqScopeList)
}

print(fft(c(1, 2, 3, 4, 5, 6, 7, 8), 3))


=begin
[((<index-ja|URL:index-ja.html>))]

= 練習帖

== CONTENTS
* ((<有限集合>))
  * ((<集合>))
  * ((<写像>))
  * ((<群>))
* ((<多項式の計算>))
* ((<多変数多項式の計算>))
* ((<多変数多項式の計算その２>))
* ((<多項式を複数の多項式で割った余りを求める>))
* ((<多項式のグレブナ基底を求める>))
* ((<素体を作る>))
* ((<代数体を作る>))
* ((<商体の生成>))
  * ((<整数環の商体を取って有理数を作る>))
  * ((<有理関数体の生成>))
  * ((<代数拡大体上の有理式の計算>))
  * ((<代数関数体>))
* ((<線形代数>))
  * ((<連立1次方程式を解く>))
  * ((<正方行列の対角化>))
  * ((<行列の単因子を求める>))
  * ((<行列の Jordan 標準形を求める>))
  * ((<Cayley-Hamilton の定理の（次元毎の）証明>))
* ((<グレブナ基底を元の基底で表現する>))
* ((<任意の基底で割った商と余りを求める（余り＝０に意味がある）>))
* ((<因数分解>))
  * ((<整数係数多項式の因数分解>))
  * ((<Zp 係数多項式の因数分解>))
  * ((<有理数の代数拡大上の多項式の因数分解>))
  * ((<有理数の代数拡大の代数拡大上の多項式の因数分解>))
  * ((<x^4 + 10x^2 + 1 の因数分解>))
  * ((<整数、有理係数多変数多項式の因数分解>))
  * ((<Zp 係数多変数多項式の因数分解>))
* ((<代数方程式>))
  * ((<最小多項式>))
  * ((<最小分解体>))
  * ((<多項式のガロア群>))
* ((<初等幾何>))
  * ((<重心の存在>))
  * ((<外心の存在>))
  * ((<垂心の存在>))
  * ((<4 つの等面積>))
* ((<解析>))
  * ((<ラグランジュの乗数法>))

== 有限集合

=== 集合

<<< sample-set01.rb.v.rd

=== 写像

<<< sample-map01.rb.v.rd

=== 群

<<< sample-group01.rb.v.rd

== 多項式の計算

<<< sample-polynomial01.rb.v.rd

== 多変数多項式の計算

<<< sample-polynomial02.rb.v.rd

== 多変数多項式の計算その２

<<< sample-m-polynomial01.rb.v.rd

== 多項式を複数の多項式で割った余りを求める

<<< sample-divmod01.rb.v.rd

== 多項式のグレブナ基底を求める

<<< sample-groebner01.rb.v.rd

== 素体を作る

<<< sample-primefield01.rb.v.rd

== 代数体を作る

<<< sample-algebraicfield01.rb.v.rd

=== これと同じものが次の様に書ける。

<<< sample-algebraicfield02.rb.v.rd

=== ルートの計算

<<< sample-algebraic-root01.rb.v.rd

== 商体の生成

=== 整数環の商体を取って有理数を作る

<<< sample-quotientfield01.rb.v.rd

=== 有理関数体の生成

<<< sample-quotientfield02.rb.v.rd

=== 代数拡大体上の有理式の計算

<<< sample-quotientfield03.rb.v.rd

=== 代数関数体

<<< sample-quotientfield04.rb.v.rd

== 線形代数

=== 連立1次方程式を解く

<<< sample-gaussian-elimination01.rb.v.rd

=== 正方行列の対角化

<<< sample-diagonalization01.rb.v.rd >>>

=== 行列の単因子を求める

<<< sample-elementary-divisor01.rb.v.rd

=== 行列の Jordan 標準形を求める

<<< sample-jordan-form01.rb.v.rd

=== Cayley-Hamilton の定理の（次元毎の）証明

<<< sample-cayleyhamilton01.rb.v.rd

== グレブナ基底を元の基底で表現する

<<< sample-groebner02.rb.v.rd

== 任意の基底で割った商と余りを求める（余り＝０に意味がある）

<<< sample-groebner03.rb.v.rd

== 因数分解

=== 整数係数多項式の因数分解

<<< sample-factorize01.rb.v.rd

=== Zp 係数多項式の因数分解

<<< sample-factorize02.rb.v.rd

=== 有理数の代数拡大上の多項式の因数分解

<<< sample-factorize03.rb.v.rd

=== 有理数の代数拡大の代数拡大上の多項式の因数分解

<<< sample-factorize04.rb.v.rd

=== x^4 + 10x^2 + 1 の因数分解

<<< sample-factorize05.rb.v.rd

=== 整数、有理係数多変数多項式の因数分解

<<< sample-m-factorize01.rb.v.rd

=== Zp 係数多変数多項式の因数分解

<<< sample-m-factorize02.rb.v.rd

== 代数方程式

=== 最小多項式

<<< sample-algebraic-equation01.rb.v.rd

=== 最小分解体

<<< sample-splitting-field01.rb.v.rd

=== 多項式のガロア群

<<< sample-galois-group01.rb.v.rd

== 初等幾何

=== 重心の存在

<<< sample-geometry01.rb.v.rd

=== 外心の存在

<<< sample-geometry02.rb.v.rd

#=== 内心の存在

#<<< sample-geometry03.rb.v.rd

=== 垂心の存在

<<< sample-geometry04.rb.v.rd

=== 4 つの等面積
see ((<URL:http://www1.odn.ne.jp/drinkcat/topic/column/quest/quest_2/quest_2.html>)) Question 3.

<<< sample-geometry07.rb.v.rd

== 解析
=== ラグランジュの乗数法
<<< sample-lagrange-multiplier01.rb.v.rd

=end


# Modifications were made so that no global variables are used. (C DuBois)

#####################################
# R FUNCTIONS FOR PERFORMING UNIVARIATE SLICE SAMPLING.
#
# Radford M. Neal, 17 March 2008.
#
# Implements, with slight modifications and extensions, the algorithm described
# in Figures 3 and 5 of the following paper:
#
#   Neal, R. M (2003) "Slice sampling" (with discussion), Annals of Statistics,
#      vol. 31, no. 3, pp. 705-767.
#
# See the documentation for the function uni.slice below for how to use it.
# The function uni.slice.test was used to test the uni.slice function.

# GLOBAL VARIABLES FOR RECORDING PERFORMANCE.

# UNIVARIATE SLICE SAMPLING WITH STEPPING OUT AND SHRINKAGE.
#
# Performs a slice sampling update from an initial point to a new point that
# leaves invariant the distribution with the specified log density function.
#
# Arguments:
#
#   x0    Initial point
#   g     Function returning the log of the probability density (plus constant)
#   w     Size of the steps for creating interval (default 1)
#   m     Limit on steps (default infinite)
#   lower Lower bound on support of the distribution (default -Inf)
#   upper Upper bound on support of the distribution (default +Inf)
#   gx0   Value of g(x0), if known (default is not known)
#
# The log density function may return -Inf for points outside the support
# of the distribution.  If a lower and/or upper bound is specified for the
# support, the log density function will not be called outside such limits.
#
# The value of this function is the new point sampled, with an attribute
# of "log.density" giving the value of the log density function, g, at this
# point.  Depending on the context, this log density might be passed as the
# gx0 argument of a future call of uni.slice.
#
# The global variable uni.slice.calls is incremented by one for each call
# of uni.slice.  The global variable uni.slice.evals is incremented by the
# number of calls made to the g function passed.
#
# WARNING:  If you provide a value for g(x0), it must of course be correct!
# In addition to giving wrong answers, wrong values for gx0 may result in
# the uni.slice function going into an infinite loop.

uni.slice.alt <- function (x0, g, w=1, m=Inf, lower=-Inf, upper=+Inf, gx0=NULL)
{
  # Check the validity of the arguments.

  if (!is.numeric(x0) || length(x0)!=1
   || !is.function(g)
   || !is.numeric(w) || length(w)!=1 || w<=0
   || !is.numeric(m) || !is.infinite(m) && (m<=0 || m>1e9 || floor(m)!=m)
   || !is.numeric(lower) || length(lower)!=1 || x0<lower
   || !is.numeric(upper) || length(upper)!=1 || x0>upper
   || upper<=lower
   || !is.null(gx0) && (!is.numeric(gx0) || length(gx0)!=1))
  {
    stop ("Invalid slice sampling argument")
  }

  # Keep track of the number of calls made to this function.
  uni.slice.calls <- 0	# Number of calls of the slice sampling function
  uni.slice.evals <- 0	# Number of density evaluations done in these calls

  uni.slice.calls <- uni.slice.calls + 1

  # Find the log density at the initial point, if not already known.

  if (is.null(gx0))
  { uni.slice.evals <- uni.slice.evals + 1
    gx0 <- g(x0)
  }

  # Determine the slice level, in log terms.

  logy <- gx0 - rexp(1)

  # Find the initial interval to sample from.

  u <- runif(1,0,w)
  L <- x0 - u
  R <- x0 + (w-u)  # should guarantee that x0 is in [L,R], even with roundoff

  # Expand the interval until its ends are outside the slice, or until
  # the limit on steps is reached.

  if (is.infinite(m))  # no limit on number of steps
  {
    repeat
    { if (L<=lower) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(L)<=logy) break
      L <- L - w
    }

    repeat
    { if (R>=upper) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(R)<=logy) break
      R <- R + w
    }
  }

  else if (m>1)  # limit on steps, bigger than one
  {
    J <- floor(runif(1,0,m))
    K <- (m-1) - J

    while (J>0)
    { if (L<=lower) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(L)<=logy) break
      L <- L - w
      J <- J - 1
    }

    while (K>0)
    { if (R>=upper) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(R)<=logy) break
      R <- R + w
      K <- K - 1
    }
  }

  # Shrink interval to lower and upper bounds.

  if (L<lower)
  { L <- lower
  }
  if (R>upper)
  { R <- upper
  }

  # Sample from the interval, shrinking it on each rejection.

  repeat
  {
    x1 <- runif(1,L,R)

    uni.slice.evals <- uni.slice.evals + 1
    gx1 <- g(x1)

    if (gx1>=logy) break

    if (x1>x0)
    { R <- x1
    }
    else
    { L <- x1
    }
  }

  # Return the point sampled, with its log density attached as an attribute.

  attr(x1,"log.density") <- gx1
  attr(x1,"uni.slice.evals") <- uni.slice.evals
  attr(x1,"uni.slice.calls") <- uni.slice.calls
  return (x1)

}

# FUNCTION TO TEST THE UNI.SLICE FUNCTION.
#
# Produces Postscript plots in slice-test.ps, one page per test, with the
# tests described in the code below.
#
# Each test applies a series of univariate slice sampling updates (ss*thin of
# them) to some distribution, starting at a point drawn from that distribution,
# with particular settings of the slice sampling options.  The page for a
# test contains the following:
#
#   - a trace plot of the results (at every 'thin' updates)
#   - a plot of the autocorrelations for this trace
#   - a plot of the bivariate distribution before and after 'thin' updates
#   - a qqplot of the sample produced vs. a correct sample
#   - the average number of evaluations per call
#   - the result of a t test for the sample mean vs. the correct mean, based
#     on 200 equally spaced points from the sample generated (which are
#     presumed to be virtually independent)

uni.slice.alt.test <- function ()
{
  postscript("slice-test.ps")
  par(mfrow=c(2,2))

  # Function to do the slice sampling updates.

  updates <- function (x0, g, reuse=FALSE)
  {
    uni.slice.calls <- 0
    uni.slice.evals <- 0

    s <<- numeric(ss)
    x1 <- x0
    s[1] <<- x0
    last.g <- NULL

    for (i in 2:ss)
    { for (j in 1:thin)
      { if (reuse)
        { x1 <- uni.slice (x1, g, w=w, m=m, lower=lower, upper=upper,
                           gx0=last.g)
          last.g <- attr(x1,"log.density")
          uni.slice.calls <- uni.slice.calls + attr(x1,"uni.slice.calls")
          uni.slice.evals <- uni.slice.evals + attr(x1,"uni.slice.evals")
        }
        else
        { x1 <- uni.slice (x1, g, w=w, m=m, lower=lower, upper=upper)
        }
      }
      s[i] <<- x1
    }
  }

  # Function to display the results.

  display <- function (r,mu,test)
  {
    plot(s,type="p",xlab="Iteration",ylab="State",pch=20)

    title (paste( test, "  ss =",ss," thin =",thin))

    acf (s, lag.max=length(s)/20, main="")

    title (paste ("w =",w," m =",m," lower =",lower," upper =",upper))

    plot(s[-1],s[-length(s)],pch=20,xlab="Current state",ylab="Next state")

    title (paste ("Average number of evaluations:",
                   round(uni.slice.evals/uni.slice.calls,2)))

    qqplot(r,s,pch=".",
       xlab="Quantiles from correct sample",
       ylab="Quantiles from slice sampling")
    abline(0,1)

    p.value <- t.test (s[seq(1,length(s),length=200)]-mu) $ p.value
    title (paste ("P-value from t test:",round(p.value,3)))
  }

  # Standard normal, m = Inf.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.5
  m <- Inf
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1), function (x) -x^2/2)
  display (rnorm(ss),0,"Standard normal")

  # Standard normal, reusing density, m = Inf.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.5
  m <- Inf
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1), function (x) -x^2/2, reuse=TRUE)
  display (rnorm(ss),0,"Standard normal, reusing density")

  # Normal mixture, m = 1.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 2.2
  m <- 1
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1,-1,1), function (x) log(dnorm(x,-1,1)+dnorm(x,1,0.5)))
  display (c (rnorm(floor(ss/2),-1,1), rnorm(ceiling(ss/2),1,0.5)), 0,
           "Normal mixture")

  # Normal mixture, m = 3.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.8
  m <- 3
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1,-1,1), function (x) log(dnorm(x,-1,1)+dnorm(x,1,0.5)))
  display (c (rnorm(floor(ss/2),-1,1), rnorm(ceiling(ss/2),1,0.5)), 0,
           "Normal mixture")

  # Exponential, m = Inf.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 10
  m <- Inf
  lower <- 0
  upper <- +Inf

  updates (rexp(1), function (x) -x)
  display (rexp(ss), 1, "Exponential")

  # Exponential, m = 2.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.5
  m <- 2
  lower <- 0
  upper <- +Inf

  updates (rexp(1), function (x) -x)
  display (rexp(ss), 1, "Exponential")

  # Beta(0.5,0.8).

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1e9
  m <- Inf
  lower <- 0
  upper <- 1

  updates (rbeta(1,0.5,0.8), function (x) dbeta(x,0.5,0.8,log=TRUE))
  display (rbeta(ss,0.5,0.8), 0.5/(0.5+0.8), "Beta(0.5,0.8)")

  dev.off()
}


# ......................................................................................
# ...............Cvičení 5 - Vybraná rozdělení diskrétní náhodné veličiny...............
# ..................Martina Litschmannová, Adéla Vrtková, Michal Béreš..................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

#  Přehled rozdělení a jejich funkcí ####
# * Úvod: Pravděpodobnostní, Kumulativní pravděpodobnostní (Distribuční) a Kvantilová ####
# funkce
# ** Pravděpodobnostní funkce ####
# - začíná písmenkem **d**: $p = P(X = x)$: p = d...(x, ...)
#
# ** Kumulativní pravděpodobnostní (Distribuční funkce) ####
# - začíná písmenkem **p**: $p = P(X \leq x)$: p = p...(x, ...)
# - pozor Kumulativní pravděpodobnostní je s alternativní definicí $P(X \leq t)$
# - pro naši distribuční funkci $F(t) = P(X<t)$: F(t) = p...(t - 1, ...)
#
# ** Kvantilová funkce ####
# - začíná písmenkem **q**:  $p \geq P(X \leq x)$: x = q...(p, ...)
# - hledá nejmenší $x$ pro které je $P(X \leq x)$ větší než $p$

# * Binomické (Alternativní): $X \sim Bi(n, π),X \sim A(π) = Bi(1, π)$ ####
# - počet úspěchů v $n$ Bernoulliho pokusech (případně pro jeden pokus v případě
# Alternativní)
# - každý pokus má šanci na úspěch $π$

# Pravděpodobnostní funkce P(X = x)
x = 10   # hodnota, pro níž hledáme p-stní funkci
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
dbinom(x, n, p)

dbinom(3.2, n, p)

options(warn=-1) # tímto se dají vypnout warningy

dbinom(3.2, n, p)

options(warn=0) # tímto zase zapnout

# vykreslíme si pravděpodobnostní funkci
x = 0:21 # minimálně 0, maximálně n má kladnou pravděpodobnost
P_x = dbinom(x, n, p)
plot(x, P_x)
grid()

# Kumulativní pravděpodobnostní funkce P(X <= x)
x = 10   # hodnota, pro níž hledáme kumulativní p-stní funkci
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
pbinom(x, n, p)

# Distribuční funkce F(x) = P(X < x)
x = 10   # hodnota, pro níž hledáme kumulativní p-stní funkci
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
pbinom(x, n, p) - dbinom(x, n, p)
# nebo
pbinom(x - 1, n, p)

# vykreslíme si distribuční funkci
x = 0:21 # minimálně 0, maximálně n má kladnou pravděpodobnost
P_x = dbinom(x, n, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# nebo
x = seq(0, 21, 0.01) # minimálně 0, maximálně n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
plot(x, F_x, cex=0.3)
grid()
options(warn=0)

# zkontrolujeme korektnost na hodnotě 10
x = seq(9.9, 10.1, 0.01) # minimálně 0, maximálně n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
options(warn=0)
plot(x, F_x, cex=0.5)
grid()

# najdi x pro dané q: q = P(X <= x)
q = 0.7  # h
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
qbinom(q, n, p)
pbinom(11, n, p)
pbinom(12, n, p)
pbinom(13, n, p)

# Kvantilová funkce (inverzi dist. fce): q = F(x) = P(X < x)
q = 0.7   # pravděpodobnost pro kterou hledáme kvantil
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
qbinom(q, n, p) + 1
pbinom(12 - 1, n, p)
pbinom(13 - 1, n, p)
pbinom(14 - 1, n, p)

# * Hypergeometrické: $X \sim H(N, M, n)$ ####
# - počet úspěchů v $n$ závislých pokusech
# - závislost typu:
#  - $N$ objektů,
#  - z toho $M$ objektů se zadanou vlastností,
#  - výběr velikosti $n$
#  - **při výběru nevracíme zpět - pravděpodobnost výběru objektu s danou vlastností se
# mění s každým dalším vybraným objektem**
# - **R funkce bere jako parametry *hyper(k, M, N - M, n)**
#  - k je počet úspěchů pro které počítáme pravděpodobnost,
#  - M je počet objektů se zadanou vlastností,
#  - N-M je počet objektů bez zadané vlastnosti,
#  - n je ceklová velikost výběru.

# Pravděpodobnostní funkce P(X = x)
x = 5   # hodnota, pro níž hledáme p-stní funkci
N = 20  # celkový počet objektů
M = 5   # z toho se zadanou vlastností
n = 10  # velikost výběru
dhyper(x, M, N - M, n)

# vykreslíme si pravděpodobnostní funkci
x = 0:5 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dhyper(x, M, N - M, n)
plot(x, P_x)
grid()

# Distribuční funkce F(x) = P(X < x)
x = 5   # hodnota, pro níž hledáme dist. funkci
N = 20  # celkový počet objektů
M = 5   # z toho se zadanou vlastností
n = 10  # velikost výběru
phyper(x - 1, M, N - M, n)

# vykreslíme si Distribuční funkci
x = 0:5 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dhyper(x, M, N - M, n)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Kvantilová funkce (inverzi dist. fce): q = P(X < x)
q = 0.7 # pravděpodobnost pro kterou hledáme kvantil
N = 20  # celkový počet objektů
M = 5   # z toho se zadanou vlastností
n = 10  # velikost výběru
qhyper(q, M, N - M, n) + 1
phyper(3 - 1, M, N - M, n)
phyper(4 - 1, M, N - M, n)
phyper(5 - 1, M, N - M, n)

# * Negativně binomické (Geometrické): $X \sim NB(k, π), X \sim Ge(π) = NB(1, π)$ ####
# - počet pokusů do $k$. úspěchu (včetně)
# - každý pokus má šanci na úspěch $π$
# - **Negativně binomická NV je v Rku definována jako počet neúspěchů před k-tým
# úspěchem**
#  - proto jako první parametr budeme posílat x - k

# Pravděpodobnostní funkce P(X = x)
x = 15   # počet pokusů pro který hledáme pravd. fci
k = 5    # požadovaný počet úspěchů
p = 0.3  # pravd. jednotlivých pokusů
# pozor první argument musí být počet neúspěchů
dnbinom(x - k, k, p)

# vykreslíme si pravděpodobnostní funkci
x = 0:40 # minimálně k, maximum neomezeno
P_x = dnbinom(x - k, k, p)
plot(x, P_x)
grid()
# hodnoty 0,1,2,3,4 mají P(x)=0

# Distribuční funkce F(x) = P(X < x)
x = 15   # počet pokusů pro který hledáme pravd. fci
k = 5    # požadovaný počet úspěchů
p = 0.3  # pravd. jednotlivých pokusů
# pozor první argument musí být počet neúspěchů
pnbinom(x - k - 1, k, p)

# vykreslíme si Distribuční funkci
x = 0:40 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dnbinom(x - k, k, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Kvantilová funkce (inverzi dist. fce): q = P(X < x)
q = 0.7  # pravd. pro kvantil
k = 5    # požadovaný počet úspěchů
p = 0.3  # pravd. jednotlivých pokusů
qnbinom(q, k, p) + k + 1
pnbinom(19 - k - 1, k, p)
pnbinom(20 - k - 1, k, p)
pnbinom(21 - k - 1, k, p)

# * Poissonovo: $X \sim Po(λt)$ ####
# - počet událostí v Poissonově procesu v uzavřené oblasti (v čase, na ploše, v objemu)
# - s hustotou výskytu $λ$
# - v čase/ploše/objemu velikosti $t$

# Pravděpodobnostní funkce P(X = x)
x = 9       # počet pokusů pro který hledáme pravd. fci
lambda = 5  # hustota výskytu
t = 2       # pravd. jednotlivých pokusů
lt = lambda*t
dpois(x, lt)

# vykreslíme si pravděpodobnostní funkci
x = 0:25 # minimálně 0, maximum neomezeno
P_x = dpois(x, lt)
plot(x, P_x)
grid()

# Distribuční funkce F(x) = P(X < x)
x = 9       # počet pokusů pro který hledáme pravd. fci
lambda = 5  # hustota výskytu
t = 2       # pravd. jednotlivých pokusů
lt = lambda*t
ppois(x - 1, lt)

# vykreslíme si Distribuční funkci
x = 0:25 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dpois(x, lt)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Kvantilová funkce (inverzi dist. fce): q = P(X < x)
q = 0.4     # pravd. pro kvantil
lambda = 5  # hustota výskytu
t = 2       # pravd. jednotlivých pokusů
lt = lambda*t
qpois(q, lt) + 1
ppois(9 - 1, lt)
ppois(10 - 1, lt)
ppois(11 - 1, lt)

#  Příklady ####
# * Příklad 1. ####
# Bridž se hraje s 52 bridžovými kartami, které se rozdají mezi 4 hráče. Vždy 2 hráči
# hrají spolu. Při rozdávání (13 karet) jste dostali do rukou 2 esa. Jaká je
# pravděpodobnost, že váš partner bude mít zbývající dvě esa?

# X ... počet es mezi 13 kartami
# X ~ H(N = 39, M = 2, n = 13)
# P(X = 2)
M = 2
N = 39 # 52-13
n = 13
# výpočet
dhyper(2, M, N - M, n) # což je dhyper(2,2,37,13)

# graf pravděpodobnostní funkce
x = 0:M   # všechny možné realizace NV X
p = dhyper(x, M, N - M, n) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 2. ####
# Pokusy se zjistilo, že radioaktivní látka vyzařuje během 7,5 s průměrně 3,87
# α-částice. Určete pravděpodobnost toho, že za 1 sekundu vyzáří tato látka alespoň
# jednu α-částici.

# X ... počet vyzářených alfa částic během 1 s
# X ~ Po(lt = 3.87/7.5)

lambda = 3.87/7.5 # četnost výskytu
t = 1 # za 1 sekundu
lt = lambda*t # parametr Poissonova rozdělení

# P(X >= 1) = P(X > 0) = 1 - P(X <= 0)
1 - ppois(1 - 1, lt)

# graf pravděpodobnostní funkce
# teoreticky může být vyzářeno až nekonečně mnoho částic,
# od jisté hodnoty je pravděpodobnost zanedbatelná
x = 0:10
p = dpois(x, lt) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 3. ####
# Kamarád vás pošle do sklepa, abyste donesl(a) 4 lahvová piva - z toho dvě desítky a
# dvě dvanáctky. Nevíte, kde rozsvítit, proto vezmete z basy poslepu 4 láhve. S jakou
# pravděpodobností jste vyhověl(a), víte-li, že v base bylo celkem 10 desítek a 6
# dvanáctek?

# X ... počet 10°piv mezi 4 vybranými
# X ~ H(N = 16, M = 10, n = 4)

x = 2
N = 16
M = 10
n = 4

# P(X = 2)
dhyper(x, M, N - M, n)

# graf pravděpodobnostní funkce
x = 0:4    # všechny možné realizace NV X
p = dhyper(x, M, N - M, n) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 4. ####
# V jednom mililitru určitého dokonale rozmíchaného roztoku se v průměru nachází 15
# určitých mikroorganismů. Určete pravděpodobnost, že při náhodném výběru vzorku o
# objemu 1/2 mililitru bude ve zkumavce méně než 5 těchto mikroorganismu.

# X ... počet mikroorganismů v 0.5 ml roztoku
# X ~ Po(lt = 15/2)

lambda = 15
t = 1/2
lt = lambda*t   # parametr Poissonova rozd.

# P(X < 5) = P(X <= 4)
ppois(5 - 1, lt)
# nebo
ppois(5,lt) - dpois(5,lt)

# graf pravděpodobnostní funkce
# teoreticky může být v roztoku až nekonečně mnoho mikroorganismů,
# od jisté hodnoty je pravděpodobnost zanedbatelná
x = 0:20
p = dpois(x, lt) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 5. ####
# Na stůl vysypeme 15 mincí. Jaká je pravděpodobnost, že počet mincí ležících lícem
# nahoře, je od 8 do 15?

# X ... počet mincí, které padnou lícem nahoru z celkového množství 15 mincí
# X ~ Bi(n = 15, p = 0.5)

n = 15
p = 0.5

# P(8 <= X <= 15) = P(X <= 15) - P(X < 8) = P(X <= 15) - P(X <= 7)
pbinom(15, n, p) - pbinom(7, n, p)

#jinak: P(8<=X<=15)=P(X>7)=1-P(X<=7)
1 - pbinom(7, n, p)

# graf pravděpodobnostní funkce
x = 0:15    # všechny možné realizace NV X
p = dbinom(x, n, p) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 6. ####
# Pravděpodobnost, že se dovoláme do studia rozhlasové stanice, která právě vyhlásila
# telefonickou soutěž je 0,08. Jaká je pravděpodobnost, že se dovoláme nejvýše na 4.
# pokus?

# X ... počet pokusů než se dovoláme do rozhlasového studia
# X ~ NB(k = 1,p = 0.08) nebo G(0.08)

x = 4
k = 1
p = 0.08

# P(X <= 4)
pnbinom(x - k, k, p)

# graf pravděpodobnostní funkce
# teoreticky můžeme uskutečnit až nekonečně mnoho pokusů,
# od jisté hodnoty je pravděpodobnost zanedbatelná
x = 1:40
p = dnbinom(x - k, k, p) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 7. ####
# V továrně se vyrobí denně 10 % vadných součástek. Jaká je pravděpodobnost, že
# vybereme-li třicet součástek z denní produkce, tak nejméně dvě budou vadné?

# X ... počet vadných součástek ze 30 vybraných
# X ~ Bi(n = 30, p = 0.1)

n = 30
p = 0.1

# P(X >= 2) = 1 - P(X < 2) = 1 - P(X <= 1)
1 - pbinom(1, n, p)

# nebo P(X >= 2) vsechno mimo 0 a 1
1 - (dbinom(0, n, p) + dbinom(1, n, p))

# graf pravděpodobnostní funkce
x = 0:30            # všechny možné realizace NV X
p = dbinom(x, n, p) # hodnoty pravděpodobnostní funkce pro x
plot(x,p)

# * Příklad 8. ####
# Ve skladu je 200 součástek. 10 % z nich je vadných. Jaká je pravděpodobnost, že
# vybereme-li ze skladu třicet součástek, tak nejméně dvě budou vadné?

# X ... počet vadných součástek ze 30 vybraných z 200
# X ~ H(N = 200, M = 20, n = 30)

N = 200
M = 20
n = 30

# P(X >= 2) = 1 - P(X < 2) = 1 - P(X <= 1)
1 - phyper(2 - 1, M, N - M, n)

# graf pravděpodobnostní funkce
x = 0:30   # všechny možné realizace NV X
p = dhyper(x, M, N - M, n) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 9. ####
# V určité firmě bylo zjištěno, že na 33 % počítačů je nainstalován nějaký nelegální
# software. Určete pravděpodobnostní a distribuční funkci počtu počítačů s nelegálním
# softwarem mezi třemi kontrolovanými počítači.

# X ... počet počítačů s nelegálním softwarem ze 3 kontrolovaných
# X ~ Bi(n = 3,p = 0.33)

n = 3
p = 0.33

# pravděpodobnostní funkce
x = 0:3  # všechny možné realizace NV X
p = dbinom(x, n, p) # hodnoty pravděpodobnostní funkce pro x

p = round(p, 3) # zaokrouhlení pravděpodobností na 3 des. místa
p[4] = 1 - sum(p[1:3]) # dopočet poslední hodnoty do 1

tab = rbind(x, p) # vytvoření tabulky pravděpodobnostní funkce
rownames(tab) = c("x", "P(x)")
tab

# graf pravděpodobnostní funkce
plot(x, p)

#distribuční funkce
cumsum(p) # zjednodušený výpis distribuční funkce

# * Příklad 10. ####
# Sportka je loterijní hra, v níž sázející tipuje šest čísel ze čtyřiceti devíti, která
# očekává, že padnou při budoucím slosování. K účasti ve hře je nutné zvolit alespoň
# jednu kombinaci 6 čísel (vždy 6 čísel na jeden sloupec) a pomocí křížků tato čísla
# označit na sázence společnosti Sazka a.s. do sloupců, počínaje sloupcem prvním.
# Sázející vyhrává v případě, že uhodne alespoň tři čísla z tažené šestice čísel. Jaká
# je pravděpodobnost, že proto, aby sázející vyhrál, bude muset vyplnit:

# Nejprve pravděpodobnost, že vehrajeme v jednom sloupci

# Y ... počet uhádnutých čísel v 6 tažených ze 49
# Y ~ H(N = 49, M = 6, n = 6)

N = 49
M = 6
n = 6

# P-st uhádnutí alespoň 3 čísel v jednom sloupci
# P(Y >= 3) = 1 - P(Y < 3) = 1 - P(Y <= 2)
pp = 1 - phyper(3 - 1, M, N - M, n)
pp

# ** a) ####
# právě tři sloupce,

# X … počet sloupců, které bude muset sázející vyplnit, aby vyhrál
# X ~ NB(k = 1, p = pp)

# a) P(X = 3)
k = 1
p = pp

dnbinom(3 - k, k, pp)

# ** b)  ####
# alespoň 5 sloupců,

# b) P(X >= 5) = 1 - P(X < 5) = 1 - P(X <= 4)

1 - pnbinom(5 - k - 1, k, pp)

# ** c) ####
# méně než 10 sloupců,

# c) P(X < 10) = P(X <= 9)
pnbinom(10 - k - 1, k, pp)

# * d) ####
# více než 5 a nejvýše 10 sloupců?

# P(5 < X <= 10) = P(X <= 10) - P(X <= 5)
pnbinom(10 - k, k, pp)-pnbinom(5 - k, k, pp)
# nebo P(X < 11) - P(X < 6)
pnbinom(11 - k - 1, k, pp)-pnbinom(6 - k - 1, k, pp)

# * Příklad 11. ####
# Pravděpodobnost, že hodíme 6 na 6stěnné kostce je 1/6. Hážeme tak dlouho, než hodíme
# šestku 10 krát.
# ** a)  ####
# Jaká je střední hodnota počtu hodů.

# X … hodů kostkou než hodíme 10 šestek
# X ~ NB(k = 10, p = 1/6)

k = 10
p = 1/6

E_X = k/p
E_X

# ** b)  ####
# S kolika hody nejméně musíme počítat, pokud chceme, aby pradvěpodobnost, že se nám
# podaří naházet 10 šestek, byla alespoň 70%.

# P(X <= k) >= 0.7
qnbinom(0.7, k, p) + k


x <- c(1,2,3,4,5,6,7,8,9,10)
x
x*3
x+2
x^2
sqrt(x)
log(x)

y <- -5:4
x + y
x - y
x / y
x < y

x <- 10:1
y <- -4:5
x < y
any(x<y)
all(x<y)

q <- c("Hockey", "Football", "Curling", "Baseball", "Rugby", "Lacrosse",
      "Tennis", "Cricket", "Soccer")
q
nchar(q)

x[1]
x[1:2]
x[c(1,4)]

c(One="a", Two ="y", Last="r")

w <- 1:3
w
names(w) <- c("a", "b", "c")
w

q2 <- c(q, "Hockey", "Lacrosse", "Hockey", "Water Polo", "Lacrosse")
q2
q2Factor <- factor(q2)
q2Factor
#Factor sorting
sizes <- factor(sizes, levels = c("small", "medium", "large"))

z <- c(1,2,NA,9,3,NA)
is.na(z)
z <- c(1, NULL, 3)
z
is.na(z)
is.null(z)
d <- (NULL)
is.null(d)

x <- 1:10
mean(x)
sum(x)
head(x)
max(x)
min(x)
summary(x)
plot(x)

mean(x=x, trim=.1)
mean(x, .1)
mean(x, na.rm = TRUE)
x[c(2,6)] <- NA
mean(x)
mean(x, na.rm = TRUE)


dir = getwd()
dir = paste(dir, "/code/Take_me_to_the_moon/", sep = "")
dir
setwd(dir)

###########################
# Formating the Dataframe #
###########################

# Creating whether data-frame
lund_data = read.csv("final_file.csv")

lund_data$Month2 = lund_data$Month

# tell R that Month is a categorical variable, not numerical:
lund_data$Month = factor(lund_data$Month,
                       levels=c(1,2,3,4,5,6,7,8,9,10,11,12),
                       labels=c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"))

# Creating a season frame where months are sorted by season.
lund_data$Season = lund_data$Month
levels(lund_data$Season) = c("Winter", "Winter", "Spring", "Spring", "Spring", "Summer", "Summer", "Summer", "Autumn", "Autumn", "Autumn", "Winter")

# Creating a frame that has sorted distances to full moon by 'Full' and 'Not'.
lund_data$Full = factor(lund_data$Dist)
levels(lund_data$Full) = c("Full", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not", "Not")

#########################################################
# Making a linear model Temps = Year + Month*Day + Dist #
#########################################################
full_model = lm(lund_data$Temp ~ lund_data$Year + lund_data$Month2*lund_data$Day + lund_data$Dist)
summary(full_model)

######################################
# Making a linear model Temps = Year #
######################################
year_model = lm(lund_data$Temp ~ lund_data$Year)
summary(year_model)

# Making a JPEG output for our plot with colours for seasons
jpeg("temps_year_season.jpeg")
with(lund_data, plot(Temp ~ Year))
with(subset(lund_data,Season=="Winter"),points(Year, Temp, col='blue'))
with(subset(lund_data,Season=="Spring"),points(Year, Temp, col='green'))
with(subset(lund_data,Season=="Summer"),points(Year, Temp, col='red'))
with(subset(lund_data,Season=="Autumn"),points(Year, Temp, col='yellow'))
abline(year_model, col="red")

# Constants needed for confidence intervals
mx = mean(lund_data$Year)
my = mean(lund_data$Temp)
beta0 = summary(year_model)$coefficients[1]
beta1 = summary(year_model)$coefficients[2]
yhat = year_model$fit
e = year_model$residuals
s = summary(year_model)$sigma
n = nrow(lund_data)
t_quant = qt(1-0.05/2, n-2)

# Calculating the 95 % prediction interval for the expected#
ci_PY0_upr = beta0 + beta1*(1960:2015) + t_quant*s*sqrt(1+(1/n)+((1960:2015)-mx)^2 /sum(((1960:2015)-mx)^2))
ci_PY0_lwr = beta0 + beta1*(1960:2015) - t_quant*s*sqrt(1+(1/n)+((1960:2015)-mx)^2 /sum(((1960:2015)-mx)^2))

lines((1960:2015), ci_PY0_upr,lty=2,col="blue",lwd=2)
lines((1960:2015), ci_PY0_lwr,lty=2,col="blue",lwd=2)

# Making a JPEG output for our plot with colours for seasons
jpeg("temps_month_fullmoon.jpeg")
with(lund_data, plot(Temp ~ Month2))
with(subset(lund_data,Full=="Full"),points(Month2, Temp, col='red'))

write.csv(x=lund_data, file="final_file_even_better.csv")


#' Samples from a mixture model
#'
#' A matrix of 2-dimensional Gaussian mixture samples, the samples came from 4 different Gaussian distributions
#'
#' @docType data
#'
#' @usage data(mmData)
#'
#' @format A matrix of Gaussian samples, each row is one sample.
"mmData"

#' Samples from a hierarchical mixture model
#'
#' A list of 2-dimensional Gaussian mixture samples and the corresponding group labels. The samples are generated by 4 different Gaussian distributions. The samples are separated into 30 groups.
#'
#' @docType data
#'
#' @usage data(mmhData)
#'
#' @format A list of two elements:
#' \describe{
#'   \item{x}{: matrix, 2-dimensional Gaussian samples, each row is a sample}
#'   \item{groupLabel}{: integer, the group label of each Gaussian sample}
#' }
"mmhData"

#' Samples from a hierarchical mixture model with two layers of hierarchies
#'
#' A list of 2-dimensional Gaussian mixture samples and the corresponding group labels. The samples are generated by 4 different Gaussian distributions. Each sample is assigned to a group and a subgroup. There are 2 groups, group 1 has 10 subgroups, group 2 has 20 subgroups.
#'
#' @docType data
#'
#' @usage data(mmhhData)
#'
#' @format A list of three elements:
#' \describe{
#'   \item{x}{: matrix, 2-dimensional Gaussian samples, each row is a sample}
#'   \item{groupLabel}{: integer, the group label of each Gaussian sample}
#'   \item{subGroupLabel}{: integer, the subgroup label of each Gaussian sample}
#' }
"mmhhData"

#' Samples from a simple linear model
#'
#' A list of two elements, a matrix "X" and a numeric vector "x". They came from a linear model: x = X*0.3 + epsilon, where epsilon is Gaussian distributed with mean 0 and variance 25.
#'
#' @docType data
#'
#' @usage data(lrData)
#'
#' @format A list of two elements:
#' \describe{
#'   \item{x}{: numeric, linear samples}
#'   \item{X}{: matrix, the "locations" of the linear samples}
#' }
"lrData"

#' @title Samples from a hierarchical linear model
#' @description
#' The data was part of the 2002 Educational Longitudinal Study (ELS), a survey of students from a large sample of schools across the United States. This dataset includes a population of schools as well as a population of students within each school.
#' @docType data
#'
#' @usage data(lrData)
#'
#' @format A list of three elements:
#' \describe{
#'   \item{mathScore}{: numeric, the mathScore of each student}
#'   \item{socioeconomicStatus}{: numeric, the socioeconomic status score of each student}
#'   \item{schoolID}{: integer, the school ID of each student}
#' }
#' @references Hoff, Peter D. A first course in Bayesian statistical methods. Vol. 580. New York: Springer, 2009.
"hlrData"

#' farm ads data
#'
#' A subset of farm ads data from https://archive.ics.uci.edu/ml/datasets/Farm+Ads
#'
#' @docType data
#'
#' @usage data(farmadsData)
#'
#' @format A list of two elements:
#' \describe{
#'   \item{word}{: character, the words}
#'   \item{document}{: integer, document id of each word}
#' }
#' @source \href{https://archive.ics.uci.edu/ml/datasets/Farm+Ads}{Farm-Ads}
"farmadsData"

#' Cancer mortality of 20 cities
#'
#' Cancer mortality data from Ordinal Data Modeling(1999) p24. This dataset is a list of 20 character vectors, representing the individuals in 20 cities' cancer mortality information. There can be only two possible values "death" and "no death" in each character vector. For example "death" occurs 3 times the 10th character vector, while "no death" occurs 582 times, this mean there are 3 death among the 585 cancer patients in city 10.
#'
#' @docType data
#'
#' @usage data(cancerData)
#'
#' @format A list of 20 character vectors.
#' @references Johnson, Valen E., and James H. Albert. Ordinal data modeling. Springer Science & Business Media, 2006.
"cancerData"

#' @title Samples from a hidden Markov model
#' @description
#' Random samples generated from a Hidden Markov Model (HMM) with 3 hidden states. The initial distribution is c(0.2,0.6,0.2), the transition matrix is matrix(c(0.9, 0.04, 0.06, 0.06, 0.9, 0.07, 0.04, 0.06, 0.87),3,3).
#'
#' @docType data
#'
#' @usage data(hmmData)
#'
#' @format A list of four elements:
#' \describe{
#'   \item{x}{: matrix, two dimensional Gaussian observations. The observations are split into 'Nsegs' segment, see 'Nsegs' and 'breaks' below.}
#'   \item{z}{: integer vector, the real hidden states.}
#'   \item{Nsegs}{: integer, the number of segments.}
#'   \item{breaks}{: integer vector, the starting and ending locations of the segments. The ith segment start at breaks[i]+1, ends at breaks[i+1]}
#' }
"hmmData"


score <- function(input) {
    return(c(subroutine0(input), subroutine1(input), subroutine2(input)))
}
subroutine0 <- function(input) {
    return(((((0.26211368729005174) + ((input[1]) * (0.4140109981888289))) + ((input[2]) * (1.4528075883131546))) + ((input[3]) * (-2.246635388925499))) + ((input[4]) * (-1.0191976648723275)))
}
subroutine1 <- function(input) {
    return(((((1.086138633246728) + ((input[1]) * (0.37719727011342175))) + ((input[2]) * (-1.549942443009465))) + ((input[3]) * (0.5880570713482801))) + ((input[4]) * (-1.3787643143262258)))
}
subroutine2 <- function(input) {
    return(((((-1.2117820645059025) + ((input[1]) * (-1.6873884533604742))) + ((input[2]) * (-1.5266822164703968))) + ((input[3]) * (2.446796117892428))) + ((input[4]) * (2.542368665459887)))
}


library(qcc)
library(readr)

spc_ipc_normal <- read.csv("Workspace/rubikAnalysis/tests/data/clickhouse/spc_ipc_abnormal.csv", sep="")
View(spc_ipc_normal)

measures <- spc_ipc_normal[,1]
# Specify the sample size
sample_size <- 3

# Get the total number of samples
number_of_samples <- length(measures)/sample_size

# Assign the measures to the corresponding sample
sample <- rep(1:number_of_samples, each = sample_size)

# Create a data frame with the measures and sample columns
df <- data.frame(measures, sample)

# Group the measures per sample
measure <- with(df, qcc.groups(measures, sample))

# View the grouped measures
head(measure)

# Specify the measures unit
measure_unit <- "lbs"

# Create the x-bar chart
xbar <- qcc(measure, type = "xbar", data.name = measure_unit)

# Specify the warning limits (2 sigmas)
(warn.limits.2 = limits.xbar(xbar$center, xbar$std.dev, xbar$sizes, 2))

# Specify the warning limits (1 sigmas)
(warn.limits.1 = limits.xbar(xbar$center, xbar$std.dev, xbar$sizes, 1))

# Plot the x-bar chart
plot(xbar, restore.par = FALSE)

# Plot the warning limit lines
abline(h = warn.limits.2, lty = 2, col = "blue")
abline(h = warn.limits.1, lty = 2, col = "lightblue")

# Get the summary for x-bar chart
summary(xbar)

# Create the R-chart
r_chart <- qcc(measure, type = "R", data.name = measure_unit)

# Get the summaries for R-chart
summary(r_chart)

# Specify the lower control limit
LSL <- as.numeric(2.57704)

# Specify the upper control limit
USL <- as.numeric(2.7223)

# Specify the target
Target <- as.numeric(2.6497)

# Plot the process capability chart
process.capability(xbar, spec.limits = c(LSL, USL), target = Target)


# Edited example from Jane Cook jane.cookng@gmail.com
require(rms)
set.seed(1)
n <- 101
y  <- runif(n)
y[1:2] <- NA
x1 <- sample(c('a','b'), n, TRUE)
x2 <- runif(n) + .15 * y
d <- data.frame(y, x1, x2)
a <- aregImpute(~ y + x1 + x2, burnin=10, n.impute=100, data=d)
f <- fit.mult.impute(y ~ x1 + x2, ols, a, data=d)

B <- 20 # actually use B=1000
ranks <- matrix(NA, nrow=B, ncol=2)
## Put - in front of plot in next line to have rank 1 = best
rankvars <- function(fit) rank(plot(anova(fit), sort='none', pl=FALSE))
Rank <- rankvars(f)
for(i in 1:B) {
j <- sample(1:n, n, TRUE)
bootfit   <- update(f, data=d, subset=j, pr=FALSE)
ranks[i,] <- rankvars(bootfit)
}
for(k in 1 : 2) {
  cat('Frequency of Ranks for Predictor:', k, '\n')
  print(table(ranks[, k]))
  cat('\n')
}

lim <- t(apply(ranks, 2, quantile, probs=c(.025,.975)))


sqrt(729)
b = 1947.0
b = as.character(b)
d = c(1:6)
class(d)
e = c(1, 'a', 2, 'b')
class(e)
f = c(1:26)
f = as.character(f)
class(f)
length(f)
f[1] = "a"
f
names = c('Ayush', 'Vijay', 'Sudhanva', 'Karthik', 'Shreedhar')
names
class(names)
length(names)
names[1:2]
names[2:3]
sort(names)
sort(names, decreasing = TRUE)
a = c(1,2,NA,4)
a = na.omit(a)
z = c(rep("a", 2),1:5,seq(7,11,by = 2)) #here type convertion takes place automatically
z
class(z)
LETTERS[1:26]
a = 1:10000
b = sample(a,100)
b
b = sample(a,100, replace = TRUE) #When population is small, use replace so that you get different values
b


LISP Interpreter Run

[[[[[

 A LISP expression that evaluates to itself!

 Let f(x): x -> (('x)('x))

 Then (('f)('f)) is a fixed point.

]]]]]

[Here is the fixed point done by hand:]

(
'lambda(x) cons cons "' cons x nil
           cons cons "' cons x nil
                nil

'lambda(x) cons cons "' cons x nil
           cons cons "' cons x nil
                nil
)

expression  ((' (lambda (x) (cons (cons ' (cons x nil)) (cons
            (cons ' (cons x nil)) nil)))) (' (lambda (x) (cons
             (cons ' (cons x nil)) (cons (cons ' (cons x nil))
             nil)))))
value       ((' (lambda (x) (cons (cons ' (cons x nil)) (cons
            (cons ' (cons x nil)) nil)))) (' (lambda (x) (cons
             (cons ' (cons x nil)) (cons (cons ' (cons x nil))
             nil)))))

[Now let's construct the fixed point.]

define (f x) let y [be] cons "' cons x nil [y is ('x)        ]
             [return] cons y cons y nil    [return (('x)('x))]

define      f
value       (lambda (x) ((' (lambda (y) (cons y (cons y nil)))
            ) (cons ' (cons x nil))))

[Here we try f:]

(f x)

expression  (f x)
value       ((' x) (' x))

[Here we use f to calculate the fixed point:]

(f f)

expression  (f f)
value       ((' (lambda (x) ((' (lambda (y) (cons y (cons y ni
            l)))) (cons ' (cons x nil))))) (' (lambda (x) (('
            (lambda (y) (cons y (cons y nil)))) (cons ' (cons
            x nil))))))

[Here we find the value of the fixed point:]

eval (f f)

expression  (eval (f f))
value       ((' (lambda (x) ((' (lambda (y) (cons y (cons y ni
            l)))) (cons ' (cons x nil))))) (' (lambda (x) (('
            (lambda (y) (cons y (cons y nil)))) (cons ' (cons
            x nil))))))

[Here we check that it's a fixed point:]

= (f f) eval (f f)

expression  (= (f f) (eval (f f)))
value       true

[Just for emphasis:]

= (f f) eval eval eval eval eval eval (f f)

expression  (= (f f) (eval (eval (eval (eval (eval (eval (f f)
            )))))))
value       true

End of LISP Run

Elapsed time is 0 seconds.


"
Создать скрипт и перенести в него результаты самостоятельного задания No 3
из Лабораторной работы No 2: создать несколько констант и переменных разных типов
выполнить арифметические расчеты по самостоятельно подготовленным формулам с
этими константами и переменными. В формулах проверить работу операторов %% и % / %.
"
{
  a <- c(5, 3, 6, 2)
  b <- 5
  s <- c(4i, 5i, 6i)

  result <- a %% b
  print(result)

  result <- a %/% b
  print(result)

  result <- s %% b
  print(result)

  result <- s %/% b
  print(result)
}


library(ggplot2)
library(tikzDevice)

disp_prob = function(C,Cth,gamma) { # defines the dispersal function
  d = rep(0,length(C))
  d[C>Cth] = 1 - (Cth*(1-gamma))/(C[C>Cth]-Cth*gamma)
  return(d)
}

densx = seq(0,3,len=100) # a vector of population densities
Cth = 1.1 # defining a threshold density value
gammas = c(0,0.5,0.9,0.99)

d = numeric()
dens = numeric()
gam = numeric()

for (g in gammas) {
  d = c(d,disp_prob(densx,Cth,g))
  dens = c(dens,densx)
  gam = c(gam,rep(g,length(densx)))
}

res = data.frame(dens=dens,disp=d,gamma=factor(gam))

gamlab = c(paste(expression(gamma==0)),
           paste(expression(gamma==0.5)),
           paste(expression(gamma==0.9)),
           paste(expression(gamma==0.99)))

x11()

ggplot(res,aes(x=dens,y=disp,colour=gamma, group=gamma, linetype=gamma)) + geom_line(size=1.25) +
  theme_bw(base_size=25) +
  scale_color_grey() +
  theme(legend.position="none", text=element_text(size=25),axis.line.x=element_line(color="black"),axis.line.y=element_line(color="black")) +
  ylab(expression(paste("Emigration probability ", italic(d)[TAE]))) +
  xlab(expression(paste("Estimated population density ",italic(N)[i]^E/bar(italic(K))))) +
  annotate("text",x=c(2.5,2.3,1.9,1.55),y=c(0.475,0.6,0.8,0.9),parse=T,label=gamlab, size=7)

dev.copy2eps(file="figure_1.eps",title="Poethke et al. | Figure 1")